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 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 *namesv = PAD_SV(cUNOP->op_targ);
164 const char *name = SvPV(namesv, len);
165 gv = (GV*)NEWSV(0,0);
166 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
169 const char *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 *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* 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 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? */
1362 else if (SvNOKp(sv)) {
1363 const NV nv = SvNV(sv);
1371 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1373 I32 items = SP - MARK;
1375 static const char oom_list_extend[] =
1376 "Out of memory during list extend";
1378 max = items * count;
1379 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1380 /* Did the max computation overflow? */
1381 if (items > 0 && max > 0 && (max < items || max < count))
1382 Perl_croak(aTHX_ oom_list_extend);
1387 /* This code was intended to fix 20010809.028:
1390 for (($x =~ /./g) x 2) {
1391 print chop; # "abcdabcd" expected as output.
1394 * but that change (#11635) broke this code:
1396 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1398 * I can't think of a better fix that doesn't introduce
1399 * an efficiency hit by copying the SVs. The stack isn't
1400 * refcounted, and mortalisation obviously doesn't
1401 * Do The Right Thing when the stack has more than
1402 * one pointer to the same mortal value.
1406 *SP = sv_2mortal(newSVsv(*SP));
1416 repeatcpy((char*)(MARK + items), (char*)MARK,
1417 items * sizeof(SV*), count - 1);
1420 else if (count <= 0)
1423 else { /* Note: mark already snarfed by pp_list */
1427 static const char oom_string_extend[] =
1428 "Out of memory during string extend";
1430 SvSetSV(TARG, tmpstr);
1431 SvPV_force(TARG, len);
1432 isutf = DO_UTF8(TARG);
1437 STRLEN max = (UV)count * len;
1438 if (len > ((MEM_SIZE)~0)/count)
1439 Perl_croak(aTHX_ oom_string_extend);
1440 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1441 SvGROW(TARG, max + 1);
1442 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1443 SvCUR_set(TARG, SvCUR(TARG) * count);
1445 *SvEND(TARG) = '\0';
1448 (void)SvPOK_only_UTF8(TARG);
1450 (void)SvPOK_only(TARG);
1452 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1453 /* The parser saw this as a list repeat, and there
1454 are probably several items on the stack. But we're
1455 in scalar context, and there's no pp_list to save us
1456 now. So drop the rest of the items -- robin@kitsite.com
1469 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1470 useleft = USE_LEFT(TOPm1s);
1471 #ifdef PERL_PRESERVE_IVUV
1472 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1473 "bad things" happen if you rely on signed integers wrapping. */
1476 /* Unless the left argument is integer in range we are going to have to
1477 use NV maths. Hence only attempt to coerce the right argument if
1478 we know the left is integer. */
1479 register UV auv = 0;
1485 a_valid = auvok = 1;
1486 /* left operand is undef, treat as zero. */
1488 /* Left operand is defined, so is it IV? */
1489 SvIV_please(TOPm1s);
1490 if (SvIOK(TOPm1s)) {
1491 if ((auvok = SvUOK(TOPm1s)))
1492 auv = SvUVX(TOPm1s);
1494 register const IV aiv = SvIVX(TOPm1s);
1497 auvok = 1; /* Now acting as a sign flag. */
1498 } else { /* 2s complement assumption for IV_MIN */
1506 bool result_good = 0;
1509 bool buvok = SvUOK(TOPs);
1514 register const IV biv = SvIVX(TOPs);
1521 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1522 else "IV" now, independent of how it came in.
1523 if a, b represents positive, A, B negative, a maps to -A etc
1528 all UV maths. negate result if A negative.
1529 subtract if signs same, add if signs differ. */
1531 if (auvok ^ buvok) {
1540 /* Must get smaller */
1545 if (result <= buv) {
1546 /* result really should be -(auv-buv). as its negation
1547 of true value, need to swap our result flag */
1559 if (result <= (UV)IV_MIN)
1560 SETi( -(IV)result );
1562 /* result valid, but out of range for IV. */
1563 SETn( -(NV)result );
1567 } /* Overflow, drop through to NVs. */
1571 useleft = USE_LEFT(TOPm1s);
1575 /* left operand is undef, treat as zero - value */
1579 SETn( TOPn - value );
1586 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1588 const IV shift = POPi;
1589 if (PL_op->op_private & HINT_INTEGER) {
1603 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1605 const IV shift = POPi;
1606 if (PL_op->op_private & HINT_INTEGER) {
1620 dSP; tryAMAGICbinSET(lt,0);
1621 #ifdef PERL_PRESERVE_IVUV
1624 SvIV_please(TOPm1s);
1625 if (SvIOK(TOPm1s)) {
1626 bool auvok = SvUOK(TOPm1s);
1627 bool buvok = SvUOK(TOPs);
1629 if (!auvok && !buvok) { /* ## IV < IV ## */
1630 const IV aiv = SvIVX(TOPm1s);
1631 const IV biv = SvIVX(TOPs);
1634 SETs(boolSV(aiv < biv));
1637 if (auvok && buvok) { /* ## UV < UV ## */
1638 const UV auv = SvUVX(TOPm1s);
1639 const UV buv = SvUVX(TOPs);
1642 SETs(boolSV(auv < buv));
1645 if (auvok) { /* ## UV < IV ## */
1647 const IV biv = SvIVX(TOPs);
1650 /* As (a) is a UV, it's >=0, so it cannot be < */
1655 SETs(boolSV(auv < (UV)biv));
1658 { /* ## IV < UV ## */
1659 const IV aiv = SvIVX(TOPm1s);
1663 /* As (b) is a UV, it's >=0, so it must be < */
1670 SETs(boolSV((UV)aiv < buv));
1676 #ifndef NV_PRESERVES_UV
1677 #ifdef PERL_PRESERVE_IVUV
1680 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1682 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1688 SETs(boolSV(TOPn < value));
1695 dSP; tryAMAGICbinSET(gt,0);
1696 #ifdef PERL_PRESERVE_IVUV
1699 SvIV_please(TOPm1s);
1700 if (SvIOK(TOPm1s)) {
1701 bool auvok = SvUOK(TOPm1s);
1702 bool buvok = SvUOK(TOPs);
1704 if (!auvok && !buvok) { /* ## IV > IV ## */
1705 const IV aiv = SvIVX(TOPm1s);
1706 const IV biv = SvIVX(TOPs);
1709 SETs(boolSV(aiv > biv));
1712 if (auvok && buvok) { /* ## UV > UV ## */
1713 const UV auv = SvUVX(TOPm1s);
1714 const UV buv = SvUVX(TOPs);
1717 SETs(boolSV(auv > buv));
1720 if (auvok) { /* ## UV > IV ## */
1722 const IV biv = SvIVX(TOPs);
1726 /* As (a) is a UV, it's >=0, so it must be > */
1731 SETs(boolSV(auv > (UV)biv));
1734 { /* ## IV > UV ## */
1735 const IV aiv = SvIVX(TOPm1s);
1739 /* As (b) is a UV, it's >=0, so it cannot be > */
1746 SETs(boolSV((UV)aiv > buv));
1752 #ifndef NV_PRESERVES_UV
1753 #ifdef PERL_PRESERVE_IVUV
1756 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1758 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1764 SETs(boolSV(TOPn > value));
1771 dSP; tryAMAGICbinSET(le,0);
1772 #ifdef PERL_PRESERVE_IVUV
1775 SvIV_please(TOPm1s);
1776 if (SvIOK(TOPm1s)) {
1777 bool auvok = SvUOK(TOPm1s);
1778 bool buvok = SvUOK(TOPs);
1780 if (!auvok && !buvok) { /* ## IV <= IV ## */
1781 const IV aiv = SvIVX(TOPm1s);
1782 const IV biv = SvIVX(TOPs);
1785 SETs(boolSV(aiv <= biv));
1788 if (auvok && buvok) { /* ## UV <= UV ## */
1789 UV auv = SvUVX(TOPm1s);
1790 UV buv = SvUVX(TOPs);
1793 SETs(boolSV(auv <= buv));
1796 if (auvok) { /* ## UV <= IV ## */
1798 const IV biv = SvIVX(TOPs);
1802 /* As (a) is a UV, it's >=0, so a cannot be <= */
1807 SETs(boolSV(auv <= (UV)biv));
1810 { /* ## IV <= UV ## */
1811 const IV aiv = SvIVX(TOPm1s);
1815 /* As (b) is a UV, it's >=0, so a must be <= */
1822 SETs(boolSV((UV)aiv <= buv));
1828 #ifndef NV_PRESERVES_UV
1829 #ifdef PERL_PRESERVE_IVUV
1832 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1834 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1840 SETs(boolSV(TOPn <= value));
1847 dSP; tryAMAGICbinSET(ge,0);
1848 #ifdef PERL_PRESERVE_IVUV
1851 SvIV_please(TOPm1s);
1852 if (SvIOK(TOPm1s)) {
1853 bool auvok = SvUOK(TOPm1s);
1854 bool buvok = SvUOK(TOPs);
1856 if (!auvok && !buvok) { /* ## IV >= IV ## */
1857 const IV aiv = SvIVX(TOPm1s);
1858 const IV biv = SvIVX(TOPs);
1861 SETs(boolSV(aiv >= biv));
1864 if (auvok && buvok) { /* ## UV >= UV ## */
1865 const UV auv = SvUVX(TOPm1s);
1866 const UV buv = SvUVX(TOPs);
1869 SETs(boolSV(auv >= buv));
1872 if (auvok) { /* ## UV >= IV ## */
1874 const IV biv = SvIVX(TOPs);
1878 /* As (a) is a UV, it's >=0, so it must be >= */
1883 SETs(boolSV(auv >= (UV)biv));
1886 { /* ## IV >= UV ## */
1887 const IV aiv = SvIVX(TOPm1s);
1891 /* As (b) is a UV, it's >=0, so a cannot be >= */
1898 SETs(boolSV((UV)aiv >= buv));
1904 #ifndef NV_PRESERVES_UV
1905 #ifdef PERL_PRESERVE_IVUV
1908 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1910 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1916 SETs(boolSV(TOPn >= value));
1923 dSP; tryAMAGICbinSET(ne,0);
1924 #ifndef NV_PRESERVES_UV
1925 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1927 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1931 #ifdef PERL_PRESERVE_IVUV
1934 SvIV_please(TOPm1s);
1935 if (SvIOK(TOPm1s)) {
1936 bool auvok = SvUOK(TOPm1s);
1937 bool buvok = SvUOK(TOPs);
1939 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1940 /* Casting IV to UV before comparison isn't going to matter
1941 on 2s complement. On 1s complement or sign&magnitude
1942 (if we have any of them) it could make negative zero
1943 differ from normal zero. As I understand it. (Need to
1944 check - is negative zero implementation defined behaviour
1946 const UV buv = SvUVX(POPs);
1947 const UV auv = SvUVX(TOPs);
1949 SETs(boolSV(auv != buv));
1952 { /* ## Mixed IV,UV ## */
1956 /* != is commutative so swap if needed (save code) */
1958 /* swap. top of stack (b) is the iv */
1962 /* As (a) is a UV, it's >0, so it cannot be == */
1971 /* As (b) is a UV, it's >0, so it cannot be == */
1975 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1977 SETs(boolSV((UV)iv != uv));
1985 SETs(boolSV(TOPn != value));
1992 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1993 #ifndef NV_PRESERVES_UV
1994 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1995 UV right = PTR2UV(SvRV(POPs));
1996 UV left = PTR2UV(SvRV(TOPs));
1997 SETi((left > right) - (left < right));
2001 #ifdef PERL_PRESERVE_IVUV
2002 /* Fortunately it seems NaN isn't IOK */
2005 SvIV_please(TOPm1s);
2006 if (SvIOK(TOPm1s)) {
2007 const bool leftuvok = SvUOK(TOPm1s);
2008 const bool rightuvok = SvUOK(TOPs);
2010 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2011 const IV leftiv = SvIVX(TOPm1s);
2012 const IV rightiv = SvIVX(TOPs);
2014 if (leftiv > rightiv)
2016 else if (leftiv < rightiv)
2020 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2021 const UV leftuv = SvUVX(TOPm1s);
2022 const UV rightuv = SvUVX(TOPs);
2024 if (leftuv > rightuv)
2026 else if (leftuv < rightuv)
2030 } else if (leftuvok) { /* ## UV <=> IV ## */
2031 const IV rightiv = SvIVX(TOPs);
2033 /* As (a) is a UV, it's >=0, so it cannot be < */
2036 const UV leftuv = SvUVX(TOPm1s);
2037 if (leftuv > (UV)rightiv) {
2039 } else if (leftuv < (UV)rightiv) {
2045 } else { /* ## IV <=> UV ## */
2046 const IV leftiv = SvIVX(TOPm1s);
2048 /* As (b) is a UV, it's >=0, so it must be < */
2051 const UV rightuv = SvUVX(TOPs);
2052 if ((UV)leftiv > rightuv) {
2054 } else if ((UV)leftiv < rightuv) {
2072 if (Perl_isnan(left) || Perl_isnan(right)) {
2076 value = (left > right) - (left < right);
2080 else if (left < right)
2082 else if (left > right)
2096 dSP; tryAMAGICbinSET_var(slt_amg,0);
2099 const int cmp = (IN_LOCALE_RUNTIME
2100 ? sv_cmp_locale(left, right)
2101 : sv_cmp(left, right));
2102 SETs(boolSV(cmp < 0));
2109 dSP; tryAMAGICbinSET_var(sgt_amg,0);
2112 const int cmp = (IN_LOCALE_RUNTIME
2113 ? sv_cmp_locale(left, right)
2114 : sv_cmp(left, right));
2115 SETs(boolSV(cmp > 0));
2122 dSP; tryAMAGICbinSET_var(sle_amg,0);
2125 const int cmp = (IN_LOCALE_RUNTIME
2126 ? sv_cmp_locale(left, right)
2127 : sv_cmp(left, right));
2128 SETs(boolSV(cmp <= 0));
2135 dSP; tryAMAGICbinSET_var(sge_amg,0);
2138 const int cmp = (IN_LOCALE_RUNTIME
2139 ? sv_cmp_locale(left, right)
2140 : sv_cmp(left, right));
2141 SETs(boolSV(cmp >= 0));
2148 dSP; tryAMAGICbinSET(seq,0);
2151 SETs(boolSV(sv_eq(left, right)));
2158 dSP; tryAMAGICbinSET(sne,0);
2161 SETs(boolSV(!sv_eq(left, right)));
2168 dSP; dTARGET; tryAMAGICbin(scmp,0);
2171 const int cmp = (IN_LOCALE_RUNTIME
2172 ? sv_cmp_locale(left, right)
2173 : sv_cmp(left, right));
2181 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2186 if (SvNIOKp(left) || SvNIOKp(right)) {
2187 if (PL_op->op_private & HINT_INTEGER) {
2188 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2192 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2197 do_vop(PL_op->op_type, TARG, left, right);
2206 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2211 if (SvNIOKp(left) || SvNIOKp(right)) {
2212 if (PL_op->op_private & HINT_INTEGER) {
2213 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2217 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2222 do_vop(PL_op->op_type, TARG, left, right);
2231 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2236 if (SvNIOKp(left) || SvNIOKp(right)) {
2237 if (PL_op->op_private & HINT_INTEGER) {
2238 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2242 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2247 do_vop(PL_op->op_type, TARG, left, right);
2256 dSP; dTARGET; tryAMAGICun(neg);
2259 const int flags = SvFLAGS(sv);
2261 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2262 /* It's publicly an integer, or privately an integer-not-float */
2265 if (SvIVX(sv) == IV_MIN) {
2266 /* 2s complement assumption. */
2267 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2270 else if (SvUVX(sv) <= IV_MAX) {
2275 else if (SvIVX(sv) != IV_MIN) {
2279 #ifdef PERL_PRESERVE_IVUV
2288 else if (SvPOKp(sv)) {
2290 const char *s = SvPV_const(sv, len);
2291 if (isIDFIRST(*s)) {
2292 sv_setpvn(TARG, "-", 1);
2295 else if (*s == '+' || *s == '-') {
2297 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2299 else if (DO_UTF8(sv)) {
2302 goto oops_its_an_int;
2304 sv_setnv(TARG, -SvNV(sv));
2306 sv_setpvn(TARG, "-", 1);
2313 goto oops_its_an_int;
2314 sv_setnv(TARG, -SvNV(sv));
2326 dSP; tryAMAGICunSET(not);
2327 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2333 dSP; dTARGET; tryAMAGICun(compl);
2338 if (PL_op->op_private & HINT_INTEGER) {
2339 const IV i = ~SvIV_nomg(sv);
2343 const UV u = ~SvUV_nomg(sv);
2352 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2353 sv_setsv_nomg(TARG, sv);
2354 tmps = (U8*)SvPV_force(TARG, len);
2357 /* Calculate exact length, let's not estimate. */
2366 while (tmps < send) {
2367 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2368 tmps += UTF8SKIP(tmps);
2369 targlen += UNISKIP(~c);
2375 /* Now rewind strings and write them. */
2379 Newxz(result, targlen + 1, U8);
2380 while (tmps < send) {
2381 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2382 tmps += UTF8SKIP(tmps);
2383 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2387 sv_setpvn(TARG, (char*)result, targlen);
2391 Newxz(result, nchar + 1, U8);
2392 while (tmps < send) {
2393 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2394 tmps += UTF8SKIP(tmps);
2399 sv_setpvn(TARG, (char*)result, nchar);
2408 register long *tmpl;
2409 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2412 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2417 for ( ; anum > 0; anum--, tmps++)
2426 /* integer versions of some of the above */
2430 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2433 SETi( left * right );
2440 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2444 DIE(aTHX_ "Illegal division by zero");
2445 value = POPi / value;
2454 /* This is the vanilla old i_modulo. */
2455 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2459 DIE(aTHX_ "Illegal modulus zero");
2460 SETi( left % right );
2465 #if defined(__GLIBC__) && IVSIZE == 8
2469 /* This is the i_modulo with the workaround for the _moddi3 bug
2470 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2471 * See below for pp_i_modulo. */
2472 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2476 DIE(aTHX_ "Illegal modulus zero");
2477 SETi( left % PERL_ABS(right) );
2485 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2489 DIE(aTHX_ "Illegal modulus zero");
2490 /* The assumption is to use hereafter the old vanilla version... */
2492 PL_ppaddr[OP_I_MODULO] =
2494 /* .. but if we have glibc, we might have a buggy _moddi3
2495 * (at least glicb 2.2.5 is known to have this bug), in other
2496 * words our integer modulus with negative quad as the second
2497 * argument might be broken. Test for this and re-patch the
2498 * opcode dispatch table if that is the case, remembering to
2499 * also apply the workaround so that this first round works
2500 * right, too. See [perl #9402] for more information. */
2501 #if defined(__GLIBC__) && IVSIZE == 8
2505 /* Cannot do this check with inlined IV constants since
2506 * that seems to work correctly even with the buggy glibc. */
2508 /* Yikes, we have the bug.
2509 * Patch in the workaround version. */
2511 PL_ppaddr[OP_I_MODULO] =
2512 &Perl_pp_i_modulo_1;
2513 /* Make certain we work right this time, too. */
2514 right = PERL_ABS(right);
2518 SETi( left % right );
2525 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2528 SETi( left + right );
2535 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2538 SETi( left - right );
2545 dSP; tryAMAGICbinSET(lt,0);
2548 SETs(boolSV(left < right));
2555 dSP; tryAMAGICbinSET(gt,0);
2558 SETs(boolSV(left > right));
2565 dSP; tryAMAGICbinSET(le,0);
2568 SETs(boolSV(left <= right));
2575 dSP; tryAMAGICbinSET(ge,0);
2578 SETs(boolSV(left >= right));
2585 dSP; tryAMAGICbinSET(eq,0);
2588 SETs(boolSV(left == right));
2595 dSP; tryAMAGICbinSET(ne,0);
2598 SETs(boolSV(left != right));
2605 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2612 else if (left < right)
2623 dSP; dTARGET; tryAMAGICun(neg);
2628 /* High falutin' math. */
2632 dSP; dTARGET; tryAMAGICbin(atan2,0);
2635 SETn(Perl_atan2(left, right));
2642 dSP; dTARGET; tryAMAGICun(sin);
2644 const NV value = POPn;
2645 XPUSHn(Perl_sin(value));
2652 dSP; dTARGET; tryAMAGICun(cos);
2654 const NV value = POPn;
2655 XPUSHn(Perl_cos(value));
2660 /* Support Configure command-line overrides for rand() functions.
2661 After 5.005, perhaps we should replace this by Configure support
2662 for drand48(), random(), or rand(). For 5.005, though, maintain
2663 compatibility by calling rand() but allow the user to override it.
2664 See INSTALL for details. --Andy Dougherty 15 July 1998
2666 /* Now it's after 5.005, and Configure supports drand48() and random(),
2667 in addition to rand(). So the overrides should not be needed any more.
2668 --Jarkko Hietaniemi 27 September 1998
2671 #ifndef HAS_DRAND48_PROTO
2672 extern double drand48 (void);
2685 if (!PL_srand_called) {
2686 (void)seedDrand01((Rand_seed_t)seed());
2687 PL_srand_called = TRUE;
2702 (void)seedDrand01((Rand_seed_t)anum);
2703 PL_srand_called = TRUE;
2710 dSP; dTARGET; tryAMAGICun(exp);
2714 value = Perl_exp(value);
2722 dSP; dTARGET; tryAMAGICun(log);
2724 const NV value = POPn;
2726 SET_NUMERIC_STANDARD();
2727 DIE(aTHX_ "Can't take log of %"NVgf, value);
2729 XPUSHn(Perl_log(value));
2736 dSP; dTARGET; tryAMAGICun(sqrt);
2738 const NV value = POPn;
2740 SET_NUMERIC_STANDARD();
2741 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2743 XPUSHn(Perl_sqrt(value));
2750 dSP; dTARGET; tryAMAGICun(int);
2752 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2753 /* XXX it's arguable that compiler casting to IV might be subtly
2754 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2755 else preferring IV has introduced a subtle behaviour change bug. OTOH
2756 relying on floating point to be accurate is a bug. */
2760 else if (SvIOK(TOPs)) {
2767 const NV value = TOPn;
2769 if (value < (NV)UV_MAX + 0.5) {
2772 SETn(Perl_floor(value));
2776 if (value > (NV)IV_MIN - 0.5) {
2779 SETn(Perl_ceil(value));
2789 dSP; dTARGET; tryAMAGICun(abs);
2791 /* This will cache the NV value if string isn't actually integer */
2796 else if (SvIOK(TOPs)) {
2797 /* IVX is precise */
2799 SETu(TOPu); /* force it to be numeric only */
2807 /* 2s complement assumption. Also, not really needed as
2808 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2814 const NV value = TOPn;
2829 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2833 SV* const sv = POPs;
2835 tmps = (SvPV_const(sv, len));
2837 /* If Unicode, try to downgrade
2838 * If not possible, croak. */
2839 SV* const tsv = sv_2mortal(newSVsv(sv));
2842 sv_utf8_downgrade(tsv, FALSE);
2843 tmps = SvPV_const(tsv, len);
2845 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2846 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2859 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2863 SV* const sv = POPs;
2865 tmps = (SvPV_const(sv, len));
2867 /* If Unicode, try to downgrade
2868 * If not possible, croak. */
2869 SV* const tsv = sv_2mortal(newSVsv(sv));
2872 sv_utf8_downgrade(tsv, FALSE);
2873 tmps = SvPV_const(tsv, len);
2875 while (*tmps && len && isSPACE(*tmps))
2880 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2881 else if (*tmps == 'b')
2882 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2884 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2886 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2903 SETi(sv_len_utf8(sv));
2919 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2921 const I32 arybase = PL_curcop->cop_arybase;
2923 const char *repl = 0;
2925 const int num_args = PL_op->op_private & 7;
2926 bool repl_need_utf8_upgrade = FALSE;
2927 bool repl_is_utf8 = FALSE;
2929 SvTAINTED_off(TARG); /* decontaminate */
2930 SvUTF8_off(TARG); /* decontaminate */
2934 repl = SvPV_const(repl_sv, repl_len);
2935 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2945 sv_utf8_upgrade(sv);
2947 else if (DO_UTF8(sv))
2948 repl_need_utf8_upgrade = TRUE;
2950 tmps = SvPV_const(sv, curlen);
2952 utf8_curlen = sv_len_utf8(sv);
2953 if (utf8_curlen == curlen)
2956 curlen = utf8_curlen;
2961 if (pos >= arybase) {
2979 else if (len >= 0) {
2981 if (rem > (I32)curlen)
2996 Perl_croak(aTHX_ "substr outside of string");
2997 if (ckWARN(WARN_SUBSTR))
2998 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3002 const I32 upos = pos;
3003 const I32 urem = rem;
3005 sv_pos_u2b(sv, &pos, &rem);
3007 /* we either return a PV or an LV. If the TARG hasn't been used
3008 * before, or is of that type, reuse it; otherwise use a mortal
3009 * instead. Note that LVs can have an extended lifetime, so also
3010 * dont reuse if refcount > 1 (bug #20933) */
3011 if (SvTYPE(TARG) > SVt_NULL) {
3012 if ( (SvTYPE(TARG) == SVt_PVLV)
3013 ? (!lvalue || SvREFCNT(TARG) > 1)
3016 TARG = sv_newmortal();
3020 sv_setpvn(TARG, tmps, rem);
3021 #ifdef USE_LOCALE_COLLATE
3022 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3027 SV* repl_sv_copy = NULL;
3029 if (repl_need_utf8_upgrade) {
3030 repl_sv_copy = newSVsv(repl_sv);
3031 sv_utf8_upgrade(repl_sv_copy);
3032 repl = SvPV_const(repl_sv_copy, repl_len);
3033 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3035 sv_insert(sv, pos, rem, repl, repl_len);
3039 SvREFCNT_dec(repl_sv_copy);
3041 else if (lvalue) { /* it's an lvalue! */
3042 if (!SvGMAGICAL(sv)) {
3044 SvPV_force_nolen(sv);
3045 if (ckWARN(WARN_SUBSTR))
3046 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3047 "Attempt to use reference as lvalue in substr");
3049 if (SvOK(sv)) /* is it defined ? */
3050 (void)SvPOK_only_UTF8(sv);
3052 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3055 if (SvTYPE(TARG) < SVt_PVLV) {
3056 sv_upgrade(TARG, SVt_PVLV);
3057 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3063 if (LvTARG(TARG) != sv) {
3065 SvREFCNT_dec(LvTARG(TARG));
3066 LvTARG(TARG) = SvREFCNT_inc(sv);
3068 LvTARGOFF(TARG) = upos;
3069 LvTARGLEN(TARG) = urem;
3073 PUSHs(TARG); /* avoid SvSETMAGIC here */
3080 register const IV size = POPi;
3081 register const IV offset = POPi;
3082 register SV * const src = POPs;
3083 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3085 SvTAINTED_off(TARG); /* decontaminate */
3086 if (lvalue) { /* it's an lvalue! */
3087 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3088 TARG = sv_newmortal();
3089 if (SvTYPE(TARG) < SVt_PVLV) {
3090 sv_upgrade(TARG, SVt_PVLV);
3091 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3094 if (LvTARG(TARG) != src) {
3096 SvREFCNT_dec(LvTARG(TARG));
3097 LvTARG(TARG) = SvREFCNT_inc(src);
3099 LvTARGOFF(TARG) = offset;
3100 LvTARGLEN(TARG) = size;
3103 sv_setuv(TARG, do_vecget(src, offset, size));
3119 const I32 arybase = PL_curcop->cop_arybase;
3126 offset = POPi - arybase;
3129 big_utf8 = DO_UTF8(big);
3130 little_utf8 = DO_UTF8(little);
3131 if (big_utf8 ^ little_utf8) {
3132 /* One needs to be upgraded. */
3133 SV * const bytes = little_utf8 ? big : little;
3135 const char * const p = SvPV_const(bytes, len);
3137 temp = newSVpvn(p, len);
3140 sv_recode_to_utf8(temp, PL_encoding);
3142 sv_utf8_upgrade(temp);
3151 if (big_utf8 && offset > 0)
3152 sv_pos_u2b(big, &offset, 0);
3153 tmps = SvPV_const(big, biglen);
3156 else if (offset > (I32)biglen)
3158 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3159 (unsigned char*)tmps + biglen, little, 0)))
3162 retval = tmps2 - tmps;
3163 if (retval > 0 && big_utf8)
3164 sv_pos_b2u(big, &retval);
3167 PUSHi(retval + arybase);
3183 const I32 arybase = PL_curcop->cop_arybase;
3191 big_utf8 = DO_UTF8(big);
3192 little_utf8 = DO_UTF8(little);
3193 if (big_utf8 ^ little_utf8) {
3194 /* One needs to be upgraded. */
3195 SV * const bytes = little_utf8 ? big : little;
3197 const char *p = SvPV_const(bytes, len);
3199 temp = newSVpvn(p, len);
3202 sv_recode_to_utf8(temp, PL_encoding);
3204 sv_utf8_upgrade(temp);
3213 tmps2 = SvPV_const(little, llen);
3214 tmps = SvPV_const(big, blen);
3219 if (offset > 0 && big_utf8)
3220 sv_pos_u2b(big, &offset, 0);
3221 offset = offset - arybase + llen;
3225 else if (offset > (I32)blen)
3227 if (!(tmps2 = rninstr(tmps, tmps + offset,
3228 tmps2, tmps2 + llen)))
3231 retval = tmps2 - tmps;
3232 if (retval > 0 && big_utf8)
3233 sv_pos_b2u(big, &retval);
3236 PUSHi(retval + arybase);
3242 dSP; dMARK; dORIGMARK; dTARGET;
3243 do_sprintf(TARG, SP-MARK, MARK+1);
3244 TAINT_IF(SvTAINTED(TARG));
3245 if (DO_UTF8(*(MARK+1)))
3257 const U8 *s = (U8*)SvPV_const(argsv, len);
3260 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3261 tmpsv = sv_2mortal(newSVsv(argsv));
3262 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3266 XPUSHu(DO_UTF8(argsv) ?
3267 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3279 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3281 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3283 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3285 (void) POPs; /* Ignore the argument value. */
3286 value = UNICODE_REPLACEMENT;
3292 SvUPGRADE(TARG,SVt_PV);
3294 if (value > 255 && !IN_BYTES) {
3295 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3296 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3297 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3299 (void)SvPOK_only(TARG);
3308 *tmps++ = (char)value;
3310 (void)SvPOK_only(TARG);
3311 if (PL_encoding && !IN_BYTES) {
3312 sv_recode_to_utf8(TARG, PL_encoding);
3314 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3315 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3319 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3320 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3335 const char *tmps = SvPV_const(left, len);
3337 if (DO_UTF8(left)) {
3338 /* If Unicode, try to downgrade.
3339 * If not possible, croak.
3340 * Yes, we made this up. */
3341 SV* const tsv = sv_2mortal(newSVsv(left));
3344 sv_utf8_downgrade(tsv, FALSE);
3345 tmps = SvPV_const(tsv, len);
3347 # ifdef USE_ITHREADS
3349 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3350 /* This should be threadsafe because in ithreads there is only
3351 * one thread per interpreter. If this would not be true,
3352 * we would need a mutex to protect this malloc. */
3353 PL_reentrant_buffer->_crypt_struct_buffer =
3354 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3355 #if defined(__GLIBC__) || defined(__EMX__)
3356 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3357 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3358 /* work around glibc-2.2.5 bug */
3359 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3363 # endif /* HAS_CRYPT_R */
3364 # endif /* USE_ITHREADS */
3366 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3368 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3374 "The crypt() function is unimplemented due to excessive paranoia.");
3387 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3388 UTF8_IS_START(*s)) {
3389 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3393 utf8_to_uvchr(s, &ulen);
3394 toTITLE_utf8(s, tmpbuf, &tculen);
3395 utf8_to_uvchr(tmpbuf, 0);
3397 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3399 /* slen is the byte length of the whole SV.
3400 * ulen is the byte length of the original Unicode character
3401 * stored as UTF-8 at s.
3402 * tculen is the byte length of the freshly titlecased
3403 * Unicode character stored as UTF-8 at tmpbuf.
3404 * We first set the result to be the titlecased character,
3405 * and then append the rest of the SV data. */
3406 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3408 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3413 s = (U8*)SvPV_force_nomg(sv, slen);
3414 Copy(tmpbuf, s, tculen, U8);
3419 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3421 SvUTF8_off(TARG); /* decontaminate */
3422 sv_setsv_nomg(TARG, sv);
3426 s1 = (U8*)SvPV_force_nomg(sv, slen);
3428 if (IN_LOCALE_RUNTIME) {
3431 *s1 = toUPPER_LC(*s1);
3450 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3451 UTF8_IS_START(*s)) {
3453 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3457 toLOWER_utf8(s, tmpbuf, &ulen);
3458 uv = utf8_to_uvchr(tmpbuf, 0);
3459 tend = uvchr_to_utf8(tmpbuf, uv);
3461 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3463 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3465 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3470 s = (U8*)SvPV_force_nomg(sv, slen);
3471 Copy(tmpbuf, s, ulen, U8);
3476 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3478 SvUTF8_off(TARG); /* decontaminate */
3479 sv_setsv_nomg(TARG, sv);
3483 s1 = (U8*)SvPV_force_nomg(sv, slen);
3485 if (IN_LOCALE_RUNTIME) {
3488 *s1 = toLOWER_LC(*s1);
3511 U8 tmpbuf[UTF8_MAXBYTES+1];
3513 s = (const U8*)SvPV_nomg_const(sv,len);
3515 SvUTF8_off(TARG); /* decontaminate */
3516 sv_setpvn(TARG, "", 0);
3520 STRLEN min = len + 1;
3522 SvUPGRADE(TARG, SVt_PV);
3524 (void)SvPOK_only(TARG);
3525 d = (U8*)SvPVX(TARG);
3528 STRLEN u = UTF8SKIP(s);
3530 toUPPER_utf8(s, tmpbuf, &ulen);
3531 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3532 /* If the eventually required minimum size outgrows
3533 * the available space, we need to grow. */
3534 UV o = d - (U8*)SvPVX_const(TARG);
3536 /* If someone uppercases one million U+03B0s we
3537 * SvGROW() one million times. Or we could try
3538 * guessing how much to allocate without allocating
3539 * too much. Such is life. */
3541 d = (U8*)SvPVX(TARG) + o;
3543 Copy(tmpbuf, d, ulen, U8);
3549 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3555 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3557 SvUTF8_off(TARG); /* decontaminate */
3558 sv_setsv_nomg(TARG, sv);
3562 s = (U8*)SvPV_force_nomg(sv, len);
3564 register const U8 *send = s + len;
3566 if (IN_LOCALE_RUNTIME) {
3569 for (; s < send; s++)
3570 *s = toUPPER_LC(*s);
3573 for (; s < send; s++)
3595 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3597 s = (const U8*)SvPV_nomg_const(sv,len);
3599 SvUTF8_off(TARG); /* decontaminate */
3600 sv_setpvn(TARG, "", 0);
3604 STRLEN min = len + 1;
3606 SvUPGRADE(TARG, SVt_PV);
3608 (void)SvPOK_only(TARG);
3609 d = (U8*)SvPVX(TARG);
3612 const STRLEN u = UTF8SKIP(s);
3613 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3615 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3616 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3618 * Now if the sigma is NOT followed by
3619 * /$ignorable_sequence$cased_letter/;
3620 * and it IS preceded by
3621 * /$cased_letter$ignorable_sequence/;
3622 * where $ignorable_sequence is
3623 * [\x{2010}\x{AD}\p{Mn}]*
3624 * and $cased_letter is
3625 * [\p{Ll}\p{Lo}\p{Lt}]
3626 * then it should be mapped to 0x03C2,
3627 * (GREEK SMALL LETTER FINAL SIGMA),
3628 * instead of staying 0x03A3.
3629 * "should be": in other words,
3630 * this is not implemented yet.
3631 * See lib/unicore/SpecialCasing.txt.
3634 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3635 /* If the eventually required minimum size outgrows
3636 * the available space, we need to grow. */
3637 UV o = d - (U8*)SvPVX_const(TARG);
3639 /* If someone lowercases one million U+0130s we
3640 * SvGROW() one million times. Or we could try
3641 * guessing how much to allocate without allocating.
3642 * too much. Such is life. */
3644 d = (U8*)SvPVX(TARG) + o;
3646 Copy(tmpbuf, d, ulen, U8);
3652 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3658 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3660 SvUTF8_off(TARG); /* decontaminate */
3661 sv_setsv_nomg(TARG, sv);
3666 s = (U8*)SvPV_force_nomg(sv, len);
3668 register const U8 * const send = s + len;
3670 if (IN_LOCALE_RUNTIME) {
3673 for (; s < send; s++)
3674 *s = toLOWER_LC(*s);
3677 for (; s < send; s++)
3689 SV * const sv = TOPs;
3691 register const char *s = SvPV_const(sv,len);
3693 SvUTF8_off(TARG); /* decontaminate */
3696 SvUPGRADE(TARG, SVt_PV);
3697 SvGROW(TARG, (len * 2) + 1);
3701 if (UTF8_IS_CONTINUED(*s)) {
3702 STRLEN ulen = UTF8SKIP(s);
3726 SvCUR_set(TARG, d - SvPVX_const(TARG));
3727 (void)SvPOK_only_UTF8(TARG);
3730 sv_setpvn(TARG, s, len);
3732 if (SvSMAGICAL(TARG))
3741 dSP; dMARK; dORIGMARK;
3742 register AV* const av = (AV*)POPs;
3743 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3745 if (SvTYPE(av) == SVt_PVAV) {
3746 const I32 arybase = PL_curcop->cop_arybase;
3747 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3750 for (svp = MARK + 1; svp <= SP; svp++) {
3751 const I32 elem = SvIVx(*svp);
3755 if (max > AvMAX(av))
3758 while (++MARK <= SP) {
3760 I32 elem = SvIVx(*MARK);
3764 svp = av_fetch(av, elem, lval);
3766 if (!svp || *svp == &PL_sv_undef)
3767 DIE(aTHX_ PL_no_aelem, elem);
3768 if (PL_op->op_private & OPpLVAL_INTRO)
3769 save_aelem(av, elem, svp);
3771 *MARK = svp ? *svp : &PL_sv_undef;
3774 if (GIMME != G_ARRAY) {
3776 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3782 /* Associative arrays. */
3787 HV * const hash = (HV*)POPs;
3789 const I32 gimme = GIMME_V;
3792 /* might clobber stack_sp */
3793 entry = hv_iternext(hash);
3798 SV* const sv = hv_iterkeysv(entry);
3799 PUSHs(sv); /* won't clobber stack_sp */
3800 if (gimme == G_ARRAY) {
3803 /* might clobber stack_sp */
3804 val = hv_iterval(hash, entry);
3809 else if (gimme == G_SCALAR)
3818 const I32 gimme = GIMME_V;
3819 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3821 if (PL_op->op_private & OPpSLICE) {
3823 HV * const hv = (HV*)POPs;
3824 const U32 hvtype = SvTYPE(hv);
3825 if (hvtype == SVt_PVHV) { /* hash element */
3826 while (++MARK <= SP) {
3827 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3828 *MARK = sv ? sv : &PL_sv_undef;
3831 else if (hvtype == SVt_PVAV) { /* array element */
3832 if (PL_op->op_flags & OPf_SPECIAL) {
3833 while (++MARK <= SP) {
3834 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3835 *MARK = sv ? sv : &PL_sv_undef;
3840 DIE(aTHX_ "Not a HASH reference");
3843 else if (gimme == G_SCALAR) {
3848 *++MARK = &PL_sv_undef;
3854 HV * const hv = (HV*)POPs;
3856 if (SvTYPE(hv) == SVt_PVHV)
3857 sv = hv_delete_ent(hv, keysv, discard, 0);
3858 else if (SvTYPE(hv) == SVt_PVAV) {
3859 if (PL_op->op_flags & OPf_SPECIAL)
3860 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3862 DIE(aTHX_ "panic: avhv_delete no longer supported");
3865 DIE(aTHX_ "Not a HASH reference");
3880 if (PL_op->op_private & OPpEXISTS_SUB) {
3883 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3886 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3892 if (SvTYPE(hv) == SVt_PVHV) {
3893 if (hv_exists_ent(hv, tmpsv, 0))
3896 else if (SvTYPE(hv) == SVt_PVAV) {
3897 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3898 if (av_exists((AV*)hv, SvIV(tmpsv)))
3903 DIE(aTHX_ "Not a HASH reference");
3910 dSP; dMARK; dORIGMARK;
3911 register HV * const hv = (HV*)POPs;
3912 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3913 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3914 bool other_magic = FALSE;
3920 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3921 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3922 /* Try to preserve the existenceness of a tied hash
3923 * element by using EXISTS and DELETE if possible.
3924 * Fallback to FETCH and STORE otherwise */
3925 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3926 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3927 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3930 while (++MARK <= SP) {
3931 SV * const keysv = *MARK;
3934 bool preeminent = FALSE;
3937 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3938 hv_exists_ent(hv, keysv, 0);
3941 he = hv_fetch_ent(hv, keysv, lval, 0);
3942 svp = he ? &HeVAL(he) : 0;
3945 if (!svp || *svp == &PL_sv_undef) {
3946 DIE(aTHX_ PL_no_helem_sv, keysv);
3950 save_helem(hv, keysv, svp);
3953 const char *key = SvPV_const(keysv, keylen);
3954 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3958 *MARK = svp ? *svp : &PL_sv_undef;
3960 if (GIMME != G_ARRAY) {
3962 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3968 /* List operators. */
3973 if (GIMME != G_ARRAY) {
3975 *MARK = *SP; /* unwanted list, return last item */
3977 *MARK = &PL_sv_undef;
3986 SV ** const lastrelem = PL_stack_sp;
3987 SV ** const lastlelem = PL_stack_base + POPMARK;
3988 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3989 register SV ** const firstrelem = lastlelem + 1;
3990 const I32 arybase = PL_curcop->cop_arybase;
3991 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3993 register const I32 max = lastrelem - lastlelem;
3994 register SV **lelem;
3996 if (GIMME != G_ARRAY) {
3997 I32 ix = SvIVx(*lastlelem);
4002 if (ix < 0 || ix >= max)
4003 *firstlelem = &PL_sv_undef;
4005 *firstlelem = firstrelem[ix];
4011 SP = firstlelem - 1;
4015 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4016 I32 ix = SvIVx(*lelem);
4021 if (ix < 0 || ix >= max)
4022 *lelem = &PL_sv_undef;
4024 is_something_there = TRUE;
4025 if (!(*lelem = firstrelem[ix]))
4026 *lelem = &PL_sv_undef;
4029 if (is_something_there)
4032 SP = firstlelem - 1;
4038 dSP; dMARK; dORIGMARK;
4039 const I32 items = SP - MARK;
4040 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4041 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4048 dSP; dMARK; dORIGMARK;
4049 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4052 SV * const key = *++MARK;
4053 SV * const val = NEWSV(46, 0);
4055 sv_setsv(val, *++MARK);
4056 else if (ckWARN(WARN_MISC))
4057 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4058 (void)hv_store_ent(hv,key,val,0);
4067 dVAR; dSP; dMARK; dORIGMARK;
4068 register AV *ary = (AV*)*++MARK;
4072 register I32 offset;
4073 register I32 length;
4078 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4081 *MARK-- = SvTIED_obj((SV*)ary, mg);
4085 call_method("SPLICE",GIMME_V);
4094 offset = i = SvIVx(*MARK);
4096 offset += AvFILLp(ary) + 1;
4098 offset -= PL_curcop->cop_arybase;
4100 DIE(aTHX_ PL_no_aelem, i);
4102 length = SvIVx(*MARK++);
4104 length += AvFILLp(ary) - offset + 1;
4110 length = AvMAX(ary) + 1; /* close enough to infinity */
4114 length = AvMAX(ary) + 1;
4116 if (offset > AvFILLp(ary) + 1) {
4117 if (ckWARN(WARN_MISC))
4118 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4119 offset = AvFILLp(ary) + 1;
4121 after = AvFILLp(ary) + 1 - (offset + length);
4122 if (after < 0) { /* not that much array */
4123 length += after; /* offset+length now in array */
4129 /* At this point, MARK .. SP-1 is our new LIST */
4132 diff = newlen - length;
4133 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4136 /* make new elements SVs now: avoid problems if they're from the array */
4137 for (dst = MARK, i = newlen; i; i--) {
4138 SV * const h = *dst;
4139 *dst++ = newSVsv(h);
4142 if (diff < 0) { /* shrinking the area */
4144 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4145 Copy(MARK, tmparyval, newlen, SV*);
4148 MARK = ORIGMARK + 1;
4149 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4150 MEXTEND(MARK, length);
4151 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4153 EXTEND_MORTAL(length);
4154 for (i = length, dst = MARK; i; i--) {
4155 sv_2mortal(*dst); /* free them eventualy */
4162 *MARK = AvARRAY(ary)[offset+length-1];
4165 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4166 SvREFCNT_dec(*dst++); /* free them now */
4169 AvFILLp(ary) += diff;
4171 /* pull up or down? */
4173 if (offset < after) { /* easier to pull up */
4174 if (offset) { /* esp. if nothing to pull */
4175 src = &AvARRAY(ary)[offset-1];
4176 dst = src - diff; /* diff is negative */
4177 for (i = offset; i > 0; i--) /* can't trust Copy */
4181 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4185 if (after) { /* anything to pull down? */
4186 src = AvARRAY(ary) + offset + length;
4187 dst = src + diff; /* diff is negative */
4188 Move(src, dst, after, SV*);
4190 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4191 /* avoid later double free */
4195 dst[--i] = &PL_sv_undef;
4198 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4199 Safefree(tmparyval);
4202 else { /* no, expanding (or same) */
4204 Newx(tmparyval, length, SV*); /* so remember deletion */
4205 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4208 if (diff > 0) { /* expanding */
4210 /* push up or down? */
4212 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4216 Move(src, dst, offset, SV*);
4218 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4220 AvFILLp(ary) += diff;
4223 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4224 av_extend(ary, AvFILLp(ary) + diff);
4225 AvFILLp(ary) += diff;
4228 dst = AvARRAY(ary) + AvFILLp(ary);
4230 for (i = after; i; i--) {
4238 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4241 MARK = ORIGMARK + 1;
4242 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4244 Copy(tmparyval, MARK, length, SV*);
4246 EXTEND_MORTAL(length);
4247 for (i = length, dst = MARK; i; i--) {
4248 sv_2mortal(*dst); /* free them eventualy */
4252 Safefree(tmparyval);
4256 else if (length--) {
4257 *MARK = tmparyval[length];
4260 while (length-- > 0)
4261 SvREFCNT_dec(tmparyval[length]);
4263 Safefree(tmparyval);
4266 *MARK = &PL_sv_undef;
4274 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4275 register AV *ary = (AV*)*++MARK;
4276 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4279 *MARK-- = SvTIED_obj((SV*)ary, mg);
4283 call_method("PUSH",G_SCALAR|G_DISCARD);
4287 PUSHi( AvFILL(ary) + 1 );
4290 for (++MARK; MARK <= SP; MARK++) {
4291 SV * const sv = NEWSV(51, 0);
4293 sv_setsv(sv, *MARK);
4294 av_store(ary, AvFILLp(ary)+1, sv);
4297 PUSHi( AvFILLp(ary) + 1 );
4305 AV * const av = (AV*)POPs;
4306 SV * const sv = av_pop(av);
4308 (void)sv_2mortal(sv);
4316 AV * const av = (AV*)POPs;
4317 SV * const sv = av_shift(av);
4322 (void)sv_2mortal(sv);
4329 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4330 register AV *ary = (AV*)*++MARK;
4331 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4334 *MARK-- = SvTIED_obj((SV*)ary, mg);
4338 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4344 av_unshift(ary, SP - MARK);
4346 SV * const sv = newSVsv(*++MARK);
4347 (void)av_store(ary, i++, sv);
4351 PUSHi( AvFILL(ary) + 1 );
4358 SV ** const oldsp = SP;
4360 if (GIMME == G_ARRAY) {
4363 register SV * const tmp = *MARK;
4367 /* safe as long as stack cannot get extended in the above */
4372 register char *down;
4378 SvUTF8_off(TARG); /* decontaminate */
4380 do_join(TARG, &PL_sv_no, MARK, SP);
4382 sv_setsv(TARG, (SP > MARK)
4384 : (padoff_du = find_rundefsvoffset(),
4385 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4386 ? DEFSV : PAD_SVl(padoff_du)));
4387 up = SvPV_force(TARG, len);
4389 if (DO_UTF8(TARG)) { /* first reverse each character */
4390 U8* s = (U8*)SvPVX(TARG);
4391 const U8* send = (U8*)(s + len);
4393 if (UTF8_IS_INVARIANT(*s)) {
4398 if (!utf8_to_uvchr(s, 0))
4402 down = (char*)(s - 1);
4403 /* reverse this character */
4407 *down-- = (char)tmp;
4413 down = SvPVX(TARG) + len - 1;
4417 *down-- = (char)tmp;
4419 (void)SvPOK_only_UTF8(TARG);
4431 register IV limit = POPi; /* note, negative is forever */
4432 SV * const sv = POPs;
4434 register const char *s = SvPV_const(sv, len);
4435 const bool do_utf8 = DO_UTF8(sv);
4436 const char *strend = s + len;
4438 register REGEXP *rx;
4440 register const char *m;
4442 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4443 I32 maxiters = slen + 10;
4445 const I32 origlimit = limit;
4448 const I32 gimme = GIMME_V;
4449 const I32 oldsave = PL_savestack_ix;
4450 I32 make_mortal = 1;
4452 MAGIC *mg = (MAGIC *) NULL;
4455 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4460 DIE(aTHX_ "panic: pp_split");
4463 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4464 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4466 RX_MATCH_UTF8_set(rx, do_utf8);
4468 if (pm->op_pmreplroot) {
4470 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4472 ary = GvAVn((GV*)pm->op_pmreplroot);
4475 else if (gimme != G_ARRAY)
4476 ary = GvAVn(PL_defgv);
4479 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4485 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4487 XPUSHs(SvTIED_obj((SV*)ary, mg));
4494 for (i = AvFILLp(ary); i >= 0; i--)
4495 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4497 /* temporarily switch stacks */
4498 SAVESWITCHSTACK(PL_curstack, ary);
4502 base = SP - PL_stack_base;
4504 if (pm->op_pmflags & PMf_SKIPWHITE) {
4505 if (pm->op_pmflags & PMf_LOCALE) {
4506 while (isSPACE_LC(*s))
4514 if (pm->op_pmflags & PMf_MULTILINE) {
4519 limit = maxiters + 2;
4520 if (pm->op_pmflags & PMf_WHITE) {
4523 while (m < strend &&
4524 !((pm->op_pmflags & PMf_LOCALE)
4525 ? isSPACE_LC(*m) : isSPACE(*m)))
4530 dstr = newSVpvn(s, m-s);
4534 (void)SvUTF8_on(dstr);
4538 while (s < strend &&
4539 ((pm->op_pmflags & PMf_LOCALE)
4540 ? isSPACE_LC(*s) : isSPACE(*s)))
4544 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4546 for (m = s; m < strend && *m != '\n'; m++)
4551 dstr = newSVpvn(s, m-s);
4555 (void)SvUTF8_on(dstr);
4560 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4561 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4562 && (rx->reganch & ROPT_CHECK_ALL)
4563 && !(rx->reganch & ROPT_ANCH)) {
4564 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4565 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4568 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4569 const char c = *SvPV_nolen_const(csv);
4571 for (m = s; m < strend && *m != c; m++)
4575 dstr = newSVpvn(s, m-s);
4579 (void)SvUTF8_on(dstr);
4581 /* The rx->minlen is in characters but we want to step
4582 * s ahead by bytes. */
4584 s = (char*)utf8_hop((U8*)m, len);
4586 s = m + len; /* Fake \n at the end */
4590 while (s < strend && --limit &&
4591 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4592 csv, multiline ? FBMrf_MULTILINE : 0)) )
4594 dstr = newSVpvn(s, m-s);
4598 (void)SvUTF8_on(dstr);
4600 /* The rx->minlen is in characters but we want to step
4601 * s ahead by bytes. */
4603 s = (char*)utf8_hop((U8*)m, len);
4605 s = m + len; /* Fake \n at the end */
4610 maxiters += slen * rx->nparens;
4611 while (s < strend && --limit)
4615 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4618 if (rex_return == 0)
4620 TAINT_IF(RX_MATCH_TAINTED(rx));
4621 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4626 strend = s + (strend - m);
4628 m = rx->startp[0] + orig;
4629 dstr = newSVpvn(s, m-s);
4633 (void)SvUTF8_on(dstr);
4637 for (i = 1; i <= (I32)rx->nparens; i++) {
4638 s = rx->startp[i] + orig;
4639 m = rx->endp[i] + orig;
4641 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4642 parens that didn't match -- they should be set to
4643 undef, not the empty string */
4644 if (m >= orig && s >= orig) {
4645 dstr = newSVpvn(s, m-s);
4648 dstr = &PL_sv_undef; /* undef, not "" */
4652 (void)SvUTF8_on(dstr);
4656 s = rx->endp[0] + orig;
4660 iters = (SP - PL_stack_base) - base;
4661 if (iters > maxiters)
4662 DIE(aTHX_ "Split loop");
4664 /* keep field after final delim? */
4665 if (s < strend || (iters && origlimit)) {
4666 const STRLEN l = strend - s;
4667 dstr = newSVpvn(s, l);
4671 (void)SvUTF8_on(dstr);
4675 else if (!origlimit) {
4676 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4677 if (TOPs && !make_mortal)
4680 *SP-- = &PL_sv_undef;
4685 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4689 if (SvSMAGICAL(ary)) {
4694 if (gimme == G_ARRAY) {
4696 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4704 call_method("PUSH",G_SCALAR|G_DISCARD);
4707 if (gimme == G_ARRAY) {
4709 /* EXTEND should not be needed - we just popped them */
4711 for (i=0; i < iters; i++) {
4712 SV **svp = av_fetch(ary, i, FALSE);
4713 PUSHs((svp) ? *svp : &PL_sv_undef);
4720 if (gimme == G_ARRAY)
4735 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4736 || SvTYPE(retsv) == SVt_PVCV) {
4737 retsv = refto(retsv);
4744 PP(unimplemented_op)
4746 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4752 * c-indentation-style: bsd
4754 * indent-tabs-mode: t
4757 * ex: set ts=8 sts=4 sw=4 noet: