3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
51 if (GIMME_V == G_SCALAR)
62 if (PL_op->op_private & OPpLVAL_INTRO)
63 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
65 if (PL_op->op_flags & OPf_REF) {
69 if (GIMME == G_SCALAR)
70 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
75 if (gimme == G_ARRAY) {
76 const I32 maxarg = AvFILL((AV*)TARG) + 1;
78 if (SvMAGICAL(TARG)) {
80 for (i=0; i < (U32)maxarg; i++) {
81 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
82 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
86 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
90 else if (gimme == G_SCALAR) {
91 SV* const sv = sv_newmortal();
92 const I32 maxarg = AvFILL((AV*)TARG) + 1;
105 if (PL_op->op_private & OPpLVAL_INTRO)
106 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
107 if (PL_op->op_flags & OPf_REF)
110 if (GIMME == G_SCALAR)
111 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
115 if (gimme == G_ARRAY) {
118 else if (gimme == G_SCALAR) {
119 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
133 tryAMAGICunDEREF(to_gv);
136 if (SvTYPE(sv) == SVt_PVIO) {
137 GV * const gv = (GV*) sv_newmortal();
138 gv_init(gv, 0, "", 0, 0);
139 GvIOp(gv) = (IO *)sv;
140 (void)SvREFCNT_inc(sv);
143 else if (SvTYPE(sv) != SVt_PVGV)
144 DIE(aTHX_ "Not a GLOB reference");
147 if (SvTYPE(sv) != SVt_PVGV) {
148 if (SvGMAGICAL(sv)) {
153 if (!SvOK(sv) && sv != &PL_sv_undef) {
154 /* If this is a 'my' scalar and flag is set then vivify
158 Perl_croak(aTHX_ PL_no_modify);
159 if (PL_op->op_private & OPpDEREF) {
161 if (cUNOP->op_targ) {
163 SV * const namesv = PAD_SV(cUNOP->op_targ);
164 const char * const name = SvPV(namesv, len);
165 gv = (GV*)NEWSV(0,0);
166 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
169 const char * const name = CopSTASHPV(PL_curcop);
172 if (SvTYPE(sv) < SVt_RV)
173 sv_upgrade(sv, SVt_RV);
174 if (SvPVX_const(sv)) {
179 SvRV_set(sv, (SV*)gv);
184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
186 DIE(aTHX_ PL_no_usym, "a symbol");
187 if (ckWARN(WARN_UNINITIALIZED))
191 if ((PL_op->op_flags & OPf_SPECIAL) &&
192 !(PL_op->op_flags & OPf_MOD))
194 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
196 && (!is_gv_magical_sv(sv,0)
197 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
203 if (PL_op->op_private & HINT_STRICT_REFS)
204 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
205 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
206 == OPpDONT_INIT_GV) {
207 /* We are the target of a coderef assignment. Return
208 the scalar unchanged, and let pp_sasssign deal with
212 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
216 if (PL_op->op_private & OPpLVAL_INTRO)
217 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
229 tryAMAGICunDEREF(to_sv);
232 switch (SvTYPE(sv)) {
236 DIE(aTHX_ "Not a SCALAR reference");
242 if (SvTYPE(gv) != SVt_PVGV) {
243 if (SvGMAGICAL(sv)) {
248 if (PL_op->op_private & HINT_STRICT_REFS) {
250 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
252 DIE(aTHX_ PL_no_usym, "a SCALAR");
255 if (PL_op->op_flags & OPf_REF)
256 DIE(aTHX_ PL_no_usym, "a SCALAR");
257 if (ckWARN(WARN_UNINITIALIZED))
261 if ((PL_op->op_flags & OPf_SPECIAL) &&
262 !(PL_op->op_flags & OPf_MOD))
264 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
266 && (!is_gv_magical_sv(sv, 0)
267 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
273 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
278 if (PL_op->op_flags & OPf_MOD) {
279 if (PL_op->op_private & OPpLVAL_INTRO) {
280 if (cUNOP->op_first->op_type == OP_NULL)
281 sv = save_scalar((GV*)TOPs);
283 sv = save_scalar(gv);
285 Perl_croak(aTHX_ PL_no_localize_ref);
287 else if (PL_op->op_private & OPpDEREF)
288 vivify_ref(sv, PL_op->op_private & OPpDEREF);
297 AV * const av = (AV*)TOPs;
298 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
301 sv_upgrade(*sv, SVt_PVMG);
302 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
310 dSP; dTARGET; dPOPss;
312 if (PL_op->op_flags & OPf_MOD || LVRET) {
313 if (SvTYPE(TARG) < SVt_PVLV) {
314 sv_upgrade(TARG, SVt_PVLV);
315 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
319 if (LvTARG(TARG) != sv) {
321 SvREFCNT_dec(LvTARG(TARG));
322 LvTARG(TARG) = SvREFCNT_inc(sv);
324 PUSHs(TARG); /* no SvSETMAGIC */
328 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
329 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
330 if (mg && mg->mg_len >= 0) {
334 PUSHi(i + PL_curcop->cop_arybase);
347 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
349 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
352 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
353 /* (But not in defined().) */
355 CV *cv = sv_2cv(TOPs, &stash, &gv, flags);
358 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
359 if ((PL_op->op_private & OPpLVAL_INTRO)) {
360 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
363 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
366 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
370 cv = (CV*)&PL_sv_undef;
381 SV *ret = &PL_sv_undef;
383 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
384 const char * const s = SvPVX_const(TOPs);
385 if (strnEQ(s, "CORE::", 6)) {
386 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
387 if (code < 0) { /* Overridable. */
388 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
389 int i = 0, n = 0, seen_question = 0;
391 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
393 if (code == -KEY_chop || code == -KEY_chomp
394 || code == -KEY_exec || code == -KEY_system)
396 while (i < MAXO) { /* The slow way. */
397 if (strEQ(s + 6, PL_op_name[i])
398 || strEQ(s + 6, PL_op_desc[i]))
404 goto nonesuch; /* Should not happen... */
406 oa = PL_opargs[i] >> OASHIFT;
408 if (oa & OA_OPTIONAL && !seen_question) {
412 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
413 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
414 /* But globs are already references (kinda) */
415 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
419 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
423 ret = sv_2mortal(newSVpvn(str, n - 1));
425 else if (code) /* Non-Overridable */
427 else { /* None such */
429 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
433 cv = sv_2cv(TOPs, &stash, &gv, 0);
435 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
444 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
446 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
462 if (GIMME != G_ARRAY) {
466 *MARK = &PL_sv_undef;
467 *MARK = refto(*MARK);
471 EXTEND_MORTAL(SP - MARK);
473 *MARK = refto(*MARK);
478 S_refto(pTHX_ SV *sv)
482 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
485 if (!(sv = LvTARG(sv)))
488 (void)SvREFCNT_inc(sv);
490 else if (SvTYPE(sv) == SVt_PVAV) {
491 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
494 (void)SvREFCNT_inc(sv);
496 else if (SvPADTMP(sv) && !IS_PADGV(sv))
500 (void)SvREFCNT_inc(sv);
503 sv_upgrade(rv, SVt_RV);
513 SV * const sv = POPs;
518 if (!sv || !SvROK(sv))
521 pv = sv_reftype(SvRV(sv),TRUE);
522 PUSHp(pv, strlen(pv));
532 stash = CopSTASH(PL_curcop);
534 SV * const ssv = POPs;
538 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
539 Perl_croak(aTHX_ "Attempt to bless into a reference");
540 ptr = SvPV_const(ssv,len);
541 if (len == 0 && ckWARN(WARN_MISC))
542 Perl_warner(aTHX_ packWARN(WARN_MISC),
543 "Explicit blessing to '' (assuming package main)");
544 stash = gv_stashpvn(ptr, len, TRUE);
547 (void)sv_bless(TOPs, stash);
556 const char * const elem = SvPV_nolen_const(sv);
557 GV * const gv = (GV*)POPs;
562 /* elem will always be NUL terminated. */
563 const char * const second_letter = elem + 1;
566 if (strEQ(second_letter, "RRAY"))
567 tmpRef = (SV*)GvAV(gv);
570 if (strEQ(second_letter, "ODE"))
571 tmpRef = (SV*)GvCVu(gv);
574 if (strEQ(second_letter, "ILEHANDLE")) {
575 /* finally deprecated in 5.8.0 */
576 deprecate("*glob{FILEHANDLE}");
577 tmpRef = (SV*)GvIOp(gv);
580 if (strEQ(second_letter, "ORMAT"))
581 tmpRef = (SV*)GvFORM(gv);
584 if (strEQ(second_letter, "LOB"))
588 if (strEQ(second_letter, "ASH"))
589 tmpRef = (SV*)GvHV(gv);
592 if (*second_letter == 'O' && !elem[2])
593 tmpRef = (SV*)GvIOp(gv);
596 if (strEQ(second_letter, "AME"))
597 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
600 if (strEQ(second_letter, "ACKAGE")) {
601 const HEK * const hek = HvNAME_HEK(GvSTASH(gv));
602 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
606 if (strEQ(second_letter, "CALAR"))
621 /* Pattern matching */
626 register unsigned char *s;
629 register I32 *sfirst;
633 if (sv == PL_lastscream) {
639 SvSCREAM_off(PL_lastscream);
640 SvREFCNT_dec(PL_lastscream);
642 PL_lastscream = SvREFCNT_inc(sv);
645 s = (unsigned char*)(SvPV(sv, len));
649 if (pos > PL_maxscream) {
650 if (PL_maxscream < 0) {
651 PL_maxscream = pos + 80;
652 Newx(PL_screamfirst, 256, I32);
653 Newx(PL_screamnext, PL_maxscream, I32);
656 PL_maxscream = pos + pos / 4;
657 Renew(PL_screamnext, PL_maxscream, I32);
661 sfirst = PL_screamfirst;
662 snext = PL_screamnext;
664 if (!sfirst || !snext)
665 DIE(aTHX_ "do_study: out of memory");
667 for (ch = 256; ch; --ch)
672 register const I32 ch = s[pos];
674 snext[pos] = sfirst[ch] - pos;
681 /* piggyback on m//g magic */
682 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
691 if (PL_op->op_flags & OPf_STACKED)
693 else if (PL_op->op_private & OPpTARGET_MY)
699 TARG = sv_newmortal();
704 /* Lvalue operators. */
716 dSP; dMARK; dTARGET; dORIGMARK;
718 do_chop(TARG, *++MARK);
727 SETi(do_chomp(TOPs));
734 register I32 count = 0;
737 count += do_chomp(POPs);
747 if (!PL_op->op_private) {
756 SV_CHECK_THINKFIRST_COW_DROP(sv);
758 switch (SvTYPE(sv)) {
768 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
769 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
770 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
774 /* let user-undef'd sub keep its identity */
775 GV* const gv = CvGV((CV*)sv);
782 SvSetMagicSV(sv, &PL_sv_undef);
787 GvGP(sv) = gp_ref(gp);
788 GvSV(sv) = NEWSV(72,0);
789 GvLINE(sv) = CopLINE(PL_curcop);
795 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
810 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
811 DIE(aTHX_ PL_no_modify);
812 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
813 && SvIVX(TOPs) != IV_MIN)
815 SvIV_set(TOPs, SvIVX(TOPs) - 1);
816 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
827 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
828 DIE(aTHX_ PL_no_modify);
829 sv_setsv(TARG, TOPs);
830 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
831 && SvIVX(TOPs) != IV_MAX)
833 SvIV_set(TOPs, SvIVX(TOPs) + 1);
834 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
839 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
849 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
850 DIE(aTHX_ PL_no_modify);
851 sv_setsv(TARG, TOPs);
852 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
853 && SvIVX(TOPs) != IV_MIN)
855 SvIV_set(TOPs, SvIVX(TOPs) - 1);
856 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
865 /* Ordinary operators. */
870 #ifdef PERL_PRESERVE_IVUV
873 tryAMAGICbin(pow,opASSIGN);
874 #ifdef PERL_PRESERVE_IVUV
875 /* For integer to integer power, we do the calculation by hand wherever
876 we're sure it is safe; otherwise we call pow() and try to convert to
877 integer afterwards. */
890 const IV iv = SvIVX(TOPs);
894 goto float_it; /* Can't do negative powers this way. */
898 baseuok = SvUOK(TOPm1s);
900 baseuv = SvUVX(TOPm1s);
902 const IV iv = SvIVX(TOPm1s);
905 baseuok = TRUE; /* effectively it's a UV now */
907 baseuv = -iv; /* abs, baseuok == false records sign */
910 /* now we have integer ** positive integer. */
913 /* foo & (foo - 1) is zero only for a power of 2. */
914 if (!(baseuv & (baseuv - 1))) {
915 /* We are raising power-of-2 to a positive integer.
916 The logic here will work for any base (even non-integer
917 bases) but it can be less accurate than
918 pow (base,power) or exp (power * log (base)) when the
919 intermediate values start to spill out of the mantissa.
920 With powers of 2 we know this can't happen.
921 And powers of 2 are the favourite thing for perl
922 programmers to notice ** not doing what they mean. */
924 NV base = baseuok ? baseuv : -(NV)baseuv;
929 while (power >>= 1) {
940 register unsigned int highbit = 8 * sizeof(UV);
941 register unsigned int diff = 8 * sizeof(UV);
944 if (baseuv >> highbit) {
948 /* we now have baseuv < 2 ** highbit */
949 if (power * highbit <= 8 * sizeof(UV)) {
950 /* result will definitely fit in UV, so use UV math
951 on same algorithm as above */
952 register UV result = 1;
953 register UV base = baseuv;
954 const bool odd_power = (bool)(power & 1);
958 while (power >>= 1) {
965 if (baseuok || !odd_power)
966 /* answer is positive */
968 else if (result <= (UV)IV_MAX)
969 /* answer negative, fits in IV */
971 else if (result == (UV)IV_MIN)
972 /* 2's complement assumption: special case IV_MIN */
975 /* answer negative, doesn't fit */
987 SETn( Perl_pow( left, right) );
988 #ifdef PERL_PRESERVE_IVUV
998 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
999 #ifdef PERL_PRESERVE_IVUV
1002 /* Unless the left argument is integer in range we are going to have to
1003 use NV maths. Hence only attempt to coerce the right argument if
1004 we know the left is integer. */
1005 /* Left operand is defined, so is it IV? */
1006 SvIV_please(TOPm1s);
1007 if (SvIOK(TOPm1s)) {
1008 bool auvok = SvUOK(TOPm1s);
1009 bool buvok = SvUOK(TOPs);
1010 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1011 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1018 alow = SvUVX(TOPm1s);
1020 const IV aiv = SvIVX(TOPm1s);
1023 auvok = TRUE; /* effectively it's a UV now */
1025 alow = -aiv; /* abs, auvok == false records sign */
1031 const IV biv = SvIVX(TOPs);
1034 buvok = TRUE; /* effectively it's a UV now */
1036 blow = -biv; /* abs, buvok == false records sign */
1040 /* If this does sign extension on unsigned it's time for plan B */
1041 ahigh = alow >> (4 * sizeof (UV));
1043 bhigh = blow >> (4 * sizeof (UV));
1045 if (ahigh && bhigh) {
1046 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1047 which is overflow. Drop to NVs below. */
1048 } else if (!ahigh && !bhigh) {
1049 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1050 so the unsigned multiply cannot overflow. */
1051 const UV product = alow * blow;
1052 if (auvok == buvok) {
1053 /* -ve * -ve or +ve * +ve gives a +ve result. */
1057 } else if (product <= (UV)IV_MIN) {
1058 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1059 /* -ve result, which could overflow an IV */
1061 SETi( -(IV)product );
1063 } /* else drop to NVs below. */
1065 /* One operand is large, 1 small */
1068 /* swap the operands */
1070 bhigh = blow; /* bhigh now the temp var for the swap */
1074 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1075 multiplies can't overflow. shift can, add can, -ve can. */
1076 product_middle = ahigh * blow;
1077 if (!(product_middle & topmask)) {
1078 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1080 product_middle <<= (4 * sizeof (UV));
1081 product_low = alow * blow;
1083 /* as for pp_add, UV + something mustn't get smaller.
1084 IIRC ANSI mandates this wrapping *behaviour* for
1085 unsigned whatever the actual representation*/
1086 product_low += product_middle;
1087 if (product_low >= product_middle) {
1088 /* didn't overflow */
1089 if (auvok == buvok) {
1090 /* -ve * -ve or +ve * +ve gives a +ve result. */
1092 SETu( product_low );
1094 } else if (product_low <= (UV)IV_MIN) {
1095 /* 2s complement assumption again */
1096 /* -ve result, which could overflow an IV */
1098 SETi( -(IV)product_low );
1100 } /* else drop to NVs below. */
1102 } /* product_middle too large */
1103 } /* ahigh && bhigh */
1104 } /* SvIOK(TOPm1s) */
1109 SETn( left * right );
1116 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1117 /* Only try to do UV divide first
1118 if ((SLOPPYDIVIDE is true) or
1119 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1121 The assumption is that it is better to use floating point divide
1122 whenever possible, only doing integer divide first if we can't be sure.
1123 If NV_PRESERVES_UV is true then we know at compile time that no UV
1124 can be too large to preserve, so don't need to compile the code to
1125 test the size of UVs. */
1128 # define PERL_TRY_UV_DIVIDE
1129 /* ensure that 20./5. == 4. */
1131 # ifdef PERL_PRESERVE_IVUV
1132 # ifndef NV_PRESERVES_UV
1133 # define PERL_TRY_UV_DIVIDE
1138 #ifdef PERL_TRY_UV_DIVIDE
1141 SvIV_please(TOPm1s);
1142 if (SvIOK(TOPm1s)) {
1143 bool left_non_neg = SvUOK(TOPm1s);
1144 bool right_non_neg = SvUOK(TOPs);
1148 if (right_non_neg) {
1149 right = SvUVX(TOPs);
1152 const IV biv = SvIVX(TOPs);
1155 right_non_neg = TRUE; /* effectively it's a UV now */
1161 /* historically undef()/0 gives a "Use of uninitialized value"
1162 warning before dieing, hence this test goes here.
1163 If it were immediately before the second SvIV_please, then
1164 DIE() would be invoked before left was even inspected, so
1165 no inpsection would give no warning. */
1167 DIE(aTHX_ "Illegal division by zero");
1170 left = SvUVX(TOPm1s);
1173 const IV aiv = SvIVX(TOPm1s);
1176 left_non_neg = TRUE; /* effectively it's a UV now */
1185 /* For sloppy divide we always attempt integer division. */
1187 /* Otherwise we only attempt it if either or both operands
1188 would not be preserved by an NV. If both fit in NVs
1189 we fall through to the NV divide code below. However,
1190 as left >= right to ensure integer result here, we know that
1191 we can skip the test on the right operand - right big
1192 enough not to be preserved can't get here unless left is
1195 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1198 /* Integer division can't overflow, but it can be imprecise. */
1199 const UV result = left / right;
1200 if (result * right == left) {
1201 SP--; /* result is valid */
1202 if (left_non_neg == right_non_neg) {
1203 /* signs identical, result is positive. */
1207 /* 2s complement assumption */
1208 if (result <= (UV)IV_MIN)
1209 SETi( -(IV)result );
1211 /* It's exact but too negative for IV. */
1212 SETn( -(NV)result );
1215 } /* tried integer divide but it was not an integer result */
1216 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1217 } /* left wasn't SvIOK */
1218 } /* right wasn't SvIOK */
1219 #endif /* PERL_TRY_UV_DIVIDE */
1223 DIE(aTHX_ "Illegal division by zero");
1224 PUSHn( left / right );
1231 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1235 bool left_neg = FALSE;
1236 bool right_neg = FALSE;
1237 bool use_double = FALSE;
1238 bool dright_valid = FALSE;
1244 right_neg = !SvUOK(TOPs);
1246 right = SvUVX(POPs);
1248 const IV biv = SvIVX(POPs);
1251 right_neg = FALSE; /* effectively it's a UV now */
1259 right_neg = dright < 0;
1262 if (dright < UV_MAX_P1) {
1263 right = U_V(dright);
1264 dright_valid = TRUE; /* In case we need to use double below. */
1270 /* At this point use_double is only true if right is out of range for
1271 a UV. In range NV has been rounded down to nearest UV and
1272 use_double false. */
1274 if (!use_double && SvIOK(TOPs)) {
1276 left_neg = !SvUOK(TOPs);
1280 const IV aiv = SvIVX(POPs);
1283 left_neg = FALSE; /* effectively it's a UV now */
1292 left_neg = dleft < 0;
1296 /* This should be exactly the 5.6 behaviour - if left and right are
1297 both in range for UV then use U_V() rather than floor. */
1299 if (dleft < UV_MAX_P1) {
1300 /* right was in range, so is dleft, so use UVs not double.
1304 /* left is out of range for UV, right was in range, so promote
1305 right (back) to double. */
1307 /* The +0.5 is used in 5.6 even though it is not strictly
1308 consistent with the implicit +0 floor in the U_V()
1309 inside the #if 1. */
1310 dleft = Perl_floor(dleft + 0.5);
1313 dright = Perl_floor(dright + 0.5);
1323 DIE(aTHX_ "Illegal modulus zero");
1325 dans = Perl_fmod(dleft, dright);
1326 if ((left_neg != right_neg) && dans)
1327 dans = dright - dans;
1330 sv_setnv(TARG, dans);
1336 DIE(aTHX_ "Illegal modulus zero");
1339 if ((left_neg != right_neg) && ans)
1342 /* XXX may warn: unary minus operator applied to unsigned type */
1343 /* could change -foo to be (~foo)+1 instead */
1344 if (ans <= ~((UV)IV_MAX)+1)
1345 sv_setiv(TARG, ~ans+1);
1347 sv_setnv(TARG, -(NV)ans);
1350 sv_setuv(TARG, ans);
1359 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1366 const UV uv = SvUV(sv);
1368 count = IV_MAX; /* The best we can do? */
1372 const IV iv = SvIV(sv);
1379 else if (SvNOKp(sv)) {
1380 const NV nv = SvNV(sv);
1388 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1390 static const char oom_list_extend[] = "Out of memory during list extend";
1391 const I32 items = SP - MARK;
1392 const I32 max = items * count;
1394 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1395 /* Did the max computation overflow? */
1396 if (items > 0 && max > 0 && (max < items || max < count))
1397 Perl_croak(aTHX_ oom_list_extend);
1402 /* This code was intended to fix 20010809.028:
1405 for (($x =~ /./g) x 2) {
1406 print chop; # "abcdabcd" expected as output.
1409 * but that change (#11635) broke this code:
1411 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1413 * I can't think of a better fix that doesn't introduce
1414 * an efficiency hit by copying the SVs. The stack isn't
1415 * refcounted, and mortalisation obviously doesn't
1416 * Do The Right Thing when the stack has more than
1417 * one pointer to the same mortal value.
1421 *SP = sv_2mortal(newSVsv(*SP));
1431 repeatcpy((char*)(MARK + items), (char*)MARK,
1432 items * sizeof(SV*), count - 1);
1435 else if (count <= 0)
1438 else { /* Note: mark already snarfed by pp_list */
1439 SV * const tmpstr = POPs;
1442 static const char oom_string_extend[] =
1443 "Out of memory during string extend";
1445 SvSetSV(TARG, tmpstr);
1446 SvPV_force(TARG, len);
1447 isutf = DO_UTF8(TARG);
1452 const STRLEN max = (UV)count * len;
1453 if (len > ((MEM_SIZE)~0)/count)
1454 Perl_croak(aTHX_ oom_string_extend);
1455 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1456 SvGROW(TARG, max + 1);
1457 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1458 SvCUR_set(TARG, SvCUR(TARG) * count);
1460 *SvEND(TARG) = '\0';
1463 (void)SvPOK_only_UTF8(TARG);
1465 (void)SvPOK_only(TARG);
1467 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1468 /* The parser saw this as a list repeat, and there
1469 are probably several items on the stack. But we're
1470 in scalar context, and there's no pp_list to save us
1471 now. So drop the rest of the items -- robin@kitsite.com
1484 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1485 useleft = USE_LEFT(TOPm1s);
1486 #ifdef PERL_PRESERVE_IVUV
1487 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1488 "bad things" happen if you rely on signed integers wrapping. */
1491 /* Unless the left argument is integer in range we are going to have to
1492 use NV maths. Hence only attempt to coerce the right argument if
1493 we know the left is integer. */
1494 register UV auv = 0;
1500 a_valid = auvok = 1;
1501 /* left operand is undef, treat as zero. */
1503 /* Left operand is defined, so is it IV? */
1504 SvIV_please(TOPm1s);
1505 if (SvIOK(TOPm1s)) {
1506 if ((auvok = SvUOK(TOPm1s)))
1507 auv = SvUVX(TOPm1s);
1509 register const IV aiv = SvIVX(TOPm1s);
1512 auvok = 1; /* Now acting as a sign flag. */
1513 } else { /* 2s complement assumption for IV_MIN */
1521 bool result_good = 0;
1524 bool buvok = SvUOK(TOPs);
1529 register const IV biv = SvIVX(TOPs);
1536 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1537 else "IV" now, independent of how it came in.
1538 if a, b represents positive, A, B negative, a maps to -A etc
1543 all UV maths. negate result if A negative.
1544 subtract if signs same, add if signs differ. */
1546 if (auvok ^ buvok) {
1555 /* Must get smaller */
1560 if (result <= buv) {
1561 /* result really should be -(auv-buv). as its negation
1562 of true value, need to swap our result flag */
1574 if (result <= (UV)IV_MIN)
1575 SETi( -(IV)result );
1577 /* result valid, but out of range for IV. */
1578 SETn( -(NV)result );
1582 } /* Overflow, drop through to NVs. */
1586 useleft = USE_LEFT(TOPm1s);
1590 /* left operand is undef, treat as zero - value */
1594 SETn( TOPn - value );
1601 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1603 const IV shift = POPi;
1604 if (PL_op->op_private & HINT_INTEGER) {
1618 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1620 const IV shift = POPi;
1621 if (PL_op->op_private & HINT_INTEGER) {
1635 dSP; tryAMAGICbinSET(lt,0);
1636 #ifdef PERL_PRESERVE_IVUV
1639 SvIV_please(TOPm1s);
1640 if (SvIOK(TOPm1s)) {
1641 bool auvok = SvUOK(TOPm1s);
1642 bool buvok = SvUOK(TOPs);
1644 if (!auvok && !buvok) { /* ## IV < IV ## */
1645 const IV aiv = SvIVX(TOPm1s);
1646 const IV biv = SvIVX(TOPs);
1649 SETs(boolSV(aiv < biv));
1652 if (auvok && buvok) { /* ## UV < UV ## */
1653 const UV auv = SvUVX(TOPm1s);
1654 const UV buv = SvUVX(TOPs);
1657 SETs(boolSV(auv < buv));
1660 if (auvok) { /* ## UV < IV ## */
1662 const IV biv = SvIVX(TOPs);
1665 /* As (a) is a UV, it's >=0, so it cannot be < */
1670 SETs(boolSV(auv < (UV)biv));
1673 { /* ## IV < UV ## */
1674 const IV aiv = SvIVX(TOPm1s);
1678 /* As (b) is a UV, it's >=0, so it must be < */
1685 SETs(boolSV((UV)aiv < buv));
1691 #ifndef NV_PRESERVES_UV
1692 #ifdef PERL_PRESERVE_IVUV
1695 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1697 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1703 SETs(boolSV(TOPn < value));
1710 dSP; tryAMAGICbinSET(gt,0);
1711 #ifdef PERL_PRESERVE_IVUV
1714 SvIV_please(TOPm1s);
1715 if (SvIOK(TOPm1s)) {
1716 bool auvok = SvUOK(TOPm1s);
1717 bool buvok = SvUOK(TOPs);
1719 if (!auvok && !buvok) { /* ## IV > IV ## */
1720 const IV aiv = SvIVX(TOPm1s);
1721 const IV biv = SvIVX(TOPs);
1724 SETs(boolSV(aiv > biv));
1727 if (auvok && buvok) { /* ## UV > UV ## */
1728 const UV auv = SvUVX(TOPm1s);
1729 const UV buv = SvUVX(TOPs);
1732 SETs(boolSV(auv > buv));
1735 if (auvok) { /* ## UV > IV ## */
1737 const IV biv = SvIVX(TOPs);
1741 /* As (a) is a UV, it's >=0, so it must be > */
1746 SETs(boolSV(auv > (UV)biv));
1749 { /* ## IV > UV ## */
1750 const IV aiv = SvIVX(TOPm1s);
1754 /* As (b) is a UV, it's >=0, so it cannot be > */
1761 SETs(boolSV((UV)aiv > buv));
1767 #ifndef NV_PRESERVES_UV
1768 #ifdef PERL_PRESERVE_IVUV
1771 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1773 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1779 SETs(boolSV(TOPn > value));
1786 dSP; tryAMAGICbinSET(le,0);
1787 #ifdef PERL_PRESERVE_IVUV
1790 SvIV_please(TOPm1s);
1791 if (SvIOK(TOPm1s)) {
1792 bool auvok = SvUOK(TOPm1s);
1793 bool buvok = SvUOK(TOPs);
1795 if (!auvok && !buvok) { /* ## IV <= IV ## */
1796 const IV aiv = SvIVX(TOPm1s);
1797 const IV biv = SvIVX(TOPs);
1800 SETs(boolSV(aiv <= biv));
1803 if (auvok && buvok) { /* ## UV <= UV ## */
1804 UV auv = SvUVX(TOPm1s);
1805 UV buv = SvUVX(TOPs);
1808 SETs(boolSV(auv <= buv));
1811 if (auvok) { /* ## UV <= IV ## */
1813 const IV biv = SvIVX(TOPs);
1817 /* As (a) is a UV, it's >=0, so a cannot be <= */
1822 SETs(boolSV(auv <= (UV)biv));
1825 { /* ## IV <= UV ## */
1826 const IV aiv = SvIVX(TOPm1s);
1830 /* As (b) is a UV, it's >=0, so a must be <= */
1837 SETs(boolSV((UV)aiv <= buv));
1843 #ifndef NV_PRESERVES_UV
1844 #ifdef PERL_PRESERVE_IVUV
1847 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1849 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1855 SETs(boolSV(TOPn <= value));
1862 dSP; tryAMAGICbinSET(ge,0);
1863 #ifdef PERL_PRESERVE_IVUV
1866 SvIV_please(TOPm1s);
1867 if (SvIOK(TOPm1s)) {
1868 bool auvok = SvUOK(TOPm1s);
1869 bool buvok = SvUOK(TOPs);
1871 if (!auvok && !buvok) { /* ## IV >= IV ## */
1872 const IV aiv = SvIVX(TOPm1s);
1873 const IV biv = SvIVX(TOPs);
1876 SETs(boolSV(aiv >= biv));
1879 if (auvok && buvok) { /* ## UV >= UV ## */
1880 const UV auv = SvUVX(TOPm1s);
1881 const UV buv = SvUVX(TOPs);
1884 SETs(boolSV(auv >= buv));
1887 if (auvok) { /* ## UV >= IV ## */
1889 const IV biv = SvIVX(TOPs);
1893 /* As (a) is a UV, it's >=0, so it must be >= */
1898 SETs(boolSV(auv >= (UV)biv));
1901 { /* ## IV >= UV ## */
1902 const IV aiv = SvIVX(TOPm1s);
1906 /* As (b) is a UV, it's >=0, so a cannot be >= */
1913 SETs(boolSV((UV)aiv >= buv));
1919 #ifndef NV_PRESERVES_UV
1920 #ifdef PERL_PRESERVE_IVUV
1923 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1925 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1931 SETs(boolSV(TOPn >= value));
1938 dSP; tryAMAGICbinSET(ne,0);
1939 #ifndef NV_PRESERVES_UV
1940 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1942 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1946 #ifdef PERL_PRESERVE_IVUV
1949 SvIV_please(TOPm1s);
1950 if (SvIOK(TOPm1s)) {
1951 const bool auvok = SvUOK(TOPm1s);
1952 const bool buvok = SvUOK(TOPs);
1954 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1955 /* Casting IV to UV before comparison isn't going to matter
1956 on 2s complement. On 1s complement or sign&magnitude
1957 (if we have any of them) it could make negative zero
1958 differ from normal zero. As I understand it. (Need to
1959 check - is negative zero implementation defined behaviour
1961 const UV buv = SvUVX(POPs);
1962 const UV auv = SvUVX(TOPs);
1964 SETs(boolSV(auv != buv));
1967 { /* ## Mixed IV,UV ## */
1971 /* != is commutative so swap if needed (save code) */
1973 /* swap. top of stack (b) is the iv */
1977 /* As (a) is a UV, it's >0, so it cannot be == */
1986 /* As (b) is a UV, it's >0, so it cannot be == */
1990 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1992 SETs(boolSV((UV)iv != uv));
2000 SETs(boolSV(TOPn != value));
2007 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2008 #ifndef NV_PRESERVES_UV
2009 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2010 const UV right = PTR2UV(SvRV(POPs));
2011 const UV left = PTR2UV(SvRV(TOPs));
2012 SETi((left > right) - (left < right));
2016 #ifdef PERL_PRESERVE_IVUV
2017 /* Fortunately it seems NaN isn't IOK */
2020 SvIV_please(TOPm1s);
2021 if (SvIOK(TOPm1s)) {
2022 const bool leftuvok = SvUOK(TOPm1s);
2023 const bool rightuvok = SvUOK(TOPs);
2025 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2026 const IV leftiv = SvIVX(TOPm1s);
2027 const IV rightiv = SvIVX(TOPs);
2029 if (leftiv > rightiv)
2031 else if (leftiv < rightiv)
2035 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2036 const UV leftuv = SvUVX(TOPm1s);
2037 const UV rightuv = SvUVX(TOPs);
2039 if (leftuv > rightuv)
2041 else if (leftuv < rightuv)
2045 } else if (leftuvok) { /* ## UV <=> IV ## */
2046 const IV rightiv = SvIVX(TOPs);
2048 /* As (a) is a UV, it's >=0, so it cannot be < */
2051 const UV leftuv = SvUVX(TOPm1s);
2052 if (leftuv > (UV)rightiv) {
2054 } else if (leftuv < (UV)rightiv) {
2060 } else { /* ## IV <=> UV ## */
2061 const IV leftiv = SvIVX(TOPm1s);
2063 /* As (b) is a UV, it's >=0, so it must be < */
2066 const UV rightuv = SvUVX(TOPs);
2067 if ((UV)leftiv > rightuv) {
2069 } else if ((UV)leftiv < rightuv) {
2087 if (Perl_isnan(left) || Perl_isnan(right)) {
2091 value = (left > right) - (left < right);
2095 else if (left < right)
2097 else if (left > right)
2113 int amg_type = sle_amg;
2117 switch (PL_op->op_type) {
2136 tryAMAGICbinSET_var(amg_type,0);
2139 const int cmp = (IN_LOCALE_RUNTIME
2140 ? sv_cmp_locale(left, right)
2141 : sv_cmp(left, right));
2142 SETs(boolSV(cmp * multiplier < rhs));
2149 dSP; tryAMAGICbinSET(seq,0);
2152 SETs(boolSV(sv_eq(left, right)));
2159 dSP; tryAMAGICbinSET(sne,0);
2162 SETs(boolSV(!sv_eq(left, right)));
2169 dSP; dTARGET; tryAMAGICbin(scmp,0);
2172 const int cmp = (IN_LOCALE_RUNTIME
2173 ? sv_cmp_locale(left, right)
2174 : sv_cmp(left, right));
2182 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2187 if (SvNIOKp(left) || SvNIOKp(right)) {
2188 if (PL_op->op_private & HINT_INTEGER) {
2189 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2193 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2198 do_vop(PL_op->op_type, TARG, left, right);
2207 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2212 if (SvNIOKp(left) || SvNIOKp(right)) {
2213 if (PL_op->op_private & HINT_INTEGER) {
2214 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2218 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2223 do_vop(PL_op->op_type, TARG, left, right);
2232 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2237 if (SvNIOKp(left) || SvNIOKp(right)) {
2238 if (PL_op->op_private & HINT_INTEGER) {
2239 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2243 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2248 do_vop(PL_op->op_type, TARG, left, right);
2257 dSP; dTARGET; tryAMAGICun(neg);
2260 const int flags = SvFLAGS(sv);
2262 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2263 /* It's publicly an integer, or privately an integer-not-float */
2266 if (SvIVX(sv) == IV_MIN) {
2267 /* 2s complement assumption. */
2268 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2271 else if (SvUVX(sv) <= IV_MAX) {
2276 else if (SvIVX(sv) != IV_MIN) {
2280 #ifdef PERL_PRESERVE_IVUV
2289 else if (SvPOKp(sv)) {
2291 const char * const s = SvPV_const(sv, len);
2292 if (isIDFIRST(*s)) {
2293 sv_setpvn(TARG, "-", 1);
2296 else if (*s == '+' || *s == '-') {
2298 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2300 else if (DO_UTF8(sv)) {
2303 goto oops_its_an_int;
2305 sv_setnv(TARG, -SvNV(sv));
2307 sv_setpvn(TARG, "-", 1);
2314 goto oops_its_an_int;
2315 sv_setnv(TARG, -SvNV(sv));
2327 dSP; tryAMAGICunSET(not);
2328 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2334 dSP; dTARGET; tryAMAGICun(compl);
2339 if (PL_op->op_private & HINT_INTEGER) {
2340 const IV i = ~SvIV_nomg(sv);
2344 const UV u = ~SvUV_nomg(sv);
2353 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2354 sv_setsv_nomg(TARG, sv);
2355 tmps = (U8*)SvPV_force(TARG, len);
2358 /* Calculate exact length, let's not estimate. */
2367 while (tmps < send) {
2368 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2369 tmps += UTF8SKIP(tmps);
2370 targlen += UNISKIP(~c);
2376 /* Now rewind strings and write them. */
2380 Newxz(result, targlen + 1, U8);
2381 while (tmps < send) {
2382 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2383 tmps += UTF8SKIP(tmps);
2384 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2388 sv_setpvn(TARG, (char*)result, targlen);
2392 Newxz(result, nchar + 1, U8);
2393 while (tmps < send) {
2394 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2395 tmps += UTF8SKIP(tmps);
2400 sv_setpvn(TARG, (char*)result, nchar);
2409 register long *tmpl;
2410 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2413 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2418 for ( ; anum > 0; anum--, tmps++)
2427 /* integer versions of some of the above */
2431 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2434 SETi( left * right );
2441 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2445 DIE(aTHX_ "Illegal division by zero");
2446 value = POPi / value;
2455 /* This is the vanilla old i_modulo. */
2456 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2460 DIE(aTHX_ "Illegal modulus zero");
2461 SETi( left % right );
2466 #if defined(__GLIBC__) && IVSIZE == 8
2470 /* This is the i_modulo with the workaround for the _moddi3 bug
2471 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2472 * See below for pp_i_modulo. */
2473 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2477 DIE(aTHX_ "Illegal modulus zero");
2478 SETi( left % PERL_ABS(right) );
2486 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2490 DIE(aTHX_ "Illegal modulus zero");
2491 /* The assumption is to use hereafter the old vanilla version... */
2493 PL_ppaddr[OP_I_MODULO] =
2495 /* .. but if we have glibc, we might have a buggy _moddi3
2496 * (at least glicb 2.2.5 is known to have this bug), in other
2497 * words our integer modulus with negative quad as the second
2498 * argument might be broken. Test for this and re-patch the
2499 * opcode dispatch table if that is the case, remembering to
2500 * also apply the workaround so that this first round works
2501 * right, too. See [perl #9402] for more information. */
2502 #if defined(__GLIBC__) && IVSIZE == 8
2506 /* Cannot do this check with inlined IV constants since
2507 * that seems to work correctly even with the buggy glibc. */
2509 /* Yikes, we have the bug.
2510 * Patch in the workaround version. */
2512 PL_ppaddr[OP_I_MODULO] =
2513 &Perl_pp_i_modulo_1;
2514 /* Make certain we work right this time, too. */
2515 right = PERL_ABS(right);
2519 SETi( left % right );
2526 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2529 SETi( left + right );
2536 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2539 SETi( left - right );
2546 dSP; tryAMAGICbinSET(lt,0);
2549 SETs(boolSV(left < right));
2556 dSP; tryAMAGICbinSET(gt,0);
2559 SETs(boolSV(left > right));
2566 dSP; tryAMAGICbinSET(le,0);
2569 SETs(boolSV(left <= right));
2576 dSP; tryAMAGICbinSET(ge,0);
2579 SETs(boolSV(left >= right));
2586 dSP; tryAMAGICbinSET(eq,0);
2589 SETs(boolSV(left == right));
2596 dSP; tryAMAGICbinSET(ne,0);
2599 SETs(boolSV(left != right));
2606 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2613 else if (left < right)
2624 dSP; dTARGET; tryAMAGICun(neg);
2629 /* High falutin' math. */
2633 dSP; dTARGET; tryAMAGICbin(atan2,0);
2636 SETn(Perl_atan2(left, right));
2643 dSP; dTARGET; tryAMAGICun(sin);
2645 const NV value = POPn;
2646 XPUSHn(Perl_sin(value));
2653 dSP; dTARGET; tryAMAGICun(cos);
2655 const NV value = POPn;
2656 XPUSHn(Perl_cos(value));
2661 /* Support Configure command-line overrides for rand() functions.
2662 After 5.005, perhaps we should replace this by Configure support
2663 for drand48(), random(), or rand(). For 5.005, though, maintain
2664 compatibility by calling rand() but allow the user to override it.
2665 See INSTALL for details. --Andy Dougherty 15 July 1998
2667 /* Now it's after 5.005, and Configure supports drand48() and random(),
2668 in addition to rand(). So the overrides should not be needed any more.
2669 --Jarkko Hietaniemi 27 September 1998
2672 #ifndef HAS_DRAND48_PROTO
2673 extern double drand48 (void);
2686 if (!PL_srand_called) {
2687 (void)seedDrand01((Rand_seed_t)seed());
2688 PL_srand_called = TRUE;
2698 const UV anum = (MAXARG < 1) ? seed() : POPu;
2699 (void)seedDrand01((Rand_seed_t)anum);
2700 PL_srand_called = TRUE;
2707 dSP; dTARGET; tryAMAGICun(exp);
2711 value = Perl_exp(value);
2719 dSP; dTARGET; tryAMAGICun(log);
2721 const NV value = POPn;
2723 SET_NUMERIC_STANDARD();
2724 DIE(aTHX_ "Can't take log of %"NVgf, value);
2726 XPUSHn(Perl_log(value));
2733 dSP; dTARGET; tryAMAGICun(sqrt);
2735 const NV value = POPn;
2737 SET_NUMERIC_STANDARD();
2738 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2740 XPUSHn(Perl_sqrt(value));
2747 dSP; dTARGET; tryAMAGICun(int);
2749 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2750 /* XXX it's arguable that compiler casting to IV might be subtly
2751 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2752 else preferring IV has introduced a subtle behaviour change bug. OTOH
2753 relying on floating point to be accurate is a bug. */
2757 else if (SvIOK(TOPs)) {
2764 const NV value = TOPn;
2766 if (value < (NV)UV_MAX + 0.5) {
2769 SETn(Perl_floor(value));
2773 if (value > (NV)IV_MIN - 0.5) {
2776 SETn(Perl_ceil(value));
2786 dSP; dTARGET; tryAMAGICun(abs);
2788 /* This will cache the NV value if string isn't actually integer */
2793 else if (SvIOK(TOPs)) {
2794 /* IVX is precise */
2796 SETu(TOPu); /* force it to be numeric only */
2804 /* 2s complement assumption. Also, not really needed as
2805 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2811 const NV value = TOPn;
2826 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2830 SV* const sv = POPs;
2832 tmps = (SvPV_const(sv, len));
2834 /* If Unicode, try to downgrade
2835 * If not possible, croak. */
2836 SV* const tsv = sv_2mortal(newSVsv(sv));
2839 sv_utf8_downgrade(tsv, FALSE);
2840 tmps = SvPV_const(tsv, len);
2842 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2843 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2856 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2860 SV* const sv = POPs;
2862 tmps = (SvPV_const(sv, len));
2864 /* If Unicode, try to downgrade
2865 * If not possible, croak. */
2866 SV* const tsv = sv_2mortal(newSVsv(sv));
2869 sv_utf8_downgrade(tsv, FALSE);
2870 tmps = SvPV_const(tsv, len);
2872 while (*tmps && len && isSPACE(*tmps))
2877 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2878 else if (*tmps == 'b')
2879 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2881 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2883 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2897 SV * const sv = TOPs;
2900 SETi(sv_len_utf8(sv));
2916 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2918 const I32 arybase = PL_curcop->cop_arybase;
2920 const char *repl = 0;
2922 const int num_args = PL_op->op_private & 7;
2923 bool repl_need_utf8_upgrade = FALSE;
2924 bool repl_is_utf8 = FALSE;
2926 SvTAINTED_off(TARG); /* decontaminate */
2927 SvUTF8_off(TARG); /* decontaminate */
2931 repl = SvPV_const(repl_sv, repl_len);
2932 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2942 sv_utf8_upgrade(sv);
2944 else if (DO_UTF8(sv))
2945 repl_need_utf8_upgrade = TRUE;
2947 tmps = SvPV_const(sv, curlen);
2949 utf8_curlen = sv_len_utf8(sv);
2950 if (utf8_curlen == curlen)
2953 curlen = utf8_curlen;
2958 if (pos >= arybase) {
2976 else if (len >= 0) {
2978 if (rem > (I32)curlen)
2993 Perl_croak(aTHX_ "substr outside of string");
2994 if (ckWARN(WARN_SUBSTR))
2995 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2999 const I32 upos = pos;
3000 const I32 urem = rem;
3002 sv_pos_u2b(sv, &pos, &rem);
3004 /* we either return a PV or an LV. If the TARG hasn't been used
3005 * before, or is of that type, reuse it; otherwise use a mortal
3006 * instead. Note that LVs can have an extended lifetime, so also
3007 * dont reuse if refcount > 1 (bug #20933) */
3008 if (SvTYPE(TARG) > SVt_NULL) {
3009 if ( (SvTYPE(TARG) == SVt_PVLV)
3010 ? (!lvalue || SvREFCNT(TARG) > 1)
3013 TARG = sv_newmortal();
3017 sv_setpvn(TARG, tmps, rem);
3018 #ifdef USE_LOCALE_COLLATE
3019 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3024 SV* repl_sv_copy = NULL;
3026 if (repl_need_utf8_upgrade) {
3027 repl_sv_copy = newSVsv(repl_sv);
3028 sv_utf8_upgrade(repl_sv_copy);
3029 repl = SvPV_const(repl_sv_copy, repl_len);
3030 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3032 sv_insert(sv, pos, rem, repl, repl_len);
3036 SvREFCNT_dec(repl_sv_copy);
3038 else if (lvalue) { /* it's an lvalue! */
3039 if (!SvGMAGICAL(sv)) {
3041 SvPV_force_nolen(sv);
3042 if (ckWARN(WARN_SUBSTR))
3043 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3044 "Attempt to use reference as lvalue in substr");
3046 if (SvOK(sv)) /* is it defined ? */
3047 (void)SvPOK_only_UTF8(sv);
3049 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3052 if (SvTYPE(TARG) < SVt_PVLV) {
3053 sv_upgrade(TARG, SVt_PVLV);
3054 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3060 if (LvTARG(TARG) != sv) {
3062 SvREFCNT_dec(LvTARG(TARG));
3063 LvTARG(TARG) = SvREFCNT_inc(sv);
3065 LvTARGOFF(TARG) = upos;
3066 LvTARGLEN(TARG) = urem;
3070 PUSHs(TARG); /* avoid SvSETMAGIC here */
3077 register const IV size = POPi;
3078 register const IV offset = POPi;
3079 register SV * const src = POPs;
3080 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3082 SvTAINTED_off(TARG); /* decontaminate */
3083 if (lvalue) { /* it's an lvalue! */
3084 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3085 TARG = sv_newmortal();
3086 if (SvTYPE(TARG) < SVt_PVLV) {
3087 sv_upgrade(TARG, SVt_PVLV);
3088 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3091 if (LvTARG(TARG) != src) {
3093 SvREFCNT_dec(LvTARG(TARG));
3094 LvTARG(TARG) = SvREFCNT_inc(src);
3096 LvTARGOFF(TARG) = offset;
3097 LvTARGLEN(TARG) = size;
3100 sv_setuv(TARG, do_vecget(src, offset, size));
3116 const I32 arybase = PL_curcop->cop_arybase;
3123 offset = POPi - arybase;
3126 big_utf8 = DO_UTF8(big);
3127 little_utf8 = DO_UTF8(little);
3128 if (big_utf8 ^ little_utf8) {
3129 /* One needs to be upgraded. */
3130 SV * const bytes = little_utf8 ? big : little;
3132 const char * const p = SvPV_const(bytes, len);
3134 temp = newSVpvn(p, len);
3137 sv_recode_to_utf8(temp, PL_encoding);
3139 sv_utf8_upgrade(temp);
3148 if (big_utf8 && offset > 0)
3149 sv_pos_u2b(big, &offset, 0);
3150 tmps = SvPV_const(big, biglen);
3153 else if (offset > (I32)biglen)
3155 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3156 (unsigned char*)tmps + biglen, little, 0)))
3159 retval = tmps2 - tmps;
3160 if (retval > 0 && big_utf8)
3161 sv_pos_b2u(big, &retval);
3164 PUSHi(retval + arybase);
3180 const I32 arybase = PL_curcop->cop_arybase;
3188 big_utf8 = DO_UTF8(big);
3189 little_utf8 = DO_UTF8(little);
3190 if (big_utf8 ^ little_utf8) {
3191 /* One needs to be upgraded. */
3192 SV * const bytes = little_utf8 ? big : little;
3194 const char *p = SvPV_const(bytes, len);
3196 temp = newSVpvn(p, len);
3199 sv_recode_to_utf8(temp, PL_encoding);
3201 sv_utf8_upgrade(temp);
3210 tmps2 = SvPV_const(little, llen);
3211 tmps = SvPV_const(big, blen);
3216 if (offset > 0 && big_utf8)
3217 sv_pos_u2b(big, &offset, 0);
3218 offset = offset - arybase + llen;
3222 else if (offset > (I32)blen)
3224 if (!(tmps2 = rninstr(tmps, tmps + offset,
3225 tmps2, tmps2 + llen)))
3228 retval = tmps2 - tmps;
3229 if (retval > 0 && big_utf8)
3230 sv_pos_b2u(big, &retval);
3233 PUSHi(retval + arybase);
3239 dSP; dMARK; dORIGMARK; dTARGET;
3240 do_sprintf(TARG, SP-MARK, MARK+1);
3241 TAINT_IF(SvTAINTED(TARG));
3252 const U8 *s = (U8*)SvPV_const(argsv, len);
3255 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3256 tmpsv = sv_2mortal(newSVsv(argsv));
3257 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3261 XPUSHu(DO_UTF8(argsv) ?
3262 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3274 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3276 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3278 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3280 (void) POPs; /* Ignore the argument value. */
3281 value = UNICODE_REPLACEMENT;
3287 SvUPGRADE(TARG,SVt_PV);
3289 if (value > 255 && !IN_BYTES) {
3290 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3291 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3292 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3294 (void)SvPOK_only(TARG);
3303 *tmps++ = (char)value;
3305 (void)SvPOK_only(TARG);
3306 if (PL_encoding && !IN_BYTES) {
3307 sv_recode_to_utf8(TARG, PL_encoding);
3309 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3310 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3314 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3315 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3330 const char *tmps = SvPV_const(left, len);
3332 if (DO_UTF8(left)) {
3333 /* If Unicode, try to downgrade.
3334 * If not possible, croak.
3335 * Yes, we made this up. */
3336 SV* const tsv = sv_2mortal(newSVsv(left));
3339 sv_utf8_downgrade(tsv, FALSE);
3340 tmps = SvPV_const(tsv, len);
3342 # ifdef USE_ITHREADS
3344 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3345 /* This should be threadsafe because in ithreads there is only
3346 * one thread per interpreter. If this would not be true,
3347 * we would need a mutex to protect this malloc. */
3348 PL_reentrant_buffer->_crypt_struct_buffer =
3349 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3350 #if defined(__GLIBC__) || defined(__EMX__)
3351 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3352 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3353 /* work around glibc-2.2.5 bug */
3354 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3358 # endif /* HAS_CRYPT_R */
3359 # endif /* USE_ITHREADS */
3361 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3363 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3369 "The crypt() function is unimplemented due to excessive paranoia.");
3379 const int op_type = PL_op->op_type;
3383 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3384 UTF8_IS_START(*s)) {
3385 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3389 utf8_to_uvchr(s, &ulen);
3390 if (op_type == OP_UCFIRST) {
3391 toTITLE_utf8(s, tmpbuf, &tculen);
3393 toLOWER_utf8(s, tmpbuf, &tculen);
3396 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3398 /* slen is the byte length of the whole SV.
3399 * ulen is the byte length of the original Unicode character
3400 * stored as UTF-8 at s.
3401 * tculen is the byte length of the freshly titlecased (or
3402 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3403 * We first set the result to be the titlecased (/lowercased)
3404 * character, and then append the rest of the SV data. */
3405 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3407 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3412 s = (U8*)SvPV_force_nomg(sv, slen);
3413 Copy(tmpbuf, s, tculen, U8);
3418 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3420 SvUTF8_off(TARG); /* decontaminate */
3421 sv_setsv_nomg(TARG, sv);
3425 s1 = (U8*)SvPV_force_nomg(sv, slen);
3427 if (IN_LOCALE_RUNTIME) {
3430 *s1 = (op_type == OP_UCFIRST)
3431 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3434 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3454 U8 tmpbuf[UTF8_MAXBYTES+1];
3456 s = (const U8*)SvPV_nomg_const(sv,len);
3458 SvUTF8_off(TARG); /* decontaminate */
3459 sv_setpvn(TARG, "", 0);
3463 STRLEN min = len + 1;
3465 SvUPGRADE(TARG, SVt_PV);
3467 (void)SvPOK_only(TARG);
3468 d = (U8*)SvPVX(TARG);
3471 STRLEN u = UTF8SKIP(s);
3473 toUPPER_utf8(s, tmpbuf, &ulen);
3474 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3475 /* If the eventually required minimum size outgrows
3476 * the available space, we need to grow. */
3477 const UV o = d - (U8*)SvPVX_const(TARG);
3479 /* If someone uppercases one million U+03B0s we
3480 * SvGROW() one million times. Or we could try
3481 * guessing how much to allocate without allocating
3482 * too much. Such is life. */
3484 d = (U8*)SvPVX(TARG) + o;
3486 Copy(tmpbuf, d, ulen, U8);
3492 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3498 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3500 SvUTF8_off(TARG); /* decontaminate */
3501 sv_setsv_nomg(TARG, sv);
3505 s = (U8*)SvPV_force_nomg(sv, len);
3507 register const U8 *send = s + len;
3509 if (IN_LOCALE_RUNTIME) {
3512 for (; s < send; s++)
3513 *s = toUPPER_LC(*s);
3516 for (; s < send; s++)
3538 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3540 s = (const U8*)SvPV_nomg_const(sv,len);
3542 SvUTF8_off(TARG); /* decontaminate */
3543 sv_setpvn(TARG, "", 0);
3547 STRLEN min = len + 1;
3549 SvUPGRADE(TARG, SVt_PV);
3551 (void)SvPOK_only(TARG);
3552 d = (U8*)SvPVX(TARG);
3555 const STRLEN u = UTF8SKIP(s);
3556 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3558 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3559 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3561 * Now if the sigma is NOT followed by
3562 * /$ignorable_sequence$cased_letter/;
3563 * and it IS preceded by
3564 * /$cased_letter$ignorable_sequence/;
3565 * where $ignorable_sequence is
3566 * [\x{2010}\x{AD}\p{Mn}]*
3567 * and $cased_letter is
3568 * [\p{Ll}\p{Lo}\p{Lt}]
3569 * then it should be mapped to 0x03C2,
3570 * (GREEK SMALL LETTER FINAL SIGMA),
3571 * instead of staying 0x03A3.
3572 * "should be": in other words,
3573 * this is not implemented yet.
3574 * See lib/unicore/SpecialCasing.txt.
3577 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3578 /* If the eventually required minimum size outgrows
3579 * the available space, we need to grow. */
3580 const UV o = d - (U8*)SvPVX_const(TARG);
3582 /* If someone lowercases one million U+0130s we
3583 * SvGROW() one million times. Or we could try
3584 * guessing how much to allocate without allocating.
3585 * too much. Such is life. */
3587 d = (U8*)SvPVX(TARG) + o;
3589 Copy(tmpbuf, d, ulen, U8);
3595 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3601 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3603 SvUTF8_off(TARG); /* decontaminate */
3604 sv_setsv_nomg(TARG, sv);
3609 s = (U8*)SvPV_force_nomg(sv, len);
3611 register const U8 * const send = s + len;
3613 if (IN_LOCALE_RUNTIME) {
3616 for (; s < send; s++)
3617 *s = toLOWER_LC(*s);
3620 for (; s < send; s++)
3632 SV * const sv = TOPs;
3634 register const char *s = SvPV_const(sv,len);
3636 SvUTF8_off(TARG); /* decontaminate */
3639 SvUPGRADE(TARG, SVt_PV);
3640 SvGROW(TARG, (len * 2) + 1);
3644 if (UTF8_IS_CONTINUED(*s)) {
3645 STRLEN ulen = UTF8SKIP(s);
3669 SvCUR_set(TARG, d - SvPVX_const(TARG));
3670 (void)SvPOK_only_UTF8(TARG);
3673 sv_setpvn(TARG, s, len);
3675 if (SvSMAGICAL(TARG))
3684 dSP; dMARK; dORIGMARK;
3685 register AV* const av = (AV*)POPs;
3686 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3688 if (SvTYPE(av) == SVt_PVAV) {
3689 const I32 arybase = PL_curcop->cop_arybase;
3690 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3693 for (svp = MARK + 1; svp <= SP; svp++) {
3694 const I32 elem = SvIVx(*svp);
3698 if (max > AvMAX(av))
3701 while (++MARK <= SP) {
3703 I32 elem = SvIVx(*MARK);
3707 svp = av_fetch(av, elem, lval);
3709 if (!svp || *svp == &PL_sv_undef)
3710 DIE(aTHX_ PL_no_aelem, elem);
3711 if (PL_op->op_private & OPpLVAL_INTRO)
3712 save_aelem(av, elem, svp);
3714 *MARK = svp ? *svp : &PL_sv_undef;
3717 if (GIMME != G_ARRAY) {
3719 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3725 /* Associative arrays. */
3730 HV * const hash = (HV*)POPs;
3732 const I32 gimme = GIMME_V;
3735 /* might clobber stack_sp */
3736 entry = hv_iternext(hash);
3741 SV* const sv = hv_iterkeysv(entry);
3742 PUSHs(sv); /* won't clobber stack_sp */
3743 if (gimme == G_ARRAY) {
3746 /* might clobber stack_sp */
3747 val = hv_iterval(hash, entry);
3752 else if (gimme == G_SCALAR)
3761 const I32 gimme = GIMME_V;
3762 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3764 if (PL_op->op_private & OPpSLICE) {
3766 HV * const hv = (HV*)POPs;
3767 const U32 hvtype = SvTYPE(hv);
3768 if (hvtype == SVt_PVHV) { /* hash element */
3769 while (++MARK <= SP) {
3770 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3771 *MARK = sv ? sv : &PL_sv_undef;
3774 else if (hvtype == SVt_PVAV) { /* array element */
3775 if (PL_op->op_flags & OPf_SPECIAL) {
3776 while (++MARK <= SP) {
3777 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3778 *MARK = sv ? sv : &PL_sv_undef;
3783 DIE(aTHX_ "Not a HASH reference");
3786 else if (gimme == G_SCALAR) {
3791 *++MARK = &PL_sv_undef;
3797 HV * const hv = (HV*)POPs;
3799 if (SvTYPE(hv) == SVt_PVHV)
3800 sv = hv_delete_ent(hv, keysv, discard, 0);
3801 else if (SvTYPE(hv) == SVt_PVAV) {
3802 if (PL_op->op_flags & OPf_SPECIAL)
3803 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3805 DIE(aTHX_ "panic: avhv_delete no longer supported");
3808 DIE(aTHX_ "Not a HASH reference");
3823 if (PL_op->op_private & OPpEXISTS_SUB) {
3825 SV * const sv = POPs;
3826 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3829 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3835 if (SvTYPE(hv) == SVt_PVHV) {
3836 if (hv_exists_ent(hv, tmpsv, 0))
3839 else if (SvTYPE(hv) == SVt_PVAV) {
3840 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3841 if (av_exists((AV*)hv, SvIV(tmpsv)))
3846 DIE(aTHX_ "Not a HASH reference");
3853 dSP; dMARK; dORIGMARK;
3854 register HV * const hv = (HV*)POPs;
3855 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3856 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3857 bool other_magic = FALSE;
3863 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3864 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3865 /* Try to preserve the existenceness of a tied hash
3866 * element by using EXISTS and DELETE if possible.
3867 * Fallback to FETCH and STORE otherwise */
3868 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3869 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3870 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3873 while (++MARK <= SP) {
3874 SV * const keysv = *MARK;
3877 bool preeminent = FALSE;
3880 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3881 hv_exists_ent(hv, keysv, 0);
3884 he = hv_fetch_ent(hv, keysv, lval, 0);
3885 svp = he ? &HeVAL(he) : 0;
3888 if (!svp || *svp == &PL_sv_undef) {
3889 DIE(aTHX_ PL_no_helem_sv, keysv);
3893 save_helem(hv, keysv, svp);
3896 const char *key = SvPV_const(keysv, keylen);
3897 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3901 *MARK = svp ? *svp : &PL_sv_undef;
3903 if (GIMME != G_ARRAY) {
3905 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3911 /* List operators. */
3916 if (GIMME != G_ARRAY) {
3918 *MARK = *SP; /* unwanted list, return last item */
3920 *MARK = &PL_sv_undef;
3929 SV ** const lastrelem = PL_stack_sp;
3930 SV ** const lastlelem = PL_stack_base + POPMARK;
3931 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3932 register SV ** const firstrelem = lastlelem + 1;
3933 const I32 arybase = PL_curcop->cop_arybase;
3934 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3936 register const I32 max = lastrelem - lastlelem;
3937 register SV **lelem;
3939 if (GIMME != G_ARRAY) {
3940 I32 ix = SvIVx(*lastlelem);
3945 if (ix < 0 || ix >= max)
3946 *firstlelem = &PL_sv_undef;
3948 *firstlelem = firstrelem[ix];
3954 SP = firstlelem - 1;
3958 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3959 I32 ix = SvIVx(*lelem);
3964 if (ix < 0 || ix >= max)
3965 *lelem = &PL_sv_undef;
3967 is_something_there = TRUE;
3968 if (!(*lelem = firstrelem[ix]))
3969 *lelem = &PL_sv_undef;
3972 if (is_something_there)
3975 SP = firstlelem - 1;
3981 dSP; dMARK; dORIGMARK;
3982 const I32 items = SP - MARK;
3983 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3984 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3991 dSP; dMARK; dORIGMARK;
3992 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3995 SV * const key = *++MARK;
3996 SV * const val = NEWSV(46, 0);
3998 sv_setsv(val, *++MARK);
3999 else if (ckWARN(WARN_MISC))
4000 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4001 (void)hv_store_ent(hv,key,val,0);
4010 dVAR; dSP; dMARK; dORIGMARK;
4011 register AV *ary = (AV*)*++MARK;
4015 register I32 offset;
4016 register I32 length;
4021 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4024 *MARK-- = SvTIED_obj((SV*)ary, mg);
4028 call_method("SPLICE",GIMME_V);
4037 offset = i = SvIVx(*MARK);
4039 offset += AvFILLp(ary) + 1;
4041 offset -= PL_curcop->cop_arybase;
4043 DIE(aTHX_ PL_no_aelem, i);
4045 length = SvIVx(*MARK++);
4047 length += AvFILLp(ary) - offset + 1;
4053 length = AvMAX(ary) + 1; /* close enough to infinity */
4057 length = AvMAX(ary) + 1;
4059 if (offset > AvFILLp(ary) + 1) {
4060 if (ckWARN(WARN_MISC))
4061 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4062 offset = AvFILLp(ary) + 1;
4064 after = AvFILLp(ary) + 1 - (offset + length);
4065 if (after < 0) { /* not that much array */
4066 length += after; /* offset+length now in array */
4072 /* At this point, MARK .. SP-1 is our new LIST */
4075 diff = newlen - length;
4076 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4079 /* make new elements SVs now: avoid problems if they're from the array */
4080 for (dst = MARK, i = newlen; i; i--) {
4081 SV * const h = *dst;
4082 *dst++ = newSVsv(h);
4085 if (diff < 0) { /* shrinking the area */
4087 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4088 Copy(MARK, tmparyval, newlen, SV*);
4091 MARK = ORIGMARK + 1;
4092 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4093 MEXTEND(MARK, length);
4094 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4096 EXTEND_MORTAL(length);
4097 for (i = length, dst = MARK; i; i--) {
4098 sv_2mortal(*dst); /* free them eventualy */
4105 *MARK = AvARRAY(ary)[offset+length-1];
4108 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4109 SvREFCNT_dec(*dst++); /* free them now */
4112 AvFILLp(ary) += diff;
4114 /* pull up or down? */
4116 if (offset < after) { /* easier to pull up */
4117 if (offset) { /* esp. if nothing to pull */
4118 src = &AvARRAY(ary)[offset-1];
4119 dst = src - diff; /* diff is negative */
4120 for (i = offset; i > 0; i--) /* can't trust Copy */
4124 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4128 if (after) { /* anything to pull down? */
4129 src = AvARRAY(ary) + offset + length;
4130 dst = src + diff; /* diff is negative */
4131 Move(src, dst, after, SV*);
4133 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4134 /* avoid later double free */
4138 dst[--i] = &PL_sv_undef;
4141 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4142 Safefree(tmparyval);
4145 else { /* no, expanding (or same) */
4147 Newx(tmparyval, length, SV*); /* so remember deletion */
4148 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4151 if (diff > 0) { /* expanding */
4153 /* push up or down? */
4155 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4159 Move(src, dst, offset, SV*);
4161 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4163 AvFILLp(ary) += diff;
4166 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4167 av_extend(ary, AvFILLp(ary) + diff);
4168 AvFILLp(ary) += diff;
4171 dst = AvARRAY(ary) + AvFILLp(ary);
4173 for (i = after; i; i--) {
4181 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4184 MARK = ORIGMARK + 1;
4185 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4187 Copy(tmparyval, MARK, length, SV*);
4189 EXTEND_MORTAL(length);
4190 for (i = length, dst = MARK; i; i--) {
4191 sv_2mortal(*dst); /* free them eventualy */
4195 Safefree(tmparyval);
4199 else if (length--) {
4200 *MARK = tmparyval[length];
4203 while (length-- > 0)
4204 SvREFCNT_dec(tmparyval[length]);
4206 Safefree(tmparyval);
4209 *MARK = &PL_sv_undef;
4217 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4218 register AV *ary = (AV*)*++MARK;
4219 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4222 *MARK-- = SvTIED_obj((SV*)ary, mg);
4226 call_method("PUSH",G_SCALAR|G_DISCARD);
4230 PUSHi( AvFILL(ary) + 1 );
4233 for (++MARK; MARK <= SP; MARK++) {
4234 SV * const sv = NEWSV(51, 0);
4236 sv_setsv(sv, *MARK);
4237 av_store(ary, AvFILLp(ary)+1, sv);
4240 PUSHi( AvFILLp(ary) + 1 );
4248 AV * const av = (AV*)POPs;
4249 SV * const sv = av_pop(av);
4251 (void)sv_2mortal(sv);
4259 AV * const av = (AV*)POPs;
4260 SV * const sv = av_shift(av);
4265 (void)sv_2mortal(sv);
4272 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4273 register AV *ary = (AV*)*++MARK;
4274 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4277 *MARK-- = SvTIED_obj((SV*)ary, mg);
4281 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4287 av_unshift(ary, SP - MARK);
4289 SV * const sv = newSVsv(*++MARK);
4290 (void)av_store(ary, i++, sv);
4294 PUSHi( AvFILL(ary) + 1 );
4301 SV ** const oldsp = SP;
4303 if (GIMME == G_ARRAY) {
4306 register SV * const tmp = *MARK;
4310 /* safe as long as stack cannot get extended in the above */
4315 register char *down;
4321 SvUTF8_off(TARG); /* decontaminate */
4323 do_join(TARG, &PL_sv_no, MARK, SP);
4325 sv_setsv(TARG, (SP > MARK)
4327 : (padoff_du = find_rundefsvoffset(),
4328 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4329 ? DEFSV : PAD_SVl(padoff_du)));
4330 up = SvPV_force(TARG, len);
4332 if (DO_UTF8(TARG)) { /* first reverse each character */
4333 U8* s = (U8*)SvPVX(TARG);
4334 const U8* send = (U8*)(s + len);
4336 if (UTF8_IS_INVARIANT(*s)) {
4341 if (!utf8_to_uvchr(s, 0))
4345 down = (char*)(s - 1);
4346 /* reverse this character */
4350 *down-- = (char)tmp;
4356 down = SvPVX(TARG) + len - 1;
4360 *down-- = (char)tmp;
4362 (void)SvPOK_only_UTF8(TARG);
4374 register IV limit = POPi; /* note, negative is forever */
4375 SV * const sv = POPs;
4377 register const char *s = SvPV_const(sv, len);
4378 const bool do_utf8 = DO_UTF8(sv);
4379 const char *strend = s + len;
4381 register REGEXP *rx;
4383 register const char *m;
4385 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4386 I32 maxiters = slen + 10;
4388 const I32 origlimit = limit;
4391 const I32 gimme = GIMME_V;
4392 const I32 oldsave = PL_savestack_ix;
4393 I32 make_mortal = 1;
4395 MAGIC *mg = (MAGIC *) NULL;
4398 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4403 DIE(aTHX_ "panic: pp_split");
4406 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4407 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4409 RX_MATCH_UTF8_set(rx, do_utf8);
4411 if (pm->op_pmreplroot) {
4413 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4415 ary = GvAVn((GV*)pm->op_pmreplroot);
4418 else if (gimme != G_ARRAY)
4419 ary = GvAVn(PL_defgv);
4422 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4428 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4430 XPUSHs(SvTIED_obj((SV*)ary, mg));
4437 for (i = AvFILLp(ary); i >= 0; i--)
4438 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4440 /* temporarily switch stacks */
4441 SAVESWITCHSTACK(PL_curstack, ary);
4445 base = SP - PL_stack_base;
4447 if (pm->op_pmflags & PMf_SKIPWHITE) {
4448 if (pm->op_pmflags & PMf_LOCALE) {
4449 while (isSPACE_LC(*s))
4457 if (pm->op_pmflags & PMf_MULTILINE) {
4462 limit = maxiters + 2;
4463 if (pm->op_pmflags & PMf_WHITE) {
4466 while (m < strend &&
4467 !((pm->op_pmflags & PMf_LOCALE)
4468 ? isSPACE_LC(*m) : isSPACE(*m)))
4473 dstr = newSVpvn(s, m-s);
4477 (void)SvUTF8_on(dstr);
4481 while (s < strend &&
4482 ((pm->op_pmflags & PMf_LOCALE)
4483 ? isSPACE_LC(*s) : isSPACE(*s)))
4487 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4489 for (m = s; m < strend && *m != '\n'; m++)
4494 dstr = newSVpvn(s, m-s);
4498 (void)SvUTF8_on(dstr);
4503 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4504 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4505 && (rx->reganch & ROPT_CHECK_ALL)
4506 && !(rx->reganch & ROPT_ANCH)) {
4507 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4508 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4511 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4512 const char c = *SvPV_nolen_const(csv);
4514 for (m = s; m < strend && *m != c; m++)
4518 dstr = newSVpvn(s, m-s);
4522 (void)SvUTF8_on(dstr);
4524 /* The rx->minlen is in characters but we want to step
4525 * s ahead by bytes. */
4527 s = (char*)utf8_hop((U8*)m, len);
4529 s = m + len; /* Fake \n at the end */
4533 while (s < strend && --limit &&
4534 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4535 csv, multiline ? FBMrf_MULTILINE : 0)) )
4537 dstr = newSVpvn(s, m-s);
4541 (void)SvUTF8_on(dstr);
4543 /* The rx->minlen is in characters but we want to step
4544 * s ahead by bytes. */
4546 s = (char*)utf8_hop((U8*)m, len);
4548 s = m + len; /* Fake \n at the end */
4553 maxiters += slen * rx->nparens;
4554 while (s < strend && --limit)
4558 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4561 if (rex_return == 0)
4563 TAINT_IF(RX_MATCH_TAINTED(rx));
4564 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4569 strend = s + (strend - m);
4571 m = rx->startp[0] + orig;
4572 dstr = newSVpvn(s, m-s);
4576 (void)SvUTF8_on(dstr);
4580 for (i = 1; i <= (I32)rx->nparens; i++) {
4581 s = rx->startp[i] + orig;
4582 m = rx->endp[i] + orig;
4584 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4585 parens that didn't match -- they should be set to
4586 undef, not the empty string */
4587 if (m >= orig && s >= orig) {
4588 dstr = newSVpvn(s, m-s);
4591 dstr = &PL_sv_undef; /* undef, not "" */
4595 (void)SvUTF8_on(dstr);
4599 s = rx->endp[0] + orig;
4603 iters = (SP - PL_stack_base) - base;
4604 if (iters > maxiters)
4605 DIE(aTHX_ "Split loop");
4607 /* keep field after final delim? */
4608 if (s < strend || (iters && origlimit)) {
4609 const STRLEN l = strend - s;
4610 dstr = newSVpvn(s, l);
4614 (void)SvUTF8_on(dstr);
4618 else if (!origlimit) {
4619 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4620 if (TOPs && !make_mortal)
4623 *SP-- = &PL_sv_undef;
4628 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4632 if (SvSMAGICAL(ary)) {
4637 if (gimme == G_ARRAY) {
4639 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4647 call_method("PUSH",G_SCALAR|G_DISCARD);
4650 if (gimme == G_ARRAY) {
4652 /* EXTEND should not be needed - we just popped them */
4654 for (i=0; i < iters; i++) {
4655 SV **svp = av_fetch(ary, i, FALSE);
4656 PUSHs((svp) ? *svp : &PL_sv_undef);
4663 if (gimme == G_ARRAY)
4678 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4679 || SvTYPE(retsv) == SVt_PVCV) {
4680 retsv = refto(retsv);
4687 PP(unimplemented_op)
4689 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4695 * c-indentation-style: bsd
4697 * indent-tabs-mode: t
4700 * ex: set ts=8 sts=4 sw=4 noet: