3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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);
38 /* variations on pp_null */
43 if (GIMME_V == G_SCALAR)
59 if (PL_op->op_private & OPpLVAL_INTRO)
60 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
62 if (PL_op->op_flags & OPf_REF) {
66 if (GIMME == G_SCALAR)
67 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
72 if (gimme == G_ARRAY) {
73 I32 maxarg = AvFILL((AV*)TARG) + 1;
75 if (SvMAGICAL(TARG)) {
77 for (i=0; i < (U32)maxarg; i++) {
78 SV **svp = av_fetch((AV*)TARG, i, FALSE);
79 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
83 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
87 else if (gimme == G_SCALAR) {
88 SV* sv = sv_newmortal();
89 I32 maxarg = AvFILL((AV*)TARG) + 1;
102 if (PL_op->op_private & OPpLVAL_INTRO)
103 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
104 if (PL_op->op_flags & OPf_REF)
107 if (GIMME == G_SCALAR)
108 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
112 if (gimme == G_ARRAY) {
115 else if (gimme == G_SCALAR) {
116 SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
124 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
135 tryAMAGICunDEREF(to_gv);
138 if (SvTYPE(sv) == SVt_PVIO) {
139 GV *gv = (GV*) sv_newmortal();
140 gv_init(gv, 0, "", 0, 0);
141 GvIOp(gv) = (IO *)sv;
142 (void)SvREFCNT_inc(sv);
145 else if (SvTYPE(sv) != SVt_PVGV)
146 DIE(aTHX_ "Not a GLOB reference");
149 if (SvTYPE(sv) != SVt_PVGV) {
153 if (SvGMAGICAL(sv)) {
158 if (!SvOK(sv) && sv != &PL_sv_undef) {
159 /* If this is a 'my' scalar and flag is set then vivify
163 Perl_croak(aTHX_ PL_no_modify);
164 if (PL_op->op_private & OPpDEREF) {
167 if (cUNOP->op_targ) {
169 SV *namesv = PAD_SV(cUNOP->op_targ);
170 name = SvPV(namesv, len);
171 gv = (GV*)NEWSV(0,0);
172 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
175 name = CopSTASHPV(PL_curcop);
178 if (SvTYPE(sv) < SVt_RV)
179 sv_upgrade(sv, SVt_RV);
181 SvOOK_off(sv); /* backoff */
184 SvLEN(sv)=SvCUR(sv)=0;
191 if (PL_op->op_flags & OPf_REF ||
192 PL_op->op_private & HINT_STRICT_REFS)
193 DIE(aTHX_ PL_no_usym, "a symbol");
194 if (ckWARN(WARN_UNINITIALIZED))
199 if ((PL_op->op_flags & OPf_SPECIAL) &&
200 !(PL_op->op_flags & OPf_MOD))
202 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
204 && (!is_gv_magical(sym,len,0)
205 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
211 if (PL_op->op_private & HINT_STRICT_REFS)
212 DIE(aTHX_ PL_no_symref, sym, "a symbol");
213 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
217 if (PL_op->op_private & OPpLVAL_INTRO)
218 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
230 tryAMAGICunDEREF(to_sv);
233 switch (SvTYPE(sv)) {
237 DIE(aTHX_ "Not a SCALAR reference");
245 if (SvTYPE(gv) != SVt_PVGV) {
246 if (SvGMAGICAL(sv)) {
252 if (PL_op->op_flags & OPf_REF ||
253 PL_op->op_private & HINT_STRICT_REFS)
254 DIE(aTHX_ PL_no_usym, "a SCALAR");
255 if (ckWARN(WARN_UNINITIALIZED))
260 if ((PL_op->op_flags & OPf_SPECIAL) &&
261 !(PL_op->op_flags & OPf_MOD))
263 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
265 && (!is_gv_magical(sym,len,0)
266 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
272 if (PL_op->op_private & HINT_STRICT_REFS)
273 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
274 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
279 if (PL_op->op_flags & OPf_MOD) {
280 if (PL_op->op_private & OPpLVAL_INTRO) {
281 if (cUNOP->op_first->op_type == OP_NULL)
282 sv = save_scalar((GV*)TOPs);
284 sv = save_scalar(gv);
286 Perl_croak(aTHX_ PL_no_localize_ref);
288 else if (PL_op->op_private & OPpDEREF)
289 vivify_ref(sv, PL_op->op_private & OPpDEREF);
299 SV *sv = AvARYLEN(av);
301 AvARYLEN(av) = sv = NEWSV(0,0);
302 sv_upgrade(sv, SVt_IV);
303 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
311 dSP; dTARGET; dPOPss;
313 if (PL_op->op_flags & OPf_MOD || LVRET) {
314 if (SvTYPE(TARG) < SVt_PVLV) {
315 sv_upgrade(TARG, SVt_PVLV);
316 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
320 if (LvTARG(TARG) != sv) {
322 SvREFCNT_dec(LvTARG(TARG));
323 LvTARG(TARG) = SvREFCNT_inc(sv);
325 PUSHs(TARG); /* no SvSETMAGIC */
331 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
332 mg = mg_find(sv, PERL_MAGIC_regex_global);
333 if (mg && mg->mg_len >= 0) {
337 PUSHi(i + PL_curcop->cop_arybase);
351 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
352 /* (But not in defined().) */
353 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
356 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
357 if ((PL_op->op_private & OPpLVAL_INTRO)) {
358 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
361 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
365 cv = (CV*)&PL_sv_undef;
379 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
380 char *s = SvPVX(TOPs);
381 if (strnEQ(s, "CORE::", 6)) {
384 code = keyword(s + 6, SvCUR(TOPs) - 6);
385 if (code < 0) { /* Overridable. */
386 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
387 int i = 0, n = 0, seen_question = 0;
389 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
391 if (code == -KEY_chop || code == -KEY_chomp)
393 while (i < MAXO) { /* The slow way. */
394 if (strEQ(s + 6, PL_op_name[i])
395 || strEQ(s + 6, PL_op_desc[i]))
401 goto nonesuch; /* Should not happen... */
403 oa = PL_opargs[i] >> OASHIFT;
405 if (oa & OA_OPTIONAL && !seen_question) {
409 else if (n && str[0] == ';' && seen_question)
410 goto set; /* XXXX system, exec */
411 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
412 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
413 /* But globs are already references (kinda) */
414 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
418 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
422 ret = sv_2mortal(newSVpvn(str, n - 1));
424 else if (code) /* Non-Overridable */
426 else { /* None such */
428 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
432 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
434 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
443 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
445 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
461 if (GIMME != G_ARRAY) {
465 *MARK = &PL_sv_undef;
466 *MARK = refto(*MARK);
470 EXTEND_MORTAL(SP - MARK);
472 *MARK = refto(*MARK);
477 S_refto(pTHX_ SV *sv)
481 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
484 if (!(sv = LvTARG(sv)))
487 (void)SvREFCNT_inc(sv);
489 else if (SvTYPE(sv) == SVt_PVAV) {
490 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
493 (void)SvREFCNT_inc(sv);
495 else if (SvPADTMP(sv) && !IS_PADGV(sv))
499 (void)SvREFCNT_inc(sv);
502 sv_upgrade(rv, SVt_RV);
516 if (sv && SvGMAGICAL(sv))
519 if (!sv || !SvROK(sv))
523 pv = sv_reftype(sv,TRUE);
524 PUSHp(pv, strlen(pv));
534 stash = CopSTASH(PL_curcop);
540 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
541 Perl_croak(aTHX_ "Attempt to bless into a reference");
543 if (ckWARN(WARN_MISC) && len == 0)
544 Perl_warner(aTHX_ packWARN(WARN_MISC),
545 "Explicit blessing to '' (assuming package main)");
546 stash = gv_stashpvn(ptr, len, TRUE);
549 (void)sv_bless(TOPs, stash);
563 elem = SvPV(sv, n_a);
567 switch (elem ? *elem : '\0')
570 if (strEQ(elem, "ARRAY"))
571 tmpRef = (SV*)GvAV(gv);
574 if (strEQ(elem, "CODE"))
575 tmpRef = (SV*)GvCVu(gv);
578 if (strEQ(elem, "FILEHANDLE")) {
579 /* finally deprecated in 5.8.0 */
580 deprecate("*glob{FILEHANDLE}");
581 tmpRef = (SV*)GvIOp(gv);
584 if (strEQ(elem, "FORMAT"))
585 tmpRef = (SV*)GvFORM(gv);
588 if (strEQ(elem, "GLOB"))
592 if (strEQ(elem, "HASH"))
593 tmpRef = (SV*)GvHV(gv);
596 if (strEQ(elem, "IO"))
597 tmpRef = (SV*)GvIOp(gv);
600 if (strEQ(elem, "NAME"))
601 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
604 if (strEQ(elem, "PACKAGE")) {
605 if (HvNAME(GvSTASH(gv)))
606 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
608 sv = newSVpv("__ANON__",0);
612 if (strEQ(elem, "SCALAR"))
626 /* Pattern matching */
631 register unsigned char *s;
634 register I32 *sfirst;
638 if (sv == PL_lastscream) {
644 SvSCREAM_off(PL_lastscream);
645 SvREFCNT_dec(PL_lastscream);
647 PL_lastscream = SvREFCNT_inc(sv);
650 s = (unsigned char*)(SvPV(sv, len));
654 if (pos > PL_maxscream) {
655 if (PL_maxscream < 0) {
656 PL_maxscream = pos + 80;
657 New(301, PL_screamfirst, 256, I32);
658 New(302, PL_screamnext, PL_maxscream, I32);
661 PL_maxscream = pos + pos / 4;
662 Renew(PL_screamnext, PL_maxscream, I32);
666 sfirst = PL_screamfirst;
667 snext = PL_screamnext;
669 if (!sfirst || !snext)
670 DIE(aTHX_ "do_study: out of memory");
672 for (ch = 256; ch; --ch)
679 snext[pos] = sfirst[ch] - pos;
686 /* piggyback on m//g magic */
687 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
696 if (PL_op->op_flags & OPf_STACKED)
698 else if (PL_op->op_private & OPpTARGET_MY)
704 TARG = sv_newmortal();
709 /* Lvalue operators. */
721 dSP; dMARK; dTARGET; dORIGMARK;
723 do_chop(TARG, *++MARK);
732 SETi(do_chomp(TOPs));
739 register I32 count = 0;
742 count += do_chomp(POPs);
753 if (!sv || !SvANY(sv))
755 switch (SvTYPE(sv)) {
757 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
758 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
762 if (HvARRAY(sv) || SvGMAGICAL(sv)
763 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
767 if (CvROOT(sv) || CvXSUB(sv))
784 if (!PL_op->op_private) {
793 SV_CHECK_THINKFIRST_COW_DROP(sv);
795 switch (SvTYPE(sv)) {
805 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
806 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
807 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
811 /* let user-undef'd sub keep its identity */
812 GV* gv = CvGV((CV*)sv);
819 SvSetMagicSV(sv, &PL_sv_undef);
823 Newz(602, gp, 1, GP);
824 GvGP(sv) = gp_ref(gp);
825 GvSV(sv) = NEWSV(72,0);
826 GvLINE(sv) = CopLINE(PL_curcop);
832 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
835 SvPV_set(sv, Nullch);
848 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
849 DIE(aTHX_ PL_no_modify);
850 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
851 && SvIVX(TOPs) != IV_MIN)
854 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
865 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
866 DIE(aTHX_ PL_no_modify);
867 sv_setsv(TARG, TOPs);
868 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
869 && SvIVX(TOPs) != IV_MAX)
872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
877 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
887 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
888 DIE(aTHX_ PL_no_modify);
889 sv_setsv(TARG, TOPs);
890 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
891 && SvIVX(TOPs) != IV_MIN)
894 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
903 /* Ordinary operators. */
908 #ifdef PERL_PRESERVE_IVUV
911 tryAMAGICbin(pow,opASSIGN);
912 #ifdef PERL_PRESERVE_IVUV
913 /* For integer to integer power, we do the calculation by hand wherever
914 we're sure it is safe; otherwise we call pow() and try to convert to
915 integer afterwards. */
919 bool baseuok = SvUOK(TOPm1s);
923 baseuv = SvUVX(TOPm1s);
925 IV iv = SvIVX(TOPm1s);
928 baseuok = TRUE; /* effectively it's a UV now */
930 baseuv = -iv; /* abs, baseuok == false records sign */
944 goto float_it; /* Can't do negative powers this way. */
947 /* now we have integer ** positive integer. */
950 /* foo & (foo - 1) is zero only for a power of 2. */
951 if (!(baseuv & (baseuv - 1))) {
952 /* We are raising power-of-2 to a positive integer.
953 The logic here will work for any base (even non-integer
954 bases) but it can be less accurate than
955 pow (base,power) or exp (power * log (base)) when the
956 intermediate values start to spill out of the mantissa.
957 With powers of 2 we know this can't happen.
958 And powers of 2 are the favourite thing for perl
959 programmers to notice ** not doing what they mean. */
961 NV base = baseuok ? baseuv : -(NV)baseuv;
964 for (; power; base *= base, n++) {
965 /* Do I look like I trust gcc with long longs here?
967 UV bit = (UV)1 << (UV)n;
970 /* Only bother to clear the bit if it is set. */
972 /* Avoid squaring base again if we're done. */
973 if (power == 0) break;
981 register unsigned int highbit = 8 * sizeof(UV);
982 register unsigned int lowbit = 0;
983 register unsigned int diff;
984 bool odd_power = (bool)(power & 1);
985 while ((diff = (highbit - lowbit) >> 1)) {
986 if (baseuv & ~((1 << (lowbit + diff)) - 1))
991 /* we now have baseuv < 2 ** highbit */
992 if (power * highbit <= 8 * sizeof(UV)) {
993 /* result will definitely fit in UV, so use UV math
994 on same algorithm as above */
995 register UV result = 1;
996 register UV base = baseuv;
998 for (; power; base *= base, n++) {
999 register UV bit = (UV)1 << (UV)n;
1003 if (power == 0) break;
1007 if (baseuok || !odd_power)
1008 /* answer is positive */
1010 else if (result <= (UV)IV_MAX)
1011 /* answer negative, fits in IV */
1012 SETi( -(IV)result );
1013 else if (result == (UV)IV_MIN)
1014 /* 2's complement assumption: special case IV_MIN */
1017 /* answer negative, doesn't fit */
1018 SETn( -(NV)result );
1029 SETn( Perl_pow( left, right) );
1030 #ifdef PERL_PRESERVE_IVUV
1040 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1041 #ifdef PERL_PRESERVE_IVUV
1044 /* Unless the left argument is integer in range we are going to have to
1045 use NV maths. Hence only attempt to coerce the right argument if
1046 we know the left is integer. */
1047 /* Left operand is defined, so is it IV? */
1048 SvIV_please(TOPm1s);
1049 if (SvIOK(TOPm1s)) {
1050 bool auvok = SvUOK(TOPm1s);
1051 bool buvok = SvUOK(TOPs);
1052 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1053 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1060 alow = SvUVX(TOPm1s);
1062 IV aiv = SvIVX(TOPm1s);
1065 auvok = TRUE; /* effectively it's a UV now */
1067 alow = -aiv; /* abs, auvok == false records sign */
1073 IV biv = SvIVX(TOPs);
1076 buvok = TRUE; /* effectively it's a UV now */
1078 blow = -biv; /* abs, buvok == false records sign */
1082 /* If this does sign extension on unsigned it's time for plan B */
1083 ahigh = alow >> (4 * sizeof (UV));
1085 bhigh = blow >> (4 * sizeof (UV));
1087 if (ahigh && bhigh) {
1088 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1089 which is overflow. Drop to NVs below. */
1090 } else if (!ahigh && !bhigh) {
1091 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1092 so the unsigned multiply cannot overflow. */
1093 UV product = alow * blow;
1094 if (auvok == buvok) {
1095 /* -ve * -ve or +ve * +ve gives a +ve result. */
1099 } else if (product <= (UV)IV_MIN) {
1100 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1101 /* -ve result, which could overflow an IV */
1103 SETi( -(IV)product );
1105 } /* else drop to NVs below. */
1107 /* One operand is large, 1 small */
1110 /* swap the operands */
1112 bhigh = blow; /* bhigh now the temp var for the swap */
1116 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1117 multiplies can't overflow. shift can, add can, -ve can. */
1118 product_middle = ahigh * blow;
1119 if (!(product_middle & topmask)) {
1120 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1122 product_middle <<= (4 * sizeof (UV));
1123 product_low = alow * blow;
1125 /* as for pp_add, UV + something mustn't get smaller.
1126 IIRC ANSI mandates this wrapping *behaviour* for
1127 unsigned whatever the actual representation*/
1128 product_low += product_middle;
1129 if (product_low >= product_middle) {
1130 /* didn't overflow */
1131 if (auvok == buvok) {
1132 /* -ve * -ve or +ve * +ve gives a +ve result. */
1134 SETu( product_low );
1136 } else if (product_low <= (UV)IV_MIN) {
1137 /* 2s complement assumption again */
1138 /* -ve result, which could overflow an IV */
1140 SETi( -(IV)product_low );
1142 } /* else drop to NVs below. */
1144 } /* product_middle too large */
1145 } /* ahigh && bhigh */
1146 } /* SvIOK(TOPm1s) */
1151 SETn( left * right );
1158 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1159 /* Only try to do UV divide first
1160 if ((SLOPPYDIVIDE is true) or
1161 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1163 The assumption is that it is better to use floating point divide
1164 whenever possible, only doing integer divide first if we can't be sure.
1165 If NV_PRESERVES_UV is true then we know at compile time that no UV
1166 can be too large to preserve, so don't need to compile the code to
1167 test the size of UVs. */
1170 # define PERL_TRY_UV_DIVIDE
1171 /* ensure that 20./5. == 4. */
1173 # ifdef PERL_PRESERVE_IVUV
1174 # ifndef NV_PRESERVES_UV
1175 # define PERL_TRY_UV_DIVIDE
1180 #ifdef PERL_TRY_UV_DIVIDE
1183 SvIV_please(TOPm1s);
1184 if (SvIOK(TOPm1s)) {
1185 bool left_non_neg = SvUOK(TOPm1s);
1186 bool right_non_neg = SvUOK(TOPs);
1190 if (right_non_neg) {
1191 right = SvUVX(TOPs);
1194 IV biv = SvIVX(TOPs);
1197 right_non_neg = TRUE; /* effectively it's a UV now */
1203 /* historically undef()/0 gives a "Use of uninitialized value"
1204 warning before dieing, hence this test goes here.
1205 If it were immediately before the second SvIV_please, then
1206 DIE() would be invoked before left was even inspected, so
1207 no inpsection would give no warning. */
1209 DIE(aTHX_ "Illegal division by zero");
1212 left = SvUVX(TOPm1s);
1215 IV aiv = SvIVX(TOPm1s);
1218 left_non_neg = TRUE; /* effectively it's a UV now */
1227 /* For sloppy divide we always attempt integer division. */
1229 /* Otherwise we only attempt it if either or both operands
1230 would not be preserved by an NV. If both fit in NVs
1231 we fall through to the NV divide code below. However,
1232 as left >= right to ensure integer result here, we know that
1233 we can skip the test on the right operand - right big
1234 enough not to be preserved can't get here unless left is
1237 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1240 /* Integer division can't overflow, but it can be imprecise. */
1241 UV result = left / right;
1242 if (result * right == left) {
1243 SP--; /* result is valid */
1244 if (left_non_neg == right_non_neg) {
1245 /* signs identical, result is positive. */
1249 /* 2s complement assumption */
1250 if (result <= (UV)IV_MIN)
1251 SETi( -(IV)result );
1253 /* It's exact but too negative for IV. */
1254 SETn( -(NV)result );
1257 } /* tried integer divide but it was not an integer result */
1258 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1259 } /* left wasn't SvIOK */
1260 } /* right wasn't SvIOK */
1261 #endif /* PERL_TRY_UV_DIVIDE */
1265 DIE(aTHX_ "Illegal division by zero");
1266 PUSHn( left / right );
1273 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1277 bool left_neg = FALSE;
1278 bool right_neg = FALSE;
1279 bool use_double = FALSE;
1280 bool dright_valid = FALSE;
1286 right_neg = !SvUOK(TOPs);
1288 right = SvUVX(POPs);
1290 IV biv = SvIVX(POPs);
1293 right_neg = FALSE; /* effectively it's a UV now */
1301 right_neg = dright < 0;
1304 if (dright < UV_MAX_P1) {
1305 right = U_V(dright);
1306 dright_valid = TRUE; /* In case we need to use double below. */
1312 /* At this point use_double is only true if right is out of range for
1313 a UV. In range NV has been rounded down to nearest UV and
1314 use_double false. */
1316 if (!use_double && SvIOK(TOPs)) {
1318 left_neg = !SvUOK(TOPs);
1322 IV aiv = SvIVX(POPs);
1325 left_neg = FALSE; /* effectively it's a UV now */
1334 left_neg = dleft < 0;
1338 /* This should be exactly the 5.6 behaviour - if left and right are
1339 both in range for UV then use U_V() rather than floor. */
1341 if (dleft < UV_MAX_P1) {
1342 /* right was in range, so is dleft, so use UVs not double.
1346 /* left is out of range for UV, right was in range, so promote
1347 right (back) to double. */
1349 /* The +0.5 is used in 5.6 even though it is not strictly
1350 consistent with the implicit +0 floor in the U_V()
1351 inside the #if 1. */
1352 dleft = Perl_floor(dleft + 0.5);
1355 dright = Perl_floor(dright + 0.5);
1365 DIE(aTHX_ "Illegal modulus zero");
1367 dans = Perl_fmod(dleft, dright);
1368 if ((left_neg != right_neg) && dans)
1369 dans = dright - dans;
1372 sv_setnv(TARG, dans);
1378 DIE(aTHX_ "Illegal modulus zero");
1381 if ((left_neg != right_neg) && ans)
1384 /* XXX may warn: unary minus operator applied to unsigned type */
1385 /* could change -foo to be (~foo)+1 instead */
1386 if (ans <= ~((UV)IV_MAX)+1)
1387 sv_setiv(TARG, ~ans+1);
1389 sv_setnv(TARG, -(NV)ans);
1392 sv_setuv(TARG, ans);
1401 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1411 count = IV_MAX; /* The best we can do? */
1422 else if (SvNOKp(sv)) {
1431 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1433 I32 items = SP - MARK;
1435 static const char oom_list_extend[] =
1436 "Out of memory during list extend";
1438 max = items * count;
1439 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1440 /* Did the max computation overflow? */
1441 if (items > 0 && max > 0 && (max < items || max < count))
1442 Perl_croak(aTHX_ oom_list_extend);
1447 /* This code was intended to fix 20010809.028:
1450 for (($x =~ /./g) x 2) {
1451 print chop; # "abcdabcd" expected as output.
1454 * but that change (#11635) broke this code:
1456 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1458 * I can't think of a better fix that doesn't introduce
1459 * an efficiency hit by copying the SVs. The stack isn't
1460 * refcounted, and mortalisation obviously doesn't
1461 * Do The Right Thing when the stack has more than
1462 * one pointer to the same mortal value.
1466 *SP = sv_2mortal(newSVsv(*SP));
1476 repeatcpy((char*)(MARK + items), (char*)MARK,
1477 items * sizeof(SV*), count - 1);
1480 else if (count <= 0)
1483 else { /* Note: mark already snarfed by pp_list */
1487 static const char oom_string_extend[] =
1488 "Out of memory during string extend";
1490 SvSetSV(TARG, tmpstr);
1491 SvPV_force(TARG, len);
1492 isutf = DO_UTF8(TARG);
1497 IV max = count * len;
1498 if (len > ((MEM_SIZE)~0)/count)
1499 Perl_croak(aTHX_ oom_string_extend);
1500 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1501 SvGROW(TARG, (count * len) + 1);
1502 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1503 SvCUR(TARG) *= count;
1505 *SvEND(TARG) = '\0';
1508 (void)SvPOK_only_UTF8(TARG);
1510 (void)SvPOK_only(TARG);
1512 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1513 /* The parser saw this as a list repeat, and there
1514 are probably several items on the stack. But we're
1515 in scalar context, and there's no pp_list to save us
1516 now. So drop the rest of the items -- robin@kitsite.com
1529 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1530 useleft = USE_LEFT(TOPm1s);
1531 #ifdef PERL_PRESERVE_IVUV
1532 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1533 "bad things" happen if you rely on signed integers wrapping. */
1536 /* Unless the left argument is integer in range we are going to have to
1537 use NV maths. Hence only attempt to coerce the right argument if
1538 we know the left is integer. */
1539 register UV auv = 0;
1545 a_valid = auvok = 1;
1546 /* left operand is undef, treat as zero. */
1548 /* Left operand is defined, so is it IV? */
1549 SvIV_please(TOPm1s);
1550 if (SvIOK(TOPm1s)) {
1551 if ((auvok = SvUOK(TOPm1s)))
1552 auv = SvUVX(TOPm1s);
1554 register IV aiv = SvIVX(TOPm1s);
1557 auvok = 1; /* Now acting as a sign flag. */
1558 } else { /* 2s complement assumption for IV_MIN */
1566 bool result_good = 0;
1569 bool buvok = SvUOK(TOPs);
1574 register IV biv = SvIVX(TOPs);
1581 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1582 else "IV" now, independent of how it came in.
1583 if a, b represents positive, A, B negative, a maps to -A etc
1588 all UV maths. negate result if A negative.
1589 subtract if signs same, add if signs differ. */
1591 if (auvok ^ buvok) {
1600 /* Must get smaller */
1605 if (result <= buv) {
1606 /* result really should be -(auv-buv). as its negation
1607 of true value, need to swap our result flag */
1619 if (result <= (UV)IV_MIN)
1620 SETi( -(IV)result );
1622 /* result valid, but out of range for IV. */
1623 SETn( -(NV)result );
1627 } /* Overflow, drop through to NVs. */
1631 useleft = USE_LEFT(TOPm1s);
1635 /* left operand is undef, treat as zero - value */
1639 SETn( TOPn - value );
1646 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1649 if (PL_op->op_private & HINT_INTEGER) {
1663 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1666 if (PL_op->op_private & HINT_INTEGER) {
1680 dSP; tryAMAGICbinSET(lt,0);
1681 #ifdef PERL_PRESERVE_IVUV
1684 SvIV_please(TOPm1s);
1685 if (SvIOK(TOPm1s)) {
1686 bool auvok = SvUOK(TOPm1s);
1687 bool buvok = SvUOK(TOPs);
1689 if (!auvok && !buvok) { /* ## IV < IV ## */
1690 IV aiv = SvIVX(TOPm1s);
1691 IV biv = SvIVX(TOPs);
1694 SETs(boolSV(aiv < biv));
1697 if (auvok && buvok) { /* ## UV < UV ## */
1698 UV auv = SvUVX(TOPm1s);
1699 UV buv = SvUVX(TOPs);
1702 SETs(boolSV(auv < buv));
1705 if (auvok) { /* ## UV < IV ## */
1712 /* As (a) is a UV, it's >=0, so it cannot be < */
1717 SETs(boolSV(auv < (UV)biv));
1720 { /* ## IV < UV ## */
1724 aiv = SvIVX(TOPm1s);
1726 /* As (b) is a UV, it's >=0, so it must be < */
1733 SETs(boolSV((UV)aiv < buv));
1739 #ifndef NV_PRESERVES_UV
1740 #ifdef PERL_PRESERVE_IVUV
1743 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1745 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1751 SETs(boolSV(TOPn < value));
1758 dSP; tryAMAGICbinSET(gt,0);
1759 #ifdef PERL_PRESERVE_IVUV
1762 SvIV_please(TOPm1s);
1763 if (SvIOK(TOPm1s)) {
1764 bool auvok = SvUOK(TOPm1s);
1765 bool buvok = SvUOK(TOPs);
1767 if (!auvok && !buvok) { /* ## IV > IV ## */
1768 IV aiv = SvIVX(TOPm1s);
1769 IV biv = SvIVX(TOPs);
1772 SETs(boolSV(aiv > biv));
1775 if (auvok && buvok) { /* ## UV > UV ## */
1776 UV auv = SvUVX(TOPm1s);
1777 UV buv = SvUVX(TOPs);
1780 SETs(boolSV(auv > buv));
1783 if (auvok) { /* ## UV > IV ## */
1790 /* As (a) is a UV, it's >=0, so it must be > */
1795 SETs(boolSV(auv > (UV)biv));
1798 { /* ## IV > UV ## */
1802 aiv = SvIVX(TOPm1s);
1804 /* As (b) is a UV, it's >=0, so it cannot be > */
1811 SETs(boolSV((UV)aiv > buv));
1817 #ifndef NV_PRESERVES_UV
1818 #ifdef PERL_PRESERVE_IVUV
1821 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1823 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1829 SETs(boolSV(TOPn > value));
1836 dSP; tryAMAGICbinSET(le,0);
1837 #ifdef PERL_PRESERVE_IVUV
1840 SvIV_please(TOPm1s);
1841 if (SvIOK(TOPm1s)) {
1842 bool auvok = SvUOK(TOPm1s);
1843 bool buvok = SvUOK(TOPs);
1845 if (!auvok && !buvok) { /* ## IV <= IV ## */
1846 IV aiv = SvIVX(TOPm1s);
1847 IV biv = SvIVX(TOPs);
1850 SETs(boolSV(aiv <= biv));
1853 if (auvok && buvok) { /* ## UV <= UV ## */
1854 UV auv = SvUVX(TOPm1s);
1855 UV buv = SvUVX(TOPs);
1858 SETs(boolSV(auv <= buv));
1861 if (auvok) { /* ## UV <= IV ## */
1868 /* As (a) is a UV, it's >=0, so a cannot be <= */
1873 SETs(boolSV(auv <= (UV)biv));
1876 { /* ## IV <= UV ## */
1880 aiv = SvIVX(TOPm1s);
1882 /* As (b) is a UV, it's >=0, so a must be <= */
1889 SETs(boolSV((UV)aiv <= buv));
1895 #ifndef NV_PRESERVES_UV
1896 #ifdef PERL_PRESERVE_IVUV
1899 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1901 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1907 SETs(boolSV(TOPn <= value));
1914 dSP; tryAMAGICbinSET(ge,0);
1915 #ifdef PERL_PRESERVE_IVUV
1918 SvIV_please(TOPm1s);
1919 if (SvIOK(TOPm1s)) {
1920 bool auvok = SvUOK(TOPm1s);
1921 bool buvok = SvUOK(TOPs);
1923 if (!auvok && !buvok) { /* ## IV >= IV ## */
1924 IV aiv = SvIVX(TOPm1s);
1925 IV biv = SvIVX(TOPs);
1928 SETs(boolSV(aiv >= biv));
1931 if (auvok && buvok) { /* ## UV >= UV ## */
1932 UV auv = SvUVX(TOPm1s);
1933 UV buv = SvUVX(TOPs);
1936 SETs(boolSV(auv >= buv));
1939 if (auvok) { /* ## UV >= IV ## */
1946 /* As (a) is a UV, it's >=0, so it must be >= */
1951 SETs(boolSV(auv >= (UV)biv));
1954 { /* ## IV >= UV ## */
1958 aiv = SvIVX(TOPm1s);
1960 /* As (b) is a UV, it's >=0, so a cannot be >= */
1967 SETs(boolSV((UV)aiv >= buv));
1973 #ifndef NV_PRESERVES_UV
1974 #ifdef PERL_PRESERVE_IVUV
1977 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1979 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1985 SETs(boolSV(TOPn >= value));
1992 dSP; tryAMAGICbinSET(ne,0);
1993 #ifndef NV_PRESERVES_UV
1994 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1996 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2000 #ifdef PERL_PRESERVE_IVUV
2003 SvIV_please(TOPm1s);
2004 if (SvIOK(TOPm1s)) {
2005 bool auvok = SvUOK(TOPm1s);
2006 bool buvok = SvUOK(TOPs);
2008 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2009 /* Casting IV to UV before comparison isn't going to matter
2010 on 2s complement. On 1s complement or sign&magnitude
2011 (if we have any of them) it could make negative zero
2012 differ from normal zero. As I understand it. (Need to
2013 check - is negative zero implementation defined behaviour
2015 UV buv = SvUVX(POPs);
2016 UV auv = SvUVX(TOPs);
2018 SETs(boolSV(auv != buv));
2021 { /* ## Mixed IV,UV ## */
2025 /* != is commutative so swap if needed (save code) */
2027 /* swap. top of stack (b) is the iv */
2031 /* As (a) is a UV, it's >0, so it cannot be == */
2040 /* As (b) is a UV, it's >0, so it cannot be == */
2044 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2046 SETs(boolSV((UV)iv != uv));
2054 SETs(boolSV(TOPn != value));
2061 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2062 #ifndef NV_PRESERVES_UV
2063 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2064 UV right = PTR2UV(SvRV(POPs));
2065 UV left = PTR2UV(SvRV(TOPs));
2066 SETi((left > right) - (left < right));
2070 #ifdef PERL_PRESERVE_IVUV
2071 /* Fortunately it seems NaN isn't IOK */
2074 SvIV_please(TOPm1s);
2075 if (SvIOK(TOPm1s)) {
2076 bool leftuvok = SvUOK(TOPm1s);
2077 bool rightuvok = SvUOK(TOPs);
2079 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2080 IV leftiv = SvIVX(TOPm1s);
2081 IV rightiv = SvIVX(TOPs);
2083 if (leftiv > rightiv)
2085 else if (leftiv < rightiv)
2089 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2090 UV leftuv = SvUVX(TOPm1s);
2091 UV rightuv = SvUVX(TOPs);
2093 if (leftuv > rightuv)
2095 else if (leftuv < rightuv)
2099 } else if (leftuvok) { /* ## UV <=> IV ## */
2103 rightiv = SvIVX(TOPs);
2105 /* As (a) is a UV, it's >=0, so it cannot be < */
2108 leftuv = SvUVX(TOPm1s);
2109 if (leftuv > (UV)rightiv) {
2111 } else if (leftuv < (UV)rightiv) {
2117 } else { /* ## IV <=> UV ## */
2121 leftiv = SvIVX(TOPm1s);
2123 /* As (b) is a UV, it's >=0, so it must be < */
2126 rightuv = SvUVX(TOPs);
2127 if ((UV)leftiv > rightuv) {
2129 } else if ((UV)leftiv < rightuv) {
2147 if (Perl_isnan(left) || Perl_isnan(right)) {
2151 value = (left > right) - (left < right);
2155 else if (left < right)
2157 else if (left > right)
2171 dSP; tryAMAGICbinSET(slt,0);
2174 int cmp = (IN_LOCALE_RUNTIME
2175 ? sv_cmp_locale(left, right)
2176 : sv_cmp(left, right));
2177 SETs(boolSV(cmp < 0));
2184 dSP; tryAMAGICbinSET(sgt,0);
2187 int cmp = (IN_LOCALE_RUNTIME
2188 ? sv_cmp_locale(left, right)
2189 : sv_cmp(left, right));
2190 SETs(boolSV(cmp > 0));
2197 dSP; tryAMAGICbinSET(sle,0);
2200 int cmp = (IN_LOCALE_RUNTIME
2201 ? sv_cmp_locale(left, right)
2202 : sv_cmp(left, right));
2203 SETs(boolSV(cmp <= 0));
2210 dSP; tryAMAGICbinSET(sge,0);
2213 int cmp = (IN_LOCALE_RUNTIME
2214 ? sv_cmp_locale(left, right)
2215 : sv_cmp(left, right));
2216 SETs(boolSV(cmp >= 0));
2223 dSP; tryAMAGICbinSET(seq,0);
2226 SETs(boolSV(sv_eq(left, right)));
2233 dSP; tryAMAGICbinSET(sne,0);
2236 SETs(boolSV(!sv_eq(left, right)));
2243 dSP; dTARGET; tryAMAGICbin(scmp,0);
2246 int cmp = (IN_LOCALE_RUNTIME
2247 ? sv_cmp_locale(left, right)
2248 : sv_cmp(left, right));
2256 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2259 if (SvGMAGICAL(left)) mg_get(left);
2260 if (SvGMAGICAL(right)) mg_get(right);
2261 if (SvNIOKp(left) || SvNIOKp(right)) {
2262 if (PL_op->op_private & HINT_INTEGER) {
2263 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2267 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2272 do_vop(PL_op->op_type, TARG, left, right);
2281 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2284 if (SvGMAGICAL(left)) mg_get(left);
2285 if (SvGMAGICAL(right)) mg_get(right);
2286 if (SvNIOKp(left) || SvNIOKp(right)) {
2287 if (PL_op->op_private & HINT_INTEGER) {
2288 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2292 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2297 do_vop(PL_op->op_type, TARG, left, right);
2306 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2309 if (SvGMAGICAL(left)) mg_get(left);
2310 if (SvGMAGICAL(right)) mg_get(right);
2311 if (SvNIOKp(left) || SvNIOKp(right)) {
2312 if (PL_op->op_private & HINT_INTEGER) {
2313 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2317 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2322 do_vop(PL_op->op_type, TARG, left, right);
2331 dSP; dTARGET; tryAMAGICun(neg);
2334 int flags = SvFLAGS(sv);
2337 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2338 /* It's publicly an integer, or privately an integer-not-float */
2341 if (SvIVX(sv) == IV_MIN) {
2342 /* 2s complement assumption. */
2343 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2346 else if (SvUVX(sv) <= IV_MAX) {
2351 else if (SvIVX(sv) != IV_MIN) {
2355 #ifdef PERL_PRESERVE_IVUV
2364 else if (SvPOKp(sv)) {
2366 char *s = SvPV(sv, len);
2367 if (isIDFIRST(*s)) {
2368 sv_setpvn(TARG, "-", 1);
2371 else if (*s == '+' || *s == '-') {
2373 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2375 else if (DO_UTF8(sv)) {
2378 goto oops_its_an_int;
2380 sv_setnv(TARG, -SvNV(sv));
2382 sv_setpvn(TARG, "-", 1);
2389 goto oops_its_an_int;
2390 sv_setnv(TARG, -SvNV(sv));
2402 dSP; tryAMAGICunSET(not);
2403 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2409 dSP; dTARGET; tryAMAGICun(compl);
2415 if (PL_op->op_private & HINT_INTEGER) {
2416 IV i = ~SvIV_nomg(sv);
2420 UV u = ~SvUV_nomg(sv);
2429 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2430 sv_setsv_nomg(TARG, sv);
2431 tmps = (U8*)SvPV_force(TARG, len);
2434 /* Calculate exact length, let's not estimate. */
2443 while (tmps < send) {
2444 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2445 tmps += UTF8SKIP(tmps);
2446 targlen += UNISKIP(~c);
2452 /* Now rewind strings and write them. */
2456 Newz(0, result, targlen + 1, U8);
2457 while (tmps < send) {
2458 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2459 tmps += UTF8SKIP(tmps);
2460 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2464 sv_setpvn(TARG, (char*)result, targlen);
2468 Newz(0, result, nchar + 1, U8);
2469 while (tmps < send) {
2470 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2471 tmps += UTF8SKIP(tmps);
2476 sv_setpvn(TARG, (char*)result, nchar);
2485 register long *tmpl;
2486 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2489 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2494 for ( ; anum > 0; anum--, tmps++)
2503 /* integer versions of some of the above */
2507 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2510 SETi( left * right );
2517 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2521 DIE(aTHX_ "Illegal division by zero");
2522 value = POPi / value;
2531 /* This is the vanilla old i_modulo. */
2532 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2536 DIE(aTHX_ "Illegal modulus zero");
2537 SETi( left % right );
2542 #if defined(__GLIBC__) && IVSIZE == 8
2546 /* This is the i_modulo with the workaround for the _moddi3 bug
2547 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2548 * See below for pp_i_modulo. */
2549 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2553 DIE(aTHX_ "Illegal modulus zero");
2554 SETi( left % PERL_ABS(right) );
2562 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2566 DIE(aTHX_ "Illegal modulus zero");
2567 /* The assumption is to use hereafter the old vanilla version... */
2569 PL_ppaddr[OP_I_MODULO] =
2570 &Perl_pp_i_modulo_0;
2571 /* .. but if we have glibc, we might have a buggy _moddi3
2572 * (at least glicb 2.2.5 is known to have this bug), in other
2573 * words our integer modulus with negative quad as the second
2574 * argument might be broken. Test for this and re-patch the
2575 * opcode dispatch table if that is the case, remembering to
2576 * also apply the workaround so that this first round works
2577 * right, too. See [perl #9402] for more information. */
2578 #if defined(__GLIBC__) && IVSIZE == 8
2582 /* Cannot do this check with inlined IV constants since
2583 * that seems to work correctly even with the buggy glibc. */
2585 /* Yikes, we have the bug.
2586 * Patch in the workaround version. */
2588 PL_ppaddr[OP_I_MODULO] =
2589 &Perl_pp_i_modulo_1;
2590 /* Make certain we work right this time, too. */
2591 right = PERL_ABS(right);
2595 SETi( left % right );
2602 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2605 SETi( left + right );
2612 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2615 SETi( left - right );
2622 dSP; tryAMAGICbinSET(lt,0);
2625 SETs(boolSV(left < right));
2632 dSP; tryAMAGICbinSET(gt,0);
2635 SETs(boolSV(left > right));
2642 dSP; tryAMAGICbinSET(le,0);
2645 SETs(boolSV(left <= right));
2652 dSP; tryAMAGICbinSET(ge,0);
2655 SETs(boolSV(left >= right));
2662 dSP; tryAMAGICbinSET(eq,0);
2665 SETs(boolSV(left == right));
2672 dSP; tryAMAGICbinSET(ne,0);
2675 SETs(boolSV(left != right));
2682 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2689 else if (left < right)
2700 dSP; dTARGET; tryAMAGICun(neg);
2705 /* High falutin' math. */
2709 dSP; dTARGET; tryAMAGICbin(atan2,0);
2712 SETn(Perl_atan2(left, right));
2719 dSP; dTARGET; tryAMAGICun(sin);
2723 value = Perl_sin(value);
2731 dSP; dTARGET; tryAMAGICun(cos);
2735 value = Perl_cos(value);
2741 /* Support Configure command-line overrides for rand() functions.
2742 After 5.005, perhaps we should replace this by Configure support
2743 for drand48(), random(), or rand(). For 5.005, though, maintain
2744 compatibility by calling rand() but allow the user to override it.
2745 See INSTALL for details. --Andy Dougherty 15 July 1998
2747 /* Now it's after 5.005, and Configure supports drand48() and random(),
2748 in addition to rand(). So the overrides should not be needed any more.
2749 --Jarkko Hietaniemi 27 September 1998
2752 #ifndef HAS_DRAND48_PROTO
2753 extern double drand48 (void);
2766 if (!PL_srand_called) {
2767 (void)seedDrand01((Rand_seed_t)seed());
2768 PL_srand_called = TRUE;
2783 (void)seedDrand01((Rand_seed_t)anum);
2784 PL_srand_called = TRUE;
2791 dSP; dTARGET; tryAMAGICun(exp);
2795 value = Perl_exp(value);
2803 dSP; dTARGET; tryAMAGICun(log);
2808 SET_NUMERIC_STANDARD();
2809 DIE(aTHX_ "Can't take log of %"NVgf, value);
2811 value = Perl_log(value);
2819 dSP; dTARGET; tryAMAGICun(sqrt);
2824 SET_NUMERIC_STANDARD();
2825 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2827 value = Perl_sqrt(value);
2835 dSP; dTARGET; tryAMAGICun(int);
2838 IV iv = TOPi; /* attempt to convert to IV if possible. */
2839 /* XXX it's arguable that compiler casting to IV might be subtly
2840 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2841 else preferring IV has introduced a subtle behaviour change bug. OTOH
2842 relying on floating point to be accurate is a bug. */
2846 else if (SvIOK(TOPs)) {
2855 if (value < (NV)UV_MAX + 0.5) {
2858 SETn(Perl_floor(value));
2862 if (value > (NV)IV_MIN - 0.5) {
2865 SETn(Perl_ceil(value));
2875 dSP; dTARGET; tryAMAGICun(abs);
2877 /* This will cache the NV value if string isn't actually integer */
2882 else if (SvIOK(TOPs)) {
2883 /* IVX is precise */
2885 SETu(TOPu); /* force it to be numeric only */
2893 /* 2s complement assumption. Also, not really needed as
2894 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2914 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2920 tmps = (SvPVx(sv, len));
2922 /* If Unicode, try to downgrade
2923 * If not possible, croak. */
2924 SV* tsv = sv_2mortal(newSVsv(sv));
2927 sv_utf8_downgrade(tsv, FALSE);
2930 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2931 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2944 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2950 tmps = (SvPVx(sv, len));
2952 /* If Unicode, try to downgrade
2953 * If not possible, croak. */
2954 SV* tsv = sv_2mortal(newSVsv(sv));
2957 sv_utf8_downgrade(tsv, FALSE);
2960 while (*tmps && len && isSPACE(*tmps))
2965 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2966 else if (*tmps == 'b')
2967 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2969 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2971 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2988 SETi(sv_len_utf8(sv));
3004 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3006 I32 arybase = PL_curcop->cop_arybase;
3010 int num_args = PL_op->op_private & 7;
3011 bool repl_need_utf8_upgrade = FALSE;
3012 bool repl_is_utf8 = FALSE;
3014 SvTAINTED_off(TARG); /* decontaminate */
3015 SvUTF8_off(TARG); /* decontaminate */
3019 repl = SvPV(repl_sv, repl_len);
3020 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3030 sv_utf8_upgrade(sv);
3032 else if (DO_UTF8(sv))
3033 repl_need_utf8_upgrade = TRUE;
3035 tmps = SvPV(sv, curlen);
3037 utf8_curlen = sv_len_utf8(sv);
3038 if (utf8_curlen == curlen)
3041 curlen = utf8_curlen;
3046 if (pos >= arybase) {
3064 else if (len >= 0) {
3066 if (rem > (I32)curlen)
3081 Perl_croak(aTHX_ "substr outside of string");
3082 if (ckWARN(WARN_SUBSTR))
3083 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3090 sv_pos_u2b(sv, &pos, &rem);
3092 /* we either return a PV or an LV. If the TARG hasn't been used
3093 * before, or is of that type, reuse it; otherwise use a mortal
3094 * instead. Note that LVs can have an extended lifetime, so also
3095 * dont reuse if refcount > 1 (bug #20933) */
3096 if (SvTYPE(TARG) > SVt_NULL) {
3097 if ( (SvTYPE(TARG) == SVt_PVLV)
3098 ? (!lvalue || SvREFCNT(TARG) > 1)
3101 TARG = sv_newmortal();
3105 sv_setpvn(TARG, tmps, rem);
3106 #ifdef USE_LOCALE_COLLATE
3107 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3112 SV* repl_sv_copy = NULL;
3114 if (repl_need_utf8_upgrade) {
3115 repl_sv_copy = newSVsv(repl_sv);
3116 sv_utf8_upgrade(repl_sv_copy);
3117 repl = SvPV(repl_sv_copy, repl_len);
3118 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3120 sv_insert(sv, pos, rem, repl, repl_len);
3124 SvREFCNT_dec(repl_sv_copy);
3126 else if (lvalue) { /* it's an lvalue! */
3127 if (!SvGMAGICAL(sv)) {
3131 if (ckWARN(WARN_SUBSTR))
3132 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3133 "Attempt to use reference as lvalue in substr");
3135 if (SvOK(sv)) /* is it defined ? */
3136 (void)SvPOK_only_UTF8(sv);
3138 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3141 if (SvTYPE(TARG) < SVt_PVLV) {
3142 sv_upgrade(TARG, SVt_PVLV);
3143 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3149 if (LvTARG(TARG) != sv) {
3151 SvREFCNT_dec(LvTARG(TARG));
3152 LvTARG(TARG) = SvREFCNT_inc(sv);
3154 LvTARGOFF(TARG) = upos;
3155 LvTARGLEN(TARG) = urem;
3159 PUSHs(TARG); /* avoid SvSETMAGIC here */
3166 register IV size = POPi;
3167 register IV offset = POPi;
3168 register SV *src = POPs;
3169 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3171 SvTAINTED_off(TARG); /* decontaminate */
3172 if (lvalue) { /* it's an lvalue! */
3173 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3174 TARG = sv_newmortal();
3175 if (SvTYPE(TARG) < SVt_PVLV) {
3176 sv_upgrade(TARG, SVt_PVLV);
3177 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3180 if (LvTARG(TARG) != src) {
3182 SvREFCNT_dec(LvTARG(TARG));
3183 LvTARG(TARG) = SvREFCNT_inc(src);
3185 LvTARGOFF(TARG) = offset;
3186 LvTARGLEN(TARG) = size;
3189 sv_setuv(TARG, do_vecget(src, offset, size));
3204 I32 arybase = PL_curcop->cop_arybase;
3209 offset = POPi - arybase;
3212 tmps = SvPV(big, biglen);
3213 if (offset > 0 && DO_UTF8(big))
3214 sv_pos_u2b(big, &offset, 0);
3217 else if (offset > (I32)biglen)
3219 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3220 (unsigned char*)tmps + biglen, little, 0)))
3223 retval = tmps2 - tmps;
3224 if (retval > 0 && DO_UTF8(big))
3225 sv_pos_b2u(big, &retval);
3226 PUSHi(retval + arybase);
3241 I32 arybase = PL_curcop->cop_arybase;
3247 tmps2 = SvPV(little, llen);
3248 tmps = SvPV(big, blen);
3252 if (offset > 0 && DO_UTF8(big))
3253 sv_pos_u2b(big, &offset, 0);
3254 offset = offset - arybase + llen;
3258 else if (offset > (I32)blen)
3260 if (!(tmps2 = rninstr(tmps, tmps + offset,
3261 tmps2, tmps2 + llen)))
3264 retval = tmps2 - tmps;
3265 if (retval > 0 && DO_UTF8(big))
3266 sv_pos_b2u(big, &retval);
3267 PUSHi(retval + arybase);
3273 dSP; dMARK; dORIGMARK; dTARGET;
3274 do_sprintf(TARG, SP-MARK, MARK+1);
3275 TAINT_IF(SvTAINTED(TARG));
3276 if (DO_UTF8(*(MARK+1)))
3288 U8 *s = (U8*)SvPVx(argsv, len);
3291 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3292 tmpsv = sv_2mortal(newSVsv(argsv));
3293 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3297 XPUSHu(DO_UTF8(argsv) ?
3298 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3310 (void)SvUPGRADE(TARG,SVt_PV);
3312 if (value > 255 && !IN_BYTES) {
3313 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3314 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3315 SvCUR_set(TARG, tmps - SvPVX(TARG));
3317 (void)SvPOK_only(TARG);
3326 *tmps++ = (char)value;
3328 (void)SvPOK_only(TARG);
3329 if (PL_encoding && !IN_BYTES) {
3330 sv_recode_to_utf8(TARG, PL_encoding);
3332 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3333 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3337 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3338 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3354 char *tmps = SvPV(left, len);
3356 if (DO_UTF8(left)) {
3357 /* If Unicode, try to downgrade.
3358 * If not possible, croak.
3359 * Yes, we made this up. */
3360 SV* tsv = sv_2mortal(newSVsv(left));
3363 sv_utf8_downgrade(tsv, FALSE);
3366 # ifdef USE_ITHREADS
3368 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3369 /* This should be threadsafe because in ithreads there is only
3370 * one thread per interpreter. If this would not be true,
3371 * we would need a mutex to protect this malloc. */
3372 PL_reentrant_buffer->_crypt_struct_buffer =
3373 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3374 #if defined(__GLIBC__) || defined(__EMX__)
3375 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3376 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3377 /* work around glibc-2.2.5 bug */
3378 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3382 # endif /* HAS_CRYPT_R */
3383 # endif /* USE_ITHREADS */
3385 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3387 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3393 "The crypt() function is unimplemented due to excessive paranoia.");
3406 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3407 UTF8_IS_START(*s)) {
3408 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3412 utf8_to_uvchr(s, &ulen);
3413 toTITLE_utf8(s, tmpbuf, &tculen);
3414 utf8_to_uvchr(tmpbuf, 0);
3416 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3418 /* slen is the byte length of the whole SV.
3419 * ulen is the byte length of the original Unicode character
3420 * stored as UTF-8 at s.
3421 * tculen is the byte length of the freshly titlecased
3422 * Unicode character stored as UTF-8 at tmpbuf.
3423 * We first set the result to be the titlecased character,
3424 * and then append the rest of the SV data. */
3425 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3427 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3432 s = (U8*)SvPV_force_nomg(sv, slen);
3433 Copy(tmpbuf, s, tculen, U8);
3437 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3439 SvUTF8_off(TARG); /* decontaminate */
3440 sv_setsv_nomg(TARG, sv);
3444 s = (U8*)SvPV_force_nomg(sv, slen);
3446 if (IN_LOCALE_RUNTIME) {
3449 *s = toUPPER_LC(*s);
3468 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3469 UTF8_IS_START(*s)) {
3471 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3475 toLOWER_utf8(s, tmpbuf, &ulen);
3476 uv = utf8_to_uvchr(tmpbuf, 0);
3477 tend = uvchr_to_utf8(tmpbuf, uv);
3479 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3481 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3483 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3488 s = (U8*)SvPV_force_nomg(sv, slen);
3489 Copy(tmpbuf, s, ulen, U8);
3493 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3495 SvUTF8_off(TARG); /* decontaminate */
3496 sv_setsv_nomg(TARG, sv);
3500 s = (U8*)SvPV_force_nomg(sv, slen);
3502 if (IN_LOCALE_RUNTIME) {
3505 *s = toLOWER_LC(*s);
3528 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3530 s = (U8*)SvPV_nomg(sv,len);
3532 SvUTF8_off(TARG); /* decontaminate */
3533 sv_setpvn(TARG, "", 0);
3537 STRLEN nchar = utf8_length(s, s + len);
3539 (void)SvUPGRADE(TARG, SVt_PV);
3540 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3541 (void)SvPOK_only(TARG);
3542 d = (U8*)SvPVX(TARG);
3545 toUPPER_utf8(s, tmpbuf, &ulen);
3546 Copy(tmpbuf, d, ulen, U8);
3552 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3557 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3559 SvUTF8_off(TARG); /* decontaminate */
3560 sv_setsv_nomg(TARG, sv);
3564 s = (U8*)SvPV_force_nomg(sv, len);
3566 register U8 *send = s + len;
3568 if (IN_LOCALE_RUNTIME) {
3571 for (; s < send; s++)
3572 *s = toUPPER_LC(*s);
3575 for (; s < send; s++)
3597 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3599 s = (U8*)SvPV_nomg(sv,len);
3601 SvUTF8_off(TARG); /* decontaminate */
3602 sv_setpvn(TARG, "", 0);
3606 STRLEN nchar = utf8_length(s, s + len);
3608 (void)SvUPGRADE(TARG, SVt_PV);
3609 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3610 (void)SvPOK_only(TARG);
3611 d = (U8*)SvPVX(TARG);
3614 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3615 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
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 * See lib/unicore/SpecCase.txt.
3632 Copy(tmpbuf, d, ulen, U8);
3638 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3643 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3645 SvUTF8_off(TARG); /* decontaminate */
3646 sv_setsv_nomg(TARG, sv);
3651 s = (U8*)SvPV_force_nomg(sv, len);
3653 register U8 *send = s + len;
3655 if (IN_LOCALE_RUNTIME) {
3658 for (; s < send; s++)
3659 *s = toLOWER_LC(*s);
3662 for (; s < send; s++)
3676 register char *s = SvPV(sv,len);
3679 SvUTF8_off(TARG); /* decontaminate */
3681 (void)SvUPGRADE(TARG, SVt_PV);
3682 SvGROW(TARG, (len * 2) + 1);
3686 if (UTF8_IS_CONTINUED(*s)) {
3687 STRLEN ulen = UTF8SKIP(s);
3711 SvCUR_set(TARG, d - SvPVX(TARG));
3712 (void)SvPOK_only_UTF8(TARG);
3715 sv_setpvn(TARG, s, len);
3717 if (SvSMAGICAL(TARG))
3726 dSP; dMARK; dORIGMARK;
3728 register AV* av = (AV*)POPs;
3729 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3730 I32 arybase = PL_curcop->cop_arybase;
3733 if (SvTYPE(av) == SVt_PVAV) {
3734 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3736 for (svp = MARK + 1; svp <= SP; svp++) {
3741 if (max > AvMAX(av))
3744 while (++MARK <= SP) {
3745 elem = SvIVx(*MARK);
3749 svp = av_fetch(av, elem, lval);
3751 if (!svp || *svp == &PL_sv_undef)
3752 DIE(aTHX_ PL_no_aelem, elem);
3753 if (PL_op->op_private & OPpLVAL_INTRO)
3754 save_aelem(av, elem, svp);
3756 *MARK = svp ? *svp : &PL_sv_undef;
3759 if (GIMME != G_ARRAY) {
3761 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3767 /* Associative arrays. */
3772 HV *hash = (HV*)POPs;
3774 I32 gimme = GIMME_V;
3777 /* might clobber stack_sp */
3778 entry = hv_iternext(hash);
3783 SV* sv = hv_iterkeysv(entry);
3784 PUSHs(sv); /* won't clobber stack_sp */
3785 if (gimme == G_ARRAY) {
3788 /* might clobber stack_sp */
3789 val = hv_iterval(hash, entry);
3794 else if (gimme == G_SCALAR)
3813 I32 gimme = GIMME_V;
3814 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3818 if (PL_op->op_private & OPpSLICE) {
3822 hvtype = SvTYPE(hv);
3823 if (hvtype == SVt_PVHV) { /* hash element */
3824 while (++MARK <= SP) {
3825 sv = hv_delete_ent(hv, *MARK, discard, 0);
3826 *MARK = sv ? sv : &PL_sv_undef;
3829 else if (hvtype == SVt_PVAV) { /* array element */
3830 if (PL_op->op_flags & OPf_SPECIAL) {
3831 while (++MARK <= SP) {
3832 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3833 *MARK = sv ? sv : &PL_sv_undef;
3838 DIE(aTHX_ "Not a HASH reference");
3841 else if (gimme == G_SCALAR) {
3846 *++MARK = &PL_sv_undef;
3853 if (SvTYPE(hv) == SVt_PVHV)
3854 sv = hv_delete_ent(hv, keysv, discard, 0);
3855 else if (SvTYPE(hv) == SVt_PVAV) {
3856 if (PL_op->op_flags & OPf_SPECIAL)
3857 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3859 DIE(aTHX_ "panic: avhv_delete no longer supported");
3862 DIE(aTHX_ "Not a HASH reference");
3877 if (PL_op->op_private & OPpEXISTS_SUB) {
3881 cv = sv_2cv(sv, &hv, &gv, FALSE);
3884 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3890 if (SvTYPE(hv) == SVt_PVHV) {
3891 if (hv_exists_ent(hv, tmpsv, 0))
3894 else if (SvTYPE(hv) == SVt_PVAV) {
3895 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3896 if (av_exists((AV*)hv, SvIV(tmpsv)))
3901 DIE(aTHX_ "Not a HASH reference");
3908 dSP; dMARK; dORIGMARK;
3909 register HV *hv = (HV*)POPs;
3910 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3911 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3912 bool other_magic = FALSE;
3918 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3919 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3920 /* Try to preserve the existenceness of a tied hash
3921 * element by using EXISTS and DELETE if possible.
3922 * Fallback to FETCH and STORE otherwise */
3923 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3924 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3925 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3928 while (++MARK <= SP) {
3932 bool preeminent = FALSE;
3935 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3936 hv_exists_ent(hv, keysv, 0);
3939 he = hv_fetch_ent(hv, keysv, lval, 0);
3940 svp = he ? &HeVAL(he) : 0;
3943 if (!svp || *svp == &PL_sv_undef) {
3945 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3949 save_helem(hv, keysv, svp);
3952 char *key = SvPV(keysv, keylen);
3953 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3957 *MARK = svp ? *svp : &PL_sv_undef;
3959 if (GIMME != G_ARRAY) {
3961 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3967 /* List operators. */
3972 if (GIMME != G_ARRAY) {
3974 *MARK = *SP; /* unwanted list, return last item */
3976 *MARK = &PL_sv_undef;
3985 SV **lastrelem = PL_stack_sp;
3986 SV **lastlelem = PL_stack_base + POPMARK;
3987 SV **firstlelem = PL_stack_base + POPMARK + 1;
3988 register SV **firstrelem = lastlelem + 1;
3989 I32 arybase = PL_curcop->cop_arybase;
3990 I32 lval = PL_op->op_flags & OPf_MOD;
3991 I32 is_something_there = lval;
3993 register I32 max = lastrelem - lastlelem;
3994 register SV **lelem;
3997 if (GIMME != G_ARRAY) {
3998 ix = SvIVx(*lastlelem);
4003 if (ix < 0 || ix >= max)
4004 *firstlelem = &PL_sv_undef;
4006 *firstlelem = firstrelem[ix];
4012 SP = firstlelem - 1;
4016 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4022 if (ix < 0 || ix >= max)
4023 *lelem = &PL_sv_undef;
4025 is_something_there = TRUE;
4026 if (!(*lelem = firstrelem[ix]))
4027 *lelem = &PL_sv_undef;
4030 if (is_something_there)
4033 SP = firstlelem - 1;
4039 dSP; dMARK; dORIGMARK;
4040 I32 items = SP - MARK;
4041 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4042 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4049 dSP; dMARK; dORIGMARK;
4050 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4054 SV *val = NEWSV(46, 0);
4056 sv_setsv(val, *++MARK);
4057 else if (ckWARN(WARN_MISC))
4058 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4059 (void)hv_store_ent(hv,key,val,0);
4068 dSP; dMARK; dORIGMARK;
4069 register AV *ary = (AV*)*++MARK;
4073 register I32 offset;
4074 register I32 length;
4081 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4082 *MARK-- = SvTIED_obj((SV*)ary, mg);
4086 call_method("SPLICE",GIMME_V);
4095 offset = i = SvIVx(*MARK);
4097 offset += AvFILLp(ary) + 1;
4099 offset -= PL_curcop->cop_arybase;
4101 DIE(aTHX_ PL_no_aelem, i);
4103 length = SvIVx(*MARK++);
4105 length += AvFILLp(ary) - offset + 1;
4111 length = AvMAX(ary) + 1; /* close enough to infinity */
4115 length = AvMAX(ary) + 1;
4117 if (offset > AvFILLp(ary) + 1) {
4118 if (ckWARN(WARN_MISC))
4119 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4120 offset = AvFILLp(ary) + 1;
4122 after = AvFILLp(ary) + 1 - (offset + length);
4123 if (after < 0) { /* not that much array */
4124 length += after; /* offset+length now in array */
4130 /* At this point, MARK .. SP-1 is our new LIST */
4133 diff = newlen - length;
4134 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4137 /* make new elements SVs now: avoid problems if they're from the array */
4138 for (dst = MARK, i = newlen; i; i--) {
4140 *dst = NEWSV(46, 0);
4141 sv_setsv(*dst++, h);
4144 if (diff < 0) { /* shrinking the area */
4146 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4147 Copy(MARK, tmparyval, newlen, SV*);
4150 MARK = ORIGMARK + 1;
4151 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4152 MEXTEND(MARK, length);
4153 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4155 EXTEND_MORTAL(length);
4156 for (i = length, dst = MARK; i; i--) {
4157 sv_2mortal(*dst); /* free them eventualy */
4164 *MARK = AvARRAY(ary)[offset+length-1];
4167 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4168 SvREFCNT_dec(*dst++); /* free them now */
4171 AvFILLp(ary) += diff;
4173 /* pull up or down? */
4175 if (offset < after) { /* easier to pull up */
4176 if (offset) { /* esp. if nothing to pull */
4177 src = &AvARRAY(ary)[offset-1];
4178 dst = src - diff; /* diff is negative */
4179 for (i = offset; i > 0; i--) /* can't trust Copy */
4183 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4187 if (after) { /* anything to pull down? */
4188 src = AvARRAY(ary) + offset + length;
4189 dst = src + diff; /* diff is negative */
4190 Move(src, dst, after, SV*);
4192 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4193 /* avoid later double free */
4197 dst[--i] = &PL_sv_undef;
4200 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4201 Safefree(tmparyval);
4204 else { /* no, expanding (or same) */
4206 New(452, tmparyval, length, SV*); /* so remember deletion */
4207 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4210 if (diff > 0) { /* expanding */
4212 /* push up or down? */
4214 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4218 Move(src, dst, offset, SV*);
4220 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4222 AvFILLp(ary) += diff;
4225 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4226 av_extend(ary, AvFILLp(ary) + diff);
4227 AvFILLp(ary) += diff;
4230 dst = AvARRAY(ary) + AvFILLp(ary);
4232 for (i = after; i; i--) {
4240 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4243 MARK = ORIGMARK + 1;
4244 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4246 Copy(tmparyval, MARK, length, SV*);
4248 EXTEND_MORTAL(length);
4249 for (i = length, dst = MARK; i; i--) {
4250 sv_2mortal(*dst); /* free them eventualy */
4254 Safefree(tmparyval);
4258 else if (length--) {
4259 *MARK = tmparyval[length];
4262 while (length-- > 0)
4263 SvREFCNT_dec(tmparyval[length]);
4265 Safefree(tmparyval);
4268 *MARK = &PL_sv_undef;
4276 dSP; dMARK; dORIGMARK; dTARGET;
4277 register AV *ary = (AV*)*++MARK;
4278 register SV *sv = &PL_sv_undef;
4281 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4282 *MARK-- = SvTIED_obj((SV*)ary, mg);
4286 call_method("PUSH",G_SCALAR|G_DISCARD);
4291 /* Why no pre-extend of ary here ? */
4292 for (++MARK; MARK <= SP; MARK++) {
4295 sv_setsv(sv, *MARK);
4300 PUSHi( AvFILL(ary) + 1 );
4308 SV *sv = av_pop(av);
4310 (void)sv_2mortal(sv);
4319 SV *sv = av_shift(av);
4324 (void)sv_2mortal(sv);
4331 dSP; dMARK; dORIGMARK; dTARGET;
4332 register AV *ary = (AV*)*++MARK;
4337 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4338 *MARK-- = SvTIED_obj((SV*)ary, mg);
4342 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4347 av_unshift(ary, SP - MARK);
4350 sv_setsv(sv, *++MARK);
4351 (void)av_store(ary, i++, sv);
4355 PUSHi( AvFILL(ary) + 1 );
4365 if (GIMME == G_ARRAY) {
4372 /* safe as long as stack cannot get extended in the above */
4377 register char *down;
4383 SvUTF8_off(TARG); /* decontaminate */
4385 do_join(TARG, &PL_sv_no, MARK, SP);
4387 sv_setsv(TARG, (SP > MARK)
4389 : (padoff_du = find_rundefsvoffset(),
4390 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4391 ? DEFSV : PAD_SVl(padoff_du)));
4392 up = SvPV_force(TARG, len);
4394 if (DO_UTF8(TARG)) { /* first reverse each character */
4395 U8* s = (U8*)SvPVX(TARG);
4396 U8* send = (U8*)(s + len);
4398 if (UTF8_IS_INVARIANT(*s)) {
4403 if (!utf8_to_uvchr(s, 0))
4407 down = (char*)(s - 1);
4408 /* reverse this character */
4412 *down-- = (char)tmp;
4418 down = SvPVX(TARG) + len - 1;
4422 *down-- = (char)tmp;
4424 (void)SvPOK_only_UTF8(TARG);
4436 register IV limit = POPi; /* note, negative is forever */
4439 register char *s = SvPV(sv, len);
4440 bool do_utf8 = DO_UTF8(sv);
4441 char *strend = s + len;
4443 register REGEXP *rx;
4447 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4448 I32 maxiters = slen + 10;
4451 I32 origlimit = limit;
4454 I32 gimme = GIMME_V;
4455 I32 oldsave = PL_savestack_ix;
4456 I32 make_mortal = 1;
4457 MAGIC *mg = (MAGIC *) NULL;
4460 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4465 DIE(aTHX_ "panic: pp_split");
4468 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4469 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4471 RX_MATCH_UTF8_set(rx, do_utf8);
4473 if (pm->op_pmreplroot) {
4475 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4477 ary = GvAVn((GV*)pm->op_pmreplroot);
4480 else if (gimme != G_ARRAY)
4481 ary = GvAVn(PL_defgv);
4484 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4490 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4492 XPUSHs(SvTIED_obj((SV*)ary, mg));
4498 for (i = AvFILLp(ary); i >= 0; i--)
4499 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4501 /* temporarily switch stacks */
4502 SAVESWITCHSTACK(PL_curstack, ary);
4506 base = SP - PL_stack_base;
4508 if (pm->op_pmflags & PMf_SKIPWHITE) {
4509 if (pm->op_pmflags & PMf_LOCALE) {
4510 while (isSPACE_LC(*s))
4518 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4519 SAVEINT(PL_multiline);
4520 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4524 limit = maxiters + 2;
4525 if (pm->op_pmflags & PMf_WHITE) {
4528 while (m < strend &&
4529 !((pm->op_pmflags & PMf_LOCALE)
4530 ? isSPACE_LC(*m) : isSPACE(*m)))
4535 dstr = NEWSV(30, m-s);
4536 sv_setpvn(dstr, s, m-s);
4540 (void)SvUTF8_on(dstr);
4544 while (s < strend &&
4545 ((pm->op_pmflags & PMf_LOCALE)
4546 ? isSPACE_LC(*s) : isSPACE(*s)))
4550 else if (strEQ("^", rx->precomp)) {
4553 for (m = s; m < strend && *m != '\n'; m++) ;
4557 dstr = NEWSV(30, m-s);
4558 sv_setpvn(dstr, s, m-s);
4562 (void)SvUTF8_on(dstr);
4567 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4568 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4569 && (rx->reganch & ROPT_CHECK_ALL)
4570 && !(rx->reganch & ROPT_ANCH)) {
4571 int tail = (rx->reganch & RE_INTUIT_TAIL);
4572 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4575 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4577 char c = *SvPV(csv, n_a);
4580 for (m = s; m < strend && *m != c; m++) ;
4583 dstr = NEWSV(30, m-s);
4584 sv_setpvn(dstr, s, m-s);
4588 (void)SvUTF8_on(dstr);
4590 /* The rx->minlen is in characters but we want to step
4591 * s ahead by bytes. */
4593 s = (char*)utf8_hop((U8*)m, len);
4595 s = m + len; /* Fake \n at the end */
4600 while (s < strend && --limit &&
4601 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4602 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4605 dstr = NEWSV(31, m-s);
4606 sv_setpvn(dstr, s, m-s);
4610 (void)SvUTF8_on(dstr);
4612 /* The rx->minlen is in characters but we want to step
4613 * s ahead by bytes. */
4615 s = (char*)utf8_hop((U8*)m, len);
4617 s = m + len; /* Fake \n at the end */
4622 maxiters += slen * rx->nparens;
4623 while (s < strend && --limit)
4626 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4630 TAINT_IF(RX_MATCH_TAINTED(rx));
4631 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4636 strend = s + (strend - m);
4638 m = rx->startp[0] + orig;
4639 dstr = NEWSV(32, m-s);
4640 sv_setpvn(dstr, s, m-s);
4644 (void)SvUTF8_on(dstr);
4647 for (i = 1; i <= (I32)rx->nparens; i++) {
4648 s = rx->startp[i] + orig;
4649 m = rx->endp[i] + orig;
4651 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4652 parens that didn't match -- they should be set to
4653 undef, not the empty string */
4654 if (m >= orig && s >= orig) {
4655 dstr = NEWSV(33, m-s);
4656 sv_setpvn(dstr, s, m-s);
4659 dstr = &PL_sv_undef; /* undef, not "" */
4663 (void)SvUTF8_on(dstr);
4667 s = rx->endp[0] + orig;
4671 iters = (SP - PL_stack_base) - base;
4672 if (iters > maxiters)
4673 DIE(aTHX_ "Split loop");
4675 /* keep field after final delim? */
4676 if (s < strend || (iters && origlimit)) {
4677 STRLEN l = strend - s;
4678 dstr = NEWSV(34, l);
4679 sv_setpvn(dstr, s, l);
4683 (void)SvUTF8_on(dstr);
4687 else if (!origlimit) {
4688 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4689 if (TOPs && !make_mortal)
4692 *SP-- = &PL_sv_undef;
4697 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4701 if (SvSMAGICAL(ary)) {
4706 if (gimme == G_ARRAY) {
4708 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4716 call_method("PUSH",G_SCALAR|G_DISCARD);
4719 if (gimme == G_ARRAY) {
4720 /* EXTEND should not be needed - we just popped them */
4722 for (i=0; i < iters; i++) {
4723 SV **svp = av_fetch(ary, i, FALSE);
4724 PUSHs((svp) ? *svp : &PL_sv_undef);
4731 if (gimme == G_ARRAY)
4746 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4747 || SvTYPE(retsv) == SVt_PVCV) {
4748 retsv = refto(retsv);
4756 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");