3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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
23 /* XXX I can't imagine anyone who doesn't have this actually _needs_
24 it, since pid_t is an integral type.
27 #ifdef NEED_GETPID_PROTO
28 extern Pid_t getpid (void);
31 /* variations on pp_null */
36 if (GIMME_V == G_SCALAR)
52 if (PL_op->op_private & OPpLVAL_INTRO)
53 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
55 if (PL_op->op_flags & OPf_REF) {
59 if (GIMME == G_SCALAR)
60 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
65 if (gimme == G_ARRAY) {
66 I32 maxarg = AvFILL((AV*)TARG) + 1;
68 if (SvMAGICAL(TARG)) {
70 for (i=0; i < (U32)maxarg; i++) {
71 SV **svp = av_fetch((AV*)TARG, i, FALSE);
72 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
76 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
80 else if (gimme == G_SCALAR) {
81 SV* sv = sv_newmortal();
82 I32 maxarg = AvFILL((AV*)TARG) + 1;
95 if (PL_op->op_private & OPpLVAL_INTRO)
96 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
97 if (PL_op->op_flags & OPf_REF)
100 if (GIMME == G_SCALAR)
101 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
105 if (gimme == G_ARRAY) {
108 else if (gimme == G_SCALAR) {
109 SV* sv = sv_newmortal();
110 if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied))
111 Perl_croak(aTHX_ "Can't provide tied hash usage; "
112 "use keys(%%hash) to test if empty");
113 if (HvFILL((HV*)TARG))
114 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
115 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
125 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
136 tryAMAGICunDEREF(to_gv);
139 if (SvTYPE(sv) == SVt_PVIO) {
140 GV *gv = (GV*) sv_newmortal();
141 gv_init(gv, 0, "", 0, 0);
142 GvIOp(gv) = (IO *)sv;
143 (void)SvREFCNT_inc(sv);
146 else if (SvTYPE(sv) != SVt_PVGV)
147 DIE(aTHX_ "Not a GLOB reference");
150 if (SvTYPE(sv) != SVt_PVGV) {
154 if (SvGMAGICAL(sv)) {
159 if (!SvOK(sv) && sv != &PL_sv_undef) {
160 /* If this is a 'my' scalar and flag is set then vivify
163 if (PL_op->op_private & OPpDEREF) {
166 if (cUNOP->op_targ) {
168 SV *namesv = PAD_SV(cUNOP->op_targ);
169 name = SvPV(namesv, len);
170 gv = (GV*)NEWSV(0,0);
171 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
174 name = CopSTASHPV(PL_curcop);
177 if (SvTYPE(sv) < SVt_RV)
178 sv_upgrade(sv, SVt_RV);
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))
192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
195 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
197 && (!is_gv_magical(sym,len,0)
198 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
204 if (PL_op->op_private & HINT_STRICT_REFS)
205 DIE(aTHX_ PL_no_symref, sym, "a symbol");
206 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
210 if (PL_op->op_private & OPpLVAL_INTRO)
211 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
223 tryAMAGICunDEREF(to_sv);
226 switch (SvTYPE(sv)) {
230 DIE(aTHX_ "Not a SCALAR reference");
238 if (SvTYPE(gv) != SVt_PVGV) {
239 if (SvGMAGICAL(sv)) {
245 if (PL_op->op_flags & OPf_REF ||
246 PL_op->op_private & HINT_STRICT_REFS)
247 DIE(aTHX_ PL_no_usym, "a SCALAR");
248 if (ckWARN(WARN_UNINITIALIZED))
253 if ((PL_op->op_flags & OPf_SPECIAL) &&
254 !(PL_op->op_flags & OPf_MOD))
256 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
258 && (!is_gv_magical(sym,len,0)
259 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
265 if (PL_op->op_private & HINT_STRICT_REFS)
266 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
267 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
272 if (PL_op->op_flags & OPf_MOD) {
273 if (PL_op->op_private & OPpLVAL_INTRO) {
274 if (cUNOP->op_first->op_type == OP_NULL)
275 sv = save_scalar((GV*)TOPs);
277 sv = save_scalar(gv);
279 Perl_croak(aTHX_ PL_no_localize_ref);
281 else if (PL_op->op_private & OPpDEREF)
282 vivify_ref(sv, PL_op->op_private & OPpDEREF);
292 SV *sv = AvARYLEN(av);
294 AvARYLEN(av) = sv = NEWSV(0,0);
295 sv_upgrade(sv, SVt_IV);
296 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
304 dSP; dTARGET; dPOPss;
306 if (PL_op->op_flags & OPf_MOD || LVRET) {
307 if (SvTYPE(TARG) < SVt_PVLV) {
308 sv_upgrade(TARG, SVt_PVLV);
309 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
313 if (LvTARG(TARG) != sv) {
315 SvREFCNT_dec(LvTARG(TARG));
316 LvTARG(TARG) = SvREFCNT_inc(sv);
318 PUSHs(TARG); /* no SvSETMAGIC */
324 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
325 mg = mg_find(sv, PERL_MAGIC_regex_global);
326 if (mg && mg->mg_len >= 0) {
330 PUSHi(i + PL_curcop->cop_arybase);
344 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
345 /* (But not in defined().) */
346 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
349 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
350 if ((PL_op->op_private & OPpLVAL_INTRO)) {
351 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
354 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
358 cv = (CV*)&PL_sv_undef;
372 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
373 char *s = SvPVX(TOPs);
374 if (strnEQ(s, "CORE::", 6)) {
377 code = keyword(s + 6, SvCUR(TOPs) - 6);
378 if (code < 0) { /* Overridable. */
379 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
380 int i = 0, n = 0, seen_question = 0;
382 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
384 if (code == -KEY_chop || code == -KEY_chomp)
386 while (i < MAXO) { /* The slow way. */
387 if (strEQ(s + 6, PL_op_name[i])
388 || strEQ(s + 6, PL_op_desc[i]))
394 goto nonesuch; /* Should not happen... */
396 oa = PL_opargs[i] >> OASHIFT;
398 if (oa & OA_OPTIONAL && !seen_question) {
402 else if (n && str[0] == ';' && seen_question)
403 goto set; /* XXXX system, exec */
404 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
405 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
406 /* But globs are already references (kinda) */
407 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
411 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
415 ret = sv_2mortal(newSVpvn(str, n - 1));
417 else if (code) /* Non-Overridable */
419 else { /* None such */
421 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
425 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
427 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
436 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
438 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
454 if (GIMME != G_ARRAY) {
458 *MARK = &PL_sv_undef;
459 *MARK = refto(*MARK);
463 EXTEND_MORTAL(SP - MARK);
465 *MARK = refto(*MARK);
470 S_refto(pTHX_ SV *sv)
474 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
477 if (!(sv = LvTARG(sv)))
480 (void)SvREFCNT_inc(sv);
482 else if (SvTYPE(sv) == SVt_PVAV) {
483 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
486 (void)SvREFCNT_inc(sv);
488 else if (SvPADTMP(sv) && !IS_PADGV(sv))
492 (void)SvREFCNT_inc(sv);
495 sv_upgrade(rv, SVt_RV);
509 if (sv && SvGMAGICAL(sv))
512 if (!sv || !SvROK(sv))
516 pv = sv_reftype(sv,TRUE);
517 PUSHp(pv, strlen(pv));
527 stash = CopSTASH(PL_curcop);
533 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
534 Perl_croak(aTHX_ "Attempt to bless into a reference");
536 if (ckWARN(WARN_MISC) && len == 0)
537 Perl_warner(aTHX_ packWARN(WARN_MISC),
538 "Explicit blessing to '' (assuming package main)");
539 stash = gv_stashpvn(ptr, len, TRUE);
542 (void)sv_bless(TOPs, stash);
556 elem = SvPV(sv, n_a);
560 switch (elem ? *elem : '\0')
563 if (strEQ(elem, "ARRAY"))
564 tmpRef = (SV*)GvAV(gv);
567 if (strEQ(elem, "CODE"))
568 tmpRef = (SV*)GvCVu(gv);
571 if (strEQ(elem, "FILEHANDLE")) {
572 /* finally deprecated in 5.8.0 */
573 deprecate("*glob{FILEHANDLE}");
574 tmpRef = (SV*)GvIOp(gv);
577 if (strEQ(elem, "FORMAT"))
578 tmpRef = (SV*)GvFORM(gv);
581 if (strEQ(elem, "GLOB"))
585 if (strEQ(elem, "HASH"))
586 tmpRef = (SV*)GvHV(gv);
589 if (strEQ(elem, "IO"))
590 tmpRef = (SV*)GvIOp(gv);
593 if (strEQ(elem, "NAME"))
594 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
597 if (strEQ(elem, "PACKAGE")) {
598 if (HvNAME(GvSTASH(gv)))
599 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
601 sv = newSVpv("__ANON__",0);
605 if (strEQ(elem, "SCALAR"))
619 /* Pattern matching */
624 register unsigned char *s;
627 register I32 *sfirst;
631 if (sv == PL_lastscream) {
637 SvSCREAM_off(PL_lastscream);
638 SvREFCNT_dec(PL_lastscream);
640 PL_lastscream = SvREFCNT_inc(sv);
643 s = (unsigned char*)(SvPV(sv, len));
647 if (pos > PL_maxscream) {
648 if (PL_maxscream < 0) {
649 PL_maxscream = pos + 80;
650 New(301, PL_screamfirst, 256, I32);
651 New(302, PL_screamnext, PL_maxscream, I32);
654 PL_maxscream = pos + pos / 4;
655 Renew(PL_screamnext, PL_maxscream, I32);
659 sfirst = PL_screamfirst;
660 snext = PL_screamnext;
662 if (!sfirst || !snext)
663 DIE(aTHX_ "do_study: out of memory");
665 for (ch = 256; ch; --ch)
672 snext[pos] = sfirst[ch] - pos;
679 /* piggyback on m//g magic */
680 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
689 if (PL_op->op_flags & OPf_STACKED)
695 TARG = sv_newmortal();
700 /* Lvalue operators. */
712 dSP; dMARK; dTARGET; dORIGMARK;
714 do_chop(TARG, *++MARK);
723 SETi(do_chomp(TOPs));
730 register I32 count = 0;
733 count += do_chomp(POPs);
744 if (!sv || !SvANY(sv))
746 switch (SvTYPE(sv)) {
748 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
749 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
753 if (HvARRAY(sv) || SvGMAGICAL(sv)
754 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
758 if (CvROOT(sv) || CvXSUB(sv))
775 if (!PL_op->op_private) {
784 SV_CHECK_THINKFIRST_COW_DROP(sv);
786 switch (SvTYPE(sv)) {
796 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
797 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
798 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
802 /* let user-undef'd sub keep its identity */
803 GV* gv = CvGV((CV*)sv);
810 SvSetMagicSV(sv, &PL_sv_undef);
814 Newz(602, gp, 1, GP);
815 GvGP(sv) = gp_ref(gp);
816 GvSV(sv) = NEWSV(72,0);
817 GvLINE(sv) = CopLINE(PL_curcop);
823 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
826 SvPV_set(sv, Nullch);
839 if (SvTYPE(TOPs) > SVt_PVLV)
840 DIE(aTHX_ PL_no_modify);
841 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
842 && SvIVX(TOPs) != IV_MIN)
845 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
856 if (SvTYPE(TOPs) > SVt_PVLV)
857 DIE(aTHX_ PL_no_modify);
858 sv_setsv(TARG, TOPs);
859 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
860 && SvIVX(TOPs) != IV_MAX)
863 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
868 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
878 if (SvTYPE(TOPs) > SVt_PVLV)
879 DIE(aTHX_ PL_no_modify);
880 sv_setsv(TARG, TOPs);
881 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
882 && SvIVX(TOPs) != IV_MIN)
885 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
894 /* Ordinary operators. */
899 #ifdef PERL_PRESERVE_IVUV
902 tryAMAGICbin(pow,opASSIGN);
903 #ifdef PERL_PRESERVE_IVUV
904 /* For integer to integer power, we do the calculation by hand wherever
905 we're sure it is safe; otherwise we call pow() and try to convert to
906 integer afterwards. */
910 bool baseuok = SvUOK(TOPm1s);
914 baseuv = SvUVX(TOPm1s);
916 IV iv = SvIVX(TOPm1s);
919 baseuok = TRUE; /* effectively it's a UV now */
921 baseuv = -iv; /* abs, baseuok == false records sign */
935 goto float_it; /* Can't do negative powers this way. */
938 /* now we have integer ** positive integer. */
941 /* foo & (foo - 1) is zero only for a power of 2. */
942 if (!(baseuv & (baseuv - 1))) {
943 /* We are raising power-of-2 to a positive integer.
944 The logic here will work for any base (even non-integer
945 bases) but it can be less accurate than
946 pow (base,power) or exp (power * log (base)) when the
947 intermediate values start to spill out of the mantissa.
948 With powers of 2 we know this can't happen.
949 And powers of 2 are the favourite thing for perl
950 programmers to notice ** not doing what they mean. */
952 NV base = baseuok ? baseuv : -(NV)baseuv;
955 for (; power; base *= base, n++) {
956 /* Do I look like I trust gcc with long longs here?
958 UV bit = (UV)1 << (UV)n;
961 /* Only bother to clear the bit if it is set. */
963 /* Avoid squaring base again if we're done. */
964 if (power == 0) break;
972 register unsigned int highbit = 8 * sizeof(UV);
973 register unsigned int lowbit = 0;
974 register unsigned int diff;
975 bool odd_power = (bool)(power & 1);
976 while ((diff = (highbit - lowbit) >> 1)) {
977 if (baseuv & ~((1 << (lowbit + diff)) - 1))
982 /* we now have baseuv < 2 ** highbit */
983 if (power * highbit <= 8 * sizeof(UV)) {
984 /* result will definitely fit in UV, so use UV math
985 on same algorithm as above */
986 register UV result = 1;
987 register UV base = baseuv;
989 for (; power; base *= base, n++) {
990 register UV bit = (UV)1 << (UV)n;
994 if (power == 0) break;
998 if (baseuok || !odd_power)
999 /* answer is positive */
1001 else if (result <= (UV)IV_MAX)
1002 /* answer negative, fits in IV */
1003 SETi( -(IV)result );
1004 else if (result == (UV)IV_MIN)
1005 /* 2's complement assumption: special case IV_MIN */
1008 /* answer negative, doesn't fit */
1009 SETn( -(NV)result );
1020 SETn( Perl_pow( left, right) );
1021 #ifdef PERL_PRESERVE_IVUV
1031 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1032 #ifdef PERL_PRESERVE_IVUV
1035 /* Unless the left argument is integer in range we are going to have to
1036 use NV maths. Hence only attempt to coerce the right argument if
1037 we know the left is integer. */
1038 /* Left operand is defined, so is it IV? */
1039 SvIV_please(TOPm1s);
1040 if (SvIOK(TOPm1s)) {
1041 bool auvok = SvUOK(TOPm1s);
1042 bool buvok = SvUOK(TOPs);
1043 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1044 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1051 alow = SvUVX(TOPm1s);
1053 IV aiv = SvIVX(TOPm1s);
1056 auvok = TRUE; /* effectively it's a UV now */
1058 alow = -aiv; /* abs, auvok == false records sign */
1064 IV biv = SvIVX(TOPs);
1067 buvok = TRUE; /* effectively it's a UV now */
1069 blow = -biv; /* abs, buvok == false records sign */
1073 /* If this does sign extension on unsigned it's time for plan B */
1074 ahigh = alow >> (4 * sizeof (UV));
1076 bhigh = blow >> (4 * sizeof (UV));
1078 if (ahigh && bhigh) {
1079 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1080 which is overflow. Drop to NVs below. */
1081 } else if (!ahigh && !bhigh) {
1082 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1083 so the unsigned multiply cannot overflow. */
1084 UV product = alow * blow;
1085 if (auvok == buvok) {
1086 /* -ve * -ve or +ve * +ve gives a +ve result. */
1090 } else if (product <= (UV)IV_MIN) {
1091 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1092 /* -ve result, which could overflow an IV */
1094 SETi( -(IV)product );
1096 } /* else drop to NVs below. */
1098 /* One operand is large, 1 small */
1101 /* swap the operands */
1103 bhigh = blow; /* bhigh now the temp var for the swap */
1107 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1108 multiplies can't overflow. shift can, add can, -ve can. */
1109 product_middle = ahigh * blow;
1110 if (!(product_middle & topmask)) {
1111 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1113 product_middle <<= (4 * sizeof (UV));
1114 product_low = alow * blow;
1116 /* as for pp_add, UV + something mustn't get smaller.
1117 IIRC ANSI mandates this wrapping *behaviour* for
1118 unsigned whatever the actual representation*/
1119 product_low += product_middle;
1120 if (product_low >= product_middle) {
1121 /* didn't overflow */
1122 if (auvok == buvok) {
1123 /* -ve * -ve or +ve * +ve gives a +ve result. */
1125 SETu( product_low );
1127 } else if (product_low <= (UV)IV_MIN) {
1128 /* 2s complement assumption again */
1129 /* -ve result, which could overflow an IV */
1131 SETi( -(IV)product_low );
1133 } /* else drop to NVs below. */
1135 } /* product_middle too large */
1136 } /* ahigh && bhigh */
1137 } /* SvIOK(TOPm1s) */
1142 SETn( left * right );
1149 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1150 /* Only try to do UV divide first
1151 if ((SLOPPYDIVIDE is true) or
1152 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1154 The assumption is that it is better to use floating point divide
1155 whenever possible, only doing integer divide first if we can't be sure.
1156 If NV_PRESERVES_UV is true then we know at compile time that no UV
1157 can be too large to preserve, so don't need to compile the code to
1158 test the size of UVs. */
1161 # define PERL_TRY_UV_DIVIDE
1162 /* ensure that 20./5. == 4. */
1164 # ifdef PERL_PRESERVE_IVUV
1165 # ifndef NV_PRESERVES_UV
1166 # define PERL_TRY_UV_DIVIDE
1171 #ifdef PERL_TRY_UV_DIVIDE
1174 SvIV_please(TOPm1s);
1175 if (SvIOK(TOPm1s)) {
1176 bool left_non_neg = SvUOK(TOPm1s);
1177 bool right_non_neg = SvUOK(TOPs);
1181 if (right_non_neg) {
1182 right = SvUVX(TOPs);
1185 IV biv = SvIVX(TOPs);
1188 right_non_neg = TRUE; /* effectively it's a UV now */
1194 /* historically undef()/0 gives a "Use of uninitialized value"
1195 warning before dieing, hence this test goes here.
1196 If it were immediately before the second SvIV_please, then
1197 DIE() would be invoked before left was even inspected, so
1198 no inpsection would give no warning. */
1200 DIE(aTHX_ "Illegal division by zero");
1203 left = SvUVX(TOPm1s);
1206 IV aiv = SvIVX(TOPm1s);
1209 left_non_neg = TRUE; /* effectively it's a UV now */
1218 /* For sloppy divide we always attempt integer division. */
1220 /* Otherwise we only attempt it if either or both operands
1221 would not be preserved by an NV. If both fit in NVs
1222 we fall through to the NV divide code below. However,
1223 as left >= right to ensure integer result here, we know that
1224 we can skip the test on the right operand - right big
1225 enough not to be preserved can't get here unless left is
1228 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1231 /* Integer division can't overflow, but it can be imprecise. */
1232 UV result = left / right;
1233 if (result * right == left) {
1234 SP--; /* result is valid */
1235 if (left_non_neg == right_non_neg) {
1236 /* signs identical, result is positive. */
1240 /* 2s complement assumption */
1241 if (result <= (UV)IV_MIN)
1242 SETi( -(IV)result );
1244 /* It's exact but too negative for IV. */
1245 SETn( -(NV)result );
1248 } /* tried integer divide but it was not an integer result */
1249 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1250 } /* left wasn't SvIOK */
1251 } /* right wasn't SvIOK */
1252 #endif /* PERL_TRY_UV_DIVIDE */
1256 DIE(aTHX_ "Illegal division by zero");
1257 PUSHn( left / right );
1264 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1268 bool left_neg = FALSE;
1269 bool right_neg = FALSE;
1270 bool use_double = FALSE;
1271 bool dright_valid = FALSE;
1277 right_neg = !SvUOK(TOPs);
1279 right = SvUVX(POPs);
1281 IV biv = SvIVX(POPs);
1284 right_neg = FALSE; /* effectively it's a UV now */
1292 right_neg = dright < 0;
1295 if (dright < UV_MAX_P1) {
1296 right = U_V(dright);
1297 dright_valid = TRUE; /* In case we need to use double below. */
1303 /* At this point use_double is only true if right is out of range for
1304 a UV. In range NV has been rounded down to nearest UV and
1305 use_double false. */
1307 if (!use_double && SvIOK(TOPs)) {
1309 left_neg = !SvUOK(TOPs);
1313 IV aiv = SvIVX(POPs);
1316 left_neg = FALSE; /* effectively it's a UV now */
1325 left_neg = dleft < 0;
1329 /* This should be exactly the 5.6 behaviour - if left and right are
1330 both in range for UV then use U_V() rather than floor. */
1332 if (dleft < UV_MAX_P1) {
1333 /* right was in range, so is dleft, so use UVs not double.
1337 /* left is out of range for UV, right was in range, so promote
1338 right (back) to double. */
1340 /* The +0.5 is used in 5.6 even though it is not strictly
1341 consistent with the implicit +0 floor in the U_V()
1342 inside the #if 1. */
1343 dleft = Perl_floor(dleft + 0.5);
1346 dright = Perl_floor(dright + 0.5);
1356 DIE(aTHX_ "Illegal modulus zero");
1358 dans = Perl_fmod(dleft, dright);
1359 if ((left_neg != right_neg) && dans)
1360 dans = dright - dans;
1363 sv_setnv(TARG, dans);
1369 DIE(aTHX_ "Illegal modulus zero");
1372 if ((left_neg != right_neg) && ans)
1375 /* XXX may warn: unary minus operator applied to unsigned type */
1376 /* could change -foo to be (~foo)+1 instead */
1377 if (ans <= ~((UV)IV_MAX)+1)
1378 sv_setiv(TARG, ~ans+1);
1380 sv_setnv(TARG, -(NV)ans);
1383 sv_setuv(TARG, ans);
1392 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1394 register IV count = POPi;
1395 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1397 I32 items = SP - MARK;
1400 max = items * count;
1405 /* This code was intended to fix 20010809.028:
1408 for (($x =~ /./g) x 2) {
1409 print chop; # "abcdabcd" expected as output.
1412 * but that change (#11635) broke this code:
1414 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1416 * I can't think of a better fix that doesn't introduce
1417 * an efficiency hit by copying the SVs. The stack isn't
1418 * refcounted, and mortalisation obviously doesn't
1419 * Do The Right Thing when the stack has more than
1420 * one pointer to the same mortal value.
1424 *SP = sv_2mortal(newSVsv(*SP));
1434 repeatcpy((char*)(MARK + items), (char*)MARK,
1435 items * sizeof(SV*), count - 1);
1438 else if (count <= 0)
1441 else { /* Note: mark already snarfed by pp_list */
1446 SvSetSV(TARG, tmpstr);
1447 SvPV_force(TARG, len);
1448 isutf = DO_UTF8(TARG);
1453 SvGROW(TARG, (count * len) + 1);
1454 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1455 SvCUR(TARG) *= count;
1457 *SvEND(TARG) = '\0';
1460 (void)SvPOK_only_UTF8(TARG);
1462 (void)SvPOK_only(TARG);
1464 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1465 /* The parser saw this as a list repeat, and there
1466 are probably several items on the stack. But we're
1467 in scalar context, and there's no pp_list to save us
1468 now. So drop the rest of the items -- robin@kitsite.com
1481 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1482 useleft = USE_LEFT(TOPm1s);
1483 #ifdef PERL_PRESERVE_IVUV
1484 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1485 "bad things" happen if you rely on signed integers wrapping. */
1488 /* Unless the left argument is integer in range we are going to have to
1489 use NV maths. Hence only attempt to coerce the right argument if
1490 we know the left is integer. */
1491 register UV auv = 0;
1497 a_valid = auvok = 1;
1498 /* left operand is undef, treat as zero. */
1500 /* Left operand is defined, so is it IV? */
1501 SvIV_please(TOPm1s);
1502 if (SvIOK(TOPm1s)) {
1503 if ((auvok = SvUOK(TOPm1s)))
1504 auv = SvUVX(TOPm1s);
1506 register IV aiv = SvIVX(TOPm1s);
1509 auvok = 1; /* Now acting as a sign flag. */
1510 } else { /* 2s complement assumption for IV_MIN */
1518 bool result_good = 0;
1521 bool buvok = SvUOK(TOPs);
1526 register IV biv = SvIVX(TOPs);
1533 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1534 else "IV" now, independent of how it came in.
1535 if a, b represents positive, A, B negative, a maps to -A etc
1540 all UV maths. negate result if A negative.
1541 subtract if signs same, add if signs differ. */
1543 if (auvok ^ buvok) {
1552 /* Must get smaller */
1557 if (result <= buv) {
1558 /* result really should be -(auv-buv). as its negation
1559 of true value, need to swap our result flag */
1571 if (result <= (UV)IV_MIN)
1572 SETi( -(IV)result );
1574 /* result valid, but out of range for IV. */
1575 SETn( -(NV)result );
1579 } /* Overflow, drop through to NVs. */
1583 useleft = USE_LEFT(TOPm1s);
1587 /* left operand is undef, treat as zero - value */
1591 SETn( TOPn - value );
1598 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1601 if (PL_op->op_private & HINT_INTEGER) {
1615 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1618 if (PL_op->op_private & HINT_INTEGER) {
1632 dSP; tryAMAGICbinSET(lt,0);
1633 #ifdef PERL_PRESERVE_IVUV
1636 SvIV_please(TOPm1s);
1637 if (SvIOK(TOPm1s)) {
1638 bool auvok = SvUOK(TOPm1s);
1639 bool buvok = SvUOK(TOPs);
1641 if (!auvok && !buvok) { /* ## IV < IV ## */
1642 IV aiv = SvIVX(TOPm1s);
1643 IV biv = SvIVX(TOPs);
1646 SETs(boolSV(aiv < biv));
1649 if (auvok && buvok) { /* ## UV < UV ## */
1650 UV auv = SvUVX(TOPm1s);
1651 UV buv = SvUVX(TOPs);
1654 SETs(boolSV(auv < buv));
1657 if (auvok) { /* ## UV < IV ## */
1664 /* As (a) is a UV, it's >=0, so it cannot be < */
1669 SETs(boolSV(auv < (UV)biv));
1672 { /* ## IV < UV ## */
1676 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) && SvROK(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 IV aiv = SvIVX(TOPm1s);
1721 IV biv = SvIVX(TOPs);
1724 SETs(boolSV(aiv > biv));
1727 if (auvok && buvok) { /* ## UV > UV ## */
1728 UV auv = SvUVX(TOPm1s);
1729 UV buv = SvUVX(TOPs);
1732 SETs(boolSV(auv > buv));
1735 if (auvok) { /* ## UV > IV ## */
1742 /* As (a) is a UV, it's >=0, so it must be > */
1747 SETs(boolSV(auv > (UV)biv));
1750 { /* ## IV > UV ## */
1754 aiv = SvIVX(TOPm1s);
1756 /* As (b) is a UV, it's >=0, so it cannot be > */
1763 SETs(boolSV((UV)aiv > buv));
1769 #ifndef NV_PRESERVES_UV
1770 #ifdef PERL_PRESERVE_IVUV
1773 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1775 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1781 SETs(boolSV(TOPn > value));
1788 dSP; tryAMAGICbinSET(le,0);
1789 #ifdef PERL_PRESERVE_IVUV
1792 SvIV_please(TOPm1s);
1793 if (SvIOK(TOPm1s)) {
1794 bool auvok = SvUOK(TOPm1s);
1795 bool buvok = SvUOK(TOPs);
1797 if (!auvok && !buvok) { /* ## IV <= IV ## */
1798 IV aiv = SvIVX(TOPm1s);
1799 IV biv = SvIVX(TOPs);
1802 SETs(boolSV(aiv <= biv));
1805 if (auvok && buvok) { /* ## UV <= UV ## */
1806 UV auv = SvUVX(TOPm1s);
1807 UV buv = SvUVX(TOPs);
1810 SETs(boolSV(auv <= buv));
1813 if (auvok) { /* ## UV <= IV ## */
1820 /* As (a) is a UV, it's >=0, so a cannot be <= */
1825 SETs(boolSV(auv <= (UV)biv));
1828 { /* ## IV <= UV ## */
1832 aiv = SvIVX(TOPm1s);
1834 /* As (b) is a UV, it's >=0, so a must be <= */
1841 SETs(boolSV((UV)aiv <= buv));
1847 #ifndef NV_PRESERVES_UV
1848 #ifdef PERL_PRESERVE_IVUV
1851 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1853 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1859 SETs(boolSV(TOPn <= value));
1866 dSP; tryAMAGICbinSET(ge,0);
1867 #ifdef PERL_PRESERVE_IVUV
1870 SvIV_please(TOPm1s);
1871 if (SvIOK(TOPm1s)) {
1872 bool auvok = SvUOK(TOPm1s);
1873 bool buvok = SvUOK(TOPs);
1875 if (!auvok && !buvok) { /* ## IV >= IV ## */
1876 IV aiv = SvIVX(TOPm1s);
1877 IV biv = SvIVX(TOPs);
1880 SETs(boolSV(aiv >= biv));
1883 if (auvok && buvok) { /* ## UV >= UV ## */
1884 UV auv = SvUVX(TOPm1s);
1885 UV buv = SvUVX(TOPs);
1888 SETs(boolSV(auv >= buv));
1891 if (auvok) { /* ## UV >= IV ## */
1898 /* As (a) is a UV, it's >=0, so it must be >= */
1903 SETs(boolSV(auv >= (UV)biv));
1906 { /* ## IV >= UV ## */
1910 aiv = SvIVX(TOPm1s);
1912 /* As (b) is a UV, it's >=0, so a cannot be >= */
1919 SETs(boolSV((UV)aiv >= buv));
1925 #ifndef NV_PRESERVES_UV
1926 #ifdef PERL_PRESERVE_IVUV
1929 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1931 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1937 SETs(boolSV(TOPn >= value));
1944 dSP; tryAMAGICbinSET(ne,0);
1945 #ifndef NV_PRESERVES_UV
1946 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1948 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1952 #ifdef PERL_PRESERVE_IVUV
1955 SvIV_please(TOPm1s);
1956 if (SvIOK(TOPm1s)) {
1957 bool auvok = SvUOK(TOPm1s);
1958 bool buvok = SvUOK(TOPs);
1960 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1961 /* Casting IV to UV before comparison isn't going to matter
1962 on 2s complement. On 1s complement or sign&magnitude
1963 (if we have any of them) it could make negative zero
1964 differ from normal zero. As I understand it. (Need to
1965 check - is negative zero implementation defined behaviour
1967 UV buv = SvUVX(POPs);
1968 UV auv = SvUVX(TOPs);
1970 SETs(boolSV(auv != buv));
1973 { /* ## Mixed IV,UV ## */
1977 /* != is commutative so swap if needed (save code) */
1979 /* swap. top of stack (b) is the iv */
1983 /* As (a) is a UV, it's >0, so it cannot be == */
1992 /* As (b) is a UV, it's >0, so it cannot be == */
1996 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1998 SETs(boolSV((UV)iv != uv));
2006 SETs(boolSV(TOPn != value));
2013 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2014 #ifndef NV_PRESERVES_UV
2015 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2016 UV right = PTR2UV(SvRV(POPs));
2017 UV left = PTR2UV(SvRV(TOPs));
2018 SETi((left > right) - (left < right));
2022 #ifdef PERL_PRESERVE_IVUV
2023 /* Fortunately it seems NaN isn't IOK */
2026 SvIV_please(TOPm1s);
2027 if (SvIOK(TOPm1s)) {
2028 bool leftuvok = SvUOK(TOPm1s);
2029 bool rightuvok = SvUOK(TOPs);
2031 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2032 IV leftiv = SvIVX(TOPm1s);
2033 IV rightiv = SvIVX(TOPs);
2035 if (leftiv > rightiv)
2037 else if (leftiv < rightiv)
2041 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2042 UV leftuv = SvUVX(TOPm1s);
2043 UV rightuv = SvUVX(TOPs);
2045 if (leftuv > rightuv)
2047 else if (leftuv < rightuv)
2051 } else if (leftuvok) { /* ## UV <=> IV ## */
2055 rightiv = SvIVX(TOPs);
2057 /* As (a) is a UV, it's >=0, so it cannot be < */
2060 leftuv = SvUVX(TOPm1s);
2061 if (leftuv > (UV)rightiv) {
2063 } else if (leftuv < (UV)rightiv) {
2069 } else { /* ## IV <=> UV ## */
2073 leftiv = SvIVX(TOPm1s);
2075 /* As (b) is a UV, it's >=0, so it must be < */
2078 rightuv = SvUVX(TOPs);
2079 if ((UV)leftiv > rightuv) {
2081 } else if ((UV)leftiv < rightuv) {
2099 if (Perl_isnan(left) || Perl_isnan(right)) {
2103 value = (left > right) - (left < right);
2107 else if (left < right)
2109 else if (left > right)
2123 dSP; tryAMAGICbinSET(slt,0);
2126 int cmp = (IN_LOCALE_RUNTIME
2127 ? sv_cmp_locale(left, right)
2128 : sv_cmp(left, right));
2129 SETs(boolSV(cmp < 0));
2136 dSP; tryAMAGICbinSET(sgt,0);
2139 int cmp = (IN_LOCALE_RUNTIME
2140 ? sv_cmp_locale(left, right)
2141 : sv_cmp(left, right));
2142 SETs(boolSV(cmp > 0));
2149 dSP; tryAMAGICbinSET(sle,0);
2152 int cmp = (IN_LOCALE_RUNTIME
2153 ? sv_cmp_locale(left, right)
2154 : sv_cmp(left, right));
2155 SETs(boolSV(cmp <= 0));
2162 dSP; tryAMAGICbinSET(sge,0);
2165 int cmp = (IN_LOCALE_RUNTIME
2166 ? sv_cmp_locale(left, right)
2167 : sv_cmp(left, right));
2168 SETs(boolSV(cmp >= 0));
2175 dSP; tryAMAGICbinSET(seq,0);
2178 SETs(boolSV(sv_eq(left, right)));
2185 dSP; tryAMAGICbinSET(sne,0);
2188 SETs(boolSV(!sv_eq(left, right)));
2195 dSP; dTARGET; tryAMAGICbin(scmp,0);
2198 int cmp = (IN_LOCALE_RUNTIME
2199 ? sv_cmp_locale(left, right)
2200 : sv_cmp(left, right));
2208 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2211 if (SvNIOKp(left) || SvNIOKp(right)) {
2212 if (PL_op->op_private & HINT_INTEGER) {
2213 IV i = SvIV(left) & SvIV(right);
2217 UV u = SvUV(left) & SvUV(right);
2222 do_vop(PL_op->op_type, TARG, left, right);
2231 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2234 if (SvNIOKp(left) || SvNIOKp(right)) {
2235 if (PL_op->op_private & HINT_INTEGER) {
2236 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2240 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2245 do_vop(PL_op->op_type, TARG, left, right);
2254 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2257 if (SvNIOKp(left) || SvNIOKp(right)) {
2258 if (PL_op->op_private & HINT_INTEGER) {
2259 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2263 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2268 do_vop(PL_op->op_type, TARG, left, right);
2277 dSP; dTARGET; tryAMAGICun(neg);
2280 int flags = SvFLAGS(sv);
2283 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2284 /* It's publicly an integer, or privately an integer-not-float */
2287 if (SvIVX(sv) == IV_MIN) {
2288 /* 2s complement assumption. */
2289 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2292 else if (SvUVX(sv) <= IV_MAX) {
2297 else if (SvIVX(sv) != IV_MIN) {
2301 #ifdef PERL_PRESERVE_IVUV
2310 else if (SvPOKp(sv)) {
2312 char *s = SvPV(sv, len);
2313 if (isIDFIRST(*s)) {
2314 sv_setpvn(TARG, "-", 1);
2317 else if (*s == '+' || *s == '-') {
2319 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2321 else if (DO_UTF8(sv)) {
2324 goto oops_its_an_int;
2326 sv_setnv(TARG, -SvNV(sv));
2328 sv_setpvn(TARG, "-", 1);
2335 goto oops_its_an_int;
2336 sv_setnv(TARG, -SvNV(sv));
2348 dSP; tryAMAGICunSET(not);
2349 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2355 dSP; dTARGET; tryAMAGICun(compl);
2359 if (PL_op->op_private & HINT_INTEGER) {
2374 tmps = (U8*)SvPV_force(TARG, len);
2377 /* Calculate exact length, let's not estimate. */
2386 while (tmps < send) {
2387 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2388 tmps += UTF8SKIP(tmps);
2389 targlen += UNISKIP(~c);
2395 /* Now rewind strings and write them. */
2399 Newz(0, result, targlen + 1, U8);
2400 while (tmps < send) {
2401 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2402 tmps += UTF8SKIP(tmps);
2403 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2407 sv_setpvn(TARG, (char*)result, targlen);
2411 Newz(0, result, nchar + 1, U8);
2412 while (tmps < send) {
2413 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2414 tmps += UTF8SKIP(tmps);
2419 sv_setpvn(TARG, (char*)result, nchar);
2427 register long *tmpl;
2428 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2431 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2436 for ( ; anum > 0; anum--, tmps++)
2445 /* integer versions of some of the above */
2449 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2452 SETi( left * right );
2459 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2463 DIE(aTHX_ "Illegal division by zero");
2464 value = POPi / value;
2473 /* This is the vanilla old i_modulo. */
2474 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2478 DIE(aTHX_ "Illegal modulus zero");
2479 SETi( left % right );
2484 #if defined(__GLIBC__) && IVSIZE == 8
2488 /* This is the i_modulo with the workaround for the _moddi3 bug
2489 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2490 * See below for pp_i_modulo. */
2491 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2495 DIE(aTHX_ "Illegal modulus zero");
2496 SETi( left % PERL_ABS(right) );
2504 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2508 DIE(aTHX_ "Illegal modulus zero");
2509 /* The assumption is to use hereafter the old vanilla version... */
2511 PL_ppaddr[OP_I_MODULO] =
2512 &Perl_pp_i_modulo_0;
2513 /* .. but if we have glibc, we might have a buggy _moddi3
2514 * (at least glicb 2.2.5 is known to have this bug), in other
2515 * words our integer modulus with negative quad as the second
2516 * argument might be broken. Test for this and re-patch the
2517 * opcode dispatch table if that is the case, remembering to
2518 * also apply the workaround so that this first round works
2519 * right, too. See [perl #9402] for more information. */
2520 #if defined(__GLIBC__) && IVSIZE == 8
2524 /* Cannot do this check with inlined IV constants since
2525 * that seems to work correctly even with the buggy glibc. */
2527 /* Yikes, we have the bug.
2528 * Patch in the workaround version. */
2530 PL_ppaddr[OP_I_MODULO] =
2531 &Perl_pp_i_modulo_1;
2532 /* Make certain we work right this time, too. */
2533 right = PERL_ABS(right);
2537 SETi( left % right );
2544 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2547 SETi( left + right );
2554 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2557 SETi( left - right );
2564 dSP; tryAMAGICbinSET(lt,0);
2567 SETs(boolSV(left < right));
2574 dSP; tryAMAGICbinSET(gt,0);
2577 SETs(boolSV(left > right));
2584 dSP; tryAMAGICbinSET(le,0);
2587 SETs(boolSV(left <= right));
2594 dSP; tryAMAGICbinSET(ge,0);
2597 SETs(boolSV(left >= right));
2604 dSP; tryAMAGICbinSET(eq,0);
2607 SETs(boolSV(left == right));
2614 dSP; tryAMAGICbinSET(ne,0);
2617 SETs(boolSV(left != right));
2624 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2631 else if (left < right)
2642 dSP; dTARGET; tryAMAGICun(neg);
2647 /* High falutin' math. */
2651 dSP; dTARGET; tryAMAGICbin(atan2,0);
2654 SETn(Perl_atan2(left, right));
2661 dSP; dTARGET; tryAMAGICun(sin);
2665 value = Perl_sin(value);
2673 dSP; dTARGET; tryAMAGICun(cos);
2677 value = Perl_cos(value);
2683 /* Support Configure command-line overrides for rand() functions.
2684 After 5.005, perhaps we should replace this by Configure support
2685 for drand48(), random(), or rand(). For 5.005, though, maintain
2686 compatibility by calling rand() but allow the user to override it.
2687 See INSTALL for details. --Andy Dougherty 15 July 1998
2689 /* Now it's after 5.005, and Configure supports drand48() and random(),
2690 in addition to rand(). So the overrides should not be needed any more.
2691 --Jarkko Hietaniemi 27 September 1998
2694 #ifndef HAS_DRAND48_PROTO
2695 extern double drand48 (void);
2708 if (!PL_srand_called) {
2709 (void)seedDrand01((Rand_seed_t)seed());
2710 PL_srand_called = TRUE;
2725 (void)seedDrand01((Rand_seed_t)anum);
2726 PL_srand_called = TRUE;
2733 dSP; dTARGET; tryAMAGICun(exp);
2737 value = Perl_exp(value);
2745 dSP; dTARGET; tryAMAGICun(log);
2750 SET_NUMERIC_STANDARD();
2751 DIE(aTHX_ "Can't take log of %"NVgf, value);
2753 value = Perl_log(value);
2761 dSP; dTARGET; tryAMAGICun(sqrt);
2766 SET_NUMERIC_STANDARD();
2767 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2769 value = Perl_sqrt(value);
2777 dSP; dTARGET; tryAMAGICun(int);
2780 IV iv = TOPi; /* attempt to convert to IV if possible. */
2781 /* XXX it's arguable that compiler casting to IV might be subtly
2782 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2783 else preferring IV has introduced a subtle behaviour change bug. OTOH
2784 relying on floating point to be accurate is a bug. */
2795 if (value < (NV)UV_MAX + 0.5) {
2798 SETn(Perl_floor(value));
2802 if (value > (NV)IV_MIN - 0.5) {
2805 /* This is maint, and we don't have Perl_ceil in perl.h */
2806 SETn(-Perl_floor(-value));
2816 dSP; dTARGET; tryAMAGICun(abs);
2818 /* This will cache the NV value if string isn't actually integer */
2822 /* IVX is precise */
2824 SETu(TOPu); /* force it to be numeric only */
2832 /* 2s complement assumption. Also, not really needed as
2833 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2853 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2859 tmps = (SvPVx(sv, len));
2861 /* If Unicode, try to downgrade
2862 * If not possible, croak. */
2863 SV* tsv = sv_2mortal(newSVsv(sv));
2866 sv_utf8_downgrade(tsv, FALSE);
2869 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2870 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2883 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2889 tmps = (SvPVx(sv, len));
2891 /* If Unicode, try to downgrade
2892 * If not possible, croak. */
2893 SV* tsv = sv_2mortal(newSVsv(sv));
2896 sv_utf8_downgrade(tsv, FALSE);
2899 while (*tmps && len && isSPACE(*tmps))
2904 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2905 else if (*tmps == 'b')
2906 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2908 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2910 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2927 SETi(sv_len_utf8(sv));
2943 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2945 I32 arybase = PL_curcop->cop_arybase;
2949 int num_args = PL_op->op_private & 7;
2950 bool repl_need_utf8_upgrade = FALSE;
2951 bool repl_is_utf8 = FALSE;
2953 SvTAINTED_off(TARG); /* decontaminate */
2954 SvUTF8_off(TARG); /* decontaminate */
2958 repl = SvPV(repl_sv, repl_len);
2959 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2969 sv_utf8_upgrade(sv);
2971 else if (DO_UTF8(sv))
2972 repl_need_utf8_upgrade = TRUE;
2974 tmps = SvPV(sv, curlen);
2976 utf8_curlen = sv_len_utf8(sv);
2977 if (utf8_curlen == curlen)
2980 curlen = utf8_curlen;
2985 if (pos >= arybase) {
3003 else if (len >= 0) {
3005 if (rem > (I32)curlen)
3020 Perl_croak(aTHX_ "substr outside of string");
3021 if (ckWARN(WARN_SUBSTR))
3022 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3029 sv_pos_u2b(sv, &pos, &rem);
3031 sv_setpvn(TARG, tmps, rem);
3032 #ifdef USE_LOCALE_COLLATE
3033 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3038 SV* repl_sv_copy = NULL;
3040 if (repl_need_utf8_upgrade) {
3041 repl_sv_copy = newSVsv(repl_sv);
3042 sv_utf8_upgrade(repl_sv_copy);
3043 repl = SvPV(repl_sv_copy, repl_len);
3044 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3046 sv_insert(sv, pos, rem, repl, repl_len);
3050 SvREFCNT_dec(repl_sv_copy);
3052 else if (lvalue) { /* it's an lvalue! */
3053 if (!SvGMAGICAL(sv)) {
3057 if (ckWARN(WARN_SUBSTR))
3058 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3059 "Attempt to use reference as lvalue in substr");
3061 if (SvOK(sv)) /* is it defined ? */
3062 (void)SvPOK_only_UTF8(sv);
3064 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3067 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3068 TARG = sv_newmortal();
3069 if (SvTYPE(TARG) < SVt_PVLV) {
3070 sv_upgrade(TARG, SVt_PVLV);
3071 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3074 (void)SvOK_off(TARG);
3077 if (LvTARG(TARG) != sv) {
3079 SvREFCNT_dec(LvTARG(TARG));
3080 LvTARG(TARG) = SvREFCNT_inc(sv);
3082 LvTARGOFF(TARG) = upos;
3083 LvTARGLEN(TARG) = urem;
3087 PUSHs(TARG); /* avoid SvSETMAGIC here */
3094 register IV size = POPi;
3095 register IV offset = POPi;
3096 register SV *src = POPs;
3097 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3099 SvTAINTED_off(TARG); /* decontaminate */
3100 if (lvalue) { /* it's an lvalue! */
3101 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3102 TARG = sv_newmortal();
3103 if (SvTYPE(TARG) < SVt_PVLV) {
3104 sv_upgrade(TARG, SVt_PVLV);
3105 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3108 if (LvTARG(TARG) != src) {
3110 SvREFCNT_dec(LvTARG(TARG));
3111 LvTARG(TARG) = SvREFCNT_inc(src);
3113 LvTARGOFF(TARG) = offset;
3114 LvTARGLEN(TARG) = size;
3117 sv_setuv(TARG, do_vecget(src, offset, size));
3132 I32 arybase = PL_curcop->cop_arybase;
3137 offset = POPi - arybase;
3140 tmps = SvPV(big, biglen);
3141 if (offset > 0 && DO_UTF8(big))
3142 sv_pos_u2b(big, &offset, 0);
3145 else if (offset > (I32)biglen)
3147 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3148 (unsigned char*)tmps + biglen, little, 0)))
3151 retval = tmps2 - tmps;
3152 if (retval > 0 && DO_UTF8(big))
3153 sv_pos_b2u(big, &retval);
3154 PUSHi(retval + arybase);
3169 I32 arybase = PL_curcop->cop_arybase;
3175 tmps2 = SvPV(little, llen);
3176 tmps = SvPV(big, blen);
3180 if (offset > 0 && DO_UTF8(big))
3181 sv_pos_u2b(big, &offset, 0);
3182 offset = offset - arybase + llen;
3186 else if (offset > (I32)blen)
3188 if (!(tmps2 = rninstr(tmps, tmps + offset,
3189 tmps2, tmps2 + llen)))
3192 retval = tmps2 - tmps;
3193 if (retval > 0 && DO_UTF8(big))
3194 sv_pos_b2u(big, &retval);
3195 PUSHi(retval + arybase);
3201 dSP; dMARK; dORIGMARK; dTARGET;
3202 do_sprintf(TARG, SP-MARK, MARK+1);
3203 TAINT_IF(SvTAINTED(TARG));
3204 if (DO_UTF8(*(MARK+1)))
3216 U8 *s = (U8*)SvPVx(argsv, len);
3219 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3220 tmpsv = sv_2mortal(newSVsv(argsv));
3221 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3225 XPUSHu(DO_UTF8(argsv) ?
3226 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3238 (void)SvUPGRADE(TARG,SVt_PV);
3240 if (value > 255 && !IN_BYTES) {
3241 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3242 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3243 SvCUR_set(TARG, tmps - SvPVX(TARG));
3245 (void)SvPOK_only(TARG);
3254 *tmps++ = (char)value;
3256 (void)SvPOK_only(TARG);
3257 if (PL_encoding && !IN_BYTES) {
3258 sv_recode_to_utf8(TARG, PL_encoding);
3260 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3261 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3265 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3266 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3282 char *tmps = SvPV(left, len);
3284 if (DO_UTF8(left)) {
3285 /* If Unicode, try to downgrade.
3286 * If not possible, croak.
3287 * Yes, we made this up. */
3288 SV* tsv = sv_2mortal(newSVsv(left));
3291 sv_utf8_downgrade(tsv, FALSE);
3294 # ifdef USE_ITHREADS
3296 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3297 /* This should be threadsafe because in ithreads there is only
3298 * one thread per interpreter. If this would not be true,
3299 * we would need a mutex to protect this malloc. */
3300 PL_reentrant_buffer->_crypt_struct_buffer =
3301 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3302 #if defined(__GLIBC__) || defined(__EMX__)
3303 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3304 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3305 /* work around glibc-2.2.5 bug */
3306 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3310 # endif /* HAS_CRYPT_R */
3311 # endif /* USE_ITHREADS */
3313 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3315 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3321 "The crypt() function is unimplemented due to excessive paranoia.");
3334 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3335 UTF8_IS_START(*s)) {
3336 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3340 utf8_to_uvchr(s, &ulen);
3341 toTITLE_utf8(s, tmpbuf, &tculen);
3342 utf8_to_uvchr(tmpbuf, 0);
3344 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3346 /* slen is the byte length of the whole SV.
3347 * ulen is the byte length of the original Unicode character
3348 * stored as UTF-8 at s.
3349 * tculen is the byte length of the freshly titlecased
3350 * Unicode character stored as UTF-8 at tmpbuf.
3351 * We first set the result to be the titlecased character,
3352 * and then append the rest of the SV data. */
3353 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3355 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3360 s = (U8*)SvPV_force_nomg(sv, slen);
3361 Copy(tmpbuf, s, tculen, U8);
3365 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3367 SvUTF8_off(TARG); /* decontaminate */
3368 sv_setsv_nomg(TARG, sv);
3372 s = (U8*)SvPV_force_nomg(sv, slen);
3374 if (IN_LOCALE_RUNTIME) {
3377 *s = toUPPER_LC(*s);
3396 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3397 UTF8_IS_START(*s)) {
3399 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3403 toLOWER_utf8(s, tmpbuf, &ulen);
3404 uv = utf8_to_uvchr(tmpbuf, 0);
3405 tend = uvchr_to_utf8(tmpbuf, uv);
3407 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3409 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3411 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3416 s = (U8*)SvPV_force_nomg(sv, slen);
3417 Copy(tmpbuf, s, ulen, U8);
3421 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3423 SvUTF8_off(TARG); /* decontaminate */
3424 sv_setsv_nomg(TARG, sv);
3428 s = (U8*)SvPV_force_nomg(sv, slen);
3430 if (IN_LOCALE_RUNTIME) {
3433 *s = toLOWER_LC(*s);
3456 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3458 s = (U8*)SvPV_nomg(sv,len);
3460 SvUTF8_off(TARG); /* decontaminate */
3461 sv_setpvn(TARG, "", 0);
3465 STRLEN nchar = utf8_length(s, s + len);
3467 (void)SvUPGRADE(TARG, SVt_PV);
3468 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3469 (void)SvPOK_only(TARG);
3470 d = (U8*)SvPVX(TARG);
3473 toUPPER_utf8(s, tmpbuf, &ulen);
3474 Copy(tmpbuf, d, ulen, U8);
3480 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3485 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3487 SvUTF8_off(TARG); /* decontaminate */
3488 sv_setsv_nomg(TARG, sv);
3492 s = (U8*)SvPV_force_nomg(sv, len);
3494 register U8 *send = s + len;
3496 if (IN_LOCALE_RUNTIME) {
3499 for (; s < send; s++)
3500 *s = toUPPER_LC(*s);
3503 for (; s < send; s++)
3525 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3527 s = (U8*)SvPV_nomg(sv,len);
3529 SvUTF8_off(TARG); /* decontaminate */
3530 sv_setpvn(TARG, "", 0);
3534 STRLEN nchar = utf8_length(s, s + len);
3536 (void)SvUPGRADE(TARG, SVt_PV);
3537 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3538 (void)SvPOK_only(TARG);
3539 d = (U8*)SvPVX(TARG);
3542 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3543 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3544 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3546 * Now if the sigma is NOT followed by
3547 * /$ignorable_sequence$cased_letter/;
3548 * and it IS preceded by
3549 * /$cased_letter$ignorable_sequence/;
3550 * where $ignorable_sequence is
3551 * [\x{2010}\x{AD}\p{Mn}]*
3552 * and $cased_letter is
3553 * [\p{Ll}\p{Lo}\p{Lt}]
3554 * then it should be mapped to 0x03C2,
3555 * (GREEK SMALL LETTER FINAL SIGMA),
3556 * instead of staying 0x03A3.
3557 * See lib/unicore/SpecCase.txt.
3560 Copy(tmpbuf, d, ulen, U8);
3566 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3571 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3573 SvUTF8_off(TARG); /* decontaminate */
3574 sv_setsv_nomg(TARG, sv);
3579 s = (U8*)SvPV_force_nomg(sv, len);
3581 register U8 *send = s + len;
3583 if (IN_LOCALE_RUNTIME) {
3586 for (; s < send; s++)
3587 *s = toLOWER_LC(*s);
3590 for (; s < send; s++)
3604 register char *s = SvPV(sv,len);
3607 SvUTF8_off(TARG); /* decontaminate */
3609 (void)SvUPGRADE(TARG, SVt_PV);
3610 SvGROW(TARG, (len * 2) + 1);
3614 if (UTF8_IS_CONTINUED(*s)) {
3615 STRLEN ulen = UTF8SKIP(s);
3639 SvCUR_set(TARG, d - SvPVX(TARG));
3640 (void)SvPOK_only_UTF8(TARG);
3643 sv_setpvn(TARG, s, len);
3645 if (SvSMAGICAL(TARG))
3654 dSP; dMARK; dORIGMARK;
3656 register AV* av = (AV*)POPs;
3657 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3658 I32 arybase = PL_curcop->cop_arybase;
3661 if (SvTYPE(av) == SVt_PVAV) {
3662 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3664 for (svp = MARK + 1; svp <= SP; svp++) {
3669 if (max > AvMAX(av))
3672 while (++MARK <= SP) {
3673 elem = SvIVx(*MARK);
3677 svp = av_fetch(av, elem, lval);
3679 if (!svp || *svp == &PL_sv_undef)
3680 DIE(aTHX_ PL_no_aelem, elem);
3681 if (PL_op->op_private & OPpLVAL_INTRO)
3682 save_aelem(av, elem, svp);
3684 *MARK = svp ? *svp : &PL_sv_undef;
3687 if (GIMME != G_ARRAY) {
3695 /* Associative arrays. */
3700 HV *hash = (HV*)POPs;
3702 I32 gimme = GIMME_V;
3705 /* might clobber stack_sp */
3706 entry = hv_iternext(hash);
3711 SV* sv = hv_iterkeysv(entry);
3712 PUSHs(sv); /* won't clobber stack_sp */
3713 if (gimme == G_ARRAY) {
3716 /* might clobber stack_sp */
3717 val = hv_iterval(hash, entry);
3722 else if (gimme == G_SCALAR)
3741 I32 gimme = GIMME_V;
3742 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3746 if (PL_op->op_private & OPpSLICE) {
3750 hvtype = SvTYPE(hv);
3751 if (hvtype == SVt_PVHV) { /* hash element */
3752 while (++MARK <= SP) {
3753 sv = hv_delete_ent(hv, *MARK, discard, 0);
3754 *MARK = sv ? sv : &PL_sv_undef;
3757 else if (hvtype == SVt_PVAV) { /* array element */
3758 if (PL_op->op_flags & OPf_SPECIAL) {
3759 while (++MARK <= SP) {
3760 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3761 *MARK = sv ? sv : &PL_sv_undef;
3766 DIE(aTHX_ "Not a HASH reference");
3769 else if (gimme == G_SCALAR) {
3778 if (SvTYPE(hv) == SVt_PVHV)
3779 sv = hv_delete_ent(hv, keysv, discard, 0);
3780 else if (SvTYPE(hv) == SVt_PVAV) {
3781 if (PL_op->op_flags & OPf_SPECIAL)
3782 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3784 DIE(aTHX_ "panic: avhv_delete no longer supported");
3787 DIE(aTHX_ "Not a HASH reference");
3802 if (PL_op->op_private & OPpEXISTS_SUB) {
3806 cv = sv_2cv(sv, &hv, &gv, FALSE);
3809 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3815 if (SvTYPE(hv) == SVt_PVHV) {
3816 if (hv_exists_ent(hv, tmpsv, 0))
3819 else if (SvTYPE(hv) == SVt_PVAV) {
3820 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3821 if (av_exists((AV*)hv, SvIV(tmpsv)))
3826 DIE(aTHX_ "Not a HASH reference");
3833 dSP; dMARK; dORIGMARK;
3834 register HV *hv = (HV*)POPs;
3835 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3836 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3837 bool other_magic = FALSE;
3843 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3844 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3845 /* Try to preserve the existenceness of a tied hash
3846 * element by using EXISTS and DELETE if possible.
3847 * Fallback to FETCH and STORE otherwise */
3848 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3849 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3850 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3853 while (++MARK <= SP) {
3857 bool preeminent = FALSE;
3860 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3861 hv_exists_ent(hv, keysv, 0);
3864 he = hv_fetch_ent(hv, keysv, lval, 0);
3865 svp = he ? &HeVAL(he) : 0;
3868 if (!svp || *svp == &PL_sv_undef) {
3870 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3874 save_helem(hv, keysv, svp);
3877 char *key = SvPV(keysv, keylen);
3878 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3882 *MARK = svp ? *svp : &PL_sv_undef;
3884 if (GIMME != G_ARRAY) {
3892 /* List operators. */
3897 if (GIMME != G_ARRAY) {
3899 *MARK = *SP; /* unwanted list, return last item */
3901 *MARK = &PL_sv_undef;
3910 SV **lastrelem = PL_stack_sp;
3911 SV **lastlelem = PL_stack_base + POPMARK;
3912 SV **firstlelem = PL_stack_base + POPMARK + 1;
3913 register SV **firstrelem = lastlelem + 1;
3914 I32 arybase = PL_curcop->cop_arybase;
3915 I32 lval = PL_op->op_flags & OPf_MOD;
3916 I32 is_something_there = lval;
3918 register I32 max = lastrelem - lastlelem;
3919 register SV **lelem;
3922 if (GIMME != G_ARRAY) {
3923 ix = SvIVx(*lastlelem);
3928 if (ix < 0 || ix >= max)
3929 *firstlelem = &PL_sv_undef;
3931 *firstlelem = firstrelem[ix];
3937 SP = firstlelem - 1;
3941 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3947 if (ix < 0 || ix >= max)
3948 *lelem = &PL_sv_undef;
3950 is_something_there = TRUE;
3951 if (!(*lelem = firstrelem[ix]))
3952 *lelem = &PL_sv_undef;
3955 if (is_something_there)
3958 SP = firstlelem - 1;
3964 dSP; dMARK; dORIGMARK;
3965 I32 items = SP - MARK;
3966 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3967 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3974 dSP; dMARK; dORIGMARK;
3975 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3979 SV *val = NEWSV(46, 0);
3981 sv_setsv(val, *++MARK);
3982 else if (ckWARN(WARN_MISC))
3983 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3984 (void)hv_store_ent(hv,key,val,0);
3993 dSP; dMARK; dORIGMARK;
3994 register AV *ary = (AV*)*++MARK;
3998 register I32 offset;
3999 register I32 length;
4006 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4007 *MARK-- = SvTIED_obj((SV*)ary, mg);
4011 call_method("SPLICE",GIMME_V);
4020 offset = i = SvIVx(*MARK);
4022 offset += AvFILLp(ary) + 1;
4024 offset -= PL_curcop->cop_arybase;
4026 DIE(aTHX_ PL_no_aelem, i);
4028 length = SvIVx(*MARK++);
4030 length += AvFILLp(ary) - offset + 1;
4036 length = AvMAX(ary) + 1; /* close enough to infinity */
4040 length = AvMAX(ary) + 1;
4042 if (offset > AvFILLp(ary) + 1) {
4043 if (ckWARN(WARN_MISC))
4044 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4045 offset = AvFILLp(ary) + 1;
4047 after = AvFILLp(ary) + 1 - (offset + length);
4048 if (after < 0) { /* not that much array */
4049 length += after; /* offset+length now in array */
4055 /* At this point, MARK .. SP-1 is our new LIST */
4058 diff = newlen - length;
4059 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4062 if (diff < 0) { /* shrinking the area */
4064 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4065 Copy(MARK, tmparyval, newlen, SV*);
4068 MARK = ORIGMARK + 1;
4069 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4070 MEXTEND(MARK, length);
4071 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4073 EXTEND_MORTAL(length);
4074 for (i = length, dst = MARK; i; i--) {
4075 sv_2mortal(*dst); /* free them eventualy */
4082 *MARK = AvARRAY(ary)[offset+length-1];
4085 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4086 SvREFCNT_dec(*dst++); /* free them now */
4089 AvFILLp(ary) += diff;
4091 /* pull up or down? */
4093 if (offset < after) { /* easier to pull up */
4094 if (offset) { /* esp. if nothing to pull */
4095 src = &AvARRAY(ary)[offset-1];
4096 dst = src - diff; /* diff is negative */
4097 for (i = offset; i > 0; i--) /* can't trust Copy */
4101 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4105 if (after) { /* anything to pull down? */
4106 src = AvARRAY(ary) + offset + length;
4107 dst = src + diff; /* diff is negative */
4108 Move(src, dst, after, SV*);
4110 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4111 /* avoid later double free */
4115 dst[--i] = &PL_sv_undef;
4118 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4120 *dst = NEWSV(46, 0);
4121 sv_setsv(*dst++, *src++);
4123 Safefree(tmparyval);
4126 else { /* no, expanding (or same) */
4128 New(452, tmparyval, length, SV*); /* so remember deletion */
4129 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4132 if (diff > 0) { /* expanding */
4134 /* push up or down? */
4136 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4140 Move(src, dst, offset, SV*);
4142 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4144 AvFILLp(ary) += diff;
4147 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4148 av_extend(ary, AvFILLp(ary) + diff);
4149 AvFILLp(ary) += diff;
4152 dst = AvARRAY(ary) + AvFILLp(ary);
4154 for (i = after; i; i--) {
4161 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4162 *dst = NEWSV(46, 0);
4163 sv_setsv(*dst++, *src++);
4165 MARK = ORIGMARK + 1;
4166 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4168 Copy(tmparyval, MARK, length, SV*);
4170 EXTEND_MORTAL(length);
4171 for (i = length, dst = MARK; i; i--) {
4172 sv_2mortal(*dst); /* free them eventualy */
4176 Safefree(tmparyval);
4180 else if (length--) {
4181 *MARK = tmparyval[length];
4184 while (length-- > 0)
4185 SvREFCNT_dec(tmparyval[length]);
4187 Safefree(tmparyval);
4190 *MARK = &PL_sv_undef;
4198 dSP; dMARK; dORIGMARK; dTARGET;
4199 register AV *ary = (AV*)*++MARK;
4200 register SV *sv = &PL_sv_undef;
4203 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4204 *MARK-- = SvTIED_obj((SV*)ary, mg);
4208 call_method("PUSH",G_SCALAR|G_DISCARD);
4213 /* Why no pre-extend of ary here ? */
4214 for (++MARK; MARK <= SP; MARK++) {
4217 sv_setsv(sv, *MARK);
4222 PUSHi( AvFILL(ary) + 1 );
4230 SV *sv = av_pop(av);
4232 (void)sv_2mortal(sv);
4241 SV *sv = av_shift(av);
4246 (void)sv_2mortal(sv);
4253 dSP; dMARK; dORIGMARK; dTARGET;
4254 register AV *ary = (AV*)*++MARK;
4259 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4260 *MARK-- = SvTIED_obj((SV*)ary, mg);
4264 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4269 av_unshift(ary, SP - MARK);
4272 sv_setsv(sv, *++MARK);
4273 (void)av_store(ary, i++, sv);
4277 PUSHi( AvFILL(ary) + 1 );
4287 if (GIMME == G_ARRAY) {
4294 /* safe as long as stack cannot get extended in the above */
4299 register char *down;
4304 SvUTF8_off(TARG); /* decontaminate */
4306 do_join(TARG, &PL_sv_no, MARK, SP);
4308 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4309 up = SvPV_force(TARG, len);
4311 if (DO_UTF8(TARG)) { /* first reverse each character */
4312 U8* s = (U8*)SvPVX(TARG);
4313 U8* send = (U8*)(s + len);
4315 if (UTF8_IS_INVARIANT(*s)) {
4320 if (!utf8_to_uvchr(s, 0))
4324 down = (char*)(s - 1);
4325 /* reverse this character */
4329 *down-- = (char)tmp;
4335 down = SvPVX(TARG) + len - 1;
4339 *down-- = (char)tmp;
4341 (void)SvPOK_only_UTF8(TARG);
4353 register IV limit = POPi; /* note, negative is forever */
4356 register char *s = SvPV(sv, len);
4357 bool do_utf8 = DO_UTF8(sv);
4358 char *strend = s + len;
4360 register REGEXP *rx;
4364 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4365 I32 maxiters = slen + 10;
4368 I32 origlimit = limit;
4371 AV *oldstack = PL_curstack;
4372 I32 gimme = GIMME_V;
4373 I32 oldsave = PL_savestack_ix;
4374 I32 make_mortal = 1;
4375 MAGIC *mg = (MAGIC *) NULL;
4378 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4383 DIE(aTHX_ "panic: pp_split");
4386 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4387 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4389 RX_MATCH_UTF8_set(rx, do_utf8);
4391 if (pm->op_pmreplroot) {
4393 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4395 ary = GvAVn((GV*)pm->op_pmreplroot);
4398 else if (gimme != G_ARRAY)
4399 ary = GvAVn(PL_defgv);
4402 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4408 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4410 XPUSHs(SvTIED_obj((SV*)ary, mg));
4416 for (i = AvFILLp(ary); i >= 0; i--)
4417 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4419 /* temporarily switch stacks */
4420 SWITCHSTACK(PL_curstack, ary);
4421 PL_curstackinfo->si_stack = ary;
4425 base = SP - PL_stack_base;
4427 if (pm->op_pmflags & PMf_SKIPWHITE) {
4428 if (pm->op_pmflags & PMf_LOCALE) {
4429 while (isSPACE_LC(*s))
4437 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4438 SAVEINT(PL_multiline);
4439 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4443 limit = maxiters + 2;
4444 if (pm->op_pmflags & PMf_WHITE) {
4447 while (m < strend &&
4448 !((pm->op_pmflags & PMf_LOCALE)
4449 ? isSPACE_LC(*m) : isSPACE(*m)))
4454 dstr = NEWSV(30, m-s);
4455 sv_setpvn(dstr, s, m-s);
4459 (void)SvUTF8_on(dstr);
4463 while (s < strend &&
4464 ((pm->op_pmflags & PMf_LOCALE)
4465 ? isSPACE_LC(*s) : isSPACE(*s)))
4469 else if (strEQ("^", rx->precomp)) {
4472 for (m = s; m < strend && *m != '\n'; m++) ;
4476 dstr = NEWSV(30, m-s);
4477 sv_setpvn(dstr, s, m-s);
4481 (void)SvUTF8_on(dstr);
4486 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4487 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4488 && (rx->reganch & ROPT_CHECK_ALL)
4489 && !(rx->reganch & ROPT_ANCH)) {
4490 int tail = (rx->reganch & RE_INTUIT_TAIL);
4491 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4494 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4496 char c = *SvPV(csv, n_a);
4499 for (m = s; m < strend && *m != c; m++) ;
4502 dstr = NEWSV(30, m-s);
4503 sv_setpvn(dstr, s, m-s);
4507 (void)SvUTF8_on(dstr);
4509 /* The rx->minlen is in characters but we want to step
4510 * s ahead by bytes. */
4512 s = (char*)utf8_hop((U8*)m, len);
4514 s = m + len; /* Fake \n at the end */
4519 while (s < strend && --limit &&
4520 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4521 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4524 dstr = NEWSV(31, m-s);
4525 sv_setpvn(dstr, s, m-s);
4529 (void)SvUTF8_on(dstr);
4531 /* The rx->minlen is in characters but we want to step
4532 * s ahead by bytes. */
4534 s = (char*)utf8_hop((U8*)m, len);
4536 s = m + len; /* Fake \n at the end */
4541 maxiters += slen * rx->nparens;
4542 while (s < strend && --limit)
4545 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4549 TAINT_IF(RX_MATCH_TAINTED(rx));
4550 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4555 strend = s + (strend - m);
4557 m = rx->startp[0] + orig;
4558 dstr = NEWSV(32, m-s);
4559 sv_setpvn(dstr, s, m-s);
4563 (void)SvUTF8_on(dstr);
4566 for (i = 1; i <= (I32)rx->nparens; i++) {
4567 s = rx->startp[i] + orig;
4568 m = rx->endp[i] + orig;
4570 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4571 parens that didn't match -- they should be set to
4572 undef, not the empty string */
4573 if (m >= orig && s >= orig) {
4574 dstr = NEWSV(33, m-s);
4575 sv_setpvn(dstr, s, m-s);
4578 dstr = &PL_sv_undef; /* undef, not "" */
4582 (void)SvUTF8_on(dstr);
4586 s = rx->endp[0] + orig;
4590 LEAVE_SCOPE(oldsave);
4591 iters = (SP - PL_stack_base) - base;
4592 if (iters > maxiters)
4593 DIE(aTHX_ "Split loop");
4595 /* keep field after final delim? */
4596 if (s < strend || (iters && origlimit)) {
4597 STRLEN l = strend - s;
4598 dstr = NEWSV(34, l);
4599 sv_setpvn(dstr, s, l);
4603 (void)SvUTF8_on(dstr);
4607 else if (!origlimit) {
4608 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4609 if (TOPs && !make_mortal)
4618 SWITCHSTACK(ary, oldstack);
4619 PL_curstackinfo->si_stack = oldstack;
4620 if (SvSMAGICAL(ary)) {
4625 if (gimme == G_ARRAY) {
4627 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4635 call_method("PUSH",G_SCALAR|G_DISCARD);
4638 if (gimme == G_ARRAY) {
4639 /* EXTEND should not be needed - we just popped them */
4641 for (i=0; i < iters; i++) {
4642 SV **svp = av_fetch(ary, i, FALSE);
4643 PUSHs((svp) ? *svp : &PL_sv_undef);
4650 if (gimme == G_ARRAY)
4665 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4666 || SvTYPE(retsv) == SVt_PVCV) {
4667 retsv = refto(retsv);
4675 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");