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)
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 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
209 if (PL_op->op_private & OPpLVAL_INTRO)
210 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
222 tryAMAGICunDEREF(to_sv);
225 switch (SvTYPE(sv)) {
229 DIE(aTHX_ "Not a SCALAR reference");
235 if (SvTYPE(gv) != SVt_PVGV) {
236 if (SvGMAGICAL(sv)) {
241 if (PL_op->op_private & HINT_STRICT_REFS) {
243 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
245 DIE(aTHX_ PL_no_usym, "a SCALAR");
248 if (PL_op->op_flags & OPf_REF)
249 DIE(aTHX_ PL_no_usym, "a SCALAR");
250 if (ckWARN(WARN_UNINITIALIZED))
254 if ((PL_op->op_flags & OPf_SPECIAL) &&
255 !(PL_op->op_flags & OPf_MOD))
257 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
259 && (!is_gv_magical_sv(sv, 0)
260 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
266 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
271 if (PL_op->op_flags & OPf_MOD) {
272 if (PL_op->op_private & OPpLVAL_INTRO) {
273 if (cUNOP->op_first->op_type == OP_NULL)
274 sv = save_scalar((GV*)TOPs);
276 sv = save_scalar(gv);
278 Perl_croak(aTHX_ PL_no_localize_ref);
280 else if (PL_op->op_private & OPpDEREF)
281 vivify_ref(sv, PL_op->op_private & OPpDEREF);
290 AV * const av = (AV*)TOPs;
291 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
294 sv_upgrade(*sv, SVt_PVMG);
295 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
303 dSP; dTARGET; dPOPss;
305 if (PL_op->op_flags & OPf_MOD || LVRET) {
306 if (SvTYPE(TARG) < SVt_PVLV) {
307 sv_upgrade(TARG, SVt_PVLV);
308 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
312 if (LvTARG(TARG) != sv) {
314 SvREFCNT_dec(LvTARG(TARG));
315 LvTARG(TARG) = SvREFCNT_inc(sv);
317 PUSHs(TARG); /* no SvSETMAGIC */
321 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
322 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
323 if (mg && mg->mg_len >= 0) {
327 PUSHi(i + PL_curcop->cop_arybase);
341 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
342 /* (But not in defined().) */
343 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
346 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
347 if ((PL_op->op_private & OPpLVAL_INTRO)) {
348 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
351 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
355 cv = (CV*)&PL_sv_undef;
369 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
370 const char * const s = SvPVX_const(TOPs);
371 if (strnEQ(s, "CORE::", 6)) {
372 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
373 if (code < 0) { /* Overridable. */
374 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
375 int i = 0, n = 0, seen_question = 0;
377 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
379 if (code == -KEY_chop || code == -KEY_chomp
380 || code == -KEY_exec || code == -KEY_system)
382 while (i < MAXO) { /* The slow way. */
383 if (strEQ(s + 6, PL_op_name[i])
384 || strEQ(s + 6, PL_op_desc[i]))
390 goto nonesuch; /* Should not happen... */
392 oa = PL_opargs[i] >> OASHIFT;
394 if (oa & OA_OPTIONAL && !seen_question) {
398 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
399 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
400 /* But globs are already references (kinda) */
401 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
405 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
409 ret = sv_2mortal(newSVpvn(str, n - 1));
411 else if (code) /* Non-Overridable */
413 else { /* None such */
415 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
419 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
421 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
430 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
432 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
448 if (GIMME != G_ARRAY) {
452 *MARK = &PL_sv_undef;
453 *MARK = refto(*MARK);
457 EXTEND_MORTAL(SP - MARK);
459 *MARK = refto(*MARK);
464 S_refto(pTHX_ SV *sv)
468 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
471 if (!(sv = LvTARG(sv)))
474 (void)SvREFCNT_inc(sv);
476 else if (SvTYPE(sv) == SVt_PVAV) {
477 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
480 (void)SvREFCNT_inc(sv);
482 else if (SvPADTMP(sv) && !IS_PADGV(sv))
486 (void)SvREFCNT_inc(sv);
489 sv_upgrade(rv, SVt_RV);
499 SV * const sv = POPs;
504 if (!sv || !SvROK(sv))
507 pv = sv_reftype(SvRV(sv),TRUE);
508 PUSHp(pv, strlen(pv));
518 stash = CopSTASH(PL_curcop);
520 SV * const ssv = POPs;
524 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
525 Perl_croak(aTHX_ "Attempt to bless into a reference");
526 ptr = SvPV_const(ssv,len);
527 if (len == 0 && ckWARN(WARN_MISC))
528 Perl_warner(aTHX_ packWARN(WARN_MISC),
529 "Explicit blessing to '' (assuming package main)");
530 stash = gv_stashpvn(ptr, len, TRUE);
533 (void)sv_bless(TOPs, stash);
542 const char * const elem = SvPV_nolen_const(sv);
543 GV * const gv = (GV*)POPs;
544 SV * tmpRef = Nullsv;
548 /* elem will always be NUL terminated. */
549 const char * const second_letter = elem + 1;
552 if (strEQ(second_letter, "RRAY"))
553 tmpRef = (SV*)GvAV(gv);
556 if (strEQ(second_letter, "ODE"))
557 tmpRef = (SV*)GvCVu(gv);
560 if (strEQ(second_letter, "ILEHANDLE")) {
561 /* finally deprecated in 5.8.0 */
562 deprecate("*glob{FILEHANDLE}");
563 tmpRef = (SV*)GvIOp(gv);
566 if (strEQ(second_letter, "ORMAT"))
567 tmpRef = (SV*)GvFORM(gv);
570 if (strEQ(second_letter, "LOB"))
574 if (strEQ(second_letter, "ASH"))
575 tmpRef = (SV*)GvHV(gv);
578 if (*second_letter == 'O' && !elem[2])
579 tmpRef = (SV*)GvIOp(gv);
582 if (strEQ(second_letter, "AME"))
583 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
586 if (strEQ(second_letter, "ACKAGE")) {
587 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
588 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
592 if (strEQ(second_letter, "CALAR"))
607 /* Pattern matching */
612 register unsigned char *s;
615 register I32 *sfirst;
619 if (sv == PL_lastscream) {
625 SvSCREAM_off(PL_lastscream);
626 SvREFCNT_dec(PL_lastscream);
628 PL_lastscream = SvREFCNT_inc(sv);
631 s = (unsigned char*)(SvPV(sv, len));
635 if (pos > PL_maxscream) {
636 if (PL_maxscream < 0) {
637 PL_maxscream = pos + 80;
638 Newx(PL_screamfirst, 256, I32);
639 Newx(PL_screamnext, PL_maxscream, I32);
642 PL_maxscream = pos + pos / 4;
643 Renew(PL_screamnext, PL_maxscream, I32);
647 sfirst = PL_screamfirst;
648 snext = PL_screamnext;
650 if (!sfirst || !snext)
651 DIE(aTHX_ "do_study: out of memory");
653 for (ch = 256; ch; --ch)
658 register const I32 ch = s[pos];
660 snext[pos] = sfirst[ch] - pos;
667 /* piggyback on m//g magic */
668 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
677 if (PL_op->op_flags & OPf_STACKED)
679 else if (PL_op->op_private & OPpTARGET_MY)
685 TARG = sv_newmortal();
690 /* Lvalue operators. */
702 dSP; dMARK; dTARGET; dORIGMARK;
704 do_chop(TARG, *++MARK);
713 SETi(do_chomp(TOPs));
720 register I32 count = 0;
723 count += do_chomp(POPs);
733 if (!PL_op->op_private) {
742 SV_CHECK_THINKFIRST_COW_DROP(sv);
744 switch (SvTYPE(sv)) {
754 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
755 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
756 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
760 /* let user-undef'd sub keep its identity */
761 GV* const gv = CvGV((CV*)sv);
768 SvSetMagicSV(sv, &PL_sv_undef);
773 GvGP(sv) = gp_ref(gp);
774 GvSV(sv) = NEWSV(72,0);
775 GvLINE(sv) = CopLINE(PL_curcop);
781 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
783 SvPV_set(sv, Nullch);
796 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
797 DIE(aTHX_ PL_no_modify);
798 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
799 && SvIVX(TOPs) != IV_MIN)
801 SvIV_set(TOPs, SvIVX(TOPs) - 1);
802 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
813 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
814 DIE(aTHX_ PL_no_modify);
815 sv_setsv(TARG, TOPs);
816 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
817 && SvIVX(TOPs) != IV_MAX)
819 SvIV_set(TOPs, SvIVX(TOPs) + 1);
820 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
825 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
835 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
836 DIE(aTHX_ PL_no_modify);
837 sv_setsv(TARG, TOPs);
838 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
839 && SvIVX(TOPs) != IV_MIN)
841 SvIV_set(TOPs, SvIVX(TOPs) - 1);
842 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
851 /* Ordinary operators. */
856 #ifdef PERL_PRESERVE_IVUV
859 tryAMAGICbin(pow,opASSIGN);
860 #ifdef PERL_PRESERVE_IVUV
861 /* For integer to integer power, we do the calculation by hand wherever
862 we're sure it is safe; otherwise we call pow() and try to convert to
863 integer afterwards. */
876 const IV iv = SvIVX(TOPs);
880 goto float_it; /* Can't do negative powers this way. */
884 baseuok = SvUOK(TOPm1s);
886 baseuv = SvUVX(TOPm1s);
888 const IV iv = SvIVX(TOPm1s);
891 baseuok = TRUE; /* effectively it's a UV now */
893 baseuv = -iv; /* abs, baseuok == false records sign */
896 /* now we have integer ** positive integer. */
899 /* foo & (foo - 1) is zero only for a power of 2. */
900 if (!(baseuv & (baseuv - 1))) {
901 /* We are raising power-of-2 to a positive integer.
902 The logic here will work for any base (even non-integer
903 bases) but it can be less accurate than
904 pow (base,power) or exp (power * log (base)) when the
905 intermediate values start to spill out of the mantissa.
906 With powers of 2 we know this can't happen.
907 And powers of 2 are the favourite thing for perl
908 programmers to notice ** not doing what they mean. */
910 NV base = baseuok ? baseuv : -(NV)baseuv;
915 while (power >>= 1) {
926 register unsigned int highbit = 8 * sizeof(UV);
927 register unsigned int diff = 8 * sizeof(UV);
930 if (baseuv >> highbit) {
934 /* we now have baseuv < 2 ** highbit */
935 if (power * highbit <= 8 * sizeof(UV)) {
936 /* result will definitely fit in UV, so use UV math
937 on same algorithm as above */
938 register UV result = 1;
939 register UV base = baseuv;
940 const bool odd_power = (bool)(power & 1);
944 while (power >>= 1) {
951 if (baseuok || !odd_power)
952 /* answer is positive */
954 else if (result <= (UV)IV_MAX)
955 /* answer negative, fits in IV */
957 else if (result == (UV)IV_MIN)
958 /* 2's complement assumption: special case IV_MIN */
961 /* answer negative, doesn't fit */
973 SETn( Perl_pow( left, right) );
974 #ifdef PERL_PRESERVE_IVUV
984 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
985 #ifdef PERL_PRESERVE_IVUV
988 /* Unless the left argument is integer in range we are going to have to
989 use NV maths. Hence only attempt to coerce the right argument if
990 we know the left is integer. */
991 /* Left operand is defined, so is it IV? */
994 bool auvok = SvUOK(TOPm1s);
995 bool buvok = SvUOK(TOPs);
996 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
997 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1004 alow = SvUVX(TOPm1s);
1006 const IV aiv = SvIVX(TOPm1s);
1009 auvok = TRUE; /* effectively it's a UV now */
1011 alow = -aiv; /* abs, auvok == false records sign */
1017 const IV biv = SvIVX(TOPs);
1020 buvok = TRUE; /* effectively it's a UV now */
1022 blow = -biv; /* abs, buvok == false records sign */
1026 /* If this does sign extension on unsigned it's time for plan B */
1027 ahigh = alow >> (4 * sizeof (UV));
1029 bhigh = blow >> (4 * sizeof (UV));
1031 if (ahigh && bhigh) {
1032 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1033 which is overflow. Drop to NVs below. */
1034 } else if (!ahigh && !bhigh) {
1035 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1036 so the unsigned multiply cannot overflow. */
1037 UV product = alow * blow;
1038 if (auvok == buvok) {
1039 /* -ve * -ve or +ve * +ve gives a +ve result. */
1043 } else if (product <= (UV)IV_MIN) {
1044 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1045 /* -ve result, which could overflow an IV */
1047 SETi( -(IV)product );
1049 } /* else drop to NVs below. */
1051 /* One operand is large, 1 small */
1054 /* swap the operands */
1056 bhigh = blow; /* bhigh now the temp var for the swap */
1060 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1061 multiplies can't overflow. shift can, add can, -ve can. */
1062 product_middle = ahigh * blow;
1063 if (!(product_middle & topmask)) {
1064 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1066 product_middle <<= (4 * sizeof (UV));
1067 product_low = alow * blow;
1069 /* as for pp_add, UV + something mustn't get smaller.
1070 IIRC ANSI mandates this wrapping *behaviour* for
1071 unsigned whatever the actual representation*/
1072 product_low += product_middle;
1073 if (product_low >= product_middle) {
1074 /* didn't overflow */
1075 if (auvok == buvok) {
1076 /* -ve * -ve or +ve * +ve gives a +ve result. */
1078 SETu( product_low );
1080 } else if (product_low <= (UV)IV_MIN) {
1081 /* 2s complement assumption again */
1082 /* -ve result, which could overflow an IV */
1084 SETi( -(IV)product_low );
1086 } /* else drop to NVs below. */
1088 } /* product_middle too large */
1089 } /* ahigh && bhigh */
1090 } /* SvIOK(TOPm1s) */
1095 SETn( left * right );
1102 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1103 /* Only try to do UV divide first
1104 if ((SLOPPYDIVIDE is true) or
1105 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1107 The assumption is that it is better to use floating point divide
1108 whenever possible, only doing integer divide first if we can't be sure.
1109 If NV_PRESERVES_UV is true then we know at compile time that no UV
1110 can be too large to preserve, so don't need to compile the code to
1111 test the size of UVs. */
1114 # define PERL_TRY_UV_DIVIDE
1115 /* ensure that 20./5. == 4. */
1117 # ifdef PERL_PRESERVE_IVUV
1118 # ifndef NV_PRESERVES_UV
1119 # define PERL_TRY_UV_DIVIDE
1124 #ifdef PERL_TRY_UV_DIVIDE
1127 SvIV_please(TOPm1s);
1128 if (SvIOK(TOPm1s)) {
1129 bool left_non_neg = SvUOK(TOPm1s);
1130 bool right_non_neg = SvUOK(TOPs);
1134 if (right_non_neg) {
1135 right = SvUVX(TOPs);
1138 const IV biv = SvIVX(TOPs);
1141 right_non_neg = TRUE; /* effectively it's a UV now */
1147 /* historically undef()/0 gives a "Use of uninitialized value"
1148 warning before dieing, hence this test goes here.
1149 If it were immediately before the second SvIV_please, then
1150 DIE() would be invoked before left was even inspected, so
1151 no inpsection would give no warning. */
1153 DIE(aTHX_ "Illegal division by zero");
1156 left = SvUVX(TOPm1s);
1159 const IV aiv = SvIVX(TOPm1s);
1162 left_non_neg = TRUE; /* effectively it's a UV now */
1171 /* For sloppy divide we always attempt integer division. */
1173 /* Otherwise we only attempt it if either or both operands
1174 would not be preserved by an NV. If both fit in NVs
1175 we fall through to the NV divide code below. However,
1176 as left >= right to ensure integer result here, we know that
1177 we can skip the test on the right operand - right big
1178 enough not to be preserved can't get here unless left is
1181 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1184 /* Integer division can't overflow, but it can be imprecise. */
1185 const UV result = left / right;
1186 if (result * right == left) {
1187 SP--; /* result is valid */
1188 if (left_non_neg == right_non_neg) {
1189 /* signs identical, result is positive. */
1193 /* 2s complement assumption */
1194 if (result <= (UV)IV_MIN)
1195 SETi( -(IV)result );
1197 /* It's exact but too negative for IV. */
1198 SETn( -(NV)result );
1201 } /* tried integer divide but it was not an integer result */
1202 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1203 } /* left wasn't SvIOK */
1204 } /* right wasn't SvIOK */
1205 #endif /* PERL_TRY_UV_DIVIDE */
1209 DIE(aTHX_ "Illegal division by zero");
1210 PUSHn( left / right );
1217 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1221 bool left_neg = FALSE;
1222 bool right_neg = FALSE;
1223 bool use_double = FALSE;
1224 bool dright_valid = FALSE;
1230 right_neg = !SvUOK(TOPs);
1232 right = SvUVX(POPs);
1234 const IV biv = SvIVX(POPs);
1237 right_neg = FALSE; /* effectively it's a UV now */
1245 right_neg = dright < 0;
1248 if (dright < UV_MAX_P1) {
1249 right = U_V(dright);
1250 dright_valid = TRUE; /* In case we need to use double below. */
1256 /* At this point use_double is only true if right is out of range for
1257 a UV. In range NV has been rounded down to nearest UV and
1258 use_double false. */
1260 if (!use_double && SvIOK(TOPs)) {
1262 left_neg = !SvUOK(TOPs);
1266 const IV aiv = SvIVX(POPs);
1269 left_neg = FALSE; /* effectively it's a UV now */
1278 left_neg = dleft < 0;
1282 /* This should be exactly the 5.6 behaviour - if left and right are
1283 both in range for UV then use U_V() rather than floor. */
1285 if (dleft < UV_MAX_P1) {
1286 /* right was in range, so is dleft, so use UVs not double.
1290 /* left is out of range for UV, right was in range, so promote
1291 right (back) to double. */
1293 /* The +0.5 is used in 5.6 even though it is not strictly
1294 consistent with the implicit +0 floor in the U_V()
1295 inside the #if 1. */
1296 dleft = Perl_floor(dleft + 0.5);
1299 dright = Perl_floor(dright + 0.5);
1309 DIE(aTHX_ "Illegal modulus zero");
1311 dans = Perl_fmod(dleft, dright);
1312 if ((left_neg != right_neg) && dans)
1313 dans = dright - dans;
1316 sv_setnv(TARG, dans);
1322 DIE(aTHX_ "Illegal modulus zero");
1325 if ((left_neg != right_neg) && ans)
1328 /* XXX may warn: unary minus operator applied to unsigned type */
1329 /* could change -foo to be (~foo)+1 instead */
1330 if (ans <= ~((UV)IV_MAX)+1)
1331 sv_setiv(TARG, ~ans+1);
1333 sv_setnv(TARG, -(NV)ans);
1336 sv_setuv(TARG, ans);
1345 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1352 const UV uv = SvUV(sv);
1354 count = IV_MAX; /* The best we can do? */
1358 const IV iv = SvIV(sv);
1365 else if (SvNOKp(sv)) {
1366 const NV nv = SvNV(sv);
1374 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1376 static const char oom_list_extend[] = "Out of memory during list extend";
1377 const I32 items = SP - MARK;
1378 const I32 max = items * count;
1380 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1381 /* Did the max computation overflow? */
1382 if (items > 0 && max > 0 && (max < items || max < count))
1383 Perl_croak(aTHX_ oom_list_extend);
1388 /* This code was intended to fix 20010809.028:
1391 for (($x =~ /./g) x 2) {
1392 print chop; # "abcdabcd" expected as output.
1395 * but that change (#11635) broke this code:
1397 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1399 * I can't think of a better fix that doesn't introduce
1400 * an efficiency hit by copying the SVs. The stack isn't
1401 * refcounted, and mortalisation obviously doesn't
1402 * Do The Right Thing when the stack has more than
1403 * one pointer to the same mortal value.
1407 *SP = sv_2mortal(newSVsv(*SP));
1417 repeatcpy((char*)(MARK + items), (char*)MARK,
1418 items * sizeof(SV*), count - 1);
1421 else if (count <= 0)
1424 else { /* Note: mark already snarfed by pp_list */
1425 SV * const tmpstr = POPs;
1428 static const char oom_string_extend[] =
1429 "Out of memory during string extend";
1431 SvSetSV(TARG, tmpstr);
1432 SvPV_force(TARG, len);
1433 isutf = DO_UTF8(TARG);
1438 STRLEN max = (UV)count * len;
1439 if (len > ((MEM_SIZE)~0)/count)
1440 Perl_croak(aTHX_ oom_string_extend);
1441 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1442 SvGROW(TARG, max + 1);
1443 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1444 SvCUR_set(TARG, SvCUR(TARG) * count);
1446 *SvEND(TARG) = '\0';
1449 (void)SvPOK_only_UTF8(TARG);
1451 (void)SvPOK_only(TARG);
1453 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1454 /* The parser saw this as a list repeat, and there
1455 are probably several items on the stack. But we're
1456 in scalar context, and there's no pp_list to save us
1457 now. So drop the rest of the items -- robin@kitsite.com
1470 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1471 useleft = USE_LEFT(TOPm1s);
1472 #ifdef PERL_PRESERVE_IVUV
1473 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1474 "bad things" happen if you rely on signed integers wrapping. */
1477 /* Unless the left argument is integer in range we are going to have to
1478 use NV maths. Hence only attempt to coerce the right argument if
1479 we know the left is integer. */
1480 register UV auv = 0;
1486 a_valid = auvok = 1;
1487 /* left operand is undef, treat as zero. */
1489 /* Left operand is defined, so is it IV? */
1490 SvIV_please(TOPm1s);
1491 if (SvIOK(TOPm1s)) {
1492 if ((auvok = SvUOK(TOPm1s)))
1493 auv = SvUVX(TOPm1s);
1495 register const IV aiv = SvIVX(TOPm1s);
1498 auvok = 1; /* Now acting as a sign flag. */
1499 } else { /* 2s complement assumption for IV_MIN */
1507 bool result_good = 0;
1510 bool buvok = SvUOK(TOPs);
1515 register const IV biv = SvIVX(TOPs);
1522 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1523 else "IV" now, independent of how it came in.
1524 if a, b represents positive, A, B negative, a maps to -A etc
1529 all UV maths. negate result if A negative.
1530 subtract if signs same, add if signs differ. */
1532 if (auvok ^ buvok) {
1541 /* Must get smaller */
1546 if (result <= buv) {
1547 /* result really should be -(auv-buv). as its negation
1548 of true value, need to swap our result flag */
1560 if (result <= (UV)IV_MIN)
1561 SETi( -(IV)result );
1563 /* result valid, but out of range for IV. */
1564 SETn( -(NV)result );
1568 } /* Overflow, drop through to NVs. */
1572 useleft = USE_LEFT(TOPm1s);
1576 /* left operand is undef, treat as zero - value */
1580 SETn( TOPn - value );
1587 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1589 const IV shift = POPi;
1590 if (PL_op->op_private & HINT_INTEGER) {
1604 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1606 const IV shift = POPi;
1607 if (PL_op->op_private & HINT_INTEGER) {
1621 dSP; tryAMAGICbinSET(lt,0);
1622 #ifdef PERL_PRESERVE_IVUV
1625 SvIV_please(TOPm1s);
1626 if (SvIOK(TOPm1s)) {
1627 bool auvok = SvUOK(TOPm1s);
1628 bool buvok = SvUOK(TOPs);
1630 if (!auvok && !buvok) { /* ## IV < IV ## */
1631 const IV aiv = SvIVX(TOPm1s);
1632 const IV biv = SvIVX(TOPs);
1635 SETs(boolSV(aiv < biv));
1638 if (auvok && buvok) { /* ## UV < UV ## */
1639 const UV auv = SvUVX(TOPm1s);
1640 const UV buv = SvUVX(TOPs);
1643 SETs(boolSV(auv < buv));
1646 if (auvok) { /* ## UV < IV ## */
1648 const IV biv = SvIVX(TOPs);
1651 /* As (a) is a UV, it's >=0, so it cannot be < */
1656 SETs(boolSV(auv < (UV)biv));
1659 { /* ## IV < UV ## */
1660 const IV aiv = SvIVX(TOPm1s);
1664 /* As (b) is a UV, it's >=0, so it must be < */
1671 SETs(boolSV((UV)aiv < buv));
1677 #ifndef NV_PRESERVES_UV
1678 #ifdef PERL_PRESERVE_IVUV
1681 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1683 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1689 SETs(boolSV(TOPn < value));
1696 dSP; tryAMAGICbinSET(gt,0);
1697 #ifdef PERL_PRESERVE_IVUV
1700 SvIV_please(TOPm1s);
1701 if (SvIOK(TOPm1s)) {
1702 bool auvok = SvUOK(TOPm1s);
1703 bool buvok = SvUOK(TOPs);
1705 if (!auvok && !buvok) { /* ## IV > IV ## */
1706 const IV aiv = SvIVX(TOPm1s);
1707 const IV biv = SvIVX(TOPs);
1710 SETs(boolSV(aiv > biv));
1713 if (auvok && buvok) { /* ## UV > UV ## */
1714 const UV auv = SvUVX(TOPm1s);
1715 const UV buv = SvUVX(TOPs);
1718 SETs(boolSV(auv > buv));
1721 if (auvok) { /* ## UV > IV ## */
1723 const IV biv = SvIVX(TOPs);
1727 /* As (a) is a UV, it's >=0, so it must be > */
1732 SETs(boolSV(auv > (UV)biv));
1735 { /* ## IV > UV ## */
1736 const IV aiv = SvIVX(TOPm1s);
1740 /* As (b) is a UV, it's >=0, so it cannot be > */
1747 SETs(boolSV((UV)aiv > buv));
1753 #ifndef NV_PRESERVES_UV
1754 #ifdef PERL_PRESERVE_IVUV
1757 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1759 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1765 SETs(boolSV(TOPn > value));
1772 dSP; tryAMAGICbinSET(le,0);
1773 #ifdef PERL_PRESERVE_IVUV
1776 SvIV_please(TOPm1s);
1777 if (SvIOK(TOPm1s)) {
1778 bool auvok = SvUOK(TOPm1s);
1779 bool buvok = SvUOK(TOPs);
1781 if (!auvok && !buvok) { /* ## IV <= IV ## */
1782 const IV aiv = SvIVX(TOPm1s);
1783 const IV biv = SvIVX(TOPs);
1786 SETs(boolSV(aiv <= biv));
1789 if (auvok && buvok) { /* ## UV <= UV ## */
1790 UV auv = SvUVX(TOPm1s);
1791 UV buv = SvUVX(TOPs);
1794 SETs(boolSV(auv <= buv));
1797 if (auvok) { /* ## UV <= IV ## */
1799 const IV biv = SvIVX(TOPs);
1803 /* As (a) is a UV, it's >=0, so a cannot be <= */
1808 SETs(boolSV(auv <= (UV)biv));
1811 { /* ## IV <= UV ## */
1812 const IV aiv = SvIVX(TOPm1s);
1816 /* As (b) is a UV, it's >=0, so a must be <= */
1823 SETs(boolSV((UV)aiv <= buv));
1829 #ifndef NV_PRESERVES_UV
1830 #ifdef PERL_PRESERVE_IVUV
1833 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1835 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1841 SETs(boolSV(TOPn <= value));
1848 dSP; tryAMAGICbinSET(ge,0);
1849 #ifdef PERL_PRESERVE_IVUV
1852 SvIV_please(TOPm1s);
1853 if (SvIOK(TOPm1s)) {
1854 bool auvok = SvUOK(TOPm1s);
1855 bool buvok = SvUOK(TOPs);
1857 if (!auvok && !buvok) { /* ## IV >= IV ## */
1858 const IV aiv = SvIVX(TOPm1s);
1859 const IV biv = SvIVX(TOPs);
1862 SETs(boolSV(aiv >= biv));
1865 if (auvok && buvok) { /* ## UV >= UV ## */
1866 const UV auv = SvUVX(TOPm1s);
1867 const UV buv = SvUVX(TOPs);
1870 SETs(boolSV(auv >= buv));
1873 if (auvok) { /* ## UV >= IV ## */
1875 const IV biv = SvIVX(TOPs);
1879 /* As (a) is a UV, it's >=0, so it must be >= */
1884 SETs(boolSV(auv >= (UV)biv));
1887 { /* ## IV >= UV ## */
1888 const IV aiv = SvIVX(TOPm1s);
1892 /* As (b) is a UV, it's >=0, so a cannot be >= */
1899 SETs(boolSV((UV)aiv >= buv));
1905 #ifndef NV_PRESERVES_UV
1906 #ifdef PERL_PRESERVE_IVUV
1909 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1911 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1917 SETs(boolSV(TOPn >= value));
1924 dSP; tryAMAGICbinSET(ne,0);
1925 #ifndef NV_PRESERVES_UV
1926 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1928 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1932 #ifdef PERL_PRESERVE_IVUV
1935 SvIV_please(TOPm1s);
1936 if (SvIOK(TOPm1s)) {
1937 const bool auvok = SvUOK(TOPm1s);
1938 const bool buvok = SvUOK(TOPs);
1940 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1941 /* Casting IV to UV before comparison isn't going to matter
1942 on 2s complement. On 1s complement or sign&magnitude
1943 (if we have any of them) it could make negative zero
1944 differ from normal zero. As I understand it. (Need to
1945 check - is negative zero implementation defined behaviour
1947 const UV buv = SvUVX(POPs);
1948 const UV auv = SvUVX(TOPs);
1950 SETs(boolSV(auv != buv));
1953 { /* ## Mixed IV,UV ## */
1957 /* != is commutative so swap if needed (save code) */
1959 /* swap. top of stack (b) is the iv */
1963 /* As (a) is a UV, it's >0, so it cannot be == */
1972 /* As (b) is a UV, it's >0, so it cannot be == */
1976 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1978 SETs(boolSV((UV)iv != uv));
1986 SETs(boolSV(TOPn != value));
1993 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1994 #ifndef NV_PRESERVES_UV
1995 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1996 const UV right = PTR2UV(SvRV(POPs));
1997 const UV left = PTR2UV(SvRV(TOPs));
1998 SETi((left > right) - (left < right));
2002 #ifdef PERL_PRESERVE_IVUV
2003 /* Fortunately it seems NaN isn't IOK */
2006 SvIV_please(TOPm1s);
2007 if (SvIOK(TOPm1s)) {
2008 const bool leftuvok = SvUOK(TOPm1s);
2009 const bool rightuvok = SvUOK(TOPs);
2011 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2012 const IV leftiv = SvIVX(TOPm1s);
2013 const IV rightiv = SvIVX(TOPs);
2015 if (leftiv > rightiv)
2017 else if (leftiv < rightiv)
2021 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2022 const UV leftuv = SvUVX(TOPm1s);
2023 const UV rightuv = SvUVX(TOPs);
2025 if (leftuv > rightuv)
2027 else if (leftuv < rightuv)
2031 } else if (leftuvok) { /* ## UV <=> IV ## */
2032 const IV rightiv = SvIVX(TOPs);
2034 /* As (a) is a UV, it's >=0, so it cannot be < */
2037 const UV leftuv = SvUVX(TOPm1s);
2038 if (leftuv > (UV)rightiv) {
2040 } else if (leftuv < (UV)rightiv) {
2046 } else { /* ## IV <=> UV ## */
2047 const IV leftiv = SvIVX(TOPm1s);
2049 /* As (b) is a UV, it's >=0, so it must be < */
2052 const UV rightuv = SvUVX(TOPs);
2053 if ((UV)leftiv > rightuv) {
2055 } else if ((UV)leftiv < rightuv) {
2073 if (Perl_isnan(left) || Perl_isnan(right)) {
2077 value = (left > right) - (left < right);
2081 else if (left < right)
2083 else if (left > right)
2099 int amg_type = sle_amg;
2103 switch (PL_op->op_type) {
2122 tryAMAGICbinSET_var(amg_type,0);
2125 const int cmp = (IN_LOCALE_RUNTIME
2126 ? sv_cmp_locale(left, right)
2127 : sv_cmp(left, right));
2128 SETs(boolSV(cmp * multiplier < rhs));
2135 dSP; tryAMAGICbinSET(seq,0);
2138 SETs(boolSV(sv_eq(left, right)));
2145 dSP; tryAMAGICbinSET(sne,0);
2148 SETs(boolSV(!sv_eq(left, right)));
2155 dSP; dTARGET; tryAMAGICbin(scmp,0);
2158 const int cmp = (IN_LOCALE_RUNTIME
2159 ? sv_cmp_locale(left, right)
2160 : sv_cmp(left, right));
2168 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2173 if (SvNIOKp(left) || SvNIOKp(right)) {
2174 if (PL_op->op_private & HINT_INTEGER) {
2175 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2179 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2184 do_vop(PL_op->op_type, TARG, left, right);
2193 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2198 if (SvNIOKp(left) || SvNIOKp(right)) {
2199 if (PL_op->op_private & HINT_INTEGER) {
2200 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2204 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2209 do_vop(PL_op->op_type, TARG, left, right);
2218 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2223 if (SvNIOKp(left) || SvNIOKp(right)) {
2224 if (PL_op->op_private & HINT_INTEGER) {
2225 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2229 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2234 do_vop(PL_op->op_type, TARG, left, right);
2243 dSP; dTARGET; tryAMAGICun(neg);
2246 const int flags = SvFLAGS(sv);
2248 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2249 /* It's publicly an integer, or privately an integer-not-float */
2252 if (SvIVX(sv) == IV_MIN) {
2253 /* 2s complement assumption. */
2254 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2257 else if (SvUVX(sv) <= IV_MAX) {
2262 else if (SvIVX(sv) != IV_MIN) {
2266 #ifdef PERL_PRESERVE_IVUV
2275 else if (SvPOKp(sv)) {
2277 const char *s = SvPV_const(sv, len);
2278 if (isIDFIRST(*s)) {
2279 sv_setpvn(TARG, "-", 1);
2282 else if (*s == '+' || *s == '-') {
2284 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2286 else if (DO_UTF8(sv)) {
2289 goto oops_its_an_int;
2291 sv_setnv(TARG, -SvNV(sv));
2293 sv_setpvn(TARG, "-", 1);
2300 goto oops_its_an_int;
2301 sv_setnv(TARG, -SvNV(sv));
2313 dSP; tryAMAGICunSET(not);
2314 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2320 dSP; dTARGET; tryAMAGICun(compl);
2325 if (PL_op->op_private & HINT_INTEGER) {
2326 const IV i = ~SvIV_nomg(sv);
2330 const UV u = ~SvUV_nomg(sv);
2339 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2340 sv_setsv_nomg(TARG, sv);
2341 tmps = (U8*)SvPV_force(TARG, len);
2344 /* Calculate exact length, let's not estimate. */
2353 while (tmps < send) {
2354 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2355 tmps += UTF8SKIP(tmps);
2356 targlen += UNISKIP(~c);
2362 /* Now rewind strings and write them. */
2366 Newxz(result, targlen + 1, U8);
2367 while (tmps < send) {
2368 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2369 tmps += UTF8SKIP(tmps);
2370 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2374 sv_setpvn(TARG, (char*)result, targlen);
2378 Newxz(result, nchar + 1, U8);
2379 while (tmps < send) {
2380 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2381 tmps += UTF8SKIP(tmps);
2386 sv_setpvn(TARG, (char*)result, nchar);
2395 register long *tmpl;
2396 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2399 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2404 for ( ; anum > 0; anum--, tmps++)
2413 /* integer versions of some of the above */
2417 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2420 SETi( left * right );
2427 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2431 DIE(aTHX_ "Illegal division by zero");
2432 value = POPi / value;
2441 /* This is the vanilla old i_modulo. */
2442 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2446 DIE(aTHX_ "Illegal modulus zero");
2447 SETi( left % right );
2452 #if defined(__GLIBC__) && IVSIZE == 8
2456 /* This is the i_modulo with the workaround for the _moddi3 bug
2457 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2458 * See below for pp_i_modulo. */
2459 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2463 DIE(aTHX_ "Illegal modulus zero");
2464 SETi( left % PERL_ABS(right) );
2472 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2476 DIE(aTHX_ "Illegal modulus zero");
2477 /* The assumption is to use hereafter the old vanilla version... */
2479 PL_ppaddr[OP_I_MODULO] =
2481 /* .. but if we have glibc, we might have a buggy _moddi3
2482 * (at least glicb 2.2.5 is known to have this bug), in other
2483 * words our integer modulus with negative quad as the second
2484 * argument might be broken. Test for this and re-patch the
2485 * opcode dispatch table if that is the case, remembering to
2486 * also apply the workaround so that this first round works
2487 * right, too. See [perl #9402] for more information. */
2488 #if defined(__GLIBC__) && IVSIZE == 8
2492 /* Cannot do this check with inlined IV constants since
2493 * that seems to work correctly even with the buggy glibc. */
2495 /* Yikes, we have the bug.
2496 * Patch in the workaround version. */
2498 PL_ppaddr[OP_I_MODULO] =
2499 &Perl_pp_i_modulo_1;
2500 /* Make certain we work right this time, too. */
2501 right = PERL_ABS(right);
2505 SETi( left % right );
2512 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2515 SETi( left + right );
2522 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2525 SETi( left - right );
2532 dSP; tryAMAGICbinSET(lt,0);
2535 SETs(boolSV(left < right));
2542 dSP; tryAMAGICbinSET(gt,0);
2545 SETs(boolSV(left > right));
2552 dSP; tryAMAGICbinSET(le,0);
2555 SETs(boolSV(left <= right));
2562 dSP; tryAMAGICbinSET(ge,0);
2565 SETs(boolSV(left >= right));
2572 dSP; tryAMAGICbinSET(eq,0);
2575 SETs(boolSV(left == right));
2582 dSP; tryAMAGICbinSET(ne,0);
2585 SETs(boolSV(left != right));
2592 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2599 else if (left < right)
2610 dSP; dTARGET; tryAMAGICun(neg);
2615 /* High falutin' math. */
2619 dSP; dTARGET; tryAMAGICbin(atan2,0);
2622 SETn(Perl_atan2(left, right));
2629 dSP; dTARGET; tryAMAGICun(sin);
2631 const NV value = POPn;
2632 XPUSHn(Perl_sin(value));
2639 dSP; dTARGET; tryAMAGICun(cos);
2641 const NV value = POPn;
2642 XPUSHn(Perl_cos(value));
2647 /* Support Configure command-line overrides for rand() functions.
2648 After 5.005, perhaps we should replace this by Configure support
2649 for drand48(), random(), or rand(). For 5.005, though, maintain
2650 compatibility by calling rand() but allow the user to override it.
2651 See INSTALL for details. --Andy Dougherty 15 July 1998
2653 /* Now it's after 5.005, and Configure supports drand48() and random(),
2654 in addition to rand(). So the overrides should not be needed any more.
2655 --Jarkko Hietaniemi 27 September 1998
2658 #ifndef HAS_DRAND48_PROTO
2659 extern double drand48 (void);
2672 if (!PL_srand_called) {
2673 (void)seedDrand01((Rand_seed_t)seed());
2674 PL_srand_called = TRUE;
2684 const UV anum = (MAXARG < 1) ? seed() : POPu;
2685 (void)seedDrand01((Rand_seed_t)anum);
2686 PL_srand_called = TRUE;
2693 dSP; dTARGET; tryAMAGICun(exp);
2697 value = Perl_exp(value);
2705 dSP; dTARGET; tryAMAGICun(log);
2707 const NV value = POPn;
2709 SET_NUMERIC_STANDARD();
2710 DIE(aTHX_ "Can't take log of %"NVgf, value);
2712 XPUSHn(Perl_log(value));
2719 dSP; dTARGET; tryAMAGICun(sqrt);
2721 const NV value = POPn;
2723 SET_NUMERIC_STANDARD();
2724 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2726 XPUSHn(Perl_sqrt(value));
2733 dSP; dTARGET; tryAMAGICun(int);
2735 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2736 /* XXX it's arguable that compiler casting to IV might be subtly
2737 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2738 else preferring IV has introduced a subtle behaviour change bug. OTOH
2739 relying on floating point to be accurate is a bug. */
2743 else if (SvIOK(TOPs)) {
2750 const NV value = TOPn;
2752 if (value < (NV)UV_MAX + 0.5) {
2755 SETn(Perl_floor(value));
2759 if (value > (NV)IV_MIN - 0.5) {
2762 SETn(Perl_ceil(value));
2772 dSP; dTARGET; tryAMAGICun(abs);
2774 /* This will cache the NV value if string isn't actually integer */
2779 else if (SvIOK(TOPs)) {
2780 /* IVX is precise */
2782 SETu(TOPu); /* force it to be numeric only */
2790 /* 2s complement assumption. Also, not really needed as
2791 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2797 const NV value = TOPn;
2812 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2816 SV* const sv = POPs;
2818 tmps = (SvPV_const(sv, len));
2820 /* If Unicode, try to downgrade
2821 * If not possible, croak. */
2822 SV* const tsv = sv_2mortal(newSVsv(sv));
2825 sv_utf8_downgrade(tsv, FALSE);
2826 tmps = SvPV_const(tsv, len);
2828 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2829 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2842 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2846 SV* const sv = POPs;
2848 tmps = (SvPV_const(sv, len));
2850 /* If Unicode, try to downgrade
2851 * If not possible, croak. */
2852 SV* const tsv = sv_2mortal(newSVsv(sv));
2855 sv_utf8_downgrade(tsv, FALSE);
2856 tmps = SvPV_const(tsv, len);
2858 while (*tmps && len && isSPACE(*tmps))
2863 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2864 else if (*tmps == 'b')
2865 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2867 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2869 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2883 SV * const sv = TOPs;
2886 SETi(sv_len_utf8(sv));
2902 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2904 const I32 arybase = PL_curcop->cop_arybase;
2906 const char *repl = 0;
2908 const int num_args = PL_op->op_private & 7;
2909 bool repl_need_utf8_upgrade = FALSE;
2910 bool repl_is_utf8 = FALSE;
2912 SvTAINTED_off(TARG); /* decontaminate */
2913 SvUTF8_off(TARG); /* decontaminate */
2917 repl = SvPV_const(repl_sv, repl_len);
2918 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2928 sv_utf8_upgrade(sv);
2930 else if (DO_UTF8(sv))
2931 repl_need_utf8_upgrade = TRUE;
2933 tmps = SvPV_const(sv, curlen);
2935 utf8_curlen = sv_len_utf8(sv);
2936 if (utf8_curlen == curlen)
2939 curlen = utf8_curlen;
2944 if (pos >= arybase) {
2962 else if (len >= 0) {
2964 if (rem > (I32)curlen)
2979 Perl_croak(aTHX_ "substr outside of string");
2980 if (ckWARN(WARN_SUBSTR))
2981 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2985 const I32 upos = pos;
2986 const I32 urem = rem;
2988 sv_pos_u2b(sv, &pos, &rem);
2990 /* we either return a PV or an LV. If the TARG hasn't been used
2991 * before, or is of that type, reuse it; otherwise use a mortal
2992 * instead. Note that LVs can have an extended lifetime, so also
2993 * dont reuse if refcount > 1 (bug #20933) */
2994 if (SvTYPE(TARG) > SVt_NULL) {
2995 if ( (SvTYPE(TARG) == SVt_PVLV)
2996 ? (!lvalue || SvREFCNT(TARG) > 1)
2999 TARG = sv_newmortal();
3003 sv_setpvn(TARG, tmps, rem);
3004 #ifdef USE_LOCALE_COLLATE
3005 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3010 SV* repl_sv_copy = NULL;
3012 if (repl_need_utf8_upgrade) {
3013 repl_sv_copy = newSVsv(repl_sv);
3014 sv_utf8_upgrade(repl_sv_copy);
3015 repl = SvPV_const(repl_sv_copy, repl_len);
3016 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3018 sv_insert(sv, pos, rem, repl, repl_len);
3022 SvREFCNT_dec(repl_sv_copy);
3024 else if (lvalue) { /* it's an lvalue! */
3025 if (!SvGMAGICAL(sv)) {
3027 SvPV_force_nolen(sv);
3028 if (ckWARN(WARN_SUBSTR))
3029 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3030 "Attempt to use reference as lvalue in substr");
3032 if (SvOK(sv)) /* is it defined ? */
3033 (void)SvPOK_only_UTF8(sv);
3035 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3038 if (SvTYPE(TARG) < SVt_PVLV) {
3039 sv_upgrade(TARG, SVt_PVLV);
3040 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3046 if (LvTARG(TARG) != sv) {
3048 SvREFCNT_dec(LvTARG(TARG));
3049 LvTARG(TARG) = SvREFCNT_inc(sv);
3051 LvTARGOFF(TARG) = upos;
3052 LvTARGLEN(TARG) = urem;
3056 PUSHs(TARG); /* avoid SvSETMAGIC here */
3063 register const IV size = POPi;
3064 register const IV offset = POPi;
3065 register SV * const src = POPs;
3066 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3068 SvTAINTED_off(TARG); /* decontaminate */
3069 if (lvalue) { /* it's an lvalue! */
3070 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3071 TARG = sv_newmortal();
3072 if (SvTYPE(TARG) < SVt_PVLV) {
3073 sv_upgrade(TARG, SVt_PVLV);
3074 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3077 if (LvTARG(TARG) != src) {
3079 SvREFCNT_dec(LvTARG(TARG));
3080 LvTARG(TARG) = SvREFCNT_inc(src);
3082 LvTARGOFF(TARG) = offset;
3083 LvTARGLEN(TARG) = size;
3086 sv_setuv(TARG, do_vecget(src, offset, size));
3102 const I32 arybase = PL_curcop->cop_arybase;
3109 offset = POPi - arybase;
3112 big_utf8 = DO_UTF8(big);
3113 little_utf8 = DO_UTF8(little);
3114 if (big_utf8 ^ little_utf8) {
3115 /* One needs to be upgraded. */
3116 SV * const bytes = little_utf8 ? big : little;
3118 const char * const p = SvPV_const(bytes, len);
3120 temp = newSVpvn(p, len);
3123 sv_recode_to_utf8(temp, PL_encoding);
3125 sv_utf8_upgrade(temp);
3134 if (big_utf8 && offset > 0)
3135 sv_pos_u2b(big, &offset, 0);
3136 tmps = SvPV_const(big, biglen);
3139 else if (offset > (I32)biglen)
3141 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3142 (unsigned char*)tmps + biglen, little, 0)))
3145 retval = tmps2 - tmps;
3146 if (retval > 0 && big_utf8)
3147 sv_pos_b2u(big, &retval);
3150 PUSHi(retval + arybase);
3166 const I32 arybase = PL_curcop->cop_arybase;
3174 big_utf8 = DO_UTF8(big);
3175 little_utf8 = DO_UTF8(little);
3176 if (big_utf8 ^ little_utf8) {
3177 /* One needs to be upgraded. */
3178 SV * const bytes = little_utf8 ? big : little;
3180 const char *p = SvPV_const(bytes, len);
3182 temp = newSVpvn(p, len);
3185 sv_recode_to_utf8(temp, PL_encoding);
3187 sv_utf8_upgrade(temp);
3196 tmps2 = SvPV_const(little, llen);
3197 tmps = SvPV_const(big, blen);
3202 if (offset > 0 && big_utf8)
3203 sv_pos_u2b(big, &offset, 0);
3204 offset = offset - arybase + llen;
3208 else if (offset > (I32)blen)
3210 if (!(tmps2 = rninstr(tmps, tmps + offset,
3211 tmps2, tmps2 + llen)))
3214 retval = tmps2 - tmps;
3215 if (retval > 0 && big_utf8)
3216 sv_pos_b2u(big, &retval);
3219 PUSHi(retval + arybase);
3225 dSP; dMARK; dORIGMARK; dTARGET;
3226 do_sprintf(TARG, SP-MARK, MARK+1);
3227 TAINT_IF(SvTAINTED(TARG));
3238 const U8 *s = (U8*)SvPV_const(argsv, len);
3241 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3242 tmpsv = sv_2mortal(newSVsv(argsv));
3243 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3247 XPUSHu(DO_UTF8(argsv) ?
3248 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3260 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3262 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3264 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3266 (void) POPs; /* Ignore the argument value. */
3267 value = UNICODE_REPLACEMENT;
3273 SvUPGRADE(TARG,SVt_PV);
3275 if (value > 255 && !IN_BYTES) {
3276 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3277 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3278 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3280 (void)SvPOK_only(TARG);
3289 *tmps++ = (char)value;
3291 (void)SvPOK_only(TARG);
3292 if (PL_encoding && !IN_BYTES) {
3293 sv_recode_to_utf8(TARG, PL_encoding);
3295 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3296 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3300 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3301 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3316 const char *tmps = SvPV_const(left, len);
3318 if (DO_UTF8(left)) {
3319 /* If Unicode, try to downgrade.
3320 * If not possible, croak.
3321 * Yes, we made this up. */
3322 SV* const tsv = sv_2mortal(newSVsv(left));
3325 sv_utf8_downgrade(tsv, FALSE);
3326 tmps = SvPV_const(tsv, len);
3328 # ifdef USE_ITHREADS
3330 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3331 /* This should be threadsafe because in ithreads there is only
3332 * one thread per interpreter. If this would not be true,
3333 * we would need a mutex to protect this malloc. */
3334 PL_reentrant_buffer->_crypt_struct_buffer =
3335 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3336 #if defined(__GLIBC__) || defined(__EMX__)
3337 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3338 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3339 /* work around glibc-2.2.5 bug */
3340 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3344 # endif /* HAS_CRYPT_R */
3345 # endif /* USE_ITHREADS */
3347 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3349 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3355 "The crypt() function is unimplemented due to excessive paranoia.");
3365 const int op_type = PL_op->op_type;
3369 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3370 UTF8_IS_START(*s)) {
3371 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3375 utf8_to_uvchr(s, &ulen);
3376 if (op_type == OP_UCFIRST) {
3377 toTITLE_utf8(s, tmpbuf, &tculen);
3379 toLOWER_utf8(s, tmpbuf, &tculen);
3382 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3384 /* slen is the byte length of the whole SV.
3385 * ulen is the byte length of the original Unicode character
3386 * stored as UTF-8 at s.
3387 * tculen is the byte length of the freshly titlecased (or
3388 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3389 * We first set the result to be the titlecased (/lowercased)
3390 * character, and then append the rest of the SV data. */
3391 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3393 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3398 s = (U8*)SvPV_force_nomg(sv, slen);
3399 Copy(tmpbuf, s, tculen, U8);
3404 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3406 SvUTF8_off(TARG); /* decontaminate */
3407 sv_setsv_nomg(TARG, sv);
3411 s1 = (U8*)SvPV_force_nomg(sv, slen);
3413 if (IN_LOCALE_RUNTIME) {
3416 *s1 = (op_type == OP_UCFIRST)
3417 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3420 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3440 U8 tmpbuf[UTF8_MAXBYTES+1];
3442 s = (const U8*)SvPV_nomg_const(sv,len);
3444 SvUTF8_off(TARG); /* decontaminate */
3445 sv_setpvn(TARG, "", 0);
3449 STRLEN min = len + 1;
3451 SvUPGRADE(TARG, SVt_PV);
3453 (void)SvPOK_only(TARG);
3454 d = (U8*)SvPVX(TARG);
3457 STRLEN u = UTF8SKIP(s);
3459 toUPPER_utf8(s, tmpbuf, &ulen);
3460 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3461 /* If the eventually required minimum size outgrows
3462 * the available space, we need to grow. */
3463 const UV o = d - (U8*)SvPVX_const(TARG);
3465 /* If someone uppercases one million U+03B0s we
3466 * SvGROW() one million times. Or we could try
3467 * guessing how much to allocate without allocating
3468 * too much. Such is life. */
3470 d = (U8*)SvPVX(TARG) + o;
3472 Copy(tmpbuf, d, ulen, U8);
3478 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3484 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3486 SvUTF8_off(TARG); /* decontaminate */
3487 sv_setsv_nomg(TARG, sv);
3491 s = (U8*)SvPV_force_nomg(sv, len);
3493 register const U8 *send = s + len;
3495 if (IN_LOCALE_RUNTIME) {
3498 for (; s < send; s++)
3499 *s = toUPPER_LC(*s);
3502 for (; s < send; s++)
3524 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3526 s = (const U8*)SvPV_nomg_const(sv,len);
3528 SvUTF8_off(TARG); /* decontaminate */
3529 sv_setpvn(TARG, "", 0);
3533 STRLEN min = len + 1;
3535 SvUPGRADE(TARG, SVt_PV);
3537 (void)SvPOK_only(TARG);
3538 d = (U8*)SvPVX(TARG);
3541 const STRLEN u = UTF8SKIP(s);
3542 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3544 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3545 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3547 * Now if the sigma is NOT followed by
3548 * /$ignorable_sequence$cased_letter/;
3549 * and it IS preceded by
3550 * /$cased_letter$ignorable_sequence/;
3551 * where $ignorable_sequence is
3552 * [\x{2010}\x{AD}\p{Mn}]*
3553 * and $cased_letter is
3554 * [\p{Ll}\p{Lo}\p{Lt}]
3555 * then it should be mapped to 0x03C2,
3556 * (GREEK SMALL LETTER FINAL SIGMA),
3557 * instead of staying 0x03A3.
3558 * "should be": in other words,
3559 * this is not implemented yet.
3560 * See lib/unicore/SpecialCasing.txt.
3563 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3564 /* If the eventually required minimum size outgrows
3565 * the available space, we need to grow. */
3566 const UV o = d - (U8*)SvPVX_const(TARG);
3568 /* If someone lowercases one million U+0130s we
3569 * SvGROW() one million times. Or we could try
3570 * guessing how much to allocate without allocating.
3571 * too much. Such is life. */
3573 d = (U8*)SvPVX(TARG) + o;
3575 Copy(tmpbuf, d, ulen, U8);
3581 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3587 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3589 SvUTF8_off(TARG); /* decontaminate */
3590 sv_setsv_nomg(TARG, sv);
3595 s = (U8*)SvPV_force_nomg(sv, len);
3597 register const U8 * const send = s + len;
3599 if (IN_LOCALE_RUNTIME) {
3602 for (; s < send; s++)
3603 *s = toLOWER_LC(*s);
3606 for (; s < send; s++)
3618 SV * const sv = TOPs;
3620 register const char *s = SvPV_const(sv,len);
3622 SvUTF8_off(TARG); /* decontaminate */
3625 SvUPGRADE(TARG, SVt_PV);
3626 SvGROW(TARG, (len * 2) + 1);
3630 if (UTF8_IS_CONTINUED(*s)) {
3631 STRLEN ulen = UTF8SKIP(s);
3655 SvCUR_set(TARG, d - SvPVX_const(TARG));
3656 (void)SvPOK_only_UTF8(TARG);
3659 sv_setpvn(TARG, s, len);
3661 if (SvSMAGICAL(TARG))
3670 dSP; dMARK; dORIGMARK;
3671 register AV* const av = (AV*)POPs;
3672 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3674 if (SvTYPE(av) == SVt_PVAV) {
3675 const I32 arybase = PL_curcop->cop_arybase;
3676 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3679 for (svp = MARK + 1; svp <= SP; svp++) {
3680 const I32 elem = SvIVx(*svp);
3684 if (max > AvMAX(av))
3687 while (++MARK <= SP) {
3689 I32 elem = SvIVx(*MARK);
3693 svp = av_fetch(av, elem, lval);
3695 if (!svp || *svp == &PL_sv_undef)
3696 DIE(aTHX_ PL_no_aelem, elem);
3697 if (PL_op->op_private & OPpLVAL_INTRO)
3698 save_aelem(av, elem, svp);
3700 *MARK = svp ? *svp : &PL_sv_undef;
3703 if (GIMME != G_ARRAY) {
3705 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3711 /* Associative arrays. */
3716 HV * const hash = (HV*)POPs;
3718 const I32 gimme = GIMME_V;
3721 /* might clobber stack_sp */
3722 entry = hv_iternext(hash);
3727 SV* const sv = hv_iterkeysv(entry);
3728 PUSHs(sv); /* won't clobber stack_sp */
3729 if (gimme == G_ARRAY) {
3732 /* might clobber stack_sp */
3733 val = hv_iterval(hash, entry);
3738 else if (gimme == G_SCALAR)
3747 const I32 gimme = GIMME_V;
3748 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3750 if (PL_op->op_private & OPpSLICE) {
3752 HV * const hv = (HV*)POPs;
3753 const U32 hvtype = SvTYPE(hv);
3754 if (hvtype == SVt_PVHV) { /* hash element */
3755 while (++MARK <= SP) {
3756 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3757 *MARK = sv ? sv : &PL_sv_undef;
3760 else if (hvtype == SVt_PVAV) { /* array element */
3761 if (PL_op->op_flags & OPf_SPECIAL) {
3762 while (++MARK <= SP) {
3763 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3764 *MARK = sv ? sv : &PL_sv_undef;
3769 DIE(aTHX_ "Not a HASH reference");
3772 else if (gimme == G_SCALAR) {
3777 *++MARK = &PL_sv_undef;
3783 HV * const hv = (HV*)POPs;
3785 if (SvTYPE(hv) == SVt_PVHV)
3786 sv = hv_delete_ent(hv, keysv, discard, 0);
3787 else if (SvTYPE(hv) == SVt_PVAV) {
3788 if (PL_op->op_flags & OPf_SPECIAL)
3789 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3791 DIE(aTHX_ "panic: avhv_delete no longer supported");
3794 DIE(aTHX_ "Not a HASH reference");
3809 if (PL_op->op_private & OPpEXISTS_SUB) {
3811 SV * const sv = POPs;
3812 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3815 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3821 if (SvTYPE(hv) == SVt_PVHV) {
3822 if (hv_exists_ent(hv, tmpsv, 0))
3825 else if (SvTYPE(hv) == SVt_PVAV) {
3826 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3827 if (av_exists((AV*)hv, SvIV(tmpsv)))
3832 DIE(aTHX_ "Not a HASH reference");
3839 dSP; dMARK; dORIGMARK;
3840 register HV * const hv = (HV*)POPs;
3841 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3842 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3843 bool other_magic = FALSE;
3849 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3850 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3851 /* Try to preserve the existenceness of a tied hash
3852 * element by using EXISTS and DELETE if possible.
3853 * Fallback to FETCH and STORE otherwise */
3854 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3855 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3856 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3859 while (++MARK <= SP) {
3860 SV * const keysv = *MARK;
3863 bool preeminent = FALSE;
3866 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3867 hv_exists_ent(hv, keysv, 0);
3870 he = hv_fetch_ent(hv, keysv, lval, 0);
3871 svp = he ? &HeVAL(he) : 0;
3874 if (!svp || *svp == &PL_sv_undef) {
3875 DIE(aTHX_ PL_no_helem_sv, keysv);
3879 save_helem(hv, keysv, svp);
3882 const char *key = SvPV_const(keysv, keylen);
3883 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3887 *MARK = svp ? *svp : &PL_sv_undef;
3889 if (GIMME != G_ARRAY) {
3891 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3897 /* List operators. */
3902 if (GIMME != G_ARRAY) {
3904 *MARK = *SP; /* unwanted list, return last item */
3906 *MARK = &PL_sv_undef;
3915 SV ** const lastrelem = PL_stack_sp;
3916 SV ** const lastlelem = PL_stack_base + POPMARK;
3917 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3918 register SV ** const firstrelem = lastlelem + 1;
3919 const I32 arybase = PL_curcop->cop_arybase;
3920 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3922 register const I32 max = lastrelem - lastlelem;
3923 register SV **lelem;
3925 if (GIMME != G_ARRAY) {
3926 I32 ix = SvIVx(*lastlelem);
3931 if (ix < 0 || ix >= max)
3932 *firstlelem = &PL_sv_undef;
3934 *firstlelem = firstrelem[ix];
3940 SP = firstlelem - 1;
3944 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3945 I32 ix = SvIVx(*lelem);
3950 if (ix < 0 || ix >= max)
3951 *lelem = &PL_sv_undef;
3953 is_something_there = TRUE;
3954 if (!(*lelem = firstrelem[ix]))
3955 *lelem = &PL_sv_undef;
3958 if (is_something_there)
3961 SP = firstlelem - 1;
3967 dSP; dMARK; dORIGMARK;
3968 const I32 items = SP - MARK;
3969 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3970 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3977 dSP; dMARK; dORIGMARK;
3978 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3981 SV * const key = *++MARK;
3982 SV * const val = NEWSV(46, 0);
3984 sv_setsv(val, *++MARK);
3985 else if (ckWARN(WARN_MISC))
3986 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3987 (void)hv_store_ent(hv,key,val,0);
3996 dVAR; dSP; dMARK; dORIGMARK;
3997 register AV *ary = (AV*)*++MARK;
4001 register I32 offset;
4002 register I32 length;
4007 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4010 *MARK-- = SvTIED_obj((SV*)ary, mg);
4014 call_method("SPLICE",GIMME_V);
4023 offset = i = SvIVx(*MARK);
4025 offset += AvFILLp(ary) + 1;
4027 offset -= PL_curcop->cop_arybase;
4029 DIE(aTHX_ PL_no_aelem, i);
4031 length = SvIVx(*MARK++);
4033 length += AvFILLp(ary) - offset + 1;
4039 length = AvMAX(ary) + 1; /* close enough to infinity */
4043 length = AvMAX(ary) + 1;
4045 if (offset > AvFILLp(ary) + 1) {
4046 if (ckWARN(WARN_MISC))
4047 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4048 offset = AvFILLp(ary) + 1;
4050 after = AvFILLp(ary) + 1 - (offset + length);
4051 if (after < 0) { /* not that much array */
4052 length += after; /* offset+length now in array */
4058 /* At this point, MARK .. SP-1 is our new LIST */
4061 diff = newlen - length;
4062 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4065 /* make new elements SVs now: avoid problems if they're from the array */
4066 for (dst = MARK, i = newlen; i; i--) {
4067 SV * const h = *dst;
4068 *dst++ = newSVsv(h);
4071 if (diff < 0) { /* shrinking the area */
4073 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4074 Copy(MARK, tmparyval, newlen, SV*);
4077 MARK = ORIGMARK + 1;
4078 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4079 MEXTEND(MARK, length);
4080 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4082 EXTEND_MORTAL(length);
4083 for (i = length, dst = MARK; i; i--) {
4084 sv_2mortal(*dst); /* free them eventualy */
4091 *MARK = AvARRAY(ary)[offset+length-1];
4094 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4095 SvREFCNT_dec(*dst++); /* free them now */
4098 AvFILLp(ary) += diff;
4100 /* pull up or down? */
4102 if (offset < after) { /* easier to pull up */
4103 if (offset) { /* esp. if nothing to pull */
4104 src = &AvARRAY(ary)[offset-1];
4105 dst = src - diff; /* diff is negative */
4106 for (i = offset; i > 0; i--) /* can't trust Copy */
4110 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4114 if (after) { /* anything to pull down? */
4115 src = AvARRAY(ary) + offset + length;
4116 dst = src + diff; /* diff is negative */
4117 Move(src, dst, after, SV*);
4119 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4120 /* avoid later double free */
4124 dst[--i] = &PL_sv_undef;
4127 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4128 Safefree(tmparyval);
4131 else { /* no, expanding (or same) */
4133 Newx(tmparyval, length, SV*); /* so remember deletion */
4134 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4137 if (diff > 0) { /* expanding */
4139 /* push up or down? */
4141 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4145 Move(src, dst, offset, SV*);
4147 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4149 AvFILLp(ary) += diff;
4152 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4153 av_extend(ary, AvFILLp(ary) + diff);
4154 AvFILLp(ary) += diff;
4157 dst = AvARRAY(ary) + AvFILLp(ary);
4159 for (i = after; i; i--) {
4167 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4170 MARK = ORIGMARK + 1;
4171 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4173 Copy(tmparyval, MARK, length, SV*);
4175 EXTEND_MORTAL(length);
4176 for (i = length, dst = MARK; i; i--) {
4177 sv_2mortal(*dst); /* free them eventualy */
4181 Safefree(tmparyval);
4185 else if (length--) {
4186 *MARK = tmparyval[length];
4189 while (length-- > 0)
4190 SvREFCNT_dec(tmparyval[length]);
4192 Safefree(tmparyval);
4195 *MARK = &PL_sv_undef;
4203 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4204 register AV *ary = (AV*)*++MARK;
4205 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4208 *MARK-- = SvTIED_obj((SV*)ary, mg);
4212 call_method("PUSH",G_SCALAR|G_DISCARD);
4216 PUSHi( AvFILL(ary) + 1 );
4219 for (++MARK; MARK <= SP; MARK++) {
4220 SV * const sv = NEWSV(51, 0);
4222 sv_setsv(sv, *MARK);
4223 av_store(ary, AvFILLp(ary)+1, sv);
4226 PUSHi( AvFILLp(ary) + 1 );
4234 AV * const av = (AV*)POPs;
4235 SV * const sv = av_pop(av);
4237 (void)sv_2mortal(sv);
4245 AV * const av = (AV*)POPs;
4246 SV * const sv = av_shift(av);
4251 (void)sv_2mortal(sv);
4258 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4259 register AV *ary = (AV*)*++MARK;
4260 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4263 *MARK-- = SvTIED_obj((SV*)ary, mg);
4267 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4273 av_unshift(ary, SP - MARK);
4275 SV * const sv = newSVsv(*++MARK);
4276 (void)av_store(ary, i++, sv);
4280 PUSHi( AvFILL(ary) + 1 );
4287 SV ** const oldsp = SP;
4289 if (GIMME == G_ARRAY) {
4292 register SV * const tmp = *MARK;
4296 /* safe as long as stack cannot get extended in the above */
4301 register char *down;
4307 SvUTF8_off(TARG); /* decontaminate */
4309 do_join(TARG, &PL_sv_no, MARK, SP);
4311 sv_setsv(TARG, (SP > MARK)
4313 : (padoff_du = find_rundefsvoffset(),
4314 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4315 ? DEFSV : PAD_SVl(padoff_du)));
4316 up = SvPV_force(TARG, len);
4318 if (DO_UTF8(TARG)) { /* first reverse each character */
4319 U8* s = (U8*)SvPVX(TARG);
4320 const U8* send = (U8*)(s + len);
4322 if (UTF8_IS_INVARIANT(*s)) {
4327 if (!utf8_to_uvchr(s, 0))
4331 down = (char*)(s - 1);
4332 /* reverse this character */
4336 *down-- = (char)tmp;
4342 down = SvPVX(TARG) + len - 1;
4346 *down-- = (char)tmp;
4348 (void)SvPOK_only_UTF8(TARG);
4360 register IV limit = POPi; /* note, negative is forever */
4361 SV * const sv = POPs;
4363 register const char *s = SvPV_const(sv, len);
4364 const bool do_utf8 = DO_UTF8(sv);
4365 const char *strend = s + len;
4367 register REGEXP *rx;
4369 register const char *m;
4371 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4372 I32 maxiters = slen + 10;
4374 const I32 origlimit = limit;
4377 const I32 gimme = GIMME_V;
4378 const I32 oldsave = PL_savestack_ix;
4379 I32 make_mortal = 1;
4381 MAGIC *mg = (MAGIC *) NULL;
4384 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4389 DIE(aTHX_ "panic: pp_split");
4392 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4393 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4395 RX_MATCH_UTF8_set(rx, do_utf8);
4397 if (pm->op_pmreplroot) {
4399 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4401 ary = GvAVn((GV*)pm->op_pmreplroot);
4404 else if (gimme != G_ARRAY)
4405 ary = GvAVn(PL_defgv);
4408 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4414 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4416 XPUSHs(SvTIED_obj((SV*)ary, mg));
4423 for (i = AvFILLp(ary); i >= 0; i--)
4424 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4426 /* temporarily switch stacks */
4427 SAVESWITCHSTACK(PL_curstack, ary);
4431 base = SP - PL_stack_base;
4433 if (pm->op_pmflags & PMf_SKIPWHITE) {
4434 if (pm->op_pmflags & PMf_LOCALE) {
4435 while (isSPACE_LC(*s))
4443 if (pm->op_pmflags & PMf_MULTILINE) {
4448 limit = maxiters + 2;
4449 if (pm->op_pmflags & PMf_WHITE) {
4452 while (m < strend &&
4453 !((pm->op_pmflags & PMf_LOCALE)
4454 ? isSPACE_LC(*m) : isSPACE(*m)))
4459 dstr = newSVpvn(s, m-s);
4463 (void)SvUTF8_on(dstr);
4467 while (s < strend &&
4468 ((pm->op_pmflags & PMf_LOCALE)
4469 ? isSPACE_LC(*s) : isSPACE(*s)))
4473 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4475 for (m = s; m < strend && *m != '\n'; m++)
4480 dstr = newSVpvn(s, m-s);
4484 (void)SvUTF8_on(dstr);
4489 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4490 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4491 && (rx->reganch & ROPT_CHECK_ALL)
4492 && !(rx->reganch & ROPT_ANCH)) {
4493 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4494 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4497 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4498 const char c = *SvPV_nolen_const(csv);
4500 for (m = s; m < strend && *m != c; m++)
4504 dstr = newSVpvn(s, m-s);
4508 (void)SvUTF8_on(dstr);
4510 /* The rx->minlen is in characters but we want to step
4511 * s ahead by bytes. */
4513 s = (char*)utf8_hop((U8*)m, len);
4515 s = m + len; /* Fake \n at the end */
4519 while (s < strend && --limit &&
4520 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4521 csv, multiline ? FBMrf_MULTILINE : 0)) )
4523 dstr = newSVpvn(s, m-s);
4527 (void)SvUTF8_on(dstr);
4529 /* The rx->minlen is in characters but we want to step
4530 * s ahead by bytes. */
4532 s = (char*)utf8_hop((U8*)m, len);
4534 s = m + len; /* Fake \n at the end */
4539 maxiters += slen * rx->nparens;
4540 while (s < strend && --limit)
4544 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4547 if (rex_return == 0)
4549 TAINT_IF(RX_MATCH_TAINTED(rx));
4550 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4555 strend = s + (strend - m);
4557 m = rx->startp[0] + orig;
4558 dstr = newSVpvn(s, m-s);
4562 (void)SvUTF8_on(dstr);
4566 for (i = 1; i <= (I32)rx->nparens; i++) {
4567 s = rx->startp[i] + orig;
4568 m = rx->endp[i] + orig;
4570 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4571 parens that didn't match -- they should be set to
4572 undef, not the empty string */
4573 if (m >= orig && s >= orig) {
4574 dstr = newSVpvn(s, m-s);
4577 dstr = &PL_sv_undef; /* undef, not "" */
4581 (void)SvUTF8_on(dstr);
4585 s = rx->endp[0] + orig;
4589 iters = (SP - PL_stack_base) - base;
4590 if (iters > maxiters)
4591 DIE(aTHX_ "Split loop");
4593 /* keep field after final delim? */
4594 if (s < strend || (iters && origlimit)) {
4595 const STRLEN l = strend - s;
4596 dstr = newSVpvn(s, l);
4600 (void)SvUTF8_on(dstr);
4604 else if (!origlimit) {
4605 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4606 if (TOPs && !make_mortal)
4609 *SP-- = &PL_sv_undef;
4614 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4618 if (SvSMAGICAL(ary)) {
4623 if (gimme == G_ARRAY) {
4625 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4633 call_method("PUSH",G_SCALAR|G_DISCARD);
4636 if (gimme == G_ARRAY) {
4638 /* EXTEND should not be needed - we just popped them */
4640 for (i=0; i < iters; i++) {
4641 SV **svp = av_fetch(ary, i, FALSE);
4642 PUSHs((svp) ? *svp : &PL_sv_undef);
4649 if (gimme == G_ARRAY)
4664 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4665 || SvTYPE(retsv) == SVt_PVCV) {
4666 retsv = refto(retsv);
4673 PP(unimplemented_op)
4675 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4681 * c-indentation-style: bsd
4683 * indent-tabs-mode: t
4686 * ex: set ts=8 sts=4 sw=4 noet: