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, FALSE, SVt_PVGV);
196 && (!is_gv_magical_sv(sv,0)
197 || !(sv = (SV*)gv_fetchsv(sv, TRUE, 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, TRUE, 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)) {
242 if (PL_op->op_flags & OPf_REF ||
243 PL_op->op_private & HINT_STRICT_REFS)
244 DIE(aTHX_ PL_no_usym, "a SCALAR");
245 if (ckWARN(WARN_UNINITIALIZED))
249 if ((PL_op->op_flags & OPf_SPECIAL) &&
250 !(PL_op->op_flags & OPf_MOD))
252 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
254 && (!is_gv_magical_sv(sv, 0)
255 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
261 if (PL_op->op_private & HINT_STRICT_REFS)
262 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
263 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
268 if (PL_op->op_flags & OPf_MOD) {
269 if (PL_op->op_private & OPpLVAL_INTRO) {
270 if (cUNOP->op_first->op_type == OP_NULL)
271 sv = save_scalar((GV*)TOPs);
273 sv = save_scalar(gv);
275 Perl_croak(aTHX_ PL_no_localize_ref);
277 else if (PL_op->op_private & OPpDEREF)
278 vivify_ref(sv, PL_op->op_private & OPpDEREF);
287 AV * const av = (AV*)TOPs;
288 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
291 sv_upgrade(*sv, SVt_PVMG);
292 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
300 dSP; dTARGET; dPOPss;
302 if (PL_op->op_flags & OPf_MOD || LVRET) {
303 if (SvTYPE(TARG) < SVt_PVLV) {
304 sv_upgrade(TARG, SVt_PVLV);
305 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
309 if (LvTARG(TARG) != sv) {
311 SvREFCNT_dec(LvTARG(TARG));
312 LvTARG(TARG) = SvREFCNT_inc(sv);
314 PUSHs(TARG); /* no SvSETMAGIC */
318 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
319 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
320 if (mg && mg->mg_len >= 0) {
324 PUSHi(i + PL_curcop->cop_arybase);
338 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
339 /* (But not in defined().) */
340 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
343 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
344 if ((PL_op->op_private & OPpLVAL_INTRO)) {
345 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
348 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
352 cv = (CV*)&PL_sv_undef;
366 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
367 const char * const s = SvPVX_const(TOPs);
368 if (strnEQ(s, "CORE::", 6)) {
369 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
370 if (code < 0) { /* Overridable. */
371 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
372 int i = 0, n = 0, seen_question = 0;
374 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
376 if (code == -KEY_chop || code == -KEY_chomp
377 || code == -KEY_exec || code == -KEY_system)
379 while (i < MAXO) { /* The slow way. */
380 if (strEQ(s + 6, PL_op_name[i])
381 || strEQ(s + 6, PL_op_desc[i]))
387 goto nonesuch; /* Should not happen... */
389 oa = PL_opargs[i] >> OASHIFT;
391 if (oa & OA_OPTIONAL && !seen_question) {
395 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
396 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
397 /* But globs are already references (kinda) */
398 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
402 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
406 ret = sv_2mortal(newSVpvn(str, n - 1));
408 else if (code) /* Non-Overridable */
410 else { /* None such */
412 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
416 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
418 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
427 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
429 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
445 if (GIMME != G_ARRAY) {
449 *MARK = &PL_sv_undef;
450 *MARK = refto(*MARK);
454 EXTEND_MORTAL(SP - MARK);
456 *MARK = refto(*MARK);
461 S_refto(pTHX_ SV *sv)
465 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
468 if (!(sv = LvTARG(sv)))
471 (void)SvREFCNT_inc(sv);
473 else if (SvTYPE(sv) == SVt_PVAV) {
474 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
477 (void)SvREFCNT_inc(sv);
479 else if (SvPADTMP(sv) && !IS_PADGV(sv))
483 (void)SvREFCNT_inc(sv);
486 sv_upgrade(rv, SVt_RV);
496 SV * const sv = POPs;
501 if (!sv || !SvROK(sv))
504 pv = sv_reftype(SvRV(sv),TRUE);
505 PUSHp(pv, strlen(pv));
515 stash = CopSTASH(PL_curcop);
517 SV * const ssv = POPs;
521 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
522 Perl_croak(aTHX_ "Attempt to bless into a reference");
523 ptr = SvPV_const(ssv,len);
524 if (len == 0 && ckWARN(WARN_MISC))
525 Perl_warner(aTHX_ packWARN(WARN_MISC),
526 "Explicit blessing to '' (assuming package main)");
527 stash = gv_stashpvn(ptr, len, TRUE);
530 (void)sv_bless(TOPs, stash);
539 const char * const elem = SvPV_nolen_const(sv);
540 GV * const gv = (GV*)POPs;
541 SV * tmpRef = Nullsv;
545 /* elem will always be NUL terminated. */
546 const char * const second_letter = elem + 1;
549 if (strEQ(second_letter, "RRAY"))
550 tmpRef = (SV*)GvAV(gv);
553 if (strEQ(second_letter, "ODE"))
554 tmpRef = (SV*)GvCVu(gv);
557 if (strEQ(second_letter, "ILEHANDLE")) {
558 /* finally deprecated in 5.8.0 */
559 deprecate("*glob{FILEHANDLE}");
560 tmpRef = (SV*)GvIOp(gv);
563 if (strEQ(second_letter, "ORMAT"))
564 tmpRef = (SV*)GvFORM(gv);
567 if (strEQ(second_letter, "LOB"))
571 if (strEQ(second_letter, "ASH"))
572 tmpRef = (SV*)GvHV(gv);
575 if (*second_letter == 'O' && !elem[2])
576 tmpRef = (SV*)GvIOp(gv);
579 if (strEQ(second_letter, "AME"))
580 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
583 if (strEQ(second_letter, "ACKAGE")) {
584 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
585 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
589 if (strEQ(second_letter, "CALAR"))
604 /* Pattern matching */
609 register unsigned char *s;
612 register I32 *sfirst;
616 if (sv == PL_lastscream) {
622 SvSCREAM_off(PL_lastscream);
623 SvREFCNT_dec(PL_lastscream);
625 PL_lastscream = SvREFCNT_inc(sv);
628 s = (unsigned char*)(SvPV(sv, len));
632 if (pos > PL_maxscream) {
633 if (PL_maxscream < 0) {
634 PL_maxscream = pos + 80;
635 Newx(PL_screamfirst, 256, I32);
636 Newx(PL_screamnext, PL_maxscream, I32);
639 PL_maxscream = pos + pos / 4;
640 Renew(PL_screamnext, PL_maxscream, I32);
644 sfirst = PL_screamfirst;
645 snext = PL_screamnext;
647 if (!sfirst || !snext)
648 DIE(aTHX_ "do_study: out of memory");
650 for (ch = 256; ch; --ch)
655 register const I32 ch = s[pos];
657 snext[pos] = sfirst[ch] - pos;
664 /* piggyback on m//g magic */
665 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
674 if (PL_op->op_flags & OPf_STACKED)
676 else if (PL_op->op_private & OPpTARGET_MY)
682 TARG = sv_newmortal();
687 /* Lvalue operators. */
699 dSP; dMARK; dTARGET; dORIGMARK;
701 do_chop(TARG, *++MARK);
710 SETi(do_chomp(TOPs));
717 register I32 count = 0;
720 count += do_chomp(POPs);
730 if (!PL_op->op_private) {
739 SV_CHECK_THINKFIRST_COW_DROP(sv);
741 switch (SvTYPE(sv)) {
751 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
752 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
753 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
757 /* let user-undef'd sub keep its identity */
758 GV* const gv = CvGV((CV*)sv);
765 SvSetMagicSV(sv, &PL_sv_undef);
770 GvGP(sv) = gp_ref(gp);
771 GvSV(sv) = NEWSV(72,0);
772 GvLINE(sv) = CopLINE(PL_curcop);
778 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
780 SvPV_set(sv, Nullch);
793 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
794 DIE(aTHX_ PL_no_modify);
795 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
796 && SvIVX(TOPs) != IV_MIN)
798 SvIV_set(TOPs, SvIVX(TOPs) - 1);
799 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
810 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
811 DIE(aTHX_ PL_no_modify);
812 sv_setsv(TARG, TOPs);
813 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
814 && SvIVX(TOPs) != IV_MAX)
816 SvIV_set(TOPs, SvIVX(TOPs) + 1);
817 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
822 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
832 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
833 DIE(aTHX_ PL_no_modify);
834 sv_setsv(TARG, TOPs);
835 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
836 && SvIVX(TOPs) != IV_MIN)
838 SvIV_set(TOPs, SvIVX(TOPs) - 1);
839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
848 /* Ordinary operators. */
853 #ifdef PERL_PRESERVE_IVUV
856 tryAMAGICbin(pow,opASSIGN);
857 #ifdef PERL_PRESERVE_IVUV
858 /* For integer to integer power, we do the calculation by hand wherever
859 we're sure it is safe; otherwise we call pow() and try to convert to
860 integer afterwards. */
873 const IV iv = SvIVX(TOPs);
877 goto float_it; /* Can't do negative powers this way. */
881 baseuok = SvUOK(TOPm1s);
883 baseuv = SvUVX(TOPm1s);
885 const IV iv = SvIVX(TOPm1s);
888 baseuok = TRUE; /* effectively it's a UV now */
890 baseuv = -iv; /* abs, baseuok == false records sign */
893 /* now we have integer ** positive integer. */
896 /* foo & (foo - 1) is zero only for a power of 2. */
897 if (!(baseuv & (baseuv - 1))) {
898 /* We are raising power-of-2 to a positive integer.
899 The logic here will work for any base (even non-integer
900 bases) but it can be less accurate than
901 pow (base,power) or exp (power * log (base)) when the
902 intermediate values start to spill out of the mantissa.
903 With powers of 2 we know this can't happen.
904 And powers of 2 are the favourite thing for perl
905 programmers to notice ** not doing what they mean. */
907 NV base = baseuok ? baseuv : -(NV)baseuv;
912 while (power >>= 1) {
923 register unsigned int highbit = 8 * sizeof(UV);
924 register unsigned int diff = 8 * sizeof(UV);
927 if (baseuv >> highbit) {
931 /* we now have baseuv < 2 ** highbit */
932 if (power * highbit <= 8 * sizeof(UV)) {
933 /* result will definitely fit in UV, so use UV math
934 on same algorithm as above */
935 register UV result = 1;
936 register UV base = baseuv;
937 const bool odd_power = (bool)(power & 1);
941 while (power >>= 1) {
948 if (baseuok || !odd_power)
949 /* answer is positive */
951 else if (result <= (UV)IV_MAX)
952 /* answer negative, fits in IV */
954 else if (result == (UV)IV_MIN)
955 /* 2's complement assumption: special case IV_MIN */
958 /* answer negative, doesn't fit */
970 SETn( Perl_pow( left, right) );
971 #ifdef PERL_PRESERVE_IVUV
981 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
982 #ifdef PERL_PRESERVE_IVUV
985 /* Unless the left argument is integer in range we are going to have to
986 use NV maths. Hence only attempt to coerce the right argument if
987 we know the left is integer. */
988 /* Left operand is defined, so is it IV? */
991 bool auvok = SvUOK(TOPm1s);
992 bool buvok = SvUOK(TOPs);
993 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
994 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1001 alow = SvUVX(TOPm1s);
1003 const IV aiv = SvIVX(TOPm1s);
1006 auvok = TRUE; /* effectively it's a UV now */
1008 alow = -aiv; /* abs, auvok == false records sign */
1014 const IV biv = SvIVX(TOPs);
1017 buvok = TRUE; /* effectively it's a UV now */
1019 blow = -biv; /* abs, buvok == false records sign */
1023 /* If this does sign extension on unsigned it's time for plan B */
1024 ahigh = alow >> (4 * sizeof (UV));
1026 bhigh = blow >> (4 * sizeof (UV));
1028 if (ahigh && bhigh) {
1029 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1030 which is overflow. Drop to NVs below. */
1031 } else if (!ahigh && !bhigh) {
1032 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1033 so the unsigned multiply cannot overflow. */
1034 UV product = alow * blow;
1035 if (auvok == buvok) {
1036 /* -ve * -ve or +ve * +ve gives a +ve result. */
1040 } else if (product <= (UV)IV_MIN) {
1041 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1042 /* -ve result, which could overflow an IV */
1044 SETi( -(IV)product );
1046 } /* else drop to NVs below. */
1048 /* One operand is large, 1 small */
1051 /* swap the operands */
1053 bhigh = blow; /* bhigh now the temp var for the swap */
1057 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1058 multiplies can't overflow. shift can, add can, -ve can. */
1059 product_middle = ahigh * blow;
1060 if (!(product_middle & topmask)) {
1061 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1063 product_middle <<= (4 * sizeof (UV));
1064 product_low = alow * blow;
1066 /* as for pp_add, UV + something mustn't get smaller.
1067 IIRC ANSI mandates this wrapping *behaviour* for
1068 unsigned whatever the actual representation*/
1069 product_low += product_middle;
1070 if (product_low >= product_middle) {
1071 /* didn't overflow */
1072 if (auvok == buvok) {
1073 /* -ve * -ve or +ve * +ve gives a +ve result. */
1075 SETu( product_low );
1077 } else if (product_low <= (UV)IV_MIN) {
1078 /* 2s complement assumption again */
1079 /* -ve result, which could overflow an IV */
1081 SETi( -(IV)product_low );
1083 } /* else drop to NVs below. */
1085 } /* product_middle too large */
1086 } /* ahigh && bhigh */
1087 } /* SvIOK(TOPm1s) */
1092 SETn( left * right );
1099 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1100 /* Only try to do UV divide first
1101 if ((SLOPPYDIVIDE is true) or
1102 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1104 The assumption is that it is better to use floating point divide
1105 whenever possible, only doing integer divide first if we can't be sure.
1106 If NV_PRESERVES_UV is true then we know at compile time that no UV
1107 can be too large to preserve, so don't need to compile the code to
1108 test the size of UVs. */
1111 # define PERL_TRY_UV_DIVIDE
1112 /* ensure that 20./5. == 4. */
1114 # ifdef PERL_PRESERVE_IVUV
1115 # ifndef NV_PRESERVES_UV
1116 # define PERL_TRY_UV_DIVIDE
1121 #ifdef PERL_TRY_UV_DIVIDE
1124 SvIV_please(TOPm1s);
1125 if (SvIOK(TOPm1s)) {
1126 bool left_non_neg = SvUOK(TOPm1s);
1127 bool right_non_neg = SvUOK(TOPs);
1131 if (right_non_neg) {
1132 right = SvUVX(TOPs);
1135 const IV biv = SvIVX(TOPs);
1138 right_non_neg = TRUE; /* effectively it's a UV now */
1144 /* historically undef()/0 gives a "Use of uninitialized value"
1145 warning before dieing, hence this test goes here.
1146 If it were immediately before the second SvIV_please, then
1147 DIE() would be invoked before left was even inspected, so
1148 no inpsection would give no warning. */
1150 DIE(aTHX_ "Illegal division by zero");
1153 left = SvUVX(TOPm1s);
1156 const IV aiv = SvIVX(TOPm1s);
1159 left_non_neg = TRUE; /* effectively it's a UV now */
1168 /* For sloppy divide we always attempt integer division. */
1170 /* Otherwise we only attempt it if either or both operands
1171 would not be preserved by an NV. If both fit in NVs
1172 we fall through to the NV divide code below. However,
1173 as left >= right to ensure integer result here, we know that
1174 we can skip the test on the right operand - right big
1175 enough not to be preserved can't get here unless left is
1178 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1181 /* Integer division can't overflow, but it can be imprecise. */
1182 const UV result = left / right;
1183 if (result * right == left) {
1184 SP--; /* result is valid */
1185 if (left_non_neg == right_non_neg) {
1186 /* signs identical, result is positive. */
1190 /* 2s complement assumption */
1191 if (result <= (UV)IV_MIN)
1192 SETi( -(IV)result );
1194 /* It's exact but too negative for IV. */
1195 SETn( -(NV)result );
1198 } /* tried integer divide but it was not an integer result */
1199 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1200 } /* left wasn't SvIOK */
1201 } /* right wasn't SvIOK */
1202 #endif /* PERL_TRY_UV_DIVIDE */
1206 DIE(aTHX_ "Illegal division by zero");
1207 PUSHn( left / right );
1214 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1218 bool left_neg = FALSE;
1219 bool right_neg = FALSE;
1220 bool use_double = FALSE;
1221 bool dright_valid = FALSE;
1227 right_neg = !SvUOK(TOPs);
1229 right = SvUVX(POPs);
1231 const IV biv = SvIVX(POPs);
1234 right_neg = FALSE; /* effectively it's a UV now */
1242 right_neg = dright < 0;
1245 if (dright < UV_MAX_P1) {
1246 right = U_V(dright);
1247 dright_valid = TRUE; /* In case we need to use double below. */
1253 /* At this point use_double is only true if right is out of range for
1254 a UV. In range NV has been rounded down to nearest UV and
1255 use_double false. */
1257 if (!use_double && SvIOK(TOPs)) {
1259 left_neg = !SvUOK(TOPs);
1263 const IV aiv = SvIVX(POPs);
1266 left_neg = FALSE; /* effectively it's a UV now */
1275 left_neg = dleft < 0;
1279 /* This should be exactly the 5.6 behaviour - if left and right are
1280 both in range for UV then use U_V() rather than floor. */
1282 if (dleft < UV_MAX_P1) {
1283 /* right was in range, so is dleft, so use UVs not double.
1287 /* left is out of range for UV, right was in range, so promote
1288 right (back) to double. */
1290 /* The +0.5 is used in 5.6 even though it is not strictly
1291 consistent with the implicit +0 floor in the U_V()
1292 inside the #if 1. */
1293 dleft = Perl_floor(dleft + 0.5);
1296 dright = Perl_floor(dright + 0.5);
1306 DIE(aTHX_ "Illegal modulus zero");
1308 dans = Perl_fmod(dleft, dright);
1309 if ((left_neg != right_neg) && dans)
1310 dans = dright - dans;
1313 sv_setnv(TARG, dans);
1319 DIE(aTHX_ "Illegal modulus zero");
1322 if ((left_neg != right_neg) && ans)
1325 /* XXX may warn: unary minus operator applied to unsigned type */
1326 /* could change -foo to be (~foo)+1 instead */
1327 if (ans <= ~((UV)IV_MAX)+1)
1328 sv_setiv(TARG, ~ans+1);
1330 sv_setnv(TARG, -(NV)ans);
1333 sv_setuv(TARG, ans);
1342 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1349 const UV uv = SvUV(sv);
1351 count = IV_MAX; /* The best we can do? */
1355 const IV iv = SvIV(sv);
1362 else if (SvNOKp(sv)) {
1363 const NV nv = SvNV(sv);
1371 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1373 static const char oom_list_extend[] = "Out of memory during list extend";
1374 const I32 items = SP - MARK;
1375 const I32 max = items * count;
1377 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1378 /* Did the max computation overflow? */
1379 if (items > 0 && max > 0 && (max < items || max < count))
1380 Perl_croak(aTHX_ oom_list_extend);
1385 /* This code was intended to fix 20010809.028:
1388 for (($x =~ /./g) x 2) {
1389 print chop; # "abcdabcd" expected as output.
1392 * but that change (#11635) broke this code:
1394 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1396 * I can't think of a better fix that doesn't introduce
1397 * an efficiency hit by copying the SVs. The stack isn't
1398 * refcounted, and mortalisation obviously doesn't
1399 * Do The Right Thing when the stack has more than
1400 * one pointer to the same mortal value.
1404 *SP = sv_2mortal(newSVsv(*SP));
1414 repeatcpy((char*)(MARK + items), (char*)MARK,
1415 items * sizeof(SV*), count - 1);
1418 else if (count <= 0)
1421 else { /* Note: mark already snarfed by pp_list */
1422 SV * const tmpstr = POPs;
1425 static const char oom_string_extend[] =
1426 "Out of memory during string extend";
1428 SvSetSV(TARG, tmpstr);
1429 SvPV_force(TARG, len);
1430 isutf = DO_UTF8(TARG);
1435 STRLEN max = (UV)count * len;
1436 if (len > ((MEM_SIZE)~0)/count)
1437 Perl_croak(aTHX_ oom_string_extend);
1438 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1439 SvGROW(TARG, max + 1);
1440 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1441 SvCUR_set(TARG, SvCUR(TARG) * count);
1443 *SvEND(TARG) = '\0';
1446 (void)SvPOK_only_UTF8(TARG);
1448 (void)SvPOK_only(TARG);
1450 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1451 /* The parser saw this as a list repeat, and there
1452 are probably several items on the stack. But we're
1453 in scalar context, and there's no pp_list to save us
1454 now. So drop the rest of the items -- robin@kitsite.com
1467 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1468 useleft = USE_LEFT(TOPm1s);
1469 #ifdef PERL_PRESERVE_IVUV
1470 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1471 "bad things" happen if you rely on signed integers wrapping. */
1474 /* Unless the left argument is integer in range we are going to have to
1475 use NV maths. Hence only attempt to coerce the right argument if
1476 we know the left is integer. */
1477 register UV auv = 0;
1483 a_valid = auvok = 1;
1484 /* left operand is undef, treat as zero. */
1486 /* Left operand is defined, so is it IV? */
1487 SvIV_please(TOPm1s);
1488 if (SvIOK(TOPm1s)) {
1489 if ((auvok = SvUOK(TOPm1s)))
1490 auv = SvUVX(TOPm1s);
1492 register const IV aiv = SvIVX(TOPm1s);
1495 auvok = 1; /* Now acting as a sign flag. */
1496 } else { /* 2s complement assumption for IV_MIN */
1504 bool result_good = 0;
1507 bool buvok = SvUOK(TOPs);
1512 register const IV biv = SvIVX(TOPs);
1519 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1520 else "IV" now, independent of how it came in.
1521 if a, b represents positive, A, B negative, a maps to -A etc
1526 all UV maths. negate result if A negative.
1527 subtract if signs same, add if signs differ. */
1529 if (auvok ^ buvok) {
1538 /* Must get smaller */
1543 if (result <= buv) {
1544 /* result really should be -(auv-buv). as its negation
1545 of true value, need to swap our result flag */
1557 if (result <= (UV)IV_MIN)
1558 SETi( -(IV)result );
1560 /* result valid, but out of range for IV. */
1561 SETn( -(NV)result );
1565 } /* Overflow, drop through to NVs. */
1569 useleft = USE_LEFT(TOPm1s);
1573 /* left operand is undef, treat as zero - value */
1577 SETn( TOPn - value );
1584 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1586 const IV shift = POPi;
1587 if (PL_op->op_private & HINT_INTEGER) {
1601 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1603 const IV shift = POPi;
1604 if (PL_op->op_private & HINT_INTEGER) {
1618 dSP; tryAMAGICbinSET(lt,0);
1619 #ifdef PERL_PRESERVE_IVUV
1622 SvIV_please(TOPm1s);
1623 if (SvIOK(TOPm1s)) {
1624 bool auvok = SvUOK(TOPm1s);
1625 bool buvok = SvUOK(TOPs);
1627 if (!auvok && !buvok) { /* ## IV < IV ## */
1628 const IV aiv = SvIVX(TOPm1s);
1629 const IV biv = SvIVX(TOPs);
1632 SETs(boolSV(aiv < biv));
1635 if (auvok && buvok) { /* ## UV < UV ## */
1636 const UV auv = SvUVX(TOPm1s);
1637 const UV buv = SvUVX(TOPs);
1640 SETs(boolSV(auv < buv));
1643 if (auvok) { /* ## UV < IV ## */
1645 const IV biv = SvIVX(TOPs);
1648 /* As (a) is a UV, it's >=0, so it cannot be < */
1653 SETs(boolSV(auv < (UV)biv));
1656 { /* ## IV < UV ## */
1657 const IV aiv = SvIVX(TOPm1s);
1661 /* As (b) is a UV, it's >=0, so it must be < */
1668 SETs(boolSV((UV)aiv < buv));
1674 #ifndef NV_PRESERVES_UV
1675 #ifdef PERL_PRESERVE_IVUV
1678 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1680 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1686 SETs(boolSV(TOPn < value));
1693 dSP; tryAMAGICbinSET(gt,0);
1694 #ifdef PERL_PRESERVE_IVUV
1697 SvIV_please(TOPm1s);
1698 if (SvIOK(TOPm1s)) {
1699 bool auvok = SvUOK(TOPm1s);
1700 bool buvok = SvUOK(TOPs);
1702 if (!auvok && !buvok) { /* ## IV > IV ## */
1703 const IV aiv = SvIVX(TOPm1s);
1704 const IV biv = SvIVX(TOPs);
1707 SETs(boolSV(aiv > biv));
1710 if (auvok && buvok) { /* ## UV > UV ## */
1711 const UV auv = SvUVX(TOPm1s);
1712 const UV buv = SvUVX(TOPs);
1715 SETs(boolSV(auv > buv));
1718 if (auvok) { /* ## UV > IV ## */
1720 const IV biv = SvIVX(TOPs);
1724 /* As (a) is a UV, it's >=0, so it must be > */
1729 SETs(boolSV(auv > (UV)biv));
1732 { /* ## IV > UV ## */
1733 const IV aiv = SvIVX(TOPm1s);
1737 /* As (b) is a UV, it's >=0, so it cannot be > */
1744 SETs(boolSV((UV)aiv > buv));
1750 #ifndef NV_PRESERVES_UV
1751 #ifdef PERL_PRESERVE_IVUV
1754 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1756 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1762 SETs(boolSV(TOPn > value));
1769 dSP; tryAMAGICbinSET(le,0);
1770 #ifdef PERL_PRESERVE_IVUV
1773 SvIV_please(TOPm1s);
1774 if (SvIOK(TOPm1s)) {
1775 bool auvok = SvUOK(TOPm1s);
1776 bool buvok = SvUOK(TOPs);
1778 if (!auvok && !buvok) { /* ## IV <= IV ## */
1779 const IV aiv = SvIVX(TOPm1s);
1780 const IV biv = SvIVX(TOPs);
1783 SETs(boolSV(aiv <= biv));
1786 if (auvok && buvok) { /* ## UV <= UV ## */
1787 UV auv = SvUVX(TOPm1s);
1788 UV buv = SvUVX(TOPs);
1791 SETs(boolSV(auv <= buv));
1794 if (auvok) { /* ## UV <= IV ## */
1796 const IV biv = SvIVX(TOPs);
1800 /* As (a) is a UV, it's >=0, so a cannot be <= */
1805 SETs(boolSV(auv <= (UV)biv));
1808 { /* ## IV <= UV ## */
1809 const IV aiv = SvIVX(TOPm1s);
1813 /* As (b) is a UV, it's >=0, so a must be <= */
1820 SETs(boolSV((UV)aiv <= buv));
1826 #ifndef NV_PRESERVES_UV
1827 #ifdef PERL_PRESERVE_IVUV
1830 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1832 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1838 SETs(boolSV(TOPn <= value));
1845 dSP; tryAMAGICbinSET(ge,0);
1846 #ifdef PERL_PRESERVE_IVUV
1849 SvIV_please(TOPm1s);
1850 if (SvIOK(TOPm1s)) {
1851 bool auvok = SvUOK(TOPm1s);
1852 bool buvok = SvUOK(TOPs);
1854 if (!auvok && !buvok) { /* ## IV >= IV ## */
1855 const IV aiv = SvIVX(TOPm1s);
1856 const IV biv = SvIVX(TOPs);
1859 SETs(boolSV(aiv >= biv));
1862 if (auvok && buvok) { /* ## UV >= UV ## */
1863 const UV auv = SvUVX(TOPm1s);
1864 const UV buv = SvUVX(TOPs);
1867 SETs(boolSV(auv >= buv));
1870 if (auvok) { /* ## UV >= IV ## */
1872 const IV biv = SvIVX(TOPs);
1876 /* As (a) is a UV, it's >=0, so it must be >= */
1881 SETs(boolSV(auv >= (UV)biv));
1884 { /* ## IV >= UV ## */
1885 const IV aiv = SvIVX(TOPm1s);
1889 /* As (b) is a UV, it's >=0, so a cannot be >= */
1896 SETs(boolSV((UV)aiv >= buv));
1902 #ifndef NV_PRESERVES_UV
1903 #ifdef PERL_PRESERVE_IVUV
1906 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1908 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1914 SETs(boolSV(TOPn >= value));
1921 dSP; tryAMAGICbinSET(ne,0);
1922 #ifndef NV_PRESERVES_UV
1923 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1925 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1929 #ifdef PERL_PRESERVE_IVUV
1932 SvIV_please(TOPm1s);
1933 if (SvIOK(TOPm1s)) {
1934 const bool auvok = SvUOK(TOPm1s);
1935 const bool buvok = SvUOK(TOPs);
1937 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1938 /* Casting IV to UV before comparison isn't going to matter
1939 on 2s complement. On 1s complement or sign&magnitude
1940 (if we have any of them) it could make negative zero
1941 differ from normal zero. As I understand it. (Need to
1942 check - is negative zero implementation defined behaviour
1944 const UV buv = SvUVX(POPs);
1945 const UV auv = SvUVX(TOPs);
1947 SETs(boolSV(auv != buv));
1950 { /* ## Mixed IV,UV ## */
1954 /* != is commutative so swap if needed (save code) */
1956 /* swap. top of stack (b) is the iv */
1960 /* As (a) is a UV, it's >0, so it cannot be == */
1969 /* As (b) is a UV, it's >0, so it cannot be == */
1973 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1975 SETs(boolSV((UV)iv != uv));
1983 SETs(boolSV(TOPn != value));
1990 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1991 #ifndef NV_PRESERVES_UV
1992 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1993 const UV right = PTR2UV(SvRV(POPs));
1994 const UV left = PTR2UV(SvRV(TOPs));
1995 SETi((left > right) - (left < right));
1999 #ifdef PERL_PRESERVE_IVUV
2000 /* Fortunately it seems NaN isn't IOK */
2003 SvIV_please(TOPm1s);
2004 if (SvIOK(TOPm1s)) {
2005 const bool leftuvok = SvUOK(TOPm1s);
2006 const bool rightuvok = SvUOK(TOPs);
2008 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2009 const IV leftiv = SvIVX(TOPm1s);
2010 const IV rightiv = SvIVX(TOPs);
2012 if (leftiv > rightiv)
2014 else if (leftiv < rightiv)
2018 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2019 const UV leftuv = SvUVX(TOPm1s);
2020 const UV rightuv = SvUVX(TOPs);
2022 if (leftuv > rightuv)
2024 else if (leftuv < rightuv)
2028 } else if (leftuvok) { /* ## UV <=> IV ## */
2029 const IV rightiv = SvIVX(TOPs);
2031 /* As (a) is a UV, it's >=0, so it cannot be < */
2034 const UV leftuv = SvUVX(TOPm1s);
2035 if (leftuv > (UV)rightiv) {
2037 } else if (leftuv < (UV)rightiv) {
2043 } else { /* ## IV <=> UV ## */
2044 const IV leftiv = SvIVX(TOPm1s);
2046 /* As (b) is a UV, it's >=0, so it must be < */
2049 const UV rightuv = SvUVX(TOPs);
2050 if ((UV)leftiv > rightuv) {
2052 } else if ((UV)leftiv < rightuv) {
2070 if (Perl_isnan(left) || Perl_isnan(right)) {
2074 value = (left > right) - (left < right);
2078 else if (left < right)
2080 else if (left > right)
2096 int amg_type = sle_amg;
2100 switch (PL_op->op_type) {
2119 tryAMAGICbinSET_var(amg_type,0);
2122 const int cmp = (IN_LOCALE_RUNTIME
2123 ? sv_cmp_locale(left, right)
2124 : sv_cmp(left, right));
2125 SETs(boolSV(cmp * multiplier < rhs));
2132 dSP; tryAMAGICbinSET(seq,0);
2135 SETs(boolSV(sv_eq(left, right)));
2142 dSP; tryAMAGICbinSET(sne,0);
2145 SETs(boolSV(!sv_eq(left, right)));
2152 dSP; dTARGET; tryAMAGICbin(scmp,0);
2155 const int cmp = (IN_LOCALE_RUNTIME
2156 ? sv_cmp_locale(left, right)
2157 : sv_cmp(left, right));
2165 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2170 if (SvNIOKp(left) || SvNIOKp(right)) {
2171 if (PL_op->op_private & HINT_INTEGER) {
2172 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2176 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2181 do_vop(PL_op->op_type, TARG, left, right);
2190 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2195 if (SvNIOKp(left) || SvNIOKp(right)) {
2196 if (PL_op->op_private & HINT_INTEGER) {
2197 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2201 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2206 do_vop(PL_op->op_type, TARG, left, right);
2215 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2220 if (SvNIOKp(left) || SvNIOKp(right)) {
2221 if (PL_op->op_private & HINT_INTEGER) {
2222 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2226 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2231 do_vop(PL_op->op_type, TARG, left, right);
2240 dSP; dTARGET; tryAMAGICun(neg);
2243 const int flags = SvFLAGS(sv);
2245 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2246 /* It's publicly an integer, or privately an integer-not-float */
2249 if (SvIVX(sv) == IV_MIN) {
2250 /* 2s complement assumption. */
2251 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2254 else if (SvUVX(sv) <= IV_MAX) {
2259 else if (SvIVX(sv) != IV_MIN) {
2263 #ifdef PERL_PRESERVE_IVUV
2272 else if (SvPOKp(sv)) {
2274 const char *s = SvPV_const(sv, len);
2275 if (isIDFIRST(*s)) {
2276 sv_setpvn(TARG, "-", 1);
2279 else if (*s == '+' || *s == '-') {
2281 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2283 else if (DO_UTF8(sv)) {
2286 goto oops_its_an_int;
2288 sv_setnv(TARG, -SvNV(sv));
2290 sv_setpvn(TARG, "-", 1);
2297 goto oops_its_an_int;
2298 sv_setnv(TARG, -SvNV(sv));
2310 dSP; tryAMAGICunSET(not);
2311 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2317 dSP; dTARGET; tryAMAGICun(compl);
2322 if (PL_op->op_private & HINT_INTEGER) {
2323 const IV i = ~SvIV_nomg(sv);
2327 const UV u = ~SvUV_nomg(sv);
2336 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2337 sv_setsv_nomg(TARG, sv);
2338 tmps = (U8*)SvPV_force(TARG, len);
2341 /* Calculate exact length, let's not estimate. */
2350 while (tmps < send) {
2351 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2352 tmps += UTF8SKIP(tmps);
2353 targlen += UNISKIP(~c);
2359 /* Now rewind strings and write them. */
2363 Newxz(result, targlen + 1, U8);
2364 while (tmps < send) {
2365 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2366 tmps += UTF8SKIP(tmps);
2367 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2371 sv_setpvn(TARG, (char*)result, targlen);
2375 Newxz(result, nchar + 1, U8);
2376 while (tmps < send) {
2377 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2378 tmps += UTF8SKIP(tmps);
2383 sv_setpvn(TARG, (char*)result, nchar);
2392 register long *tmpl;
2393 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2396 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2401 for ( ; anum > 0; anum--, tmps++)
2410 /* integer versions of some of the above */
2414 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2417 SETi( left * right );
2424 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2428 DIE(aTHX_ "Illegal division by zero");
2429 value = POPi / value;
2438 /* This is the vanilla old i_modulo. */
2439 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2443 DIE(aTHX_ "Illegal modulus zero");
2444 SETi( left % right );
2449 #if defined(__GLIBC__) && IVSIZE == 8
2453 /* This is the i_modulo with the workaround for the _moddi3 bug
2454 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2455 * See below for pp_i_modulo. */
2456 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2460 DIE(aTHX_ "Illegal modulus zero");
2461 SETi( left % PERL_ABS(right) );
2469 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2473 DIE(aTHX_ "Illegal modulus zero");
2474 /* The assumption is to use hereafter the old vanilla version... */
2476 PL_ppaddr[OP_I_MODULO] =
2478 /* .. but if we have glibc, we might have a buggy _moddi3
2479 * (at least glicb 2.2.5 is known to have this bug), in other
2480 * words our integer modulus with negative quad as the second
2481 * argument might be broken. Test for this and re-patch the
2482 * opcode dispatch table if that is the case, remembering to
2483 * also apply the workaround so that this first round works
2484 * right, too. See [perl #9402] for more information. */
2485 #if defined(__GLIBC__) && IVSIZE == 8
2489 /* Cannot do this check with inlined IV constants since
2490 * that seems to work correctly even with the buggy glibc. */
2492 /* Yikes, we have the bug.
2493 * Patch in the workaround version. */
2495 PL_ppaddr[OP_I_MODULO] =
2496 &Perl_pp_i_modulo_1;
2497 /* Make certain we work right this time, too. */
2498 right = PERL_ABS(right);
2502 SETi( left % right );
2509 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2512 SETi( left + right );
2519 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2522 SETi( left - right );
2529 dSP; tryAMAGICbinSET(lt,0);
2532 SETs(boolSV(left < right));
2539 dSP; tryAMAGICbinSET(gt,0);
2542 SETs(boolSV(left > right));
2549 dSP; tryAMAGICbinSET(le,0);
2552 SETs(boolSV(left <= right));
2559 dSP; tryAMAGICbinSET(ge,0);
2562 SETs(boolSV(left >= right));
2569 dSP; tryAMAGICbinSET(eq,0);
2572 SETs(boolSV(left == right));
2579 dSP; tryAMAGICbinSET(ne,0);
2582 SETs(boolSV(left != right));
2589 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2596 else if (left < right)
2607 dSP; dTARGET; tryAMAGICun(neg);
2612 /* High falutin' math. */
2616 dSP; dTARGET; tryAMAGICbin(atan2,0);
2619 SETn(Perl_atan2(left, right));
2626 dSP; dTARGET; tryAMAGICun(sin);
2628 const NV value = POPn;
2629 XPUSHn(Perl_sin(value));
2636 dSP; dTARGET; tryAMAGICun(cos);
2638 const NV value = POPn;
2639 XPUSHn(Perl_cos(value));
2644 /* Support Configure command-line overrides for rand() functions.
2645 After 5.005, perhaps we should replace this by Configure support
2646 for drand48(), random(), or rand(). For 5.005, though, maintain
2647 compatibility by calling rand() but allow the user to override it.
2648 See INSTALL for details. --Andy Dougherty 15 July 1998
2650 /* Now it's after 5.005, and Configure supports drand48() and random(),
2651 in addition to rand(). So the overrides should not be needed any more.
2652 --Jarkko Hietaniemi 27 September 1998
2655 #ifndef HAS_DRAND48_PROTO
2656 extern double drand48 (void);
2669 if (!PL_srand_called) {
2670 (void)seedDrand01((Rand_seed_t)seed());
2671 PL_srand_called = TRUE;
2681 const UV anum = (MAXARG < 1) ? seed() : POPu;
2682 (void)seedDrand01((Rand_seed_t)anum);
2683 PL_srand_called = TRUE;
2690 dSP; dTARGET; tryAMAGICun(exp);
2694 value = Perl_exp(value);
2702 dSP; dTARGET; tryAMAGICun(log);
2704 const NV value = POPn;
2706 SET_NUMERIC_STANDARD();
2707 DIE(aTHX_ "Can't take log of %"NVgf, value);
2709 XPUSHn(Perl_log(value));
2716 dSP; dTARGET; tryAMAGICun(sqrt);
2718 const NV value = POPn;
2720 SET_NUMERIC_STANDARD();
2721 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2723 XPUSHn(Perl_sqrt(value));
2730 dSP; dTARGET; tryAMAGICun(int);
2732 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2733 /* XXX it's arguable that compiler casting to IV might be subtly
2734 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2735 else preferring IV has introduced a subtle behaviour change bug. OTOH
2736 relying on floating point to be accurate is a bug. */
2740 else if (SvIOK(TOPs)) {
2747 const NV value = TOPn;
2749 if (value < (NV)UV_MAX + 0.5) {
2752 SETn(Perl_floor(value));
2756 if (value > (NV)IV_MIN - 0.5) {
2759 SETn(Perl_ceil(value));
2769 dSP; dTARGET; tryAMAGICun(abs);
2771 /* This will cache the NV value if string isn't actually integer */
2776 else if (SvIOK(TOPs)) {
2777 /* IVX is precise */
2779 SETu(TOPu); /* force it to be numeric only */
2787 /* 2s complement assumption. Also, not really needed as
2788 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2794 const NV value = TOPn;
2809 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2813 SV* const sv = POPs;
2815 tmps = (SvPV_const(sv, len));
2817 /* If Unicode, try to downgrade
2818 * If not possible, croak. */
2819 SV* const tsv = sv_2mortal(newSVsv(sv));
2822 sv_utf8_downgrade(tsv, FALSE);
2823 tmps = SvPV_const(tsv, len);
2825 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2826 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2839 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2843 SV* const sv = POPs;
2845 tmps = (SvPV_const(sv, len));
2847 /* If Unicode, try to downgrade
2848 * If not possible, croak. */
2849 SV* const tsv = sv_2mortal(newSVsv(sv));
2852 sv_utf8_downgrade(tsv, FALSE);
2853 tmps = SvPV_const(tsv, len);
2855 while (*tmps && len && isSPACE(*tmps))
2860 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2861 else if (*tmps == 'b')
2862 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2864 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2866 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2880 SV * const sv = TOPs;
2883 SETi(sv_len_utf8(sv));
2899 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2901 const I32 arybase = PL_curcop->cop_arybase;
2903 const char *repl = 0;
2905 const int num_args = PL_op->op_private & 7;
2906 bool repl_need_utf8_upgrade = FALSE;
2907 bool repl_is_utf8 = FALSE;
2909 SvTAINTED_off(TARG); /* decontaminate */
2910 SvUTF8_off(TARG); /* decontaminate */
2914 repl = SvPV_const(repl_sv, repl_len);
2915 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2925 sv_utf8_upgrade(sv);
2927 else if (DO_UTF8(sv))
2928 repl_need_utf8_upgrade = TRUE;
2930 tmps = SvPV_const(sv, curlen);
2932 utf8_curlen = sv_len_utf8(sv);
2933 if (utf8_curlen == curlen)
2936 curlen = utf8_curlen;
2941 if (pos >= arybase) {
2959 else if (len >= 0) {
2961 if (rem > (I32)curlen)
2976 Perl_croak(aTHX_ "substr outside of string");
2977 if (ckWARN(WARN_SUBSTR))
2978 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2982 const I32 upos = pos;
2983 const I32 urem = rem;
2985 sv_pos_u2b(sv, &pos, &rem);
2987 /* we either return a PV or an LV. If the TARG hasn't been used
2988 * before, or is of that type, reuse it; otherwise use a mortal
2989 * instead. Note that LVs can have an extended lifetime, so also
2990 * dont reuse if refcount > 1 (bug #20933) */
2991 if (SvTYPE(TARG) > SVt_NULL) {
2992 if ( (SvTYPE(TARG) == SVt_PVLV)
2993 ? (!lvalue || SvREFCNT(TARG) > 1)
2996 TARG = sv_newmortal();
3000 sv_setpvn(TARG, tmps, rem);
3001 #ifdef USE_LOCALE_COLLATE
3002 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3007 SV* repl_sv_copy = NULL;
3009 if (repl_need_utf8_upgrade) {
3010 repl_sv_copy = newSVsv(repl_sv);
3011 sv_utf8_upgrade(repl_sv_copy);
3012 repl = SvPV_const(repl_sv_copy, repl_len);
3013 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3015 sv_insert(sv, pos, rem, repl, repl_len);
3019 SvREFCNT_dec(repl_sv_copy);
3021 else if (lvalue) { /* it's an lvalue! */
3022 if (!SvGMAGICAL(sv)) {
3024 SvPV_force_nolen(sv);
3025 if (ckWARN(WARN_SUBSTR))
3026 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3027 "Attempt to use reference as lvalue in substr");
3029 if (SvOK(sv)) /* is it defined ? */
3030 (void)SvPOK_only_UTF8(sv);
3032 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3035 if (SvTYPE(TARG) < SVt_PVLV) {
3036 sv_upgrade(TARG, SVt_PVLV);
3037 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3043 if (LvTARG(TARG) != sv) {
3045 SvREFCNT_dec(LvTARG(TARG));
3046 LvTARG(TARG) = SvREFCNT_inc(sv);
3048 LvTARGOFF(TARG) = upos;
3049 LvTARGLEN(TARG) = urem;
3053 PUSHs(TARG); /* avoid SvSETMAGIC here */
3060 register const IV size = POPi;
3061 register const IV offset = POPi;
3062 register SV * const src = POPs;
3063 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3065 SvTAINTED_off(TARG); /* decontaminate */
3066 if (lvalue) { /* it's an lvalue! */
3067 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3068 TARG = sv_newmortal();
3069 if (SvTYPE(TARG) < SVt_PVLV) {
3070 sv_upgrade(TARG, SVt_PVLV);
3071 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3074 if (LvTARG(TARG) != src) {
3076 SvREFCNT_dec(LvTARG(TARG));
3077 LvTARG(TARG) = SvREFCNT_inc(src);
3079 LvTARGOFF(TARG) = offset;
3080 LvTARGLEN(TARG) = size;
3083 sv_setuv(TARG, do_vecget(src, offset, size));
3099 const I32 arybase = PL_curcop->cop_arybase;
3106 offset = POPi - arybase;
3109 big_utf8 = DO_UTF8(big);
3110 little_utf8 = DO_UTF8(little);
3111 if (big_utf8 ^ little_utf8) {
3112 /* One needs to be upgraded. */
3113 SV * const bytes = little_utf8 ? big : little;
3115 const char * const p = SvPV_const(bytes, len);
3117 temp = newSVpvn(p, len);
3120 sv_recode_to_utf8(temp, PL_encoding);
3122 sv_utf8_upgrade(temp);
3131 if (big_utf8 && offset > 0)
3132 sv_pos_u2b(big, &offset, 0);
3133 tmps = SvPV_const(big, biglen);
3136 else if (offset > (I32)biglen)
3138 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3139 (unsigned char*)tmps + biglen, little, 0)))
3142 retval = tmps2 - tmps;
3143 if (retval > 0 && big_utf8)
3144 sv_pos_b2u(big, &retval);
3147 PUSHi(retval + arybase);
3163 const I32 arybase = PL_curcop->cop_arybase;
3171 big_utf8 = DO_UTF8(big);
3172 little_utf8 = DO_UTF8(little);
3173 if (big_utf8 ^ little_utf8) {
3174 /* One needs to be upgraded. */
3175 SV * const bytes = little_utf8 ? big : little;
3177 const char *p = SvPV_const(bytes, len);
3179 temp = newSVpvn(p, len);
3182 sv_recode_to_utf8(temp, PL_encoding);
3184 sv_utf8_upgrade(temp);
3193 tmps2 = SvPV_const(little, llen);
3194 tmps = SvPV_const(big, blen);
3199 if (offset > 0 && big_utf8)
3200 sv_pos_u2b(big, &offset, 0);
3201 offset = offset - arybase + llen;
3205 else if (offset > (I32)blen)
3207 if (!(tmps2 = rninstr(tmps, tmps + offset,
3208 tmps2, tmps2 + llen)))
3211 retval = tmps2 - tmps;
3212 if (retval > 0 && big_utf8)
3213 sv_pos_b2u(big, &retval);
3216 PUSHi(retval + arybase);
3222 dSP; dMARK; dORIGMARK; dTARGET;
3223 do_sprintf(TARG, SP-MARK, MARK+1);
3224 TAINT_IF(SvTAINTED(TARG));
3235 const U8 *s = (U8*)SvPV_const(argsv, len);
3238 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3239 tmpsv = sv_2mortal(newSVsv(argsv));
3240 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3244 XPUSHu(DO_UTF8(argsv) ?
3245 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3257 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3259 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3261 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3263 (void) POPs; /* Ignore the argument value. */
3264 value = UNICODE_REPLACEMENT;
3270 SvUPGRADE(TARG,SVt_PV);
3272 if (value > 255 && !IN_BYTES) {
3273 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3274 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3275 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3277 (void)SvPOK_only(TARG);
3286 *tmps++ = (char)value;
3288 (void)SvPOK_only(TARG);
3289 if (PL_encoding && !IN_BYTES) {
3290 sv_recode_to_utf8(TARG, PL_encoding);
3292 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3293 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3297 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3298 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3313 const char *tmps = SvPV_const(left, len);
3315 if (DO_UTF8(left)) {
3316 /* If Unicode, try to downgrade.
3317 * If not possible, croak.
3318 * Yes, we made this up. */
3319 SV* const tsv = sv_2mortal(newSVsv(left));
3322 sv_utf8_downgrade(tsv, FALSE);
3323 tmps = SvPV_const(tsv, len);
3325 # ifdef USE_ITHREADS
3327 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3328 /* This should be threadsafe because in ithreads there is only
3329 * one thread per interpreter. If this would not be true,
3330 * we would need a mutex to protect this malloc. */
3331 PL_reentrant_buffer->_crypt_struct_buffer =
3332 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3333 #if defined(__GLIBC__) || defined(__EMX__)
3334 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3335 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3336 /* work around glibc-2.2.5 bug */
3337 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3341 # endif /* HAS_CRYPT_R */
3342 # endif /* USE_ITHREADS */
3344 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3346 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3352 "The crypt() function is unimplemented due to excessive paranoia.");
3362 const int op_type = PL_op->op_type;
3366 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3367 UTF8_IS_START(*s)) {
3368 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3372 utf8_to_uvchr(s, &ulen);
3373 if (op_type == OP_UCFIRST) {
3374 toTITLE_utf8(s, tmpbuf, &tculen);
3376 toLOWER_utf8(s, tmpbuf, &tculen);
3379 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3381 /* slen is the byte length of the whole SV.
3382 * ulen is the byte length of the original Unicode character
3383 * stored as UTF-8 at s.
3384 * tculen is the byte length of the freshly titlecased (or
3385 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3386 * We first set the result to be the titlecased (/lowercased)
3387 * character, and then append the rest of the SV data. */
3388 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3390 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3395 s = (U8*)SvPV_force_nomg(sv, slen);
3396 Copy(tmpbuf, s, tculen, U8);
3401 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3403 SvUTF8_off(TARG); /* decontaminate */
3404 sv_setsv_nomg(TARG, sv);
3408 s1 = (U8*)SvPV_force_nomg(sv, slen);
3410 if (IN_LOCALE_RUNTIME) {
3413 *s1 = (op_type == OP_UCFIRST)
3414 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3417 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3437 U8 tmpbuf[UTF8_MAXBYTES+1];
3439 s = (const U8*)SvPV_nomg_const(sv,len);
3441 SvUTF8_off(TARG); /* decontaminate */
3442 sv_setpvn(TARG, "", 0);
3446 STRLEN min = len + 1;
3448 SvUPGRADE(TARG, SVt_PV);
3450 (void)SvPOK_only(TARG);
3451 d = (U8*)SvPVX(TARG);
3454 STRLEN u = UTF8SKIP(s);
3456 toUPPER_utf8(s, tmpbuf, &ulen);
3457 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3458 /* If the eventually required minimum size outgrows
3459 * the available space, we need to grow. */
3460 const UV o = d - (U8*)SvPVX_const(TARG);
3462 /* If someone uppercases one million U+03B0s we
3463 * SvGROW() one million times. Or we could try
3464 * guessing how much to allocate without allocating
3465 * too much. Such is life. */
3467 d = (U8*)SvPVX(TARG) + o;
3469 Copy(tmpbuf, d, ulen, U8);
3475 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3481 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3483 SvUTF8_off(TARG); /* decontaminate */
3484 sv_setsv_nomg(TARG, sv);
3488 s = (U8*)SvPV_force_nomg(sv, len);
3490 register const U8 *send = s + len;
3492 if (IN_LOCALE_RUNTIME) {
3495 for (; s < send; s++)
3496 *s = toUPPER_LC(*s);
3499 for (; s < send; s++)
3521 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3523 s = (const U8*)SvPV_nomg_const(sv,len);
3525 SvUTF8_off(TARG); /* decontaminate */
3526 sv_setpvn(TARG, "", 0);
3530 STRLEN min = len + 1;
3532 SvUPGRADE(TARG, SVt_PV);
3534 (void)SvPOK_only(TARG);
3535 d = (U8*)SvPVX(TARG);
3538 const STRLEN u = UTF8SKIP(s);
3539 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3541 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3542 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3544 * Now if the sigma is NOT followed by
3545 * /$ignorable_sequence$cased_letter/;
3546 * and it IS preceded by
3547 * /$cased_letter$ignorable_sequence/;
3548 * where $ignorable_sequence is
3549 * [\x{2010}\x{AD}\p{Mn}]*
3550 * and $cased_letter is
3551 * [\p{Ll}\p{Lo}\p{Lt}]
3552 * then it should be mapped to 0x03C2,
3553 * (GREEK SMALL LETTER FINAL SIGMA),
3554 * instead of staying 0x03A3.
3555 * "should be": in other words,
3556 * this is not implemented yet.
3557 * See lib/unicore/SpecialCasing.txt.
3560 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3561 /* If the eventually required minimum size outgrows
3562 * the available space, we need to grow. */
3563 const UV o = d - (U8*)SvPVX_const(TARG);
3565 /* If someone lowercases one million U+0130s we
3566 * SvGROW() one million times. Or we could try
3567 * guessing how much to allocate without allocating.
3568 * too much. Such is life. */
3570 d = (U8*)SvPVX(TARG) + o;
3572 Copy(tmpbuf, d, ulen, U8);
3578 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3584 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3586 SvUTF8_off(TARG); /* decontaminate */
3587 sv_setsv_nomg(TARG, sv);
3592 s = (U8*)SvPV_force_nomg(sv, len);
3594 register const U8 * const send = s + len;
3596 if (IN_LOCALE_RUNTIME) {
3599 for (; s < send; s++)
3600 *s = toLOWER_LC(*s);
3603 for (; s < send; s++)
3615 SV * const sv = TOPs;
3617 register const char *s = SvPV_const(sv,len);
3619 SvUTF8_off(TARG); /* decontaminate */
3622 SvUPGRADE(TARG, SVt_PV);
3623 SvGROW(TARG, (len * 2) + 1);
3627 if (UTF8_IS_CONTINUED(*s)) {
3628 STRLEN ulen = UTF8SKIP(s);
3652 SvCUR_set(TARG, d - SvPVX_const(TARG));
3653 (void)SvPOK_only_UTF8(TARG);
3656 sv_setpvn(TARG, s, len);
3658 if (SvSMAGICAL(TARG))
3667 dSP; dMARK; dORIGMARK;
3668 register AV* const av = (AV*)POPs;
3669 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3671 if (SvTYPE(av) == SVt_PVAV) {
3672 const I32 arybase = PL_curcop->cop_arybase;
3673 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3676 for (svp = MARK + 1; svp <= SP; svp++) {
3677 const I32 elem = SvIVx(*svp);
3681 if (max > AvMAX(av))
3684 while (++MARK <= SP) {
3686 I32 elem = SvIVx(*MARK);
3690 svp = av_fetch(av, elem, lval);
3692 if (!svp || *svp == &PL_sv_undef)
3693 DIE(aTHX_ PL_no_aelem, elem);
3694 if (PL_op->op_private & OPpLVAL_INTRO)
3695 save_aelem(av, elem, svp);
3697 *MARK = svp ? *svp : &PL_sv_undef;
3700 if (GIMME != G_ARRAY) {
3702 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3708 /* Associative arrays. */
3713 HV * const hash = (HV*)POPs;
3715 const I32 gimme = GIMME_V;
3718 /* might clobber stack_sp */
3719 entry = hv_iternext(hash);
3724 SV* const sv = hv_iterkeysv(entry);
3725 PUSHs(sv); /* won't clobber stack_sp */
3726 if (gimme == G_ARRAY) {
3729 /* might clobber stack_sp */
3730 val = hv_iterval(hash, entry);
3735 else if (gimme == G_SCALAR)
3744 const I32 gimme = GIMME_V;
3745 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3747 if (PL_op->op_private & OPpSLICE) {
3749 HV * const hv = (HV*)POPs;
3750 const U32 hvtype = SvTYPE(hv);
3751 if (hvtype == SVt_PVHV) { /* hash element */
3752 while (++MARK <= SP) {
3753 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3754 *MARK = sv ? sv : &PL_sv_undef;
3757 else if (hvtype == SVt_PVAV) { /* array element */
3758 if (PL_op->op_flags & OPf_SPECIAL) {
3759 while (++MARK <= SP) {
3760 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3761 *MARK = sv ? sv : &PL_sv_undef;
3766 DIE(aTHX_ "Not a HASH reference");
3769 else if (gimme == G_SCALAR) {
3774 *++MARK = &PL_sv_undef;
3780 HV * const hv = (HV*)POPs;
3782 if (SvTYPE(hv) == SVt_PVHV)
3783 sv = hv_delete_ent(hv, keysv, discard, 0);
3784 else if (SvTYPE(hv) == SVt_PVAV) {
3785 if (PL_op->op_flags & OPf_SPECIAL)
3786 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3788 DIE(aTHX_ "panic: avhv_delete no longer supported");
3791 DIE(aTHX_ "Not a HASH reference");
3806 if (PL_op->op_private & OPpEXISTS_SUB) {
3808 SV * const sv = POPs;
3809 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3812 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3818 if (SvTYPE(hv) == SVt_PVHV) {
3819 if (hv_exists_ent(hv, tmpsv, 0))
3822 else if (SvTYPE(hv) == SVt_PVAV) {
3823 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3824 if (av_exists((AV*)hv, SvIV(tmpsv)))
3829 DIE(aTHX_ "Not a HASH reference");
3836 dSP; dMARK; dORIGMARK;
3837 register HV * const hv = (HV*)POPs;
3838 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3839 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3840 bool other_magic = FALSE;
3846 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3847 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3848 /* Try to preserve the existenceness of a tied hash
3849 * element by using EXISTS and DELETE if possible.
3850 * Fallback to FETCH and STORE otherwise */
3851 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3852 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3853 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3856 while (++MARK <= SP) {
3857 SV * const keysv = *MARK;
3860 bool preeminent = FALSE;
3863 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3864 hv_exists_ent(hv, keysv, 0);
3867 he = hv_fetch_ent(hv, keysv, lval, 0);
3868 svp = he ? &HeVAL(he) : 0;
3871 if (!svp || *svp == &PL_sv_undef) {
3872 DIE(aTHX_ PL_no_helem_sv, keysv);
3876 save_helem(hv, keysv, svp);
3879 const char *key = SvPV_const(keysv, keylen);
3880 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3884 *MARK = svp ? *svp : &PL_sv_undef;
3886 if (GIMME != G_ARRAY) {
3888 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3894 /* List operators. */
3899 if (GIMME != G_ARRAY) {
3901 *MARK = *SP; /* unwanted list, return last item */
3903 *MARK = &PL_sv_undef;
3912 SV ** const lastrelem = PL_stack_sp;
3913 SV ** const lastlelem = PL_stack_base + POPMARK;
3914 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3915 register SV ** const firstrelem = lastlelem + 1;
3916 const I32 arybase = PL_curcop->cop_arybase;
3917 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3919 register const I32 max = lastrelem - lastlelem;
3920 register SV **lelem;
3922 if (GIMME != G_ARRAY) {
3923 I32 ix = SvIVx(*lastlelem);
3928 if (ix < 0 || ix >= max)
3929 *firstlelem = &PL_sv_undef;
3931 *firstlelem = firstrelem[ix];
3937 SP = firstlelem - 1;
3941 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3942 I32 ix = SvIVx(*lelem);
3947 if (ix < 0 || ix >= max)
3948 *lelem = &PL_sv_undef;
3950 is_something_there = TRUE;
3951 if (!(*lelem = firstrelem[ix]))
3952 *lelem = &PL_sv_undef;
3955 if (is_something_there)
3958 SP = firstlelem - 1;
3964 dSP; dMARK; dORIGMARK;
3965 const I32 items = SP - MARK;
3966 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3967 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3974 dSP; dMARK; dORIGMARK;
3975 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3978 SV * const key = *++MARK;
3979 SV * const val = NEWSV(46, 0);
3981 sv_setsv(val, *++MARK);
3982 else if (ckWARN(WARN_MISC))
3983 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3984 (void)hv_store_ent(hv,key,val,0);
3993 dVAR; dSP; dMARK; dORIGMARK;
3994 register AV *ary = (AV*)*++MARK;
3998 register I32 offset;
3999 register I32 length;
4004 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4007 *MARK-- = SvTIED_obj((SV*)ary, mg);
4011 call_method("SPLICE",GIMME_V);
4020 offset = i = SvIVx(*MARK);
4022 offset += AvFILLp(ary) + 1;
4024 offset -= PL_curcop->cop_arybase;
4026 DIE(aTHX_ PL_no_aelem, i);
4028 length = SvIVx(*MARK++);
4030 length += AvFILLp(ary) - offset + 1;
4036 length = AvMAX(ary) + 1; /* close enough to infinity */
4040 length = AvMAX(ary) + 1;
4042 if (offset > AvFILLp(ary) + 1) {
4043 if (ckWARN(WARN_MISC))
4044 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4045 offset = AvFILLp(ary) + 1;
4047 after = AvFILLp(ary) + 1 - (offset + length);
4048 if (after < 0) { /* not that much array */
4049 length += after; /* offset+length now in array */
4055 /* At this point, MARK .. SP-1 is our new LIST */
4058 diff = newlen - length;
4059 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4062 /* make new elements SVs now: avoid problems if they're from the array */
4063 for (dst = MARK, i = newlen; i; i--) {
4064 SV * const h = *dst;
4065 *dst++ = newSVsv(h);
4068 if (diff < 0) { /* shrinking the area */
4070 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4071 Copy(MARK, tmparyval, newlen, SV*);
4074 MARK = ORIGMARK + 1;
4075 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4076 MEXTEND(MARK, length);
4077 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4079 EXTEND_MORTAL(length);
4080 for (i = length, dst = MARK; i; i--) {
4081 sv_2mortal(*dst); /* free them eventualy */
4088 *MARK = AvARRAY(ary)[offset+length-1];
4091 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4092 SvREFCNT_dec(*dst++); /* free them now */
4095 AvFILLp(ary) += diff;
4097 /* pull up or down? */
4099 if (offset < after) { /* easier to pull up */
4100 if (offset) { /* esp. if nothing to pull */
4101 src = &AvARRAY(ary)[offset-1];
4102 dst = src - diff; /* diff is negative */
4103 for (i = offset; i > 0; i--) /* can't trust Copy */
4107 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4111 if (after) { /* anything to pull down? */
4112 src = AvARRAY(ary) + offset + length;
4113 dst = src + diff; /* diff is negative */
4114 Move(src, dst, after, SV*);
4116 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4117 /* avoid later double free */
4121 dst[--i] = &PL_sv_undef;
4124 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4125 Safefree(tmparyval);
4128 else { /* no, expanding (or same) */
4130 Newx(tmparyval, length, SV*); /* so remember deletion */
4131 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4134 if (diff > 0) { /* expanding */
4136 /* push up or down? */
4138 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4142 Move(src, dst, offset, SV*);
4144 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4146 AvFILLp(ary) += diff;
4149 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4150 av_extend(ary, AvFILLp(ary) + diff);
4151 AvFILLp(ary) += diff;
4154 dst = AvARRAY(ary) + AvFILLp(ary);
4156 for (i = after; i; i--) {
4164 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4167 MARK = ORIGMARK + 1;
4168 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4170 Copy(tmparyval, MARK, length, SV*);
4172 EXTEND_MORTAL(length);
4173 for (i = length, dst = MARK; i; i--) {
4174 sv_2mortal(*dst); /* free them eventualy */
4178 Safefree(tmparyval);
4182 else if (length--) {
4183 *MARK = tmparyval[length];
4186 while (length-- > 0)
4187 SvREFCNT_dec(tmparyval[length]);
4189 Safefree(tmparyval);
4192 *MARK = &PL_sv_undef;
4200 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4201 register AV *ary = (AV*)*++MARK;
4202 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4205 *MARK-- = SvTIED_obj((SV*)ary, mg);
4209 call_method("PUSH",G_SCALAR|G_DISCARD);
4213 PUSHi( AvFILL(ary) + 1 );
4216 for (++MARK; MARK <= SP; MARK++) {
4217 SV * const sv = NEWSV(51, 0);
4219 sv_setsv(sv, *MARK);
4220 av_store(ary, AvFILLp(ary)+1, sv);
4223 PUSHi( AvFILLp(ary) + 1 );
4231 AV * const av = (AV*)POPs;
4232 SV * const sv = av_pop(av);
4234 (void)sv_2mortal(sv);
4242 AV * const av = (AV*)POPs;
4243 SV * const sv = av_shift(av);
4248 (void)sv_2mortal(sv);
4255 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4256 register AV *ary = (AV*)*++MARK;
4257 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4260 *MARK-- = SvTIED_obj((SV*)ary, mg);
4264 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4270 av_unshift(ary, SP - MARK);
4272 SV * const sv = newSVsv(*++MARK);
4273 (void)av_store(ary, i++, sv);
4277 PUSHi( AvFILL(ary) + 1 );
4284 SV ** const oldsp = SP;
4286 if (GIMME == G_ARRAY) {
4289 register SV * const tmp = *MARK;
4293 /* safe as long as stack cannot get extended in the above */
4298 register char *down;
4304 SvUTF8_off(TARG); /* decontaminate */
4306 do_join(TARG, &PL_sv_no, MARK, SP);
4308 sv_setsv(TARG, (SP > MARK)
4310 : (padoff_du = find_rundefsvoffset(),
4311 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4312 ? DEFSV : PAD_SVl(padoff_du)));
4313 up = SvPV_force(TARG, len);
4315 if (DO_UTF8(TARG)) { /* first reverse each character */
4316 U8* s = (U8*)SvPVX(TARG);
4317 const U8* send = (U8*)(s + len);
4319 if (UTF8_IS_INVARIANT(*s)) {
4324 if (!utf8_to_uvchr(s, 0))
4328 down = (char*)(s - 1);
4329 /* reverse this character */
4333 *down-- = (char)tmp;
4339 down = SvPVX(TARG) + len - 1;
4343 *down-- = (char)tmp;
4345 (void)SvPOK_only_UTF8(TARG);
4357 register IV limit = POPi; /* note, negative is forever */
4358 SV * const sv = POPs;
4360 register const char *s = SvPV_const(sv, len);
4361 const bool do_utf8 = DO_UTF8(sv);
4362 const char *strend = s + len;
4364 register REGEXP *rx;
4366 register const char *m;
4368 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4369 I32 maxiters = slen + 10;
4371 const I32 origlimit = limit;
4374 const I32 gimme = GIMME_V;
4375 const I32 oldsave = PL_savestack_ix;
4376 I32 make_mortal = 1;
4378 MAGIC *mg = (MAGIC *) NULL;
4381 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4386 DIE(aTHX_ "panic: pp_split");
4389 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4390 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4392 RX_MATCH_UTF8_set(rx, do_utf8);
4394 if (pm->op_pmreplroot) {
4396 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4398 ary = GvAVn((GV*)pm->op_pmreplroot);
4401 else if (gimme != G_ARRAY)
4402 ary = GvAVn(PL_defgv);
4405 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4411 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4413 XPUSHs(SvTIED_obj((SV*)ary, mg));
4420 for (i = AvFILLp(ary); i >= 0; i--)
4421 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4423 /* temporarily switch stacks */
4424 SAVESWITCHSTACK(PL_curstack, ary);
4428 base = SP - PL_stack_base;
4430 if (pm->op_pmflags & PMf_SKIPWHITE) {
4431 if (pm->op_pmflags & PMf_LOCALE) {
4432 while (isSPACE_LC(*s))
4440 if (pm->op_pmflags & PMf_MULTILINE) {
4445 limit = maxiters + 2;
4446 if (pm->op_pmflags & PMf_WHITE) {
4449 while (m < strend &&
4450 !((pm->op_pmflags & PMf_LOCALE)
4451 ? isSPACE_LC(*m) : isSPACE(*m)))
4456 dstr = newSVpvn(s, m-s);
4460 (void)SvUTF8_on(dstr);
4464 while (s < strend &&
4465 ((pm->op_pmflags & PMf_LOCALE)
4466 ? isSPACE_LC(*s) : isSPACE(*s)))
4470 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4472 for (m = s; m < strend && *m != '\n'; m++)
4477 dstr = newSVpvn(s, m-s);
4481 (void)SvUTF8_on(dstr);
4486 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4487 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4488 && (rx->reganch & ROPT_CHECK_ALL)
4489 && !(rx->reganch & ROPT_ANCH)) {
4490 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4491 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4494 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4495 const char c = *SvPV_nolen_const(csv);
4497 for (m = s; m < strend && *m != c; m++)
4501 dstr = newSVpvn(s, m-s);
4505 (void)SvUTF8_on(dstr);
4507 /* The rx->minlen is in characters but we want to step
4508 * s ahead by bytes. */
4510 s = (char*)utf8_hop((U8*)m, len);
4512 s = m + len; /* Fake \n at the end */
4516 while (s < strend && --limit &&
4517 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4518 csv, multiline ? FBMrf_MULTILINE : 0)) )
4520 dstr = newSVpvn(s, m-s);
4524 (void)SvUTF8_on(dstr);
4526 /* The rx->minlen is in characters but we want to step
4527 * s ahead by bytes. */
4529 s = (char*)utf8_hop((U8*)m, len);
4531 s = m + len; /* Fake \n at the end */
4536 maxiters += slen * rx->nparens;
4537 while (s < strend && --limit)
4541 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4544 if (rex_return == 0)
4546 TAINT_IF(RX_MATCH_TAINTED(rx));
4547 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4552 strend = s + (strend - m);
4554 m = rx->startp[0] + orig;
4555 dstr = newSVpvn(s, m-s);
4559 (void)SvUTF8_on(dstr);
4563 for (i = 1; i <= (I32)rx->nparens; i++) {
4564 s = rx->startp[i] + orig;
4565 m = rx->endp[i] + orig;
4567 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4568 parens that didn't match -- they should be set to
4569 undef, not the empty string */
4570 if (m >= orig && s >= orig) {
4571 dstr = newSVpvn(s, m-s);
4574 dstr = &PL_sv_undef; /* undef, not "" */
4578 (void)SvUTF8_on(dstr);
4582 s = rx->endp[0] + orig;
4586 iters = (SP - PL_stack_base) - base;
4587 if (iters > maxiters)
4588 DIE(aTHX_ "Split loop");
4590 /* keep field after final delim? */
4591 if (s < strend || (iters && origlimit)) {
4592 const STRLEN l = strend - s;
4593 dstr = newSVpvn(s, l);
4597 (void)SvUTF8_on(dstr);
4601 else if (!origlimit) {
4602 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4603 if (TOPs && !make_mortal)
4606 *SP-- = &PL_sv_undef;
4611 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4615 if (SvSMAGICAL(ary)) {
4620 if (gimme == G_ARRAY) {
4622 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4630 call_method("PUSH",G_SCALAR|G_DISCARD);
4633 if (gimme == G_ARRAY) {
4635 /* EXTEND should not be needed - we just popped them */
4637 for (i=0; i < iters; i++) {
4638 SV **svp = av_fetch(ary, i, FALSE);
4639 PUSHs((svp) ? *svp : &PL_sv_undef);
4646 if (gimme == G_ARRAY)
4661 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4662 || SvTYPE(retsv) == SVt_PVCV) {
4663 retsv = refto(retsv);
4670 PP(unimplemented_op)
4672 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4678 * c-indentation-style: bsd
4680 * indent-tabs-mode: t
4683 * ex: set ts=8 sts=4 sw=4 noet: