3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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)
62 if (PL_op->op_private & OPpLVAL_INTRO)
63 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
65 if (PL_op->op_flags & OPf_REF) {
69 if (GIMME == G_SCALAR)
70 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
75 if (gimme == G_ARRAY) {
76 const I32 maxarg = AvFILL((AV*)TARG) + 1;
78 if (SvMAGICAL(TARG)) {
80 for (i=0; i < (U32)maxarg; i++) {
81 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
82 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
86 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
90 else if (gimme == G_SCALAR) {
91 SV* const sv = sv_newmortal();
92 const I32 maxarg = AvFILL((AV*)TARG) + 1;
105 if (PL_op->op_private & OPpLVAL_INTRO)
106 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
107 if (PL_op->op_flags & OPf_REF)
110 if (GIMME == G_SCALAR)
111 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
115 if (gimme == G_ARRAY) {
118 else if (gimme == G_SCALAR) {
119 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
133 tryAMAGICunDEREF(to_gv);
136 if (SvTYPE(sv) == SVt_PVIO) {
137 GV * const gv = (GV*) sv_newmortal();
138 gv_init(gv, 0, "", 0, 0);
139 GvIOp(gv) = (IO *)sv;
140 (void)SvREFCNT_inc(sv);
143 else if (SvTYPE(sv) != SVt_PVGV)
144 DIE(aTHX_ "Not a GLOB reference");
147 if (SvTYPE(sv) != SVt_PVGV) {
148 if (SvGMAGICAL(sv)) {
153 if (!SvOK(sv) && sv != &PL_sv_undef) {
154 /* If this is a 'my' scalar and flag is set then vivify
158 Perl_croak(aTHX_ PL_no_modify);
159 if (PL_op->op_private & OPpDEREF) {
161 if (cUNOP->op_targ) {
163 SV * const namesv = PAD_SV(cUNOP->op_targ);
164 const char * const name = SvPV(namesv, len);
165 gv = (GV*)NEWSV(0,0);
166 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
169 const char * const name = CopSTASHPV(PL_curcop);
172 if (SvTYPE(sv) < SVt_RV)
173 sv_upgrade(sv, SVt_RV);
174 if (SvPVX_const(sv)) {
179 SvRV_set(sv, (SV*)gv);
184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
186 DIE(aTHX_ PL_no_usym, "a symbol");
187 if (ckWARN(WARN_UNINITIALIZED))
191 if ((PL_op->op_flags & OPf_SPECIAL) &&
192 !(PL_op->op_flags & OPf_MOD))
194 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
196 && (!is_gv_magical_sv(sv,0)
197 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
203 if (PL_op->op_private & HINT_STRICT_REFS)
204 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
205 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
206 == OPpDONT_INIT_GV) {
207 /* We are the target of a coderef assignment. Return
208 the scalar unchanged, and let pp_sasssign deal with
212 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
216 if (PL_op->op_private & OPpLVAL_INTRO)
217 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
229 tryAMAGICunDEREF(to_sv);
232 switch (SvTYPE(sv)) {
236 DIE(aTHX_ "Not a SCALAR reference");
242 if (SvTYPE(gv) != SVt_PVGV) {
243 if (SvGMAGICAL(sv)) {
248 if (PL_op->op_private & HINT_STRICT_REFS) {
250 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
252 DIE(aTHX_ PL_no_usym, "a SCALAR");
255 if (PL_op->op_flags & OPf_REF)
256 DIE(aTHX_ PL_no_usym, "a SCALAR");
257 if (ckWARN(WARN_UNINITIALIZED))
261 if ((PL_op->op_flags & OPf_SPECIAL) &&
262 !(PL_op->op_flags & OPf_MOD))
264 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
266 && (!is_gv_magical_sv(sv, 0)
267 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
273 gv = (GV*)gv_fetchsv(sv, GV_ADD, 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);
297 AV * const av = (AV*)TOPs;
298 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
301 sv_upgrade(*sv, SVt_PVMG);
302 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 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, NULL, PERL_MAGIC_pos, NULL, 0);
319 if (LvTARG(TARG) != sv) {
321 SvREFCNT_dec(LvTARG(TARG));
322 LvTARG(TARG) = SvREFCNT_inc(sv);
324 PUSHs(TARG); /* no SvSETMAGIC */
328 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
329 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
330 if (mg && mg->mg_len >= 0) {
334 PUSHi(i + PL_curcop->cop_arybase);
347 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
349 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
352 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
353 /* (But not in defined().) */
355 CV *cv = sv_2cv(TOPs, &stash, &gv, flags);
358 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
359 if ((PL_op->op_private & OPpLVAL_INTRO)) {
360 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
363 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
366 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
370 cv = (CV*)&PL_sv_undef;
381 SV *ret = &PL_sv_undef;
383 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
384 const char * const s = SvPVX_const(TOPs);
385 if (strnEQ(s, "CORE::", 6)) {
386 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
387 if (code < 0) { /* Overridable. */
388 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
389 int i = 0, n = 0, seen_question = 0;
391 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
393 if (code == -KEY_chop || code == -KEY_chomp
394 || code == -KEY_exec || code == -KEY_system)
396 while (i < MAXO) { /* The slow way. */
397 if (strEQ(s + 6, PL_op_name[i])
398 || strEQ(s + 6, PL_op_desc[i]))
404 goto nonesuch; /* Should not happen... */
406 oa = PL_opargs[i] >> OASHIFT;
408 if (oa & OA_OPTIONAL && !seen_question) {
412 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
413 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
414 /* But globs are already references (kinda) */
415 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
419 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
423 ret = sv_2mortal(newSVpvn(str, n - 1));
425 else if (code) /* Non-Overridable */
427 else { /* None such */
429 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
433 cv = sv_2cv(TOPs, &stash, &gv, 0);
435 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
444 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
446 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
462 if (GIMME != G_ARRAY) {
466 *MARK = &PL_sv_undef;
467 *MARK = refto(*MARK);
471 EXTEND_MORTAL(SP - MARK);
473 *MARK = refto(*MARK);
478 S_refto(pTHX_ SV *sv)
482 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
485 if (!(sv = LvTARG(sv)))
488 (void)SvREFCNT_inc(sv);
490 else if (SvTYPE(sv) == SVt_PVAV) {
491 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
494 (void)SvREFCNT_inc(sv);
496 else if (SvPADTMP(sv) && !IS_PADGV(sv))
500 (void)SvREFCNT_inc(sv);
503 sv_upgrade(rv, SVt_RV);
513 SV * const sv = POPs;
518 if (!sv || !SvROK(sv))
521 pv = sv_reftype(SvRV(sv),TRUE);
522 PUSHp(pv, strlen(pv));
532 stash = CopSTASH(PL_curcop);
534 SV * const ssv = POPs;
538 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
539 Perl_croak(aTHX_ "Attempt to bless into a reference");
540 ptr = SvPV_const(ssv,len);
541 if (len == 0 && ckWARN(WARN_MISC))
542 Perl_warner(aTHX_ packWARN(WARN_MISC),
543 "Explicit blessing to '' (assuming package main)");
544 stash = gv_stashpvn(ptr, len, TRUE);
547 (void)sv_bless(TOPs, stash);
556 const char * const elem = SvPV_nolen_const(sv);
557 GV * const gv = (GV*)POPs;
562 /* elem will always be NUL terminated. */
563 const char * const second_letter = elem + 1;
566 if (strEQ(second_letter, "RRAY"))
567 tmpRef = (SV*)GvAV(gv);
570 if (strEQ(second_letter, "ODE"))
571 tmpRef = (SV*)GvCVu(gv);
574 if (strEQ(second_letter, "ILEHANDLE")) {
575 /* finally deprecated in 5.8.0 */
576 deprecate("*glob{FILEHANDLE}");
577 tmpRef = (SV*)GvIOp(gv);
580 if (strEQ(second_letter, "ORMAT"))
581 tmpRef = (SV*)GvFORM(gv);
584 if (strEQ(second_letter, "LOB"))
588 if (strEQ(second_letter, "ASH"))
589 tmpRef = (SV*)GvHV(gv);
592 if (*second_letter == 'O' && !elem[2])
593 tmpRef = (SV*)GvIOp(gv);
596 if (strEQ(second_letter, "AME"))
597 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
600 if (strEQ(second_letter, "ACKAGE")) {
601 const HV * const stash = GvSTASH(gv);
602 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
603 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
607 if (strEQ(second_letter, "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 Newx(PL_screamfirst, 256, I32);
654 Newx(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)
673 register const I32 ch = s[pos];
675 snext[pos] = sfirst[ch] - pos;
682 /* piggyback on m//g magic */
683 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 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);
748 if (!PL_op->op_private) {
757 SV_CHECK_THINKFIRST_COW_DROP(sv);
759 switch (SvTYPE(sv)) {
769 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
770 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
771 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
775 /* let user-undef'd sub keep its identity */
776 GV* const gv = CvGV((CV*)sv);
783 SvSetMagicSV(sv, &PL_sv_undef);
788 GvGP(sv) = gp_ref(gp);
789 GvSV(sv) = NEWSV(72,0);
790 GvLINE(sv) = CopLINE(PL_curcop);
796 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
811 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
812 DIE(aTHX_ PL_no_modify);
813 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
814 && SvIVX(TOPs) != IV_MIN)
816 SvIV_set(TOPs, SvIVX(TOPs) - 1);
817 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
828 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
829 DIE(aTHX_ PL_no_modify);
830 sv_setsv(TARG, TOPs);
831 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
832 && SvIVX(TOPs) != IV_MAX)
834 SvIV_set(TOPs, SvIVX(TOPs) + 1);
835 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
840 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
850 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
851 DIE(aTHX_ PL_no_modify);
852 sv_setsv(TARG, TOPs);
853 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
854 && SvIVX(TOPs) != IV_MIN)
856 SvIV_set(TOPs, SvIVX(TOPs) - 1);
857 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
866 /* Ordinary operators. */
871 #ifdef PERL_PRESERVE_IVUV
874 tryAMAGICbin(pow,opASSIGN);
875 #ifdef PERL_PRESERVE_IVUV
876 /* For integer to integer power, we do the calculation by hand wherever
877 we're sure it is safe; otherwise we call pow() and try to convert to
878 integer afterwards. */
891 const IV iv = SvIVX(TOPs);
895 goto float_it; /* Can't do negative powers this way. */
899 baseuok = SvUOK(TOPm1s);
901 baseuv = SvUVX(TOPm1s);
903 const IV iv = SvIVX(TOPm1s);
906 baseuok = TRUE; /* effectively it's a UV now */
908 baseuv = -iv; /* abs, baseuok == false records sign */
911 /* now we have integer ** positive integer. */
914 /* foo & (foo - 1) is zero only for a power of 2. */
915 if (!(baseuv & (baseuv - 1))) {
916 /* We are raising power-of-2 to a positive integer.
917 The logic here will work for any base (even non-integer
918 bases) but it can be less accurate than
919 pow (base,power) or exp (power * log (base)) when the
920 intermediate values start to spill out of the mantissa.
921 With powers of 2 we know this can't happen.
922 And powers of 2 are the favourite thing for perl
923 programmers to notice ** not doing what they mean. */
925 NV base = baseuok ? baseuv : -(NV)baseuv;
930 while (power >>= 1) {
941 register unsigned int highbit = 8 * sizeof(UV);
942 register unsigned int diff = 8 * sizeof(UV);
945 if (baseuv >> highbit) {
949 /* we now have baseuv < 2 ** highbit */
950 if (power * highbit <= 8 * sizeof(UV)) {
951 /* result will definitely fit in UV, so use UV math
952 on same algorithm as above */
953 register UV result = 1;
954 register UV base = baseuv;
955 const bool odd_power = (bool)(power & 1);
959 while (power >>= 1) {
966 if (baseuok || !odd_power)
967 /* answer is positive */
969 else if (result <= (UV)IV_MAX)
970 /* answer negative, fits in IV */
972 else if (result == (UV)IV_MIN)
973 /* 2's complement assumption: special case IV_MIN */
976 /* answer negative, doesn't fit */
988 SETn( Perl_pow( left, right) );
989 #ifdef PERL_PRESERVE_IVUV
999 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1000 #ifdef PERL_PRESERVE_IVUV
1003 /* Unless the left argument is integer in range we are going to have to
1004 use NV maths. Hence only attempt to coerce the right argument if
1005 we know the left is integer. */
1006 /* Left operand is defined, so is it IV? */
1007 SvIV_please(TOPm1s);
1008 if (SvIOK(TOPm1s)) {
1009 bool auvok = SvUOK(TOPm1s);
1010 bool buvok = SvUOK(TOPs);
1011 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1012 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1019 alow = SvUVX(TOPm1s);
1021 const IV aiv = SvIVX(TOPm1s);
1024 auvok = TRUE; /* effectively it's a UV now */
1026 alow = -aiv; /* abs, auvok == false records sign */
1032 const IV biv = SvIVX(TOPs);
1035 buvok = TRUE; /* effectively it's a UV now */
1037 blow = -biv; /* abs, buvok == false records sign */
1041 /* If this does sign extension on unsigned it's time for plan B */
1042 ahigh = alow >> (4 * sizeof (UV));
1044 bhigh = blow >> (4 * sizeof (UV));
1046 if (ahigh && bhigh) {
1047 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1048 which is overflow. Drop to NVs below. */
1049 } else if (!ahigh && !bhigh) {
1050 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1051 so the unsigned multiply cannot overflow. */
1052 const UV product = alow * blow;
1053 if (auvok == buvok) {
1054 /* -ve * -ve or +ve * +ve gives a +ve result. */
1058 } else if (product <= (UV)IV_MIN) {
1059 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1060 /* -ve result, which could overflow an IV */
1062 SETi( -(IV)product );
1064 } /* else drop to NVs below. */
1066 /* One operand is large, 1 small */
1069 /* swap the operands */
1071 bhigh = blow; /* bhigh now the temp var for the swap */
1075 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1076 multiplies can't overflow. shift can, add can, -ve can. */
1077 product_middle = ahigh * blow;
1078 if (!(product_middle & topmask)) {
1079 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1081 product_middle <<= (4 * sizeof (UV));
1082 product_low = alow * blow;
1084 /* as for pp_add, UV + something mustn't get smaller.
1085 IIRC ANSI mandates this wrapping *behaviour* for
1086 unsigned whatever the actual representation*/
1087 product_low += product_middle;
1088 if (product_low >= product_middle) {
1089 /* didn't overflow */
1090 if (auvok == buvok) {
1091 /* -ve * -ve or +ve * +ve gives a +ve result. */
1093 SETu( product_low );
1095 } else if (product_low <= (UV)IV_MIN) {
1096 /* 2s complement assumption again */
1097 /* -ve result, which could overflow an IV */
1099 SETi( -(IV)product_low );
1101 } /* else drop to NVs below. */
1103 } /* product_middle too large */
1104 } /* ahigh && bhigh */
1105 } /* SvIOK(TOPm1s) */
1110 SETn( left * right );
1117 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1118 /* Only try to do UV divide first
1119 if ((SLOPPYDIVIDE is true) or
1120 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1122 The assumption is that it is better to use floating point divide
1123 whenever possible, only doing integer divide first if we can't be sure.
1124 If NV_PRESERVES_UV is true then we know at compile time that no UV
1125 can be too large to preserve, so don't need to compile the code to
1126 test the size of UVs. */
1129 # define PERL_TRY_UV_DIVIDE
1130 /* ensure that 20./5. == 4. */
1132 # ifdef PERL_PRESERVE_IVUV
1133 # ifndef NV_PRESERVES_UV
1134 # define PERL_TRY_UV_DIVIDE
1139 #ifdef PERL_TRY_UV_DIVIDE
1142 SvIV_please(TOPm1s);
1143 if (SvIOK(TOPm1s)) {
1144 bool left_non_neg = SvUOK(TOPm1s);
1145 bool right_non_neg = SvUOK(TOPs);
1149 if (right_non_neg) {
1150 right = SvUVX(TOPs);
1153 const IV biv = SvIVX(TOPs);
1156 right_non_neg = TRUE; /* effectively it's a UV now */
1162 /* historically undef()/0 gives a "Use of uninitialized value"
1163 warning before dieing, hence this test goes here.
1164 If it were immediately before the second SvIV_please, then
1165 DIE() would be invoked before left was even inspected, so
1166 no inpsection would give no warning. */
1168 DIE(aTHX_ "Illegal division by zero");
1171 left = SvUVX(TOPm1s);
1174 const IV aiv = SvIVX(TOPm1s);
1177 left_non_neg = TRUE; /* effectively it's a UV now */
1186 /* For sloppy divide we always attempt integer division. */
1188 /* Otherwise we only attempt it if either or both operands
1189 would not be preserved by an NV. If both fit in NVs
1190 we fall through to the NV divide code below. However,
1191 as left >= right to ensure integer result here, we know that
1192 we can skip the test on the right operand - right big
1193 enough not to be preserved can't get here unless left is
1196 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1199 /* Integer division can't overflow, but it can be imprecise. */
1200 const UV result = left / right;
1201 if (result * right == left) {
1202 SP--; /* result is valid */
1203 if (left_non_neg == right_non_neg) {
1204 /* signs identical, result is positive. */
1208 /* 2s complement assumption */
1209 if (result <= (UV)IV_MIN)
1210 SETi( -(IV)result );
1212 /* It's exact but too negative for IV. */
1213 SETn( -(NV)result );
1216 } /* tried integer divide but it was not an integer result */
1217 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1218 } /* left wasn't SvIOK */
1219 } /* right wasn't SvIOK */
1220 #endif /* PERL_TRY_UV_DIVIDE */
1224 DIE(aTHX_ "Illegal division by zero");
1225 PUSHn( left / right );
1232 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1236 bool left_neg = FALSE;
1237 bool right_neg = FALSE;
1238 bool use_double = FALSE;
1239 bool dright_valid = FALSE;
1245 right_neg = !SvUOK(TOPs);
1247 right = SvUVX(POPs);
1249 const IV biv = SvIVX(POPs);
1252 right_neg = FALSE; /* effectively it's a UV now */
1260 right_neg = dright < 0;
1263 if (dright < UV_MAX_P1) {
1264 right = U_V(dright);
1265 dright_valid = TRUE; /* In case we need to use double below. */
1271 /* At this point use_double is only true if right is out of range for
1272 a UV. In range NV has been rounded down to nearest UV and
1273 use_double false. */
1275 if (!use_double && SvIOK(TOPs)) {
1277 left_neg = !SvUOK(TOPs);
1281 const IV aiv = SvIVX(POPs);
1284 left_neg = FALSE; /* effectively it's a UV now */
1293 left_neg = dleft < 0;
1297 /* This should be exactly the 5.6 behaviour - if left and right are
1298 both in range for UV then use U_V() rather than floor. */
1300 if (dleft < UV_MAX_P1) {
1301 /* right was in range, so is dleft, so use UVs not double.
1305 /* left is out of range for UV, right was in range, so promote
1306 right (back) to double. */
1308 /* The +0.5 is used in 5.6 even though it is not strictly
1309 consistent with the implicit +0 floor in the U_V()
1310 inside the #if 1. */
1311 dleft = Perl_floor(dleft + 0.5);
1314 dright = Perl_floor(dright + 0.5);
1324 DIE(aTHX_ "Illegal modulus zero");
1326 dans = Perl_fmod(dleft, dright);
1327 if ((left_neg != right_neg) && dans)
1328 dans = dright - dans;
1331 sv_setnv(TARG, dans);
1337 DIE(aTHX_ "Illegal modulus zero");
1340 if ((left_neg != right_neg) && ans)
1343 /* XXX may warn: unary minus operator applied to unsigned type */
1344 /* could change -foo to be (~foo)+1 instead */
1345 if (ans <= ~((UV)IV_MAX)+1)
1346 sv_setiv(TARG, ~ans+1);
1348 sv_setnv(TARG, -(NV)ans);
1351 sv_setuv(TARG, ans);
1360 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1367 const UV uv = SvUV(sv);
1369 count = IV_MAX; /* The best we can do? */
1373 const IV iv = SvIV(sv);
1380 else if (SvNOKp(sv)) {
1381 const NV nv = SvNV(sv);
1389 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1391 static const char oom_list_extend[] = "Out of memory during list extend";
1392 const I32 items = SP - MARK;
1393 const I32 max = items * count;
1395 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1396 /* Did the max computation overflow? */
1397 if (items > 0 && max > 0 && (max < items || max < count))
1398 Perl_croak(aTHX_ oom_list_extend);
1403 /* This code was intended to fix 20010809.028:
1406 for (($x =~ /./g) x 2) {
1407 print chop; # "abcdabcd" expected as output.
1410 * but that change (#11635) broke this code:
1412 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1414 * I can't think of a better fix that doesn't introduce
1415 * an efficiency hit by copying the SVs. The stack isn't
1416 * refcounted, and mortalisation obviously doesn't
1417 * Do The Right Thing when the stack has more than
1418 * one pointer to the same mortal value.
1422 *SP = sv_2mortal(newSVsv(*SP));
1432 repeatcpy((char*)(MARK + items), (char*)MARK,
1433 items * sizeof(SV*), count - 1);
1436 else if (count <= 0)
1439 else { /* Note: mark already snarfed by pp_list */
1440 SV * const tmpstr = POPs;
1443 static const char oom_string_extend[] =
1444 "Out of memory during string extend";
1446 SvSetSV(TARG, tmpstr);
1447 SvPV_force(TARG, len);
1448 isutf = DO_UTF8(TARG);
1453 const STRLEN max = (UV)count * len;
1454 if (len > ((MEM_SIZE)~0)/count)
1455 Perl_croak(aTHX_ oom_string_extend);
1456 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1457 SvGROW(TARG, max + 1);
1458 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1459 SvCUR_set(TARG, SvCUR(TARG) * count);
1461 *SvEND(TARG) = '\0';
1464 (void)SvPOK_only_UTF8(TARG);
1466 (void)SvPOK_only(TARG);
1468 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1469 /* The parser saw this as a list repeat, and there
1470 are probably several items on the stack. But we're
1471 in scalar context, and there's no pp_list to save us
1472 now. So drop the rest of the items -- robin@kitsite.com
1485 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1486 useleft = USE_LEFT(TOPm1s);
1487 #ifdef PERL_PRESERVE_IVUV
1488 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1489 "bad things" happen if you rely on signed integers wrapping. */
1492 /* Unless the left argument is integer in range we are going to have to
1493 use NV maths. Hence only attempt to coerce the right argument if
1494 we know the left is integer. */
1495 register UV auv = 0;
1501 a_valid = auvok = 1;
1502 /* left operand is undef, treat as zero. */
1504 /* Left operand is defined, so is it IV? */
1505 SvIV_please(TOPm1s);
1506 if (SvIOK(TOPm1s)) {
1507 if ((auvok = SvUOK(TOPm1s)))
1508 auv = SvUVX(TOPm1s);
1510 register const IV aiv = SvIVX(TOPm1s);
1513 auvok = 1; /* Now acting as a sign flag. */
1514 } else { /* 2s complement assumption for IV_MIN */
1522 bool result_good = 0;
1525 bool buvok = SvUOK(TOPs);
1530 register const IV biv = SvIVX(TOPs);
1537 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1538 else "IV" now, independent of how it came in.
1539 if a, b represents positive, A, B negative, a maps to -A etc
1544 all UV maths. negate result if A negative.
1545 subtract if signs same, add if signs differ. */
1547 if (auvok ^ buvok) {
1556 /* Must get smaller */
1561 if (result <= buv) {
1562 /* result really should be -(auv-buv). as its negation
1563 of true value, need to swap our result flag */
1575 if (result <= (UV)IV_MIN)
1576 SETi( -(IV)result );
1578 /* result valid, but out of range for IV. */
1579 SETn( -(NV)result );
1583 } /* Overflow, drop through to NVs. */
1587 useleft = USE_LEFT(TOPm1s);
1591 /* left operand is undef, treat as zero - value */
1595 SETn( TOPn - value );
1602 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1604 const IV shift = POPi;
1605 if (PL_op->op_private & HINT_INTEGER) {
1619 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1621 const IV shift = POPi;
1622 if (PL_op->op_private & HINT_INTEGER) {
1636 dSP; tryAMAGICbinSET(lt,0);
1637 #ifdef PERL_PRESERVE_IVUV
1640 SvIV_please(TOPm1s);
1641 if (SvIOK(TOPm1s)) {
1642 bool auvok = SvUOK(TOPm1s);
1643 bool buvok = SvUOK(TOPs);
1645 if (!auvok && !buvok) { /* ## IV < IV ## */
1646 const IV aiv = SvIVX(TOPm1s);
1647 const IV biv = SvIVX(TOPs);
1650 SETs(boolSV(aiv < biv));
1653 if (auvok && buvok) { /* ## UV < UV ## */
1654 const UV auv = SvUVX(TOPm1s);
1655 const UV buv = SvUVX(TOPs);
1658 SETs(boolSV(auv < buv));
1661 if (auvok) { /* ## UV < IV ## */
1663 const IV biv = SvIVX(TOPs);
1666 /* As (a) is a UV, it's >=0, so it cannot be < */
1671 SETs(boolSV(auv < (UV)biv));
1674 { /* ## IV < UV ## */
1675 const IV aiv = SvIVX(TOPm1s);
1679 /* As (b) is a UV, it's >=0, so it must be < */
1686 SETs(boolSV((UV)aiv < buv));
1692 #ifndef NV_PRESERVES_UV
1693 #ifdef PERL_PRESERVE_IVUV
1696 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1698 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1704 SETs(boolSV(TOPn < value));
1711 dSP; tryAMAGICbinSET(gt,0);
1712 #ifdef PERL_PRESERVE_IVUV
1715 SvIV_please(TOPm1s);
1716 if (SvIOK(TOPm1s)) {
1717 bool auvok = SvUOK(TOPm1s);
1718 bool buvok = SvUOK(TOPs);
1720 if (!auvok && !buvok) { /* ## IV > IV ## */
1721 const IV aiv = SvIVX(TOPm1s);
1722 const IV biv = SvIVX(TOPs);
1725 SETs(boolSV(aiv > biv));
1728 if (auvok && buvok) { /* ## UV > UV ## */
1729 const UV auv = SvUVX(TOPm1s);
1730 const UV buv = SvUVX(TOPs);
1733 SETs(boolSV(auv > buv));
1736 if (auvok) { /* ## UV > IV ## */
1738 const IV biv = SvIVX(TOPs);
1742 /* As (a) is a UV, it's >=0, so it must be > */
1747 SETs(boolSV(auv > (UV)biv));
1750 { /* ## IV > UV ## */
1751 const IV aiv = SvIVX(TOPm1s);
1755 /* As (b) is a UV, it's >=0, so it cannot be > */
1762 SETs(boolSV((UV)aiv > buv));
1768 #ifndef NV_PRESERVES_UV
1769 #ifdef PERL_PRESERVE_IVUV
1772 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1774 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1780 SETs(boolSV(TOPn > value));
1787 dSP; tryAMAGICbinSET(le,0);
1788 #ifdef PERL_PRESERVE_IVUV
1791 SvIV_please(TOPm1s);
1792 if (SvIOK(TOPm1s)) {
1793 bool auvok = SvUOK(TOPm1s);
1794 bool buvok = SvUOK(TOPs);
1796 if (!auvok && !buvok) { /* ## IV <= IV ## */
1797 const IV aiv = SvIVX(TOPm1s);
1798 const IV biv = SvIVX(TOPs);
1801 SETs(boolSV(aiv <= biv));
1804 if (auvok && buvok) { /* ## UV <= UV ## */
1805 UV auv = SvUVX(TOPm1s);
1806 UV buv = SvUVX(TOPs);
1809 SETs(boolSV(auv <= buv));
1812 if (auvok) { /* ## UV <= IV ## */
1814 const IV biv = SvIVX(TOPs);
1818 /* As (a) is a UV, it's >=0, so a cannot be <= */
1823 SETs(boolSV(auv <= (UV)biv));
1826 { /* ## IV <= UV ## */
1827 const IV aiv = SvIVX(TOPm1s);
1831 /* As (b) is a UV, it's >=0, so a must be <= */
1838 SETs(boolSV((UV)aiv <= buv));
1844 #ifndef NV_PRESERVES_UV
1845 #ifdef PERL_PRESERVE_IVUV
1848 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1850 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1856 SETs(boolSV(TOPn <= value));
1863 dSP; tryAMAGICbinSET(ge,0);
1864 #ifdef PERL_PRESERVE_IVUV
1867 SvIV_please(TOPm1s);
1868 if (SvIOK(TOPm1s)) {
1869 bool auvok = SvUOK(TOPm1s);
1870 bool buvok = SvUOK(TOPs);
1872 if (!auvok && !buvok) { /* ## IV >= IV ## */
1873 const IV aiv = SvIVX(TOPm1s);
1874 const IV biv = SvIVX(TOPs);
1877 SETs(boolSV(aiv >= biv));
1880 if (auvok && buvok) { /* ## UV >= UV ## */
1881 const UV auv = SvUVX(TOPm1s);
1882 const UV buv = SvUVX(TOPs);
1885 SETs(boolSV(auv >= buv));
1888 if (auvok) { /* ## UV >= IV ## */
1890 const IV biv = SvIVX(TOPs);
1894 /* As (a) is a UV, it's >=0, so it must be >= */
1899 SETs(boolSV(auv >= (UV)biv));
1902 { /* ## IV >= UV ## */
1903 const IV aiv = SvIVX(TOPm1s);
1907 /* As (b) is a UV, it's >=0, so a cannot be >= */
1914 SETs(boolSV((UV)aiv >= buv));
1920 #ifndef NV_PRESERVES_UV
1921 #ifdef PERL_PRESERVE_IVUV
1924 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1926 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1932 SETs(boolSV(TOPn >= value));
1939 dSP; tryAMAGICbinSET(ne,0);
1940 #ifndef NV_PRESERVES_UV
1941 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1943 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1947 #ifdef PERL_PRESERVE_IVUV
1950 SvIV_please(TOPm1s);
1951 if (SvIOK(TOPm1s)) {
1952 const bool auvok = SvUOK(TOPm1s);
1953 const bool buvok = SvUOK(TOPs);
1955 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1956 /* Casting IV to UV before comparison isn't going to matter
1957 on 2s complement. On 1s complement or sign&magnitude
1958 (if we have any of them) it could make negative zero
1959 differ from normal zero. As I understand it. (Need to
1960 check - is negative zero implementation defined behaviour
1962 const UV buv = SvUVX(POPs);
1963 const UV auv = SvUVX(TOPs);
1965 SETs(boolSV(auv != buv));
1968 { /* ## Mixed IV,UV ## */
1972 /* != is commutative so swap if needed (save code) */
1974 /* swap. top of stack (b) is the iv */
1978 /* As (a) is a UV, it's >0, so it cannot be == */
1987 /* As (b) is a UV, it's >0, so it cannot be == */
1991 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1993 SETs(boolSV((UV)iv != uv));
2001 SETs(boolSV(TOPn != value));
2008 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2009 #ifndef NV_PRESERVES_UV
2010 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2011 const UV right = PTR2UV(SvRV(POPs));
2012 const UV left = PTR2UV(SvRV(TOPs));
2013 SETi((left > right) - (left < right));
2017 #ifdef PERL_PRESERVE_IVUV
2018 /* Fortunately it seems NaN isn't IOK */
2021 SvIV_please(TOPm1s);
2022 if (SvIOK(TOPm1s)) {
2023 const bool leftuvok = SvUOK(TOPm1s);
2024 const bool rightuvok = SvUOK(TOPs);
2026 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2027 const IV leftiv = SvIVX(TOPm1s);
2028 const IV rightiv = SvIVX(TOPs);
2030 if (leftiv > rightiv)
2032 else if (leftiv < rightiv)
2036 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2037 const UV leftuv = SvUVX(TOPm1s);
2038 const UV rightuv = SvUVX(TOPs);
2040 if (leftuv > rightuv)
2042 else if (leftuv < rightuv)
2046 } else if (leftuvok) { /* ## UV <=> IV ## */
2047 const IV rightiv = SvIVX(TOPs);
2049 /* As (a) is a UV, it's >=0, so it cannot be < */
2052 const UV leftuv = SvUVX(TOPm1s);
2053 if (leftuv > (UV)rightiv) {
2055 } else if (leftuv < (UV)rightiv) {
2061 } else { /* ## IV <=> UV ## */
2062 const IV leftiv = SvIVX(TOPm1s);
2064 /* As (b) is a UV, it's >=0, so it must be < */
2067 const UV rightuv = SvUVX(TOPs);
2068 if ((UV)leftiv > rightuv) {
2070 } else if ((UV)leftiv < rightuv) {
2088 if (Perl_isnan(left) || Perl_isnan(right)) {
2092 value = (left > right) - (left < right);
2096 else if (left < right)
2098 else if (left > right)
2114 int amg_type = sle_amg;
2118 switch (PL_op->op_type) {
2137 tryAMAGICbinSET_var(amg_type,0);
2140 const int cmp = (IN_LOCALE_RUNTIME
2141 ? sv_cmp_locale(left, right)
2142 : sv_cmp(left, right));
2143 SETs(boolSV(cmp * multiplier < rhs));
2150 dSP; tryAMAGICbinSET(seq,0);
2153 SETs(boolSV(sv_eq(left, right)));
2160 dSP; tryAMAGICbinSET(sne,0);
2163 SETs(boolSV(!sv_eq(left, right)));
2170 dSP; dTARGET; tryAMAGICbin(scmp,0);
2173 const int cmp = (IN_LOCALE_RUNTIME
2174 ? sv_cmp_locale(left, right)
2175 : sv_cmp(left, right));
2183 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2188 if (SvNIOKp(left) || SvNIOKp(right)) {
2189 if (PL_op->op_private & HINT_INTEGER) {
2190 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2194 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2199 do_vop(PL_op->op_type, TARG, left, right);
2208 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2213 if (SvNIOKp(left) || SvNIOKp(right)) {
2214 if (PL_op->op_private & HINT_INTEGER) {
2215 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2219 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2224 do_vop(PL_op->op_type, TARG, left, right);
2233 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2238 if (SvNIOKp(left) || SvNIOKp(right)) {
2239 if (PL_op->op_private & HINT_INTEGER) {
2240 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2244 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2249 do_vop(PL_op->op_type, TARG, left, right);
2258 dSP; dTARGET; tryAMAGICun(neg);
2261 const int flags = SvFLAGS(sv);
2263 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2264 /* It's publicly an integer, or privately an integer-not-float */
2267 if (SvIVX(sv) == IV_MIN) {
2268 /* 2s complement assumption. */
2269 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2272 else if (SvUVX(sv) <= IV_MAX) {
2277 else if (SvIVX(sv) != IV_MIN) {
2281 #ifdef PERL_PRESERVE_IVUV
2290 else if (SvPOKp(sv)) {
2292 const char * const s = SvPV_const(sv, len);
2293 if (isIDFIRST(*s)) {
2294 sv_setpvn(TARG, "-", 1);
2297 else if (*s == '+' || *s == '-') {
2299 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2301 else if (DO_UTF8(sv)) {
2304 goto oops_its_an_int;
2306 sv_setnv(TARG, -SvNV(sv));
2308 sv_setpvn(TARG, "-", 1);
2315 goto oops_its_an_int;
2316 sv_setnv(TARG, -SvNV(sv));
2328 dSP; tryAMAGICunSET(not);
2329 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2335 dSP; dTARGET; tryAMAGICun(compl);
2340 if (PL_op->op_private & HINT_INTEGER) {
2341 const IV i = ~SvIV_nomg(sv);
2345 const UV u = ~SvUV_nomg(sv);
2354 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2355 sv_setsv_nomg(TARG, sv);
2356 tmps = (U8*)SvPV_force(TARG, len);
2359 /* Calculate exact length, let's not estimate. */
2368 while (tmps < send) {
2369 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2370 tmps += UTF8SKIP(tmps);
2371 targlen += UNISKIP(~c);
2377 /* Now rewind strings and write them. */
2381 Newxz(result, targlen + 1, U8);
2382 while (tmps < send) {
2383 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2384 tmps += UTF8SKIP(tmps);
2385 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2389 sv_setpvn(TARG, (char*)result, targlen);
2393 Newxz(result, nchar + 1, U8);
2394 while (tmps < send) {
2395 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2396 tmps += UTF8SKIP(tmps);
2401 sv_setpvn(TARG, (char*)result, nchar);
2410 register long *tmpl;
2411 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2414 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2419 for ( ; anum > 0; anum--, tmps++)
2428 /* integer versions of some of the above */
2432 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2435 SETi( left * right );
2442 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2446 DIE(aTHX_ "Illegal division by zero");
2447 value = POPi / value;
2456 /* This is the vanilla old i_modulo. */
2457 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2461 DIE(aTHX_ "Illegal modulus zero");
2462 SETi( left % right );
2467 #if defined(__GLIBC__) && IVSIZE == 8
2471 /* This is the i_modulo with the workaround for the _moddi3 bug
2472 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2473 * See below for pp_i_modulo. */
2474 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2478 DIE(aTHX_ "Illegal modulus zero");
2479 SETi( left % PERL_ABS(right) );
2487 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2491 DIE(aTHX_ "Illegal modulus zero");
2492 /* The assumption is to use hereafter the old vanilla version... */
2494 PL_ppaddr[OP_I_MODULO] =
2496 /* .. but if we have glibc, we might have a buggy _moddi3
2497 * (at least glicb 2.2.5 is known to have this bug), in other
2498 * words our integer modulus with negative quad as the second
2499 * argument might be broken. Test for this and re-patch the
2500 * opcode dispatch table if that is the case, remembering to
2501 * also apply the workaround so that this first round works
2502 * right, too. See [perl #9402] for more information. */
2503 #if defined(__GLIBC__) && IVSIZE == 8
2507 /* Cannot do this check with inlined IV constants since
2508 * that seems to work correctly even with the buggy glibc. */
2510 /* Yikes, we have the bug.
2511 * Patch in the workaround version. */
2513 PL_ppaddr[OP_I_MODULO] =
2514 &Perl_pp_i_modulo_1;
2515 /* Make certain we work right this time, too. */
2516 right = PERL_ABS(right);
2520 SETi( left % right );
2527 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2530 SETi( left + right );
2537 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2540 SETi( left - right );
2547 dSP; tryAMAGICbinSET(lt,0);
2550 SETs(boolSV(left < right));
2557 dSP; tryAMAGICbinSET(gt,0);
2560 SETs(boolSV(left > right));
2567 dSP; tryAMAGICbinSET(le,0);
2570 SETs(boolSV(left <= right));
2577 dSP; tryAMAGICbinSET(ge,0);
2580 SETs(boolSV(left >= right));
2587 dSP; tryAMAGICbinSET(eq,0);
2590 SETs(boolSV(left == right));
2597 dSP; tryAMAGICbinSET(ne,0);
2600 SETs(boolSV(left != right));
2607 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2614 else if (left < right)
2625 dSP; dTARGET; tryAMAGICun(neg);
2630 /* High falutin' math. */
2634 dSP; dTARGET; tryAMAGICbin(atan2,0);
2637 SETn(Perl_atan2(left, right));
2644 dSP; dTARGET; tryAMAGICun(sin);
2646 const NV value = POPn;
2647 XPUSHn(Perl_sin(value));
2654 dSP; dTARGET; tryAMAGICun(cos);
2656 const NV value = POPn;
2657 XPUSHn(Perl_cos(value));
2662 /* Support Configure command-line overrides for rand() functions.
2663 After 5.005, perhaps we should replace this by Configure support
2664 for drand48(), random(), or rand(). For 5.005, though, maintain
2665 compatibility by calling rand() but allow the user to override it.
2666 See INSTALL for details. --Andy Dougherty 15 July 1998
2668 /* Now it's after 5.005, and Configure supports drand48() and random(),
2669 in addition to rand(). So the overrides should not be needed any more.
2670 --Jarkko Hietaniemi 27 September 1998
2673 #ifndef HAS_DRAND48_PROTO
2674 extern double drand48 (void);
2687 if (!PL_srand_called) {
2688 (void)seedDrand01((Rand_seed_t)seed());
2689 PL_srand_called = TRUE;
2699 const UV anum = (MAXARG < 1) ? seed() : POPu;
2700 (void)seedDrand01((Rand_seed_t)anum);
2701 PL_srand_called = TRUE;
2708 dSP; dTARGET; tryAMAGICun(exp);
2712 value = Perl_exp(value);
2720 dSP; dTARGET; tryAMAGICun(log);
2722 const NV value = POPn;
2724 SET_NUMERIC_STANDARD();
2725 DIE(aTHX_ "Can't take log of %"NVgf, value);
2727 XPUSHn(Perl_log(value));
2734 dSP; dTARGET; tryAMAGICun(sqrt);
2736 const NV value = POPn;
2738 SET_NUMERIC_STANDARD();
2739 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2741 XPUSHn(Perl_sqrt(value));
2748 dSP; dTARGET; tryAMAGICun(int);
2750 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2751 /* XXX it's arguable that compiler casting to IV might be subtly
2752 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2753 else preferring IV has introduced a subtle behaviour change bug. OTOH
2754 relying on floating point to be accurate is a bug. */
2758 else if (SvIOK(TOPs)) {
2765 const NV value = TOPn;
2767 if (value < (NV)UV_MAX + 0.5) {
2770 SETn(Perl_floor(value));
2774 if (value > (NV)IV_MIN - 0.5) {
2777 SETn(Perl_ceil(value));
2787 dSP; dTARGET; tryAMAGICun(abs);
2789 /* This will cache the NV value if string isn't actually integer */
2794 else if (SvIOK(TOPs)) {
2795 /* IVX is precise */
2797 SETu(TOPu); /* force it to be numeric only */
2805 /* 2s complement assumption. Also, not really needed as
2806 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2812 const NV value = TOPn;
2827 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2831 SV* const sv = POPs;
2833 tmps = (SvPV_const(sv, len));
2835 /* If Unicode, try to downgrade
2836 * If not possible, croak. */
2837 SV* const tsv = sv_2mortal(newSVsv(sv));
2840 sv_utf8_downgrade(tsv, FALSE);
2841 tmps = SvPV_const(tsv, len);
2843 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2844 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2857 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2861 SV* const sv = POPs;
2863 tmps = (SvPV_const(sv, len));
2865 /* If Unicode, try to downgrade
2866 * If not possible, croak. */
2867 SV* const tsv = sv_2mortal(newSVsv(sv));
2870 sv_utf8_downgrade(tsv, FALSE);
2871 tmps = SvPV_const(tsv, len);
2873 while (*tmps && len && isSPACE(*tmps))
2878 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2879 else if (*tmps == 'b')
2880 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2882 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2884 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2898 SV * const sv = TOPs;
2901 SETi(sv_len_utf8(sv));
2917 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2919 const I32 arybase = PL_curcop->cop_arybase;
2921 const char *repl = NULL;
2923 const int num_args = PL_op->op_private & 7;
2924 bool repl_need_utf8_upgrade = FALSE;
2925 bool repl_is_utf8 = FALSE;
2927 SvTAINTED_off(TARG); /* decontaminate */
2928 SvUTF8_off(TARG); /* decontaminate */
2932 repl = SvPV_const(repl_sv, repl_len);
2933 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2943 sv_utf8_upgrade(sv);
2945 else if (DO_UTF8(sv))
2946 repl_need_utf8_upgrade = TRUE;
2948 tmps = SvPV_const(sv, curlen);
2950 utf8_curlen = sv_len_utf8(sv);
2951 if (utf8_curlen == curlen)
2954 curlen = utf8_curlen;
2959 if (pos >= arybase) {
2977 else if (len >= 0) {
2979 if (rem > (I32)curlen)
2994 Perl_croak(aTHX_ "substr outside of string");
2995 if (ckWARN(WARN_SUBSTR))
2996 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3000 const I32 upos = pos;
3001 const I32 urem = rem;
3003 sv_pos_u2b(sv, &pos, &rem);
3005 /* we either return a PV or an LV. If the TARG hasn't been used
3006 * before, or is of that type, reuse it; otherwise use a mortal
3007 * instead. Note that LVs can have an extended lifetime, so also
3008 * dont reuse if refcount > 1 (bug #20933) */
3009 if (SvTYPE(TARG) > SVt_NULL) {
3010 if ( (SvTYPE(TARG) == SVt_PVLV)
3011 ? (!lvalue || SvREFCNT(TARG) > 1)
3014 TARG = sv_newmortal();
3018 sv_setpvn(TARG, tmps, rem);
3019 #ifdef USE_LOCALE_COLLATE
3020 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3025 SV* repl_sv_copy = NULL;
3027 if (repl_need_utf8_upgrade) {
3028 repl_sv_copy = newSVsv(repl_sv);
3029 sv_utf8_upgrade(repl_sv_copy);
3030 repl = SvPV_const(repl_sv_copy, repl_len);
3031 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3033 sv_insert(sv, pos, rem, repl, repl_len);
3037 SvREFCNT_dec(repl_sv_copy);
3039 else if (lvalue) { /* it's an lvalue! */
3040 if (!SvGMAGICAL(sv)) {
3042 SvPV_force_nolen(sv);
3043 if (ckWARN(WARN_SUBSTR))
3044 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3045 "Attempt to use reference as lvalue in substr");
3047 if (SvOK(sv)) /* is it defined ? */
3048 (void)SvPOK_only_UTF8(sv);
3050 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3053 if (SvTYPE(TARG) < SVt_PVLV) {
3054 sv_upgrade(TARG, SVt_PVLV);
3055 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3061 if (LvTARG(TARG) != sv) {
3063 SvREFCNT_dec(LvTARG(TARG));
3064 LvTARG(TARG) = SvREFCNT_inc(sv);
3066 LvTARGOFF(TARG) = upos;
3067 LvTARGLEN(TARG) = urem;
3071 PUSHs(TARG); /* avoid SvSETMAGIC here */
3078 register const IV size = POPi;
3079 register const IV offset = POPi;
3080 register SV * const src = POPs;
3081 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3083 SvTAINTED_off(TARG); /* decontaminate */
3084 if (lvalue) { /* it's an lvalue! */
3085 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3086 TARG = sv_newmortal();
3087 if (SvTYPE(TARG) < SVt_PVLV) {
3088 sv_upgrade(TARG, SVt_PVLV);
3089 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3092 if (LvTARG(TARG) != src) {
3094 SvREFCNT_dec(LvTARG(TARG));
3095 LvTARG(TARG) = SvREFCNT_inc(src);
3097 LvTARGOFF(TARG) = offset;
3098 LvTARGLEN(TARG) = size;
3101 sv_setuv(TARG, do_vecget(src, offset, size));
3117 const I32 arybase = PL_curcop->cop_arybase;
3124 offset = POPi - arybase;
3127 big_utf8 = DO_UTF8(big);
3128 little_utf8 = DO_UTF8(little);
3129 if (big_utf8 ^ little_utf8) {
3130 /* One needs to be upgraded. */
3131 SV * const bytes = little_utf8 ? big : little;
3133 const char * const p = SvPV_const(bytes, len);
3135 temp = newSVpvn(p, len);
3138 sv_recode_to_utf8(temp, PL_encoding);
3140 sv_utf8_upgrade(temp);
3149 if (big_utf8 && offset > 0)
3150 sv_pos_u2b(big, &offset, 0);
3151 tmps = SvPV_const(big, biglen);
3154 else if (offset > (I32)biglen)
3156 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3157 (unsigned char*)tmps + biglen, little, 0)))
3160 retval = tmps2 - tmps;
3161 if (retval > 0 && big_utf8)
3162 sv_pos_b2u(big, &retval);
3165 PUSHi(retval + arybase);
3181 const I32 arybase = PL_curcop->cop_arybase;
3189 big_utf8 = DO_UTF8(big);
3190 little_utf8 = DO_UTF8(little);
3191 if (big_utf8 ^ little_utf8) {
3192 /* One needs to be upgraded. */
3193 SV * const bytes = little_utf8 ? big : little;
3195 const char *p = SvPV_const(bytes, len);
3197 temp = newSVpvn(p, len);
3200 sv_recode_to_utf8(temp, PL_encoding);
3202 sv_utf8_upgrade(temp);
3211 tmps2 = SvPV_const(little, llen);
3212 tmps = SvPV_const(big, blen);
3217 if (offset > 0 && big_utf8)
3218 sv_pos_u2b(big, &offset, 0);
3219 offset = offset - arybase + llen;
3223 else if (offset > (I32)blen)
3225 if (!(tmps2 = rninstr(tmps, tmps + offset,
3226 tmps2, tmps2 + llen)))
3229 retval = tmps2 - tmps;
3230 if (retval > 0 && big_utf8)
3231 sv_pos_b2u(big, &retval);
3234 PUSHi(retval + arybase);
3240 dSP; dMARK; dORIGMARK; dTARGET;
3241 do_sprintf(TARG, SP-MARK, MARK+1);
3242 TAINT_IF(SvTAINTED(TARG));
3253 const U8 *s = (U8*)SvPV_const(argsv, len);
3256 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3257 tmpsv = sv_2mortal(newSVsv(argsv));
3258 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3262 XPUSHu(DO_UTF8(argsv) ?
3263 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3275 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3277 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3279 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3281 (void) POPs; /* Ignore the argument value. */
3282 value = UNICODE_REPLACEMENT;
3288 SvUPGRADE(TARG,SVt_PV);
3290 if (value > 255 && !IN_BYTES) {
3291 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3292 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3293 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3295 (void)SvPOK_only(TARG);
3304 *tmps++ = (char)value;
3306 (void)SvPOK_only(TARG);
3307 if (PL_encoding && !IN_BYTES) {
3308 sv_recode_to_utf8(TARG, PL_encoding);
3310 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3311 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3315 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3316 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3331 const char *tmps = SvPV_const(left, len);
3333 if (DO_UTF8(left)) {
3334 /* If Unicode, try to downgrade.
3335 * If not possible, croak.
3336 * Yes, we made this up. */
3337 SV* const tsv = sv_2mortal(newSVsv(left));
3340 sv_utf8_downgrade(tsv, FALSE);
3341 tmps = SvPV_const(tsv, len);
3343 # ifdef USE_ITHREADS
3345 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3346 /* This should be threadsafe because in ithreads there is only
3347 * one thread per interpreter. If this would not be true,
3348 * we would need a mutex to protect this malloc. */
3349 PL_reentrant_buffer->_crypt_struct_buffer =
3350 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3351 #if defined(__GLIBC__) || defined(__EMX__)
3352 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3353 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3354 /* work around glibc-2.2.5 bug */
3355 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3359 # endif /* HAS_CRYPT_R */
3360 # endif /* USE_ITHREADS */
3362 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3364 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3370 "The crypt() function is unimplemented due to excessive paranoia.");
3380 const int op_type = PL_op->op_type;
3384 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3385 UTF8_IS_START(*s)) {
3386 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3390 utf8_to_uvchr(s, &ulen);
3391 if (op_type == OP_UCFIRST) {
3392 toTITLE_utf8(s, tmpbuf, &tculen);
3394 toLOWER_utf8(s, tmpbuf, &tculen);
3397 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3399 /* slen is the byte length of the whole SV.
3400 * ulen is the byte length of the original Unicode character
3401 * stored as UTF-8 at s.
3402 * tculen is the byte length of the freshly titlecased (or
3403 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3404 * We first set the result to be the titlecased (/lowercased)
3405 * character, and then append the rest of the SV data. */
3406 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3408 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3413 s = (U8*)SvPV_force_nomg(sv, slen);
3414 Copy(tmpbuf, s, tculen, U8);
3419 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3421 SvUTF8_off(TARG); /* decontaminate */
3422 sv_setsv_nomg(TARG, sv);
3426 s1 = (U8*)SvPV_force_nomg(sv, slen);
3428 if (IN_LOCALE_RUNTIME) {
3431 *s1 = (op_type == OP_UCFIRST)
3432 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3435 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3455 U8 tmpbuf[UTF8_MAXBYTES+1];
3457 s = (const U8*)SvPV_nomg_const(sv,len);
3459 SvUTF8_off(TARG); /* decontaminate */
3460 sv_setpvn(TARG, "", 0);
3464 STRLEN min = len + 1;
3466 SvUPGRADE(TARG, SVt_PV);
3468 (void)SvPOK_only(TARG);
3469 d = (U8*)SvPVX(TARG);
3472 STRLEN u = UTF8SKIP(s);
3474 toUPPER_utf8(s, tmpbuf, &ulen);
3475 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3476 /* If the eventually required minimum size outgrows
3477 * the available space, we need to grow. */
3478 const UV o = d - (U8*)SvPVX_const(TARG);
3480 /* If someone uppercases one million U+03B0s we
3481 * SvGROW() one million times. Or we could try
3482 * guessing how much to allocate without allocating
3483 * too much. Such is life. */
3485 d = (U8*)SvPVX(TARG) + o;
3487 Copy(tmpbuf, d, ulen, U8);
3493 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3499 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3501 SvUTF8_off(TARG); /* decontaminate */
3502 sv_setsv_nomg(TARG, sv);
3506 s = (U8*)SvPV_force_nomg(sv, len);
3508 register const U8 *send = s + len;
3510 if (IN_LOCALE_RUNTIME) {
3513 for (; s < send; s++)
3514 *s = toUPPER_LC(*s);
3517 for (; s < send; s++)
3539 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3541 s = (const U8*)SvPV_nomg_const(sv,len);
3543 SvUTF8_off(TARG); /* decontaminate */
3544 sv_setpvn(TARG, "", 0);
3548 STRLEN min = len + 1;
3550 SvUPGRADE(TARG, SVt_PV);
3552 (void)SvPOK_only(TARG);
3553 d = (U8*)SvPVX(TARG);
3556 const STRLEN u = UTF8SKIP(s);
3557 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3559 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3560 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3562 * Now if the sigma is NOT followed by
3563 * /$ignorable_sequence$cased_letter/;
3564 * and it IS preceded by
3565 * /$cased_letter$ignorable_sequence/;
3566 * where $ignorable_sequence is
3567 * [\x{2010}\x{AD}\p{Mn}]*
3568 * and $cased_letter is
3569 * [\p{Ll}\p{Lo}\p{Lt}]
3570 * then it should be mapped to 0x03C2,
3571 * (GREEK SMALL LETTER FINAL SIGMA),
3572 * instead of staying 0x03A3.
3573 * "should be": in other words,
3574 * this is not implemented yet.
3575 * See lib/unicore/SpecialCasing.txt.
3578 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3579 /* If the eventually required minimum size outgrows
3580 * the available space, we need to grow. */
3581 const UV o = d - (U8*)SvPVX_const(TARG);
3583 /* If someone lowercases one million U+0130s we
3584 * SvGROW() one million times. Or we could try
3585 * guessing how much to allocate without allocating.
3586 * too much. Such is life. */
3588 d = (U8*)SvPVX(TARG) + o;
3590 Copy(tmpbuf, d, ulen, U8);
3596 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3602 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3604 SvUTF8_off(TARG); /* decontaminate */
3605 sv_setsv_nomg(TARG, sv);
3610 s = (U8*)SvPV_force_nomg(sv, len);
3612 register const U8 * const send = s + len;
3614 if (IN_LOCALE_RUNTIME) {
3617 for (; s < send; s++)
3618 *s = toLOWER_LC(*s);
3621 for (; s < send; s++)
3633 SV * const sv = TOPs;
3635 register const char *s = SvPV_const(sv,len);
3637 SvUTF8_off(TARG); /* decontaminate */
3640 SvUPGRADE(TARG, SVt_PV);
3641 SvGROW(TARG, (len * 2) + 1);
3645 if (UTF8_IS_CONTINUED(*s)) {
3646 STRLEN ulen = UTF8SKIP(s);
3670 SvCUR_set(TARG, d - SvPVX_const(TARG));
3671 (void)SvPOK_only_UTF8(TARG);
3674 sv_setpvn(TARG, s, len);
3676 if (SvSMAGICAL(TARG))
3685 dSP; dMARK; dORIGMARK;
3686 register AV* const av = (AV*)POPs;
3687 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3689 if (SvTYPE(av) == SVt_PVAV) {
3690 const I32 arybase = PL_curcop->cop_arybase;
3691 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3694 for (svp = MARK + 1; svp <= SP; svp++) {
3695 const I32 elem = SvIVx(*svp);
3699 if (max > AvMAX(av))
3702 while (++MARK <= SP) {
3704 I32 elem = SvIVx(*MARK);
3708 svp = av_fetch(av, elem, lval);
3710 if (!svp || *svp == &PL_sv_undef)
3711 DIE(aTHX_ PL_no_aelem, elem);
3712 if (PL_op->op_private & OPpLVAL_INTRO)
3713 save_aelem(av, elem, svp);
3715 *MARK = svp ? *svp : &PL_sv_undef;
3718 if (GIMME != G_ARRAY) {
3720 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3726 /* Associative arrays. */
3731 HV * const hash = (HV*)POPs;
3733 const I32 gimme = GIMME_V;
3736 /* might clobber stack_sp */
3737 entry = hv_iternext(hash);
3742 SV* const sv = hv_iterkeysv(entry);
3743 PUSHs(sv); /* won't clobber stack_sp */
3744 if (gimme == G_ARRAY) {
3747 /* might clobber stack_sp */
3748 val = hv_iterval(hash, entry);
3753 else if (gimme == G_SCALAR)
3762 const I32 gimme = GIMME_V;
3763 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3765 if (PL_op->op_private & OPpSLICE) {
3767 HV * const hv = (HV*)POPs;
3768 const U32 hvtype = SvTYPE(hv);
3769 if (hvtype == SVt_PVHV) { /* hash element */
3770 while (++MARK <= SP) {
3771 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3772 *MARK = sv ? sv : &PL_sv_undef;
3775 else if (hvtype == SVt_PVAV) { /* array element */
3776 if (PL_op->op_flags & OPf_SPECIAL) {
3777 while (++MARK <= SP) {
3778 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3779 *MARK = sv ? sv : &PL_sv_undef;
3784 DIE(aTHX_ "Not a HASH reference");
3787 else if (gimme == G_SCALAR) {
3792 *++MARK = &PL_sv_undef;
3798 HV * const hv = (HV*)POPs;
3800 if (SvTYPE(hv) == SVt_PVHV)
3801 sv = hv_delete_ent(hv, keysv, discard, 0);
3802 else if (SvTYPE(hv) == SVt_PVAV) {
3803 if (PL_op->op_flags & OPf_SPECIAL)
3804 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3806 DIE(aTHX_ "panic: avhv_delete no longer supported");
3809 DIE(aTHX_ "Not a HASH reference");
3824 if (PL_op->op_private & OPpEXISTS_SUB) {
3826 SV * const sv = POPs;
3827 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3830 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3836 if (SvTYPE(hv) == SVt_PVHV) {
3837 if (hv_exists_ent(hv, tmpsv, 0))
3840 else if (SvTYPE(hv) == SVt_PVAV) {
3841 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3842 if (av_exists((AV*)hv, SvIV(tmpsv)))
3847 DIE(aTHX_ "Not a HASH reference");
3854 dSP; dMARK; dORIGMARK;
3855 register HV * const hv = (HV*)POPs;
3856 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3857 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3858 bool other_magic = FALSE;
3864 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3865 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3866 /* Try to preserve the existenceness of a tied hash
3867 * element by using EXISTS and DELETE if possible.
3868 * Fallback to FETCH and STORE otherwise */
3869 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3870 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3871 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3874 while (++MARK <= SP) {
3875 SV * const keysv = *MARK;
3878 bool preeminent = FALSE;
3881 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3882 hv_exists_ent(hv, keysv, 0);
3885 he = hv_fetch_ent(hv, keysv, lval, 0);
3886 svp = he ? &HeVAL(he) : 0;
3889 if (!svp || *svp == &PL_sv_undef) {
3890 DIE(aTHX_ PL_no_helem_sv, keysv);
3894 save_helem(hv, keysv, svp);
3897 const char *key = SvPV_const(keysv, keylen);
3898 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3902 *MARK = svp ? *svp : &PL_sv_undef;
3904 if (GIMME != G_ARRAY) {
3906 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3912 /* List operators. */
3917 if (GIMME != G_ARRAY) {
3919 *MARK = *SP; /* unwanted list, return last item */
3921 *MARK = &PL_sv_undef;
3930 SV ** const lastrelem = PL_stack_sp;
3931 SV ** const lastlelem = PL_stack_base + POPMARK;
3932 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3933 register SV ** const firstrelem = lastlelem + 1;
3934 const I32 arybase = PL_curcop->cop_arybase;
3935 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3937 register const I32 max = lastrelem - lastlelem;
3938 register SV **lelem;
3940 if (GIMME != G_ARRAY) {
3941 I32 ix = SvIVx(*lastlelem);
3946 if (ix < 0 || ix >= max)
3947 *firstlelem = &PL_sv_undef;
3949 *firstlelem = firstrelem[ix];
3955 SP = firstlelem - 1;
3959 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3960 I32 ix = SvIVx(*lelem);
3965 if (ix < 0 || ix >= max)
3966 *lelem = &PL_sv_undef;
3968 is_something_there = TRUE;
3969 if (!(*lelem = firstrelem[ix]))
3970 *lelem = &PL_sv_undef;
3973 if (is_something_there)
3976 SP = firstlelem - 1;
3982 dSP; dMARK; dORIGMARK;
3983 const I32 items = SP - MARK;
3984 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3985 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3992 dSP; dMARK; dORIGMARK;
3993 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3996 SV * const key = *++MARK;
3997 SV * const val = NEWSV(46, 0);
3999 sv_setsv(val, *++MARK);
4000 else if (ckWARN(WARN_MISC))
4001 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4002 (void)hv_store_ent(hv,key,val,0);
4011 dVAR; dSP; dMARK; dORIGMARK;
4012 register AV *ary = (AV*)*++MARK;
4016 register I32 offset;
4017 register I32 length;
4021 SV **tmparyval = NULL;
4022 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4025 *MARK-- = SvTIED_obj((SV*)ary, mg);
4029 call_method("SPLICE",GIMME_V);
4038 offset = i = SvIVx(*MARK);
4040 offset += AvFILLp(ary) + 1;
4042 offset -= PL_curcop->cop_arybase;
4044 DIE(aTHX_ PL_no_aelem, i);
4046 length = SvIVx(*MARK++);
4048 length += AvFILLp(ary) - offset + 1;
4054 length = AvMAX(ary) + 1; /* close enough to infinity */
4058 length = AvMAX(ary) + 1;
4060 if (offset > AvFILLp(ary) + 1) {
4061 if (ckWARN(WARN_MISC))
4062 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4063 offset = AvFILLp(ary) + 1;
4065 after = AvFILLp(ary) + 1 - (offset + length);
4066 if (after < 0) { /* not that much array */
4067 length += after; /* offset+length now in array */
4073 /* At this point, MARK .. SP-1 is our new LIST */
4076 diff = newlen - length;
4077 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4080 /* make new elements SVs now: avoid problems if they're from the array */
4081 for (dst = MARK, i = newlen; i; i--) {
4082 SV * const h = *dst;
4083 *dst++ = newSVsv(h);
4086 if (diff < 0) { /* shrinking the area */
4088 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4089 Copy(MARK, tmparyval, newlen, SV*);
4092 MARK = ORIGMARK + 1;
4093 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4094 MEXTEND(MARK, length);
4095 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4097 EXTEND_MORTAL(length);
4098 for (i = length, dst = MARK; i; i--) {
4099 sv_2mortal(*dst); /* free them eventualy */
4106 *MARK = AvARRAY(ary)[offset+length-1];
4109 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4110 SvREFCNT_dec(*dst++); /* free them now */
4113 AvFILLp(ary) += diff;
4115 /* pull up or down? */
4117 if (offset < after) { /* easier to pull up */
4118 if (offset) { /* esp. if nothing to pull */
4119 src = &AvARRAY(ary)[offset-1];
4120 dst = src - diff; /* diff is negative */
4121 for (i = offset; i > 0; i--) /* can't trust Copy */
4125 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4129 if (after) { /* anything to pull down? */
4130 src = AvARRAY(ary) + offset + length;
4131 dst = src + diff; /* diff is negative */
4132 Move(src, dst, after, SV*);
4134 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4135 /* avoid later double free */
4139 dst[--i] = &PL_sv_undef;
4142 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4143 Safefree(tmparyval);
4146 else { /* no, expanding (or same) */
4148 Newx(tmparyval, length, SV*); /* so remember deletion */
4149 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4152 if (diff > 0) { /* expanding */
4154 /* push up or down? */
4156 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4160 Move(src, dst, offset, SV*);
4162 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4164 AvFILLp(ary) += diff;
4167 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4168 av_extend(ary, AvFILLp(ary) + diff);
4169 AvFILLp(ary) += diff;
4172 dst = AvARRAY(ary) + AvFILLp(ary);
4174 for (i = after; i; i--) {
4182 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4185 MARK = ORIGMARK + 1;
4186 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4188 Copy(tmparyval, MARK, length, SV*);
4190 EXTEND_MORTAL(length);
4191 for (i = length, dst = MARK; i; i--) {
4192 sv_2mortal(*dst); /* free them eventualy */
4196 Safefree(tmparyval);
4200 else if (length--) {
4201 *MARK = tmparyval[length];
4204 while (length-- > 0)
4205 SvREFCNT_dec(tmparyval[length]);
4207 Safefree(tmparyval);
4210 *MARK = &PL_sv_undef;
4218 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4219 register AV *ary = (AV*)*++MARK;
4220 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4223 *MARK-- = SvTIED_obj((SV*)ary, mg);
4227 call_method("PUSH",G_SCALAR|G_DISCARD);
4231 PUSHi( AvFILL(ary) + 1 );
4234 for (++MARK; MARK <= SP; MARK++) {
4235 SV * const sv = NEWSV(51, 0);
4237 sv_setsv(sv, *MARK);
4238 av_store(ary, AvFILLp(ary)+1, sv);
4241 PUSHi( AvFILLp(ary) + 1 );
4249 AV * const av = (AV*)POPs;
4250 SV * const sv = av_pop(av);
4252 (void)sv_2mortal(sv);
4260 AV * const av = (AV*)POPs;
4261 SV * const sv = av_shift(av);
4266 (void)sv_2mortal(sv);
4273 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4274 register AV *ary = (AV*)*++MARK;
4275 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4278 *MARK-- = SvTIED_obj((SV*)ary, mg);
4282 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4288 av_unshift(ary, SP - MARK);
4290 SV * const sv = newSVsv(*++MARK);
4291 (void)av_store(ary, i++, sv);
4295 PUSHi( AvFILL(ary) + 1 );
4302 SV ** const oldsp = SP;
4304 if (GIMME == G_ARRAY) {
4307 register SV * const tmp = *MARK;
4311 /* safe as long as stack cannot get extended in the above */
4316 register char *down;
4322 SvUTF8_off(TARG); /* decontaminate */
4324 do_join(TARG, &PL_sv_no, MARK, SP);
4326 sv_setsv(TARG, (SP > MARK)
4328 : (padoff_du = find_rundefsvoffset(),
4329 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4330 ? DEFSV : PAD_SVl(padoff_du)));
4331 up = SvPV_force(TARG, len);
4333 if (DO_UTF8(TARG)) { /* first reverse each character */
4334 U8* s = (U8*)SvPVX(TARG);
4335 const U8* send = (U8*)(s + len);
4337 if (UTF8_IS_INVARIANT(*s)) {
4342 if (!utf8_to_uvchr(s, 0))
4346 down = (char*)(s - 1);
4347 /* reverse this character */
4351 *down-- = (char)tmp;
4357 down = SvPVX(TARG) + len - 1;
4361 *down-- = (char)tmp;
4363 (void)SvPOK_only_UTF8(TARG);
4375 register IV limit = POPi; /* note, negative is forever */
4376 SV * const sv = POPs;
4378 register const char *s = SvPV_const(sv, len);
4379 const bool do_utf8 = DO_UTF8(sv);
4380 const char *strend = s + len;
4382 register REGEXP *rx;
4384 register const char *m;
4386 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4387 I32 maxiters = slen + 10;
4389 const I32 origlimit = limit;
4392 const I32 gimme = GIMME_V;
4393 const I32 oldsave = PL_savestack_ix;
4394 I32 make_mortal = 1;
4396 MAGIC *mg = (MAGIC *) NULL;
4399 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4404 DIE(aTHX_ "panic: pp_split");
4407 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4408 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4410 RX_MATCH_UTF8_set(rx, do_utf8);
4412 if (pm->op_pmreplroot) {
4414 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4416 ary = GvAVn((GV*)pm->op_pmreplroot);
4419 else if (gimme != G_ARRAY)
4420 ary = GvAVn(PL_defgv);
4423 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4429 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4431 XPUSHs(SvTIED_obj((SV*)ary, mg));
4438 for (i = AvFILLp(ary); i >= 0; i--)
4439 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4441 /* temporarily switch stacks */
4442 SAVESWITCHSTACK(PL_curstack, ary);
4446 base = SP - PL_stack_base;
4448 if (pm->op_pmflags & PMf_SKIPWHITE) {
4449 if (pm->op_pmflags & PMf_LOCALE) {
4450 while (isSPACE_LC(*s))
4458 if (pm->op_pmflags & PMf_MULTILINE) {
4463 limit = maxiters + 2;
4464 if (pm->op_pmflags & PMf_WHITE) {
4467 while (m < strend &&
4468 !((pm->op_pmflags & PMf_LOCALE)
4469 ? isSPACE_LC(*m) : isSPACE(*m)))
4474 dstr = newSVpvn(s, m-s);
4478 (void)SvUTF8_on(dstr);
4482 while (s < strend &&
4483 ((pm->op_pmflags & PMf_LOCALE)
4484 ? isSPACE_LC(*s) : isSPACE(*s)))
4488 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4490 for (m = s; m < strend && *m != '\n'; m++)
4495 dstr = newSVpvn(s, m-s);
4499 (void)SvUTF8_on(dstr);
4504 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4505 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4506 && (rx->reganch & ROPT_CHECK_ALL)
4507 && !(rx->reganch & ROPT_ANCH)) {
4508 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4509 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4512 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4513 const char c = *SvPV_nolen_const(csv);
4515 for (m = s; m < strend && *m != c; m++)
4519 dstr = newSVpvn(s, m-s);
4523 (void)SvUTF8_on(dstr);
4525 /* The rx->minlen is in characters but we want to step
4526 * s ahead by bytes. */
4528 s = (char*)utf8_hop((U8*)m, len);
4530 s = m + len; /* Fake \n at the end */
4534 while (s < strend && --limit &&
4535 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4536 csv, multiline ? FBMrf_MULTILINE : 0)) )
4538 dstr = newSVpvn(s, m-s);
4542 (void)SvUTF8_on(dstr);
4544 /* The rx->minlen is in characters but we want to step
4545 * s ahead by bytes. */
4547 s = (char*)utf8_hop((U8*)m, len);
4549 s = m + len; /* Fake \n at the end */
4554 maxiters += slen * rx->nparens;
4555 while (s < strend && --limit)
4559 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4562 if (rex_return == 0)
4564 TAINT_IF(RX_MATCH_TAINTED(rx));
4565 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4570 strend = s + (strend - m);
4572 m = rx->startp[0] + orig;
4573 dstr = newSVpvn(s, m-s);
4577 (void)SvUTF8_on(dstr);
4581 for (i = 1; i <= (I32)rx->nparens; i++) {
4582 s = rx->startp[i] + orig;
4583 m = rx->endp[i] + orig;
4585 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4586 parens that didn't match -- they should be set to
4587 undef, not the empty string */
4588 if (m >= orig && s >= orig) {
4589 dstr = newSVpvn(s, m-s);
4592 dstr = &PL_sv_undef; /* undef, not "" */
4596 (void)SvUTF8_on(dstr);
4600 s = rx->endp[0] + orig;
4604 iters = (SP - PL_stack_base) - base;
4605 if (iters > maxiters)
4606 DIE(aTHX_ "Split loop");
4608 /* keep field after final delim? */
4609 if (s < strend || (iters && origlimit)) {
4610 const STRLEN l = strend - s;
4611 dstr = newSVpvn(s, l);
4615 (void)SvUTF8_on(dstr);
4619 else if (!origlimit) {
4620 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4621 if (TOPs && !make_mortal)
4624 *SP-- = &PL_sv_undef;
4629 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4633 if (SvSMAGICAL(ary)) {
4638 if (gimme == G_ARRAY) {
4640 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4648 call_method("PUSH",G_SCALAR|G_DISCARD);
4651 if (gimme == G_ARRAY) {
4653 /* EXTEND should not be needed - we just popped them */
4655 for (i=0; i < iters; i++) {
4656 SV **svp = av_fetch(ary, i, FALSE);
4657 PUSHs((svp) ? *svp : &PL_sv_undef);
4664 if (gimme == G_ARRAY)
4679 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4680 || SvTYPE(retsv) == SVt_PVCV) {
4681 retsv = refto(retsv);
4688 PP(unimplemented_op)
4690 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4696 * c-indentation-style: bsd
4698 * indent-tabs-mode: t
4701 * ex: set ts=8 sts=4 sw=4 noet: