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,
344 (PL_op->op_flags & OPf_SPECIAL) ? 0 : GV_ADD);
347 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
348 if ((PL_op->op_private & OPpLVAL_INTRO)) {
349 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
352 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
356 cv = (CV*)&PL_sv_undef;
370 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
371 const char * const s = SvPVX_const(TOPs);
372 if (strnEQ(s, "CORE::", 6)) {
373 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
374 if (code < 0) { /* Overridable. */
375 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
376 int i = 0, n = 0, seen_question = 0;
378 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
380 if (code == -KEY_chop || code == -KEY_chomp
381 || code == -KEY_exec || code == -KEY_system)
383 while (i < MAXO) { /* The slow way. */
384 if (strEQ(s + 6, PL_op_name[i])
385 || strEQ(s + 6, PL_op_desc[i]))
391 goto nonesuch; /* Should not happen... */
393 oa = PL_opargs[i] >> OASHIFT;
395 if (oa & OA_OPTIONAL && !seen_question) {
399 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
400 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
401 /* But globs are already references (kinda) */
402 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
406 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
410 ret = sv_2mortal(newSVpvn(str, n - 1));
412 else if (code) /* Non-Overridable */
414 else { /* None such */
416 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
420 cv = sv_2cv(TOPs, &stash, &gv, 0);
422 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
431 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
433 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
449 if (GIMME != G_ARRAY) {
453 *MARK = &PL_sv_undef;
454 *MARK = refto(*MARK);
458 EXTEND_MORTAL(SP - MARK);
460 *MARK = refto(*MARK);
465 S_refto(pTHX_ SV *sv)
469 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
472 if (!(sv = LvTARG(sv)))
475 (void)SvREFCNT_inc(sv);
477 else if (SvTYPE(sv) == SVt_PVAV) {
478 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
481 (void)SvREFCNT_inc(sv);
483 else if (SvPADTMP(sv) && !IS_PADGV(sv))
487 (void)SvREFCNT_inc(sv);
490 sv_upgrade(rv, SVt_RV);
500 SV * const sv = POPs;
505 if (!sv || !SvROK(sv))
508 pv = sv_reftype(SvRV(sv),TRUE);
509 PUSHp(pv, strlen(pv));
519 stash = CopSTASH(PL_curcop);
521 SV * const ssv = POPs;
525 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
526 Perl_croak(aTHX_ "Attempt to bless into a reference");
527 ptr = SvPV_const(ssv,len);
528 if (len == 0 && ckWARN(WARN_MISC))
529 Perl_warner(aTHX_ packWARN(WARN_MISC),
530 "Explicit blessing to '' (assuming package main)");
531 stash = gv_stashpvn(ptr, len, TRUE);
534 (void)sv_bless(TOPs, stash);
543 const char * const elem = SvPV_nolen_const(sv);
544 GV * const gv = (GV*)POPs;
545 SV * tmpRef = Nullsv;
549 /* elem will always be NUL terminated. */
550 const char * const second_letter = elem + 1;
553 if (strEQ(second_letter, "RRAY"))
554 tmpRef = (SV*)GvAV(gv);
557 if (strEQ(second_letter, "ODE"))
558 tmpRef = (SV*)GvCVu(gv);
561 if (strEQ(second_letter, "ILEHANDLE")) {
562 /* finally deprecated in 5.8.0 */
563 deprecate("*glob{FILEHANDLE}");
564 tmpRef = (SV*)GvIOp(gv);
567 if (strEQ(second_letter, "ORMAT"))
568 tmpRef = (SV*)GvFORM(gv);
571 if (strEQ(second_letter, "LOB"))
575 if (strEQ(second_letter, "ASH"))
576 tmpRef = (SV*)GvHV(gv);
579 if (*second_letter == 'O' && !elem[2])
580 tmpRef = (SV*)GvIOp(gv);
583 if (strEQ(second_letter, "AME"))
584 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
587 if (strEQ(second_letter, "ACKAGE")) {
588 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
589 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
593 if (strEQ(second_letter, "CALAR"))
608 /* Pattern matching */
613 register unsigned char *s;
616 register I32 *sfirst;
620 if (sv == PL_lastscream) {
626 SvSCREAM_off(PL_lastscream);
627 SvREFCNT_dec(PL_lastscream);
629 PL_lastscream = SvREFCNT_inc(sv);
632 s = (unsigned char*)(SvPV(sv, len));
636 if (pos > PL_maxscream) {
637 if (PL_maxscream < 0) {
638 PL_maxscream = pos + 80;
639 Newx(PL_screamfirst, 256, I32);
640 Newx(PL_screamnext, PL_maxscream, I32);
643 PL_maxscream = pos + pos / 4;
644 Renew(PL_screamnext, PL_maxscream, I32);
648 sfirst = PL_screamfirst;
649 snext = PL_screamnext;
651 if (!sfirst || !snext)
652 DIE(aTHX_ "do_study: out of memory");
654 for (ch = 256; ch; --ch)
659 register const I32 ch = s[pos];
661 snext[pos] = sfirst[ch] - pos;
668 /* piggyback on m//g magic */
669 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
678 if (PL_op->op_flags & OPf_STACKED)
680 else if (PL_op->op_private & OPpTARGET_MY)
686 TARG = sv_newmortal();
691 /* Lvalue operators. */
703 dSP; dMARK; dTARGET; dORIGMARK;
705 do_chop(TARG, *++MARK);
714 SETi(do_chomp(TOPs));
721 register I32 count = 0;
724 count += do_chomp(POPs);
734 if (!PL_op->op_private) {
743 SV_CHECK_THINKFIRST_COW_DROP(sv);
745 switch (SvTYPE(sv)) {
755 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
756 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
757 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
761 /* let user-undef'd sub keep its identity */
762 GV* const gv = CvGV((CV*)sv);
769 SvSetMagicSV(sv, &PL_sv_undef);
774 GvGP(sv) = gp_ref(gp);
775 GvSV(sv) = NEWSV(72,0);
776 GvLINE(sv) = CopLINE(PL_curcop);
782 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
784 SvPV_set(sv, Nullch);
797 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
798 DIE(aTHX_ PL_no_modify);
799 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
800 && SvIVX(TOPs) != IV_MIN)
802 SvIV_set(TOPs, SvIVX(TOPs) - 1);
803 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
814 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
815 DIE(aTHX_ PL_no_modify);
816 sv_setsv(TARG, TOPs);
817 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
818 && SvIVX(TOPs) != IV_MAX)
820 SvIV_set(TOPs, SvIVX(TOPs) + 1);
821 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
826 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
836 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
837 DIE(aTHX_ PL_no_modify);
838 sv_setsv(TARG, TOPs);
839 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
840 && SvIVX(TOPs) != IV_MIN)
842 SvIV_set(TOPs, SvIVX(TOPs) - 1);
843 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
852 /* Ordinary operators. */
857 #ifdef PERL_PRESERVE_IVUV
860 tryAMAGICbin(pow,opASSIGN);
861 #ifdef PERL_PRESERVE_IVUV
862 /* For integer to integer power, we do the calculation by hand wherever
863 we're sure it is safe; otherwise we call pow() and try to convert to
864 integer afterwards. */
877 const IV iv = SvIVX(TOPs);
881 goto float_it; /* Can't do negative powers this way. */
885 baseuok = SvUOK(TOPm1s);
887 baseuv = SvUVX(TOPm1s);
889 const IV iv = SvIVX(TOPm1s);
892 baseuok = TRUE; /* effectively it's a UV now */
894 baseuv = -iv; /* abs, baseuok == false records sign */
897 /* now we have integer ** positive integer. */
900 /* foo & (foo - 1) is zero only for a power of 2. */
901 if (!(baseuv & (baseuv - 1))) {
902 /* We are raising power-of-2 to a positive integer.
903 The logic here will work for any base (even non-integer
904 bases) but it can be less accurate than
905 pow (base,power) or exp (power * log (base)) when the
906 intermediate values start to spill out of the mantissa.
907 With powers of 2 we know this can't happen.
908 And powers of 2 are the favourite thing for perl
909 programmers to notice ** not doing what they mean. */
911 NV base = baseuok ? baseuv : -(NV)baseuv;
916 while (power >>= 1) {
927 register unsigned int highbit = 8 * sizeof(UV);
928 register unsigned int diff = 8 * sizeof(UV);
931 if (baseuv >> highbit) {
935 /* we now have baseuv < 2 ** highbit */
936 if (power * highbit <= 8 * sizeof(UV)) {
937 /* result will definitely fit in UV, so use UV math
938 on same algorithm as above */
939 register UV result = 1;
940 register UV base = baseuv;
941 const bool odd_power = (bool)(power & 1);
945 while (power >>= 1) {
952 if (baseuok || !odd_power)
953 /* answer is positive */
955 else if (result <= (UV)IV_MAX)
956 /* answer negative, fits in IV */
958 else if (result == (UV)IV_MIN)
959 /* 2's complement assumption: special case IV_MIN */
962 /* answer negative, doesn't fit */
974 SETn( Perl_pow( left, right) );
975 #ifdef PERL_PRESERVE_IVUV
985 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
986 #ifdef PERL_PRESERVE_IVUV
989 /* Unless the left argument is integer in range we are going to have to
990 use NV maths. Hence only attempt to coerce the right argument if
991 we know the left is integer. */
992 /* Left operand is defined, so is it IV? */
995 bool auvok = SvUOK(TOPm1s);
996 bool buvok = SvUOK(TOPs);
997 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
998 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1005 alow = SvUVX(TOPm1s);
1007 const IV aiv = SvIVX(TOPm1s);
1010 auvok = TRUE; /* effectively it's a UV now */
1012 alow = -aiv; /* abs, auvok == false records sign */
1018 const IV biv = SvIVX(TOPs);
1021 buvok = TRUE; /* effectively it's a UV now */
1023 blow = -biv; /* abs, buvok == false records sign */
1027 /* If this does sign extension on unsigned it's time for plan B */
1028 ahigh = alow >> (4 * sizeof (UV));
1030 bhigh = blow >> (4 * sizeof (UV));
1032 if (ahigh && bhigh) {
1033 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1034 which is overflow. Drop to NVs below. */
1035 } else if (!ahigh && !bhigh) {
1036 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1037 so the unsigned multiply cannot overflow. */
1038 UV product = alow * blow;
1039 if (auvok == buvok) {
1040 /* -ve * -ve or +ve * +ve gives a +ve result. */
1044 } else if (product <= (UV)IV_MIN) {
1045 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1046 /* -ve result, which could overflow an IV */
1048 SETi( -(IV)product );
1050 } /* else drop to NVs below. */
1052 /* One operand is large, 1 small */
1055 /* swap the operands */
1057 bhigh = blow; /* bhigh now the temp var for the swap */
1061 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1062 multiplies can't overflow. shift can, add can, -ve can. */
1063 product_middle = ahigh * blow;
1064 if (!(product_middle & topmask)) {
1065 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1067 product_middle <<= (4 * sizeof (UV));
1068 product_low = alow * blow;
1070 /* as for pp_add, UV + something mustn't get smaller.
1071 IIRC ANSI mandates this wrapping *behaviour* for
1072 unsigned whatever the actual representation*/
1073 product_low += product_middle;
1074 if (product_low >= product_middle) {
1075 /* didn't overflow */
1076 if (auvok == buvok) {
1077 /* -ve * -ve or +ve * +ve gives a +ve result. */
1079 SETu( product_low );
1081 } else if (product_low <= (UV)IV_MIN) {
1082 /* 2s complement assumption again */
1083 /* -ve result, which could overflow an IV */
1085 SETi( -(IV)product_low );
1087 } /* else drop to NVs below. */
1089 } /* product_middle too large */
1090 } /* ahigh && bhigh */
1091 } /* SvIOK(TOPm1s) */
1096 SETn( left * right );
1103 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1104 /* Only try to do UV divide first
1105 if ((SLOPPYDIVIDE is true) or
1106 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1108 The assumption is that it is better to use floating point divide
1109 whenever possible, only doing integer divide first if we can't be sure.
1110 If NV_PRESERVES_UV is true then we know at compile time that no UV
1111 can be too large to preserve, so don't need to compile the code to
1112 test the size of UVs. */
1115 # define PERL_TRY_UV_DIVIDE
1116 /* ensure that 20./5. == 4. */
1118 # ifdef PERL_PRESERVE_IVUV
1119 # ifndef NV_PRESERVES_UV
1120 # define PERL_TRY_UV_DIVIDE
1125 #ifdef PERL_TRY_UV_DIVIDE
1128 SvIV_please(TOPm1s);
1129 if (SvIOK(TOPm1s)) {
1130 bool left_non_neg = SvUOK(TOPm1s);
1131 bool right_non_neg = SvUOK(TOPs);
1135 if (right_non_neg) {
1136 right = SvUVX(TOPs);
1139 const IV biv = SvIVX(TOPs);
1142 right_non_neg = TRUE; /* effectively it's a UV now */
1148 /* historically undef()/0 gives a "Use of uninitialized value"
1149 warning before dieing, hence this test goes here.
1150 If it were immediately before the second SvIV_please, then
1151 DIE() would be invoked before left was even inspected, so
1152 no inpsection would give no warning. */
1154 DIE(aTHX_ "Illegal division by zero");
1157 left = SvUVX(TOPm1s);
1160 const IV aiv = SvIVX(TOPm1s);
1163 left_non_neg = TRUE; /* effectively it's a UV now */
1172 /* For sloppy divide we always attempt integer division. */
1174 /* Otherwise we only attempt it if either or both operands
1175 would not be preserved by an NV. If both fit in NVs
1176 we fall through to the NV divide code below. However,
1177 as left >= right to ensure integer result here, we know that
1178 we can skip the test on the right operand - right big
1179 enough not to be preserved can't get here unless left is
1182 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1185 /* Integer division can't overflow, but it can be imprecise. */
1186 const UV result = left / right;
1187 if (result * right == left) {
1188 SP--; /* result is valid */
1189 if (left_non_neg == right_non_neg) {
1190 /* signs identical, result is positive. */
1194 /* 2s complement assumption */
1195 if (result <= (UV)IV_MIN)
1196 SETi( -(IV)result );
1198 /* It's exact but too negative for IV. */
1199 SETn( -(NV)result );
1202 } /* tried integer divide but it was not an integer result */
1203 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1204 } /* left wasn't SvIOK */
1205 } /* right wasn't SvIOK */
1206 #endif /* PERL_TRY_UV_DIVIDE */
1210 DIE(aTHX_ "Illegal division by zero");
1211 PUSHn( left / right );
1218 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1222 bool left_neg = FALSE;
1223 bool right_neg = FALSE;
1224 bool use_double = FALSE;
1225 bool dright_valid = FALSE;
1231 right_neg = !SvUOK(TOPs);
1233 right = SvUVX(POPs);
1235 const IV biv = SvIVX(POPs);
1238 right_neg = FALSE; /* effectively it's a UV now */
1246 right_neg = dright < 0;
1249 if (dright < UV_MAX_P1) {
1250 right = U_V(dright);
1251 dright_valid = TRUE; /* In case we need to use double below. */
1257 /* At this point use_double is only true if right is out of range for
1258 a UV. In range NV has been rounded down to nearest UV and
1259 use_double false. */
1261 if (!use_double && SvIOK(TOPs)) {
1263 left_neg = !SvUOK(TOPs);
1267 const IV aiv = SvIVX(POPs);
1270 left_neg = FALSE; /* effectively it's a UV now */
1279 left_neg = dleft < 0;
1283 /* This should be exactly the 5.6 behaviour - if left and right are
1284 both in range for UV then use U_V() rather than floor. */
1286 if (dleft < UV_MAX_P1) {
1287 /* right was in range, so is dleft, so use UVs not double.
1291 /* left is out of range for UV, right was in range, so promote
1292 right (back) to double. */
1294 /* The +0.5 is used in 5.6 even though it is not strictly
1295 consistent with the implicit +0 floor in the U_V()
1296 inside the #if 1. */
1297 dleft = Perl_floor(dleft + 0.5);
1300 dright = Perl_floor(dright + 0.5);
1310 DIE(aTHX_ "Illegal modulus zero");
1312 dans = Perl_fmod(dleft, dright);
1313 if ((left_neg != right_neg) && dans)
1314 dans = dright - dans;
1317 sv_setnv(TARG, dans);
1323 DIE(aTHX_ "Illegal modulus zero");
1326 if ((left_neg != right_neg) && ans)
1329 /* XXX may warn: unary minus operator applied to unsigned type */
1330 /* could change -foo to be (~foo)+1 instead */
1331 if (ans <= ~((UV)IV_MAX)+1)
1332 sv_setiv(TARG, ~ans+1);
1334 sv_setnv(TARG, -(NV)ans);
1337 sv_setuv(TARG, ans);
1346 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1353 const UV uv = SvUV(sv);
1355 count = IV_MAX; /* The best we can do? */
1359 const IV iv = SvIV(sv);
1366 else if (SvNOKp(sv)) {
1367 const NV nv = SvNV(sv);
1375 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1377 static const char oom_list_extend[] = "Out of memory during list extend";
1378 const I32 items = SP - MARK;
1379 const I32 max = items * count;
1381 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1382 /* Did the max computation overflow? */
1383 if (items > 0 && max > 0 && (max < items || max < count))
1384 Perl_croak(aTHX_ oom_list_extend);
1389 /* This code was intended to fix 20010809.028:
1392 for (($x =~ /./g) x 2) {
1393 print chop; # "abcdabcd" expected as output.
1396 * but that change (#11635) broke this code:
1398 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1400 * I can't think of a better fix that doesn't introduce
1401 * an efficiency hit by copying the SVs. The stack isn't
1402 * refcounted, and mortalisation obviously doesn't
1403 * Do The Right Thing when the stack has more than
1404 * one pointer to the same mortal value.
1408 *SP = sv_2mortal(newSVsv(*SP));
1418 repeatcpy((char*)(MARK + items), (char*)MARK,
1419 items * sizeof(SV*), count - 1);
1422 else if (count <= 0)
1425 else { /* Note: mark already snarfed by pp_list */
1426 SV * const tmpstr = POPs;
1429 static const char oom_string_extend[] =
1430 "Out of memory during string extend";
1432 SvSetSV(TARG, tmpstr);
1433 SvPV_force(TARG, len);
1434 isutf = DO_UTF8(TARG);
1439 STRLEN max = (UV)count * len;
1440 if (len > ((MEM_SIZE)~0)/count)
1441 Perl_croak(aTHX_ oom_string_extend);
1442 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1443 SvGROW(TARG, max + 1);
1444 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1445 SvCUR_set(TARG, SvCUR(TARG) * count);
1447 *SvEND(TARG) = '\0';
1450 (void)SvPOK_only_UTF8(TARG);
1452 (void)SvPOK_only(TARG);
1454 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1455 /* The parser saw this as a list repeat, and there
1456 are probably several items on the stack. But we're
1457 in scalar context, and there's no pp_list to save us
1458 now. So drop the rest of the items -- robin@kitsite.com
1471 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1472 useleft = USE_LEFT(TOPm1s);
1473 #ifdef PERL_PRESERVE_IVUV
1474 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1475 "bad things" happen if you rely on signed integers wrapping. */
1478 /* Unless the left argument is integer in range we are going to have to
1479 use NV maths. Hence only attempt to coerce the right argument if
1480 we know the left is integer. */
1481 register UV auv = 0;
1487 a_valid = auvok = 1;
1488 /* left operand is undef, treat as zero. */
1490 /* Left operand is defined, so is it IV? */
1491 SvIV_please(TOPm1s);
1492 if (SvIOK(TOPm1s)) {
1493 if ((auvok = SvUOK(TOPm1s)))
1494 auv = SvUVX(TOPm1s);
1496 register const IV aiv = SvIVX(TOPm1s);
1499 auvok = 1; /* Now acting as a sign flag. */
1500 } else { /* 2s complement assumption for IV_MIN */
1508 bool result_good = 0;
1511 bool buvok = SvUOK(TOPs);
1516 register const IV biv = SvIVX(TOPs);
1523 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1524 else "IV" now, independent of how it came in.
1525 if a, b represents positive, A, B negative, a maps to -A etc
1530 all UV maths. negate result if A negative.
1531 subtract if signs same, add if signs differ. */
1533 if (auvok ^ buvok) {
1542 /* Must get smaller */
1547 if (result <= buv) {
1548 /* result really should be -(auv-buv). as its negation
1549 of true value, need to swap our result flag */
1561 if (result <= (UV)IV_MIN)
1562 SETi( -(IV)result );
1564 /* result valid, but out of range for IV. */
1565 SETn( -(NV)result );
1569 } /* Overflow, drop through to NVs. */
1573 useleft = USE_LEFT(TOPm1s);
1577 /* left operand is undef, treat as zero - value */
1581 SETn( TOPn - value );
1588 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1590 const IV shift = POPi;
1591 if (PL_op->op_private & HINT_INTEGER) {
1605 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1607 const IV shift = POPi;
1608 if (PL_op->op_private & HINT_INTEGER) {
1622 dSP; tryAMAGICbinSET(lt,0);
1623 #ifdef PERL_PRESERVE_IVUV
1626 SvIV_please(TOPm1s);
1627 if (SvIOK(TOPm1s)) {
1628 bool auvok = SvUOK(TOPm1s);
1629 bool buvok = SvUOK(TOPs);
1631 if (!auvok && !buvok) { /* ## IV < IV ## */
1632 const IV aiv = SvIVX(TOPm1s);
1633 const IV biv = SvIVX(TOPs);
1636 SETs(boolSV(aiv < biv));
1639 if (auvok && buvok) { /* ## UV < UV ## */
1640 const UV auv = SvUVX(TOPm1s);
1641 const UV buv = SvUVX(TOPs);
1644 SETs(boolSV(auv < buv));
1647 if (auvok) { /* ## UV < IV ## */
1649 const IV biv = SvIVX(TOPs);
1652 /* As (a) is a UV, it's >=0, so it cannot be < */
1657 SETs(boolSV(auv < (UV)biv));
1660 { /* ## IV < UV ## */
1661 const IV aiv = SvIVX(TOPm1s);
1665 /* As (b) is a UV, it's >=0, so it must be < */
1672 SETs(boolSV((UV)aiv < buv));
1678 #ifndef NV_PRESERVES_UV
1679 #ifdef PERL_PRESERVE_IVUV
1682 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1684 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1690 SETs(boolSV(TOPn < value));
1697 dSP; tryAMAGICbinSET(gt,0);
1698 #ifdef PERL_PRESERVE_IVUV
1701 SvIV_please(TOPm1s);
1702 if (SvIOK(TOPm1s)) {
1703 bool auvok = SvUOK(TOPm1s);
1704 bool buvok = SvUOK(TOPs);
1706 if (!auvok && !buvok) { /* ## IV > IV ## */
1707 const IV aiv = SvIVX(TOPm1s);
1708 const IV biv = SvIVX(TOPs);
1711 SETs(boolSV(aiv > biv));
1714 if (auvok && buvok) { /* ## UV > UV ## */
1715 const UV auv = SvUVX(TOPm1s);
1716 const UV buv = SvUVX(TOPs);
1719 SETs(boolSV(auv > buv));
1722 if (auvok) { /* ## UV > IV ## */
1724 const IV biv = SvIVX(TOPs);
1728 /* As (a) is a UV, it's >=0, so it must be > */
1733 SETs(boolSV(auv > (UV)biv));
1736 { /* ## IV > UV ## */
1737 const IV aiv = SvIVX(TOPm1s);
1741 /* As (b) is a UV, it's >=0, so it cannot be > */
1748 SETs(boolSV((UV)aiv > buv));
1754 #ifndef NV_PRESERVES_UV
1755 #ifdef PERL_PRESERVE_IVUV
1758 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1760 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1766 SETs(boolSV(TOPn > value));
1773 dSP; tryAMAGICbinSET(le,0);
1774 #ifdef PERL_PRESERVE_IVUV
1777 SvIV_please(TOPm1s);
1778 if (SvIOK(TOPm1s)) {
1779 bool auvok = SvUOK(TOPm1s);
1780 bool buvok = SvUOK(TOPs);
1782 if (!auvok && !buvok) { /* ## IV <= IV ## */
1783 const IV aiv = SvIVX(TOPm1s);
1784 const IV biv = SvIVX(TOPs);
1787 SETs(boolSV(aiv <= biv));
1790 if (auvok && buvok) { /* ## UV <= UV ## */
1791 UV auv = SvUVX(TOPm1s);
1792 UV buv = SvUVX(TOPs);
1795 SETs(boolSV(auv <= buv));
1798 if (auvok) { /* ## UV <= IV ## */
1800 const IV biv = SvIVX(TOPs);
1804 /* As (a) is a UV, it's >=0, so a cannot be <= */
1809 SETs(boolSV(auv <= (UV)biv));
1812 { /* ## IV <= UV ## */
1813 const IV aiv = SvIVX(TOPm1s);
1817 /* As (b) is a UV, it's >=0, so a must be <= */
1824 SETs(boolSV((UV)aiv <= buv));
1830 #ifndef NV_PRESERVES_UV
1831 #ifdef PERL_PRESERVE_IVUV
1834 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1836 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1842 SETs(boolSV(TOPn <= value));
1849 dSP; tryAMAGICbinSET(ge,0);
1850 #ifdef PERL_PRESERVE_IVUV
1853 SvIV_please(TOPm1s);
1854 if (SvIOK(TOPm1s)) {
1855 bool auvok = SvUOK(TOPm1s);
1856 bool buvok = SvUOK(TOPs);
1858 if (!auvok && !buvok) { /* ## IV >= IV ## */
1859 const IV aiv = SvIVX(TOPm1s);
1860 const IV biv = SvIVX(TOPs);
1863 SETs(boolSV(aiv >= biv));
1866 if (auvok && buvok) { /* ## UV >= UV ## */
1867 const UV auv = SvUVX(TOPm1s);
1868 const UV buv = SvUVX(TOPs);
1871 SETs(boolSV(auv >= buv));
1874 if (auvok) { /* ## UV >= IV ## */
1876 const IV biv = SvIVX(TOPs);
1880 /* As (a) is a UV, it's >=0, so it must be >= */
1885 SETs(boolSV(auv >= (UV)biv));
1888 { /* ## IV >= UV ## */
1889 const IV aiv = SvIVX(TOPm1s);
1893 /* As (b) is a UV, it's >=0, so a cannot be >= */
1900 SETs(boolSV((UV)aiv >= buv));
1906 #ifndef NV_PRESERVES_UV
1907 #ifdef PERL_PRESERVE_IVUV
1910 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1912 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1918 SETs(boolSV(TOPn >= value));
1925 dSP; tryAMAGICbinSET(ne,0);
1926 #ifndef NV_PRESERVES_UV
1927 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1929 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1933 #ifdef PERL_PRESERVE_IVUV
1936 SvIV_please(TOPm1s);
1937 if (SvIOK(TOPm1s)) {
1938 const bool auvok = SvUOK(TOPm1s);
1939 const bool buvok = SvUOK(TOPs);
1941 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1942 /* Casting IV to UV before comparison isn't going to matter
1943 on 2s complement. On 1s complement or sign&magnitude
1944 (if we have any of them) it could make negative zero
1945 differ from normal zero. As I understand it. (Need to
1946 check - is negative zero implementation defined behaviour
1948 const UV buv = SvUVX(POPs);
1949 const UV auv = SvUVX(TOPs);
1951 SETs(boolSV(auv != buv));
1954 { /* ## Mixed IV,UV ## */
1958 /* != is commutative so swap if needed (save code) */
1960 /* swap. top of stack (b) is the iv */
1964 /* As (a) is a UV, it's >0, so it cannot be == */
1973 /* As (b) is a UV, it's >0, so it cannot be == */
1977 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1979 SETs(boolSV((UV)iv != uv));
1987 SETs(boolSV(TOPn != value));
1994 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1995 #ifndef NV_PRESERVES_UV
1996 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1997 const UV right = PTR2UV(SvRV(POPs));
1998 const UV left = PTR2UV(SvRV(TOPs));
1999 SETi((left > right) - (left < right));
2003 #ifdef PERL_PRESERVE_IVUV
2004 /* Fortunately it seems NaN isn't IOK */
2007 SvIV_please(TOPm1s);
2008 if (SvIOK(TOPm1s)) {
2009 const bool leftuvok = SvUOK(TOPm1s);
2010 const bool rightuvok = SvUOK(TOPs);
2012 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2013 const IV leftiv = SvIVX(TOPm1s);
2014 const IV rightiv = SvIVX(TOPs);
2016 if (leftiv > rightiv)
2018 else if (leftiv < rightiv)
2022 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2023 const UV leftuv = SvUVX(TOPm1s);
2024 const UV rightuv = SvUVX(TOPs);
2026 if (leftuv > rightuv)
2028 else if (leftuv < rightuv)
2032 } else if (leftuvok) { /* ## UV <=> IV ## */
2033 const IV rightiv = SvIVX(TOPs);
2035 /* As (a) is a UV, it's >=0, so it cannot be < */
2038 const UV leftuv = SvUVX(TOPm1s);
2039 if (leftuv > (UV)rightiv) {
2041 } else if (leftuv < (UV)rightiv) {
2047 } else { /* ## IV <=> UV ## */
2048 const IV leftiv = SvIVX(TOPm1s);
2050 /* As (b) is a UV, it's >=0, so it must be < */
2053 const UV rightuv = SvUVX(TOPs);
2054 if ((UV)leftiv > rightuv) {
2056 } else if ((UV)leftiv < rightuv) {
2074 if (Perl_isnan(left) || Perl_isnan(right)) {
2078 value = (left > right) - (left < right);
2082 else if (left < right)
2084 else if (left > right)
2100 int amg_type = sle_amg;
2104 switch (PL_op->op_type) {
2123 tryAMAGICbinSET_var(amg_type,0);
2126 const int cmp = (IN_LOCALE_RUNTIME
2127 ? sv_cmp_locale(left, right)
2128 : sv_cmp(left, right));
2129 SETs(boolSV(cmp * multiplier < rhs));
2136 dSP; tryAMAGICbinSET(seq,0);
2139 SETs(boolSV(sv_eq(left, right)));
2146 dSP; tryAMAGICbinSET(sne,0);
2149 SETs(boolSV(!sv_eq(left, right)));
2156 dSP; dTARGET; tryAMAGICbin(scmp,0);
2159 const int cmp = (IN_LOCALE_RUNTIME
2160 ? sv_cmp_locale(left, right)
2161 : sv_cmp(left, right));
2169 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2174 if (SvNIOKp(left) || SvNIOKp(right)) {
2175 if (PL_op->op_private & HINT_INTEGER) {
2176 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2180 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2185 do_vop(PL_op->op_type, TARG, left, right);
2194 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2199 if (SvNIOKp(left) || SvNIOKp(right)) {
2200 if (PL_op->op_private & HINT_INTEGER) {
2201 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2205 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2210 do_vop(PL_op->op_type, TARG, left, right);
2219 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2224 if (SvNIOKp(left) || SvNIOKp(right)) {
2225 if (PL_op->op_private & HINT_INTEGER) {
2226 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2230 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2235 do_vop(PL_op->op_type, TARG, left, right);
2244 dSP; dTARGET; tryAMAGICun(neg);
2247 const int flags = SvFLAGS(sv);
2249 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2250 /* It's publicly an integer, or privately an integer-not-float */
2253 if (SvIVX(sv) == IV_MIN) {
2254 /* 2s complement assumption. */
2255 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2258 else if (SvUVX(sv) <= IV_MAX) {
2263 else if (SvIVX(sv) != IV_MIN) {
2267 #ifdef PERL_PRESERVE_IVUV
2276 else if (SvPOKp(sv)) {
2278 const char *s = SvPV_const(sv, len);
2279 if (isIDFIRST(*s)) {
2280 sv_setpvn(TARG, "-", 1);
2283 else if (*s == '+' || *s == '-') {
2285 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2287 else if (DO_UTF8(sv)) {
2290 goto oops_its_an_int;
2292 sv_setnv(TARG, -SvNV(sv));
2294 sv_setpvn(TARG, "-", 1);
2301 goto oops_its_an_int;
2302 sv_setnv(TARG, -SvNV(sv));
2314 dSP; tryAMAGICunSET(not);
2315 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2321 dSP; dTARGET; tryAMAGICun(compl);
2326 if (PL_op->op_private & HINT_INTEGER) {
2327 const IV i = ~SvIV_nomg(sv);
2331 const UV u = ~SvUV_nomg(sv);
2340 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2341 sv_setsv_nomg(TARG, sv);
2342 tmps = (U8*)SvPV_force(TARG, len);
2345 /* Calculate exact length, let's not estimate. */
2354 while (tmps < send) {
2355 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2356 tmps += UTF8SKIP(tmps);
2357 targlen += UNISKIP(~c);
2363 /* Now rewind strings and write them. */
2367 Newxz(result, targlen + 1, U8);
2368 while (tmps < send) {
2369 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2370 tmps += UTF8SKIP(tmps);
2371 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2375 sv_setpvn(TARG, (char*)result, targlen);
2379 Newxz(result, nchar + 1, U8);
2380 while (tmps < send) {
2381 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2382 tmps += UTF8SKIP(tmps);
2387 sv_setpvn(TARG, (char*)result, nchar);
2396 register long *tmpl;
2397 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2400 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2405 for ( ; anum > 0; anum--, tmps++)
2414 /* integer versions of some of the above */
2418 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2421 SETi( left * right );
2428 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2432 DIE(aTHX_ "Illegal division by zero");
2433 value = POPi / value;
2442 /* This is the vanilla old i_modulo. */
2443 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2447 DIE(aTHX_ "Illegal modulus zero");
2448 SETi( left % right );
2453 #if defined(__GLIBC__) && IVSIZE == 8
2457 /* This is the i_modulo with the workaround for the _moddi3 bug
2458 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2459 * See below for pp_i_modulo. */
2460 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2464 DIE(aTHX_ "Illegal modulus zero");
2465 SETi( left % PERL_ABS(right) );
2473 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2477 DIE(aTHX_ "Illegal modulus zero");
2478 /* The assumption is to use hereafter the old vanilla version... */
2480 PL_ppaddr[OP_I_MODULO] =
2482 /* .. but if we have glibc, we might have a buggy _moddi3
2483 * (at least glicb 2.2.5 is known to have this bug), in other
2484 * words our integer modulus with negative quad as the second
2485 * argument might be broken. Test for this and re-patch the
2486 * opcode dispatch table if that is the case, remembering to
2487 * also apply the workaround so that this first round works
2488 * right, too. See [perl #9402] for more information. */
2489 #if defined(__GLIBC__) && IVSIZE == 8
2493 /* Cannot do this check with inlined IV constants since
2494 * that seems to work correctly even with the buggy glibc. */
2496 /* Yikes, we have the bug.
2497 * Patch in the workaround version. */
2499 PL_ppaddr[OP_I_MODULO] =
2500 &Perl_pp_i_modulo_1;
2501 /* Make certain we work right this time, too. */
2502 right = PERL_ABS(right);
2506 SETi( left % right );
2513 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2516 SETi( left + right );
2523 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2526 SETi( left - right );
2533 dSP; tryAMAGICbinSET(lt,0);
2536 SETs(boolSV(left < right));
2543 dSP; tryAMAGICbinSET(gt,0);
2546 SETs(boolSV(left > right));
2553 dSP; tryAMAGICbinSET(le,0);
2556 SETs(boolSV(left <= right));
2563 dSP; tryAMAGICbinSET(ge,0);
2566 SETs(boolSV(left >= right));
2573 dSP; tryAMAGICbinSET(eq,0);
2576 SETs(boolSV(left == right));
2583 dSP; tryAMAGICbinSET(ne,0);
2586 SETs(boolSV(left != right));
2593 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2600 else if (left < right)
2611 dSP; dTARGET; tryAMAGICun(neg);
2616 /* High falutin' math. */
2620 dSP; dTARGET; tryAMAGICbin(atan2,0);
2623 SETn(Perl_atan2(left, right));
2630 dSP; dTARGET; tryAMAGICun(sin);
2632 const NV value = POPn;
2633 XPUSHn(Perl_sin(value));
2640 dSP; dTARGET; tryAMAGICun(cos);
2642 const NV value = POPn;
2643 XPUSHn(Perl_cos(value));
2648 /* Support Configure command-line overrides for rand() functions.
2649 After 5.005, perhaps we should replace this by Configure support
2650 for drand48(), random(), or rand(). For 5.005, though, maintain
2651 compatibility by calling rand() but allow the user to override it.
2652 See INSTALL for details. --Andy Dougherty 15 July 1998
2654 /* Now it's after 5.005, and Configure supports drand48() and random(),
2655 in addition to rand(). So the overrides should not be needed any more.
2656 --Jarkko Hietaniemi 27 September 1998
2659 #ifndef HAS_DRAND48_PROTO
2660 extern double drand48 (void);
2673 if (!PL_srand_called) {
2674 (void)seedDrand01((Rand_seed_t)seed());
2675 PL_srand_called = TRUE;
2685 const UV anum = (MAXARG < 1) ? seed() : POPu;
2686 (void)seedDrand01((Rand_seed_t)anum);
2687 PL_srand_called = TRUE;
2694 dSP; dTARGET; tryAMAGICun(exp);
2698 value = Perl_exp(value);
2706 dSP; dTARGET; tryAMAGICun(log);
2708 const NV value = POPn;
2710 SET_NUMERIC_STANDARD();
2711 DIE(aTHX_ "Can't take log of %"NVgf, value);
2713 XPUSHn(Perl_log(value));
2720 dSP; dTARGET; tryAMAGICun(sqrt);
2722 const NV value = POPn;
2724 SET_NUMERIC_STANDARD();
2725 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2727 XPUSHn(Perl_sqrt(value));
2734 dSP; dTARGET; tryAMAGICun(int);
2736 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2737 /* XXX it's arguable that compiler casting to IV might be subtly
2738 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2739 else preferring IV has introduced a subtle behaviour change bug. OTOH
2740 relying on floating point to be accurate is a bug. */
2744 else if (SvIOK(TOPs)) {
2751 const NV value = TOPn;
2753 if (value < (NV)UV_MAX + 0.5) {
2756 SETn(Perl_floor(value));
2760 if (value > (NV)IV_MIN - 0.5) {
2763 SETn(Perl_ceil(value));
2773 dSP; dTARGET; tryAMAGICun(abs);
2775 /* This will cache the NV value if string isn't actually integer */
2780 else if (SvIOK(TOPs)) {
2781 /* IVX is precise */
2783 SETu(TOPu); /* force it to be numeric only */
2791 /* 2s complement assumption. Also, not really needed as
2792 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2798 const NV value = TOPn;
2813 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2817 SV* const sv = POPs;
2819 tmps = (SvPV_const(sv, len));
2821 /* If Unicode, try to downgrade
2822 * If not possible, croak. */
2823 SV* const tsv = sv_2mortal(newSVsv(sv));
2826 sv_utf8_downgrade(tsv, FALSE);
2827 tmps = SvPV_const(tsv, len);
2829 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2830 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2843 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2847 SV* const sv = POPs;
2849 tmps = (SvPV_const(sv, len));
2851 /* If Unicode, try to downgrade
2852 * If not possible, croak. */
2853 SV* const tsv = sv_2mortal(newSVsv(sv));
2856 sv_utf8_downgrade(tsv, FALSE);
2857 tmps = SvPV_const(tsv, len);
2859 while (*tmps && len && isSPACE(*tmps))
2864 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2865 else if (*tmps == 'b')
2866 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2868 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2870 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2884 SV * const sv = TOPs;
2887 SETi(sv_len_utf8(sv));
2903 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2905 const I32 arybase = PL_curcop->cop_arybase;
2907 const char *repl = 0;
2909 const int num_args = PL_op->op_private & 7;
2910 bool repl_need_utf8_upgrade = FALSE;
2911 bool repl_is_utf8 = FALSE;
2913 SvTAINTED_off(TARG); /* decontaminate */
2914 SvUTF8_off(TARG); /* decontaminate */
2918 repl = SvPV_const(repl_sv, repl_len);
2919 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2929 sv_utf8_upgrade(sv);
2931 else if (DO_UTF8(sv))
2932 repl_need_utf8_upgrade = TRUE;
2934 tmps = SvPV_const(sv, curlen);
2936 utf8_curlen = sv_len_utf8(sv);
2937 if (utf8_curlen == curlen)
2940 curlen = utf8_curlen;
2945 if (pos >= arybase) {
2963 else if (len >= 0) {
2965 if (rem > (I32)curlen)
2980 Perl_croak(aTHX_ "substr outside of string");
2981 if (ckWARN(WARN_SUBSTR))
2982 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2986 const I32 upos = pos;
2987 const I32 urem = rem;
2989 sv_pos_u2b(sv, &pos, &rem);
2991 /* we either return a PV or an LV. If the TARG hasn't been used
2992 * before, or is of that type, reuse it; otherwise use a mortal
2993 * instead. Note that LVs can have an extended lifetime, so also
2994 * dont reuse if refcount > 1 (bug #20933) */
2995 if (SvTYPE(TARG) > SVt_NULL) {
2996 if ( (SvTYPE(TARG) == SVt_PVLV)
2997 ? (!lvalue || SvREFCNT(TARG) > 1)
3000 TARG = sv_newmortal();
3004 sv_setpvn(TARG, tmps, rem);
3005 #ifdef USE_LOCALE_COLLATE
3006 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3011 SV* repl_sv_copy = NULL;
3013 if (repl_need_utf8_upgrade) {
3014 repl_sv_copy = newSVsv(repl_sv);
3015 sv_utf8_upgrade(repl_sv_copy);
3016 repl = SvPV_const(repl_sv_copy, repl_len);
3017 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3019 sv_insert(sv, pos, rem, repl, repl_len);
3023 SvREFCNT_dec(repl_sv_copy);
3025 else if (lvalue) { /* it's an lvalue! */
3026 if (!SvGMAGICAL(sv)) {
3028 SvPV_force_nolen(sv);
3029 if (ckWARN(WARN_SUBSTR))
3030 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3031 "Attempt to use reference as lvalue in substr");
3033 if (SvOK(sv)) /* is it defined ? */
3034 (void)SvPOK_only_UTF8(sv);
3036 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3039 if (SvTYPE(TARG) < SVt_PVLV) {
3040 sv_upgrade(TARG, SVt_PVLV);
3041 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3047 if (LvTARG(TARG) != sv) {
3049 SvREFCNT_dec(LvTARG(TARG));
3050 LvTARG(TARG) = SvREFCNT_inc(sv);
3052 LvTARGOFF(TARG) = upos;
3053 LvTARGLEN(TARG) = urem;
3057 PUSHs(TARG); /* avoid SvSETMAGIC here */
3064 register const IV size = POPi;
3065 register const IV offset = POPi;
3066 register SV * const src = POPs;
3067 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3069 SvTAINTED_off(TARG); /* decontaminate */
3070 if (lvalue) { /* it's an lvalue! */
3071 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3072 TARG = sv_newmortal();
3073 if (SvTYPE(TARG) < SVt_PVLV) {
3074 sv_upgrade(TARG, SVt_PVLV);
3075 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3078 if (LvTARG(TARG) != src) {
3080 SvREFCNT_dec(LvTARG(TARG));
3081 LvTARG(TARG) = SvREFCNT_inc(src);
3083 LvTARGOFF(TARG) = offset;
3084 LvTARGLEN(TARG) = size;
3087 sv_setuv(TARG, do_vecget(src, offset, size));
3103 const I32 arybase = PL_curcop->cop_arybase;
3110 offset = POPi - arybase;
3113 big_utf8 = DO_UTF8(big);
3114 little_utf8 = DO_UTF8(little);
3115 if (big_utf8 ^ little_utf8) {
3116 /* One needs to be upgraded. */
3117 SV * const bytes = little_utf8 ? big : little;
3119 const char * const p = SvPV_const(bytes, len);
3121 temp = newSVpvn(p, len);
3124 sv_recode_to_utf8(temp, PL_encoding);
3126 sv_utf8_upgrade(temp);
3135 if (big_utf8 && offset > 0)
3136 sv_pos_u2b(big, &offset, 0);
3137 tmps = SvPV_const(big, biglen);
3140 else if (offset > (I32)biglen)
3142 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3143 (unsigned char*)tmps + biglen, little, 0)))
3146 retval = tmps2 - tmps;
3147 if (retval > 0 && big_utf8)
3148 sv_pos_b2u(big, &retval);
3151 PUSHi(retval + arybase);
3167 const I32 arybase = PL_curcop->cop_arybase;
3175 big_utf8 = DO_UTF8(big);
3176 little_utf8 = DO_UTF8(little);
3177 if (big_utf8 ^ little_utf8) {
3178 /* One needs to be upgraded. */
3179 SV * const bytes = little_utf8 ? big : little;
3181 const char *p = SvPV_const(bytes, len);
3183 temp = newSVpvn(p, len);
3186 sv_recode_to_utf8(temp, PL_encoding);
3188 sv_utf8_upgrade(temp);
3197 tmps2 = SvPV_const(little, llen);
3198 tmps = SvPV_const(big, blen);
3203 if (offset > 0 && big_utf8)
3204 sv_pos_u2b(big, &offset, 0);
3205 offset = offset - arybase + llen;
3209 else if (offset > (I32)blen)
3211 if (!(tmps2 = rninstr(tmps, tmps + offset,
3212 tmps2, tmps2 + llen)))
3215 retval = tmps2 - tmps;
3216 if (retval > 0 && big_utf8)
3217 sv_pos_b2u(big, &retval);
3220 PUSHi(retval + arybase);
3226 dSP; dMARK; dORIGMARK; dTARGET;
3227 do_sprintf(TARG, SP-MARK, MARK+1);
3228 TAINT_IF(SvTAINTED(TARG));
3239 const U8 *s = (U8*)SvPV_const(argsv, len);
3242 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3243 tmpsv = sv_2mortal(newSVsv(argsv));
3244 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3248 XPUSHu(DO_UTF8(argsv) ?
3249 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3261 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3263 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3265 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3267 (void) POPs; /* Ignore the argument value. */
3268 value = UNICODE_REPLACEMENT;
3274 SvUPGRADE(TARG,SVt_PV);
3276 if (value > 255 && !IN_BYTES) {
3277 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3278 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3279 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3281 (void)SvPOK_only(TARG);
3290 *tmps++ = (char)value;
3292 (void)SvPOK_only(TARG);
3293 if (PL_encoding && !IN_BYTES) {
3294 sv_recode_to_utf8(TARG, PL_encoding);
3296 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3297 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3301 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3302 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3317 const char *tmps = SvPV_const(left, len);
3319 if (DO_UTF8(left)) {
3320 /* If Unicode, try to downgrade.
3321 * If not possible, croak.
3322 * Yes, we made this up. */
3323 SV* const tsv = sv_2mortal(newSVsv(left));
3326 sv_utf8_downgrade(tsv, FALSE);
3327 tmps = SvPV_const(tsv, len);
3329 # ifdef USE_ITHREADS
3331 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3332 /* This should be threadsafe because in ithreads there is only
3333 * one thread per interpreter. If this would not be true,
3334 * we would need a mutex to protect this malloc. */
3335 PL_reentrant_buffer->_crypt_struct_buffer =
3336 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3337 #if defined(__GLIBC__) || defined(__EMX__)
3338 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3339 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3340 /* work around glibc-2.2.5 bug */
3341 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3345 # endif /* HAS_CRYPT_R */
3346 # endif /* USE_ITHREADS */
3348 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3350 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3356 "The crypt() function is unimplemented due to excessive paranoia.");
3366 const int op_type = PL_op->op_type;
3370 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3371 UTF8_IS_START(*s)) {
3372 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3376 utf8_to_uvchr(s, &ulen);
3377 if (op_type == OP_UCFIRST) {
3378 toTITLE_utf8(s, tmpbuf, &tculen);
3380 toLOWER_utf8(s, tmpbuf, &tculen);
3383 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3385 /* slen is the byte length of the whole SV.
3386 * ulen is the byte length of the original Unicode character
3387 * stored as UTF-8 at s.
3388 * tculen is the byte length of the freshly titlecased (or
3389 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3390 * We first set the result to be the titlecased (/lowercased)
3391 * character, and then append the rest of the SV data. */
3392 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3394 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3399 s = (U8*)SvPV_force_nomg(sv, slen);
3400 Copy(tmpbuf, s, tculen, U8);
3405 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3407 SvUTF8_off(TARG); /* decontaminate */
3408 sv_setsv_nomg(TARG, sv);
3412 s1 = (U8*)SvPV_force_nomg(sv, slen);
3414 if (IN_LOCALE_RUNTIME) {
3417 *s1 = (op_type == OP_UCFIRST)
3418 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3421 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3441 U8 tmpbuf[UTF8_MAXBYTES+1];
3443 s = (const U8*)SvPV_nomg_const(sv,len);
3445 SvUTF8_off(TARG); /* decontaminate */
3446 sv_setpvn(TARG, "", 0);
3450 STRLEN min = len + 1;
3452 SvUPGRADE(TARG, SVt_PV);
3454 (void)SvPOK_only(TARG);
3455 d = (U8*)SvPVX(TARG);
3458 STRLEN u = UTF8SKIP(s);
3460 toUPPER_utf8(s, tmpbuf, &ulen);
3461 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3462 /* If the eventually required minimum size outgrows
3463 * the available space, we need to grow. */
3464 const UV o = d - (U8*)SvPVX_const(TARG);
3466 /* If someone uppercases one million U+03B0s we
3467 * SvGROW() one million times. Or we could try
3468 * guessing how much to allocate without allocating
3469 * too much. Such is life. */
3471 d = (U8*)SvPVX(TARG) + o;
3473 Copy(tmpbuf, d, ulen, U8);
3479 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3485 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3487 SvUTF8_off(TARG); /* decontaminate */
3488 sv_setsv_nomg(TARG, sv);
3492 s = (U8*)SvPV_force_nomg(sv, len);
3494 register const U8 *send = s + len;
3496 if (IN_LOCALE_RUNTIME) {
3499 for (; s < send; s++)
3500 *s = toUPPER_LC(*s);
3503 for (; s < send; s++)
3525 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3527 s = (const U8*)SvPV_nomg_const(sv,len);
3529 SvUTF8_off(TARG); /* decontaminate */
3530 sv_setpvn(TARG, "", 0);
3534 STRLEN min = len + 1;
3536 SvUPGRADE(TARG, SVt_PV);
3538 (void)SvPOK_only(TARG);
3539 d = (U8*)SvPVX(TARG);
3542 const STRLEN u = UTF8SKIP(s);
3543 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3545 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3546 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3548 * Now if the sigma is NOT followed by
3549 * /$ignorable_sequence$cased_letter/;
3550 * and it IS preceded by
3551 * /$cased_letter$ignorable_sequence/;
3552 * where $ignorable_sequence is
3553 * [\x{2010}\x{AD}\p{Mn}]*
3554 * and $cased_letter is
3555 * [\p{Ll}\p{Lo}\p{Lt}]
3556 * then it should be mapped to 0x03C2,
3557 * (GREEK SMALL LETTER FINAL SIGMA),
3558 * instead of staying 0x03A3.
3559 * "should be": in other words,
3560 * this is not implemented yet.
3561 * See lib/unicore/SpecialCasing.txt.
3564 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3565 /* If the eventually required minimum size outgrows
3566 * the available space, we need to grow. */
3567 const UV o = d - (U8*)SvPVX_const(TARG);
3569 /* If someone lowercases one million U+0130s we
3570 * SvGROW() one million times. Or we could try
3571 * guessing how much to allocate without allocating.
3572 * too much. Such is life. */
3574 d = (U8*)SvPVX(TARG) + o;
3576 Copy(tmpbuf, d, ulen, U8);
3582 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3588 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3590 SvUTF8_off(TARG); /* decontaminate */
3591 sv_setsv_nomg(TARG, sv);
3596 s = (U8*)SvPV_force_nomg(sv, len);
3598 register const U8 * const send = s + len;
3600 if (IN_LOCALE_RUNTIME) {
3603 for (; s < send; s++)
3604 *s = toLOWER_LC(*s);
3607 for (; s < send; s++)
3619 SV * const sv = TOPs;
3621 register const char *s = SvPV_const(sv,len);
3623 SvUTF8_off(TARG); /* decontaminate */
3626 SvUPGRADE(TARG, SVt_PV);
3627 SvGROW(TARG, (len * 2) + 1);
3631 if (UTF8_IS_CONTINUED(*s)) {
3632 STRLEN ulen = UTF8SKIP(s);
3656 SvCUR_set(TARG, d - SvPVX_const(TARG));
3657 (void)SvPOK_only_UTF8(TARG);
3660 sv_setpvn(TARG, s, len);
3662 if (SvSMAGICAL(TARG))
3671 dSP; dMARK; dORIGMARK;
3672 register AV* const av = (AV*)POPs;
3673 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3675 if (SvTYPE(av) == SVt_PVAV) {
3676 const I32 arybase = PL_curcop->cop_arybase;
3677 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3680 for (svp = MARK + 1; svp <= SP; svp++) {
3681 const I32 elem = SvIVx(*svp);
3685 if (max > AvMAX(av))
3688 while (++MARK <= SP) {
3690 I32 elem = SvIVx(*MARK);
3694 svp = av_fetch(av, elem, lval);
3696 if (!svp || *svp == &PL_sv_undef)
3697 DIE(aTHX_ PL_no_aelem, elem);
3698 if (PL_op->op_private & OPpLVAL_INTRO)
3699 save_aelem(av, elem, svp);
3701 *MARK = svp ? *svp : &PL_sv_undef;
3704 if (GIMME != G_ARRAY) {
3706 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3712 /* Associative arrays. */
3717 HV * const hash = (HV*)POPs;
3719 const I32 gimme = GIMME_V;
3722 /* might clobber stack_sp */
3723 entry = hv_iternext(hash);
3728 SV* const sv = hv_iterkeysv(entry);
3729 PUSHs(sv); /* won't clobber stack_sp */
3730 if (gimme == G_ARRAY) {
3733 /* might clobber stack_sp */
3734 val = hv_iterval(hash, entry);
3739 else if (gimme == G_SCALAR)
3748 const I32 gimme = GIMME_V;
3749 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3751 if (PL_op->op_private & OPpSLICE) {
3753 HV * const hv = (HV*)POPs;
3754 const U32 hvtype = SvTYPE(hv);
3755 if (hvtype == SVt_PVHV) { /* hash element */
3756 while (++MARK <= SP) {
3757 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3758 *MARK = sv ? sv : &PL_sv_undef;
3761 else if (hvtype == SVt_PVAV) { /* array element */
3762 if (PL_op->op_flags & OPf_SPECIAL) {
3763 while (++MARK <= SP) {
3764 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3765 *MARK = sv ? sv : &PL_sv_undef;
3770 DIE(aTHX_ "Not a HASH reference");
3773 else if (gimme == G_SCALAR) {
3778 *++MARK = &PL_sv_undef;
3784 HV * const hv = (HV*)POPs;
3786 if (SvTYPE(hv) == SVt_PVHV)
3787 sv = hv_delete_ent(hv, keysv, discard, 0);
3788 else if (SvTYPE(hv) == SVt_PVAV) {
3789 if (PL_op->op_flags & OPf_SPECIAL)
3790 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3792 DIE(aTHX_ "panic: avhv_delete no longer supported");
3795 DIE(aTHX_ "Not a HASH reference");
3810 if (PL_op->op_private & OPpEXISTS_SUB) {
3812 SV * const sv = POPs;
3813 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3816 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3822 if (SvTYPE(hv) == SVt_PVHV) {
3823 if (hv_exists_ent(hv, tmpsv, 0))
3826 else if (SvTYPE(hv) == SVt_PVAV) {
3827 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3828 if (av_exists((AV*)hv, SvIV(tmpsv)))
3833 DIE(aTHX_ "Not a HASH reference");
3840 dSP; dMARK; dORIGMARK;
3841 register HV * const hv = (HV*)POPs;
3842 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3843 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3844 bool other_magic = FALSE;
3850 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3851 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3852 /* Try to preserve the existenceness of a tied hash
3853 * element by using EXISTS and DELETE if possible.
3854 * Fallback to FETCH and STORE otherwise */
3855 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3856 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3857 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3860 while (++MARK <= SP) {
3861 SV * const keysv = *MARK;
3864 bool preeminent = FALSE;
3867 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3868 hv_exists_ent(hv, keysv, 0);
3871 he = hv_fetch_ent(hv, keysv, lval, 0);
3872 svp = he ? &HeVAL(he) : 0;
3875 if (!svp || *svp == &PL_sv_undef) {
3876 DIE(aTHX_ PL_no_helem_sv, keysv);
3880 save_helem(hv, keysv, svp);
3883 const char *key = SvPV_const(keysv, keylen);
3884 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3888 *MARK = svp ? *svp : &PL_sv_undef;
3890 if (GIMME != G_ARRAY) {
3892 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3898 /* List operators. */
3903 if (GIMME != G_ARRAY) {
3905 *MARK = *SP; /* unwanted list, return last item */
3907 *MARK = &PL_sv_undef;
3916 SV ** const lastrelem = PL_stack_sp;
3917 SV ** const lastlelem = PL_stack_base + POPMARK;
3918 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3919 register SV ** const firstrelem = lastlelem + 1;
3920 const I32 arybase = PL_curcop->cop_arybase;
3921 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3923 register const I32 max = lastrelem - lastlelem;
3924 register SV **lelem;
3926 if (GIMME != G_ARRAY) {
3927 I32 ix = SvIVx(*lastlelem);
3932 if (ix < 0 || ix >= max)
3933 *firstlelem = &PL_sv_undef;
3935 *firstlelem = firstrelem[ix];
3941 SP = firstlelem - 1;
3945 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3946 I32 ix = SvIVx(*lelem);
3951 if (ix < 0 || ix >= max)
3952 *lelem = &PL_sv_undef;
3954 is_something_there = TRUE;
3955 if (!(*lelem = firstrelem[ix]))
3956 *lelem = &PL_sv_undef;
3959 if (is_something_there)
3962 SP = firstlelem - 1;
3968 dSP; dMARK; dORIGMARK;
3969 const I32 items = SP - MARK;
3970 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3971 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3978 dSP; dMARK; dORIGMARK;
3979 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3982 SV * const key = *++MARK;
3983 SV * const val = NEWSV(46, 0);
3985 sv_setsv(val, *++MARK);
3986 else if (ckWARN(WARN_MISC))
3987 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3988 (void)hv_store_ent(hv,key,val,0);
3997 dVAR; dSP; dMARK; dORIGMARK;
3998 register AV *ary = (AV*)*++MARK;
4002 register I32 offset;
4003 register I32 length;
4008 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4011 *MARK-- = SvTIED_obj((SV*)ary, mg);
4015 call_method("SPLICE",GIMME_V);
4024 offset = i = SvIVx(*MARK);
4026 offset += AvFILLp(ary) + 1;
4028 offset -= PL_curcop->cop_arybase;
4030 DIE(aTHX_ PL_no_aelem, i);
4032 length = SvIVx(*MARK++);
4034 length += AvFILLp(ary) - offset + 1;
4040 length = AvMAX(ary) + 1; /* close enough to infinity */
4044 length = AvMAX(ary) + 1;
4046 if (offset > AvFILLp(ary) + 1) {
4047 if (ckWARN(WARN_MISC))
4048 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4049 offset = AvFILLp(ary) + 1;
4051 after = AvFILLp(ary) + 1 - (offset + length);
4052 if (after < 0) { /* not that much array */
4053 length += after; /* offset+length now in array */
4059 /* At this point, MARK .. SP-1 is our new LIST */
4062 diff = newlen - length;
4063 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4066 /* make new elements SVs now: avoid problems if they're from the array */
4067 for (dst = MARK, i = newlen; i; i--) {
4068 SV * const h = *dst;
4069 *dst++ = newSVsv(h);
4072 if (diff < 0) { /* shrinking the area */
4074 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4075 Copy(MARK, tmparyval, newlen, SV*);
4078 MARK = ORIGMARK + 1;
4079 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4080 MEXTEND(MARK, length);
4081 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4083 EXTEND_MORTAL(length);
4084 for (i = length, dst = MARK; i; i--) {
4085 sv_2mortal(*dst); /* free them eventualy */
4092 *MARK = AvARRAY(ary)[offset+length-1];
4095 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4096 SvREFCNT_dec(*dst++); /* free them now */
4099 AvFILLp(ary) += diff;
4101 /* pull up or down? */
4103 if (offset < after) { /* easier to pull up */
4104 if (offset) { /* esp. if nothing to pull */
4105 src = &AvARRAY(ary)[offset-1];
4106 dst = src - diff; /* diff is negative */
4107 for (i = offset; i > 0; i--) /* can't trust Copy */
4111 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4115 if (after) { /* anything to pull down? */
4116 src = AvARRAY(ary) + offset + length;
4117 dst = src + diff; /* diff is negative */
4118 Move(src, dst, after, SV*);
4120 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4121 /* avoid later double free */
4125 dst[--i] = &PL_sv_undef;
4128 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4129 Safefree(tmparyval);
4132 else { /* no, expanding (or same) */
4134 Newx(tmparyval, length, SV*); /* so remember deletion */
4135 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4138 if (diff > 0) { /* expanding */
4140 /* push up or down? */
4142 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4146 Move(src, dst, offset, SV*);
4148 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4150 AvFILLp(ary) += diff;
4153 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4154 av_extend(ary, AvFILLp(ary) + diff);
4155 AvFILLp(ary) += diff;
4158 dst = AvARRAY(ary) + AvFILLp(ary);
4160 for (i = after; i; i--) {
4168 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4171 MARK = ORIGMARK + 1;
4172 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4174 Copy(tmparyval, MARK, length, SV*);
4176 EXTEND_MORTAL(length);
4177 for (i = length, dst = MARK; i; i--) {
4178 sv_2mortal(*dst); /* free them eventualy */
4182 Safefree(tmparyval);
4186 else if (length--) {
4187 *MARK = tmparyval[length];
4190 while (length-- > 0)
4191 SvREFCNT_dec(tmparyval[length]);
4193 Safefree(tmparyval);
4196 *MARK = &PL_sv_undef;
4204 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4205 register AV *ary = (AV*)*++MARK;
4206 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4209 *MARK-- = SvTIED_obj((SV*)ary, mg);
4213 call_method("PUSH",G_SCALAR|G_DISCARD);
4217 PUSHi( AvFILL(ary) + 1 );
4220 for (++MARK; MARK <= SP; MARK++) {
4221 SV * const sv = NEWSV(51, 0);
4223 sv_setsv(sv, *MARK);
4224 av_store(ary, AvFILLp(ary)+1, sv);
4227 PUSHi( AvFILLp(ary) + 1 );
4235 AV * const av = (AV*)POPs;
4236 SV * const sv = av_pop(av);
4238 (void)sv_2mortal(sv);
4246 AV * const av = (AV*)POPs;
4247 SV * const sv = av_shift(av);
4252 (void)sv_2mortal(sv);
4259 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4260 register AV *ary = (AV*)*++MARK;
4261 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4264 *MARK-- = SvTIED_obj((SV*)ary, mg);
4268 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4274 av_unshift(ary, SP - MARK);
4276 SV * const sv = newSVsv(*++MARK);
4277 (void)av_store(ary, i++, sv);
4281 PUSHi( AvFILL(ary) + 1 );
4288 SV ** const oldsp = SP;
4290 if (GIMME == G_ARRAY) {
4293 register SV * const tmp = *MARK;
4297 /* safe as long as stack cannot get extended in the above */
4302 register char *down;
4308 SvUTF8_off(TARG); /* decontaminate */
4310 do_join(TARG, &PL_sv_no, MARK, SP);
4312 sv_setsv(TARG, (SP > MARK)
4314 : (padoff_du = find_rundefsvoffset(),
4315 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4316 ? DEFSV : PAD_SVl(padoff_du)));
4317 up = SvPV_force(TARG, len);
4319 if (DO_UTF8(TARG)) { /* first reverse each character */
4320 U8* s = (U8*)SvPVX(TARG);
4321 const U8* send = (U8*)(s + len);
4323 if (UTF8_IS_INVARIANT(*s)) {
4328 if (!utf8_to_uvchr(s, 0))
4332 down = (char*)(s - 1);
4333 /* reverse this character */
4337 *down-- = (char)tmp;
4343 down = SvPVX(TARG) + len - 1;
4347 *down-- = (char)tmp;
4349 (void)SvPOK_only_UTF8(TARG);
4361 register IV limit = POPi; /* note, negative is forever */
4362 SV * const sv = POPs;
4364 register const char *s = SvPV_const(sv, len);
4365 const bool do_utf8 = DO_UTF8(sv);
4366 const char *strend = s + len;
4368 register REGEXP *rx;
4370 register const char *m;
4372 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4373 I32 maxiters = slen + 10;
4375 const I32 origlimit = limit;
4378 const I32 gimme = GIMME_V;
4379 const I32 oldsave = PL_savestack_ix;
4380 I32 make_mortal = 1;
4382 MAGIC *mg = (MAGIC *) NULL;
4385 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4390 DIE(aTHX_ "panic: pp_split");
4393 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4394 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4396 RX_MATCH_UTF8_set(rx, do_utf8);
4398 if (pm->op_pmreplroot) {
4400 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4402 ary = GvAVn((GV*)pm->op_pmreplroot);
4405 else if (gimme != G_ARRAY)
4406 ary = GvAVn(PL_defgv);
4409 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4415 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4417 XPUSHs(SvTIED_obj((SV*)ary, mg));
4424 for (i = AvFILLp(ary); i >= 0; i--)
4425 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4427 /* temporarily switch stacks */
4428 SAVESWITCHSTACK(PL_curstack, ary);
4432 base = SP - PL_stack_base;
4434 if (pm->op_pmflags & PMf_SKIPWHITE) {
4435 if (pm->op_pmflags & PMf_LOCALE) {
4436 while (isSPACE_LC(*s))
4444 if (pm->op_pmflags & PMf_MULTILINE) {
4449 limit = maxiters + 2;
4450 if (pm->op_pmflags & PMf_WHITE) {
4453 while (m < strend &&
4454 !((pm->op_pmflags & PMf_LOCALE)
4455 ? isSPACE_LC(*m) : isSPACE(*m)))
4460 dstr = newSVpvn(s, m-s);
4464 (void)SvUTF8_on(dstr);
4468 while (s < strend &&
4469 ((pm->op_pmflags & PMf_LOCALE)
4470 ? isSPACE_LC(*s) : isSPACE(*s)))
4474 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4476 for (m = s; m < strend && *m != '\n'; m++)
4481 dstr = newSVpvn(s, m-s);
4485 (void)SvUTF8_on(dstr);
4490 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4491 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4492 && (rx->reganch & ROPT_CHECK_ALL)
4493 && !(rx->reganch & ROPT_ANCH)) {
4494 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4495 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4498 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4499 const char c = *SvPV_nolen_const(csv);
4501 for (m = s; m < strend && *m != c; m++)
4505 dstr = newSVpvn(s, m-s);
4509 (void)SvUTF8_on(dstr);
4511 /* The rx->minlen is in characters but we want to step
4512 * s ahead by bytes. */
4514 s = (char*)utf8_hop((U8*)m, len);
4516 s = m + len; /* Fake \n at the end */
4520 while (s < strend && --limit &&
4521 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4522 csv, multiline ? FBMrf_MULTILINE : 0)) )
4524 dstr = newSVpvn(s, m-s);
4528 (void)SvUTF8_on(dstr);
4530 /* The rx->minlen is in characters but we want to step
4531 * s ahead by bytes. */
4533 s = (char*)utf8_hop((U8*)m, len);
4535 s = m + len; /* Fake \n at the end */
4540 maxiters += slen * rx->nparens;
4541 while (s < strend && --limit)
4545 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4548 if (rex_return == 0)
4550 TAINT_IF(RX_MATCH_TAINTED(rx));
4551 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4556 strend = s + (strend - m);
4558 m = rx->startp[0] + orig;
4559 dstr = newSVpvn(s, m-s);
4563 (void)SvUTF8_on(dstr);
4567 for (i = 1; i <= (I32)rx->nparens; i++) {
4568 s = rx->startp[i] + orig;
4569 m = rx->endp[i] + orig;
4571 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4572 parens that didn't match -- they should be set to
4573 undef, not the empty string */
4574 if (m >= orig && s >= orig) {
4575 dstr = newSVpvn(s, m-s);
4578 dstr = &PL_sv_undef; /* undef, not "" */
4582 (void)SvUTF8_on(dstr);
4586 s = rx->endp[0] + orig;
4590 iters = (SP - PL_stack_base) - base;
4591 if (iters > maxiters)
4592 DIE(aTHX_ "Split loop");
4594 /* keep field after final delim? */
4595 if (s < strend || (iters && origlimit)) {
4596 const STRLEN l = strend - s;
4597 dstr = newSVpvn(s, l);
4601 (void)SvUTF8_on(dstr);
4605 else if (!origlimit) {
4606 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4607 if (TOPs && !make_mortal)
4610 *SP-- = &PL_sv_undef;
4615 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4619 if (SvSMAGICAL(ary)) {
4624 if (gimme == G_ARRAY) {
4626 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4634 call_method("PUSH",G_SCALAR|G_DISCARD);
4637 if (gimme == G_ARRAY) {
4639 /* EXTEND should not be needed - we just popped them */
4641 for (i=0; i < iters; i++) {
4642 SV **svp = av_fetch(ary, i, FALSE);
4643 PUSHs((svp) ? *svp : &PL_sv_undef);
4650 if (gimme == G_ARRAY)
4665 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4666 || SvTYPE(retsv) == SVt_PVCV) {
4667 retsv = refto(retsv);
4674 PP(unimplemented_op)
4676 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4682 * c-indentation-style: bsd
4684 * indent-tabs-mode: t
4687 * ex: set ts=8 sts=4 sw=4 noet: