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
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 = Perl_hv_scalar(aTHX_ (HV*)TARG);
117 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
128 tryAMAGICunDEREF(to_gv);
131 if (SvTYPE(sv) == SVt_PVIO) {
132 GV *gv = (GV*) sv_newmortal();
133 gv_init(gv, 0, "", 0, 0);
134 GvIOp(gv) = (IO *)sv;
135 (void)SvREFCNT_inc(sv);
138 else if (SvTYPE(sv) != SVt_PVGV)
139 DIE(aTHX_ "Not a GLOB reference");
142 if (SvTYPE(sv) != SVt_PVGV) {
146 if (SvGMAGICAL(sv)) {
151 if (!SvOK(sv) && sv != &PL_sv_undef) {
152 /* If this is a 'my' scalar and flag is set then vivify
155 if (PL_op->op_private & OPpDEREF) {
158 if (cUNOP->op_targ) {
160 SV *namesv = PAD_SV(cUNOP->op_targ);
161 name = SvPV(namesv, len);
162 gv = (GV*)NEWSV(0,0);
163 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
166 name = CopSTASHPV(PL_curcop);
169 if (SvTYPE(sv) < SVt_RV)
170 sv_upgrade(sv, SVt_RV);
172 (void)SvOOK_off(sv); /* backoff */
175 SvLEN(sv)=SvCUR(sv)=0;
182 if (PL_op->op_flags & OPf_REF ||
183 PL_op->op_private & HINT_STRICT_REFS)
184 DIE(aTHX_ PL_no_usym, "a symbol");
185 if (ckWARN(WARN_UNINITIALIZED))
190 if ((PL_op->op_flags & OPf_SPECIAL) &&
191 !(PL_op->op_flags & OPf_MOD))
193 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
195 && (!is_gv_magical(sym,len,0)
196 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
202 if (PL_op->op_private & HINT_STRICT_REFS)
203 DIE(aTHX_ PL_no_symref, sym, "a symbol");
204 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
208 if (PL_op->op_private & OPpLVAL_INTRO)
209 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
221 tryAMAGICunDEREF(to_sv);
224 switch (SvTYPE(sv)) {
228 DIE(aTHX_ "Not a SCALAR reference");
236 if (SvTYPE(gv) != SVt_PVGV) {
237 if (SvGMAGICAL(sv)) {
243 if (PL_op->op_flags & OPf_REF ||
244 PL_op->op_private & HINT_STRICT_REFS)
245 DIE(aTHX_ PL_no_usym, "a SCALAR");
246 if (ckWARN(WARN_UNINITIALIZED))
251 if ((PL_op->op_flags & OPf_SPECIAL) &&
252 !(PL_op->op_flags & OPf_MOD))
254 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
256 && (!is_gv_magical(sym,len,0)
257 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
263 if (PL_op->op_private & HINT_STRICT_REFS)
264 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
265 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
270 if (PL_op->op_flags & OPf_MOD) {
271 if (PL_op->op_private & OPpLVAL_INTRO) {
272 if (cUNOP->op_first->op_type == OP_NULL)
273 sv = save_scalar((GV*)TOPs);
275 sv = save_scalar(gv);
277 Perl_croak(aTHX_ PL_no_localize_ref);
279 else if (PL_op->op_private & OPpDEREF)
280 vivify_ref(sv, PL_op->op_private & OPpDEREF);
290 SV *sv = AvARYLEN(av);
292 AvARYLEN(av) = sv = NEWSV(0,0);
293 sv_upgrade(sv, SVt_IV);
294 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
302 dSP; dTARGET; dPOPss;
304 if (PL_op->op_flags & OPf_MOD || LVRET) {
305 if (SvTYPE(TARG) < SVt_PVLV) {
306 sv_upgrade(TARG, SVt_PVLV);
307 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
311 if (LvTARG(TARG) != sv) {
313 SvREFCNT_dec(LvTARG(TARG));
314 LvTARG(TARG) = SvREFCNT_inc(sv);
316 PUSHs(TARG); /* no SvSETMAGIC */
322 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
323 mg = mg_find(sv, PERL_MAGIC_regex_global);
324 if (mg && mg->mg_len >= 0) {
328 PUSHi(i + PL_curcop->cop_arybase);
342 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
343 /* (But not in defined().) */
344 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
347 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
348 if ((PL_op->op_private & OPpLVAL_INTRO)) {
349 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
352 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
356 cv = (CV*)&PL_sv_undef;
370 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
371 char *s = SvPVX(TOPs);
372 if (strnEQ(s, "CORE::", 6)) {
375 code = keyword(s + 6, SvCUR(TOPs) - 6);
376 if (code < 0) { /* Overridable. */
377 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
378 int i = 0, n = 0, seen_question = 0;
380 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
382 if (code == -KEY_chop || code == -KEY_chomp)
384 while (i < MAXO) { /* The slow way. */
385 if (strEQ(s + 6, PL_op_name[i])
386 || strEQ(s + 6, PL_op_desc[i]))
392 goto nonesuch; /* Should not happen... */
394 oa = PL_opargs[i] >> OASHIFT;
396 if (oa & OA_OPTIONAL && !seen_question) {
400 else if (n && str[0] == ';' && seen_question)
401 goto set; /* XXXX system, exec */
402 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
403 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
404 /* But globs are already references (kinda) */
405 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
409 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
413 ret = sv_2mortal(newSVpvn(str, n - 1));
415 else if (code) /* Non-Overridable */
417 else { /* None such */
419 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
423 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
425 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
434 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
436 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
452 if (GIMME != G_ARRAY) {
456 *MARK = &PL_sv_undef;
457 *MARK = refto(*MARK);
461 EXTEND_MORTAL(SP - MARK);
463 *MARK = refto(*MARK);
468 S_refto(pTHX_ SV *sv)
472 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
475 if (!(sv = LvTARG(sv)))
478 (void)SvREFCNT_inc(sv);
480 else if (SvTYPE(sv) == SVt_PVAV) {
481 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
484 (void)SvREFCNT_inc(sv);
486 else if (SvPADTMP(sv) && !IS_PADGV(sv))
490 (void)SvREFCNT_inc(sv);
493 sv_upgrade(rv, SVt_RV);
507 if (sv && SvGMAGICAL(sv))
510 if (!sv || !SvROK(sv))
514 pv = sv_reftype(sv,TRUE);
515 PUSHp(pv, strlen(pv));
525 stash = CopSTASH(PL_curcop);
531 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
532 Perl_croak(aTHX_ "Attempt to bless into a reference");
534 if (ckWARN(WARN_MISC) && len == 0)
535 Perl_warner(aTHX_ packWARN(WARN_MISC),
536 "Explicit blessing to '' (assuming package main)");
537 stash = gv_stashpvn(ptr, len, TRUE);
540 (void)sv_bless(TOPs, stash);
554 elem = SvPV(sv, n_a);
558 switch (elem ? *elem : '\0')
561 if (strEQ(elem, "ARRAY"))
562 tmpRef = (SV*)GvAV(gv);
565 if (strEQ(elem, "CODE"))
566 tmpRef = (SV*)GvCVu(gv);
569 if (strEQ(elem, "FILEHANDLE")) {
570 /* finally deprecated in 5.8.0 */
571 deprecate("*glob{FILEHANDLE}");
572 tmpRef = (SV*)GvIOp(gv);
575 if (strEQ(elem, "FORMAT"))
576 tmpRef = (SV*)GvFORM(gv);
579 if (strEQ(elem, "GLOB"))
583 if (strEQ(elem, "HASH"))
584 tmpRef = (SV*)GvHV(gv);
587 if (strEQ(elem, "IO"))
588 tmpRef = (SV*)GvIOp(gv);
591 if (strEQ(elem, "NAME"))
592 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
595 if (strEQ(elem, "PACKAGE")) {
596 if (HvNAME(GvSTASH(gv)))
597 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
599 sv = newSVpv("__ANON__",0);
603 if (strEQ(elem, "SCALAR"))
617 /* Pattern matching */
622 register unsigned char *s;
625 register I32 *sfirst;
629 if (sv == PL_lastscream) {
635 SvSCREAM_off(PL_lastscream);
636 SvREFCNT_dec(PL_lastscream);
638 PL_lastscream = SvREFCNT_inc(sv);
641 s = (unsigned char*)(SvPV(sv, len));
645 if (pos > PL_maxscream) {
646 if (PL_maxscream < 0) {
647 PL_maxscream = pos + 80;
648 New(301, PL_screamfirst, 256, I32);
649 New(302, PL_screamnext, PL_maxscream, I32);
652 PL_maxscream = pos + pos / 4;
653 Renew(PL_screamnext, PL_maxscream, I32);
657 sfirst = PL_screamfirst;
658 snext = PL_screamnext;
660 if (!sfirst || !snext)
661 DIE(aTHX_ "do_study: out of memory");
663 for (ch = 256; ch; --ch)
670 snext[pos] = sfirst[ch] - pos;
677 /* piggyback on m//g magic */
678 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
687 if (PL_op->op_flags & OPf_STACKED)
689 else if (PL_op->op_private & OPpTARGET_MY)
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_PVGV && 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_PVGV && 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_PVGV && 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;
1397 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1399 I32 items = SP - MARK;
1401 static const char list_extend[] = "panic: list extend";
1403 max = items * count;
1404 MEM_WRAP_CHECK_1(max, SV*, list_extend);
1405 if (items > 0 && max > 0 && (max < items || max < count))
1406 Perl_croak(aTHX_ list_extend);
1411 /* This code was intended to fix 20010809.028:
1414 for (($x =~ /./g) x 2) {
1415 print chop; # "abcdabcd" expected as output.
1418 * but that change (#11635) broke this code:
1420 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1422 * I can't think of a better fix that doesn't introduce
1423 * an efficiency hit by copying the SVs. The stack isn't
1424 * refcounted, and mortalisation obviously doesn't
1425 * Do The Right Thing when the stack has more than
1426 * one pointer to the same mortal value.
1430 *SP = sv_2mortal(newSVsv(*SP));
1440 repeatcpy((char*)(MARK + items), (char*)MARK,
1441 items * sizeof(SV*), count - 1);
1444 else if (count <= 0)
1447 else { /* Note: mark already snarfed by pp_list */
1452 SvSetSV(TARG, tmpstr);
1453 SvPV_force(TARG, len);
1454 isutf = DO_UTF8(TARG);
1459 MEM_WRAP_CHECK_1(count, len, "panic: string extend");
1460 SvGROW(TARG, (count * len) + 1);
1461 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1462 SvCUR(TARG) *= count;
1464 *SvEND(TARG) = '\0';
1467 (void)SvPOK_only_UTF8(TARG);
1469 (void)SvPOK_only(TARG);
1471 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1472 /* The parser saw this as a list repeat, and there
1473 are probably several items on the stack. But we're
1474 in scalar context, and there's no pp_list to save us
1475 now. So drop the rest of the items -- robin@kitsite.com
1488 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1489 useleft = USE_LEFT(TOPm1s);
1490 #ifdef PERL_PRESERVE_IVUV
1491 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1492 "bad things" happen if you rely on signed integers wrapping. */
1495 /* Unless the left argument is integer in range we are going to have to
1496 use NV maths. Hence only attempt to coerce the right argument if
1497 we know the left is integer. */
1498 register UV auv = 0;
1504 a_valid = auvok = 1;
1505 /* left operand is undef, treat as zero. */
1507 /* Left operand is defined, so is it IV? */
1508 SvIV_please(TOPm1s);
1509 if (SvIOK(TOPm1s)) {
1510 if ((auvok = SvUOK(TOPm1s)))
1511 auv = SvUVX(TOPm1s);
1513 register IV aiv = SvIVX(TOPm1s);
1516 auvok = 1; /* Now acting as a sign flag. */
1517 } else { /* 2s complement assumption for IV_MIN */
1525 bool result_good = 0;
1528 bool buvok = SvUOK(TOPs);
1533 register IV biv = SvIVX(TOPs);
1540 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1541 else "IV" now, independent of how it came in.
1542 if a, b represents positive, A, B negative, a maps to -A etc
1547 all UV maths. negate result if A negative.
1548 subtract if signs same, add if signs differ. */
1550 if (auvok ^ buvok) {
1559 /* Must get smaller */
1564 if (result <= buv) {
1565 /* result really should be -(auv-buv). as its negation
1566 of true value, need to swap our result flag */
1578 if (result <= (UV)IV_MIN)
1579 SETi( -(IV)result );
1581 /* result valid, but out of range for IV. */
1582 SETn( -(NV)result );
1586 } /* Overflow, drop through to NVs. */
1590 useleft = USE_LEFT(TOPm1s);
1594 /* left operand is undef, treat as zero - value */
1598 SETn( TOPn - value );
1605 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1608 if (PL_op->op_private & HINT_INTEGER) {
1622 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1625 if (PL_op->op_private & HINT_INTEGER) {
1639 dSP; tryAMAGICbinSET(lt,0);
1640 #ifdef PERL_PRESERVE_IVUV
1643 SvIV_please(TOPm1s);
1644 if (SvIOK(TOPm1s)) {
1645 bool auvok = SvUOK(TOPm1s);
1646 bool buvok = SvUOK(TOPs);
1648 if (!auvok && !buvok) { /* ## IV < IV ## */
1649 IV aiv = SvIVX(TOPm1s);
1650 IV biv = SvIVX(TOPs);
1653 SETs(boolSV(aiv < biv));
1656 if (auvok && buvok) { /* ## UV < UV ## */
1657 UV auv = SvUVX(TOPm1s);
1658 UV buv = SvUVX(TOPs);
1661 SETs(boolSV(auv < buv));
1664 if (auvok) { /* ## UV < IV ## */
1671 /* As (a) is a UV, it's >=0, so it cannot be < */
1676 SETs(boolSV(auv < (UV)biv));
1679 { /* ## IV < UV ## */
1683 aiv = SvIVX(TOPm1s);
1685 /* As (b) is a UV, it's >=0, so it must be < */
1692 SETs(boolSV((UV)aiv < buv));
1698 #ifndef NV_PRESERVES_UV
1699 #ifdef PERL_PRESERVE_IVUV
1702 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1704 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1710 SETs(boolSV(TOPn < value));
1717 dSP; tryAMAGICbinSET(gt,0);
1718 #ifdef PERL_PRESERVE_IVUV
1721 SvIV_please(TOPm1s);
1722 if (SvIOK(TOPm1s)) {
1723 bool auvok = SvUOK(TOPm1s);
1724 bool buvok = SvUOK(TOPs);
1726 if (!auvok && !buvok) { /* ## IV > IV ## */
1727 IV aiv = SvIVX(TOPm1s);
1728 IV biv = SvIVX(TOPs);
1731 SETs(boolSV(aiv > biv));
1734 if (auvok && buvok) { /* ## UV > UV ## */
1735 UV auv = SvUVX(TOPm1s);
1736 UV buv = SvUVX(TOPs);
1739 SETs(boolSV(auv > buv));
1742 if (auvok) { /* ## UV > IV ## */
1749 /* As (a) is a UV, it's >=0, so it must be > */
1754 SETs(boolSV(auv > (UV)biv));
1757 { /* ## IV > UV ## */
1761 aiv = SvIVX(TOPm1s);
1763 /* As (b) is a UV, it's >=0, so it cannot be > */
1770 SETs(boolSV((UV)aiv > buv));
1776 #ifndef NV_PRESERVES_UV
1777 #ifdef PERL_PRESERVE_IVUV
1780 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1782 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1788 SETs(boolSV(TOPn > value));
1795 dSP; tryAMAGICbinSET(le,0);
1796 #ifdef PERL_PRESERVE_IVUV
1799 SvIV_please(TOPm1s);
1800 if (SvIOK(TOPm1s)) {
1801 bool auvok = SvUOK(TOPm1s);
1802 bool buvok = SvUOK(TOPs);
1804 if (!auvok && !buvok) { /* ## IV <= IV ## */
1805 IV aiv = SvIVX(TOPm1s);
1806 IV biv = SvIVX(TOPs);
1809 SETs(boolSV(aiv <= biv));
1812 if (auvok && buvok) { /* ## UV <= UV ## */
1813 UV auv = SvUVX(TOPm1s);
1814 UV buv = SvUVX(TOPs);
1817 SETs(boolSV(auv <= buv));
1820 if (auvok) { /* ## UV <= IV ## */
1827 /* As (a) is a UV, it's >=0, so a cannot be <= */
1832 SETs(boolSV(auv <= (UV)biv));
1835 { /* ## IV <= UV ## */
1839 aiv = SvIVX(TOPm1s);
1841 /* As (b) is a UV, it's >=0, so a must be <= */
1848 SETs(boolSV((UV)aiv <= buv));
1854 #ifndef NV_PRESERVES_UV
1855 #ifdef PERL_PRESERVE_IVUV
1858 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1860 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1866 SETs(boolSV(TOPn <= value));
1873 dSP; tryAMAGICbinSET(ge,0);
1874 #ifdef PERL_PRESERVE_IVUV
1877 SvIV_please(TOPm1s);
1878 if (SvIOK(TOPm1s)) {
1879 bool auvok = SvUOK(TOPm1s);
1880 bool buvok = SvUOK(TOPs);
1882 if (!auvok && !buvok) { /* ## IV >= IV ## */
1883 IV aiv = SvIVX(TOPm1s);
1884 IV biv = SvIVX(TOPs);
1887 SETs(boolSV(aiv >= biv));
1890 if (auvok && buvok) { /* ## UV >= UV ## */
1891 UV auv = SvUVX(TOPm1s);
1892 UV buv = SvUVX(TOPs);
1895 SETs(boolSV(auv >= buv));
1898 if (auvok) { /* ## UV >= IV ## */
1905 /* As (a) is a UV, it's >=0, so it must be >= */
1910 SETs(boolSV(auv >= (UV)biv));
1913 { /* ## IV >= UV ## */
1917 aiv = SvIVX(TOPm1s);
1919 /* As (b) is a UV, it's >=0, so a cannot be >= */
1926 SETs(boolSV((UV)aiv >= buv));
1932 #ifndef NV_PRESERVES_UV
1933 #ifdef PERL_PRESERVE_IVUV
1936 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1938 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1944 SETs(boolSV(TOPn >= value));
1951 dSP; tryAMAGICbinSET(ne,0);
1952 #ifndef NV_PRESERVES_UV
1953 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1955 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1959 #ifdef PERL_PRESERVE_IVUV
1962 SvIV_please(TOPm1s);
1963 if (SvIOK(TOPm1s)) {
1964 bool auvok = SvUOK(TOPm1s);
1965 bool buvok = SvUOK(TOPs);
1967 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1968 /* Casting IV to UV before comparison isn't going to matter
1969 on 2s complement. On 1s complement or sign&magnitude
1970 (if we have any of them) it could make negative zero
1971 differ from normal zero. As I understand it. (Need to
1972 check - is negative zero implementation defined behaviour
1974 UV buv = SvUVX(POPs);
1975 UV auv = SvUVX(TOPs);
1977 SETs(boolSV(auv != buv));
1980 { /* ## Mixed IV,UV ## */
1984 /* != is commutative so swap if needed (save code) */
1986 /* swap. top of stack (b) is the iv */
1990 /* As (a) is a UV, it's >0, so it cannot be == */
1999 /* As (b) is a UV, it's >0, so it cannot be == */
2003 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2005 SETs(boolSV((UV)iv != uv));
2013 SETs(boolSV(TOPn != value));
2020 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2021 #ifndef NV_PRESERVES_UV
2022 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2023 UV right = PTR2UV(SvRV(POPs));
2024 UV left = PTR2UV(SvRV(TOPs));
2025 SETi((left > right) - (left < right));
2029 #ifdef PERL_PRESERVE_IVUV
2030 /* Fortunately it seems NaN isn't IOK */
2033 SvIV_please(TOPm1s);
2034 if (SvIOK(TOPm1s)) {
2035 bool leftuvok = SvUOK(TOPm1s);
2036 bool rightuvok = SvUOK(TOPs);
2038 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2039 IV leftiv = SvIVX(TOPm1s);
2040 IV rightiv = SvIVX(TOPs);
2042 if (leftiv > rightiv)
2044 else if (leftiv < rightiv)
2048 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2049 UV leftuv = SvUVX(TOPm1s);
2050 UV rightuv = SvUVX(TOPs);
2052 if (leftuv > rightuv)
2054 else if (leftuv < rightuv)
2058 } else if (leftuvok) { /* ## UV <=> IV ## */
2062 rightiv = SvIVX(TOPs);
2064 /* As (a) is a UV, it's >=0, so it cannot be < */
2067 leftuv = SvUVX(TOPm1s);
2068 if (leftuv > (UV)rightiv) {
2070 } else if (leftuv < (UV)rightiv) {
2076 } else { /* ## IV <=> UV ## */
2080 leftiv = SvIVX(TOPm1s);
2082 /* As (b) is a UV, it's >=0, so it must be < */
2085 rightuv = SvUVX(TOPs);
2086 if ((UV)leftiv > rightuv) {
2088 } else if ((UV)leftiv < rightuv) {
2106 if (Perl_isnan(left) || Perl_isnan(right)) {
2110 value = (left > right) - (left < right);
2114 else if (left < right)
2116 else if (left > right)
2130 dSP; tryAMAGICbinSET(slt,0);
2133 int cmp = (IN_LOCALE_RUNTIME
2134 ? sv_cmp_locale(left, right)
2135 : sv_cmp(left, right));
2136 SETs(boolSV(cmp < 0));
2143 dSP; tryAMAGICbinSET(sgt,0);
2146 int cmp = (IN_LOCALE_RUNTIME
2147 ? sv_cmp_locale(left, right)
2148 : sv_cmp(left, right));
2149 SETs(boolSV(cmp > 0));
2156 dSP; tryAMAGICbinSET(sle,0);
2159 int cmp = (IN_LOCALE_RUNTIME
2160 ? sv_cmp_locale(left, right)
2161 : sv_cmp(left, right));
2162 SETs(boolSV(cmp <= 0));
2169 dSP; tryAMAGICbinSET(sge,0);
2172 int cmp = (IN_LOCALE_RUNTIME
2173 ? sv_cmp_locale(left, right)
2174 : sv_cmp(left, right));
2175 SETs(boolSV(cmp >= 0));
2182 dSP; tryAMAGICbinSET(seq,0);
2185 SETs(boolSV(sv_eq(left, right)));
2192 dSP; tryAMAGICbinSET(sne,0);
2195 SETs(boolSV(!sv_eq(left, right)));
2202 dSP; dTARGET; tryAMAGICbin(scmp,0);
2205 int cmp = (IN_LOCALE_RUNTIME
2206 ? sv_cmp_locale(left, right)
2207 : sv_cmp(left, right));
2215 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2218 if (SvGMAGICAL(left)) mg_get(left);
2219 if (SvGMAGICAL(right)) mg_get(right);
2220 if (SvNIOKp(left) || SvNIOKp(right)) {
2221 if (PL_op->op_private & HINT_INTEGER) {
2222 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2226 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2231 do_vop(PL_op->op_type, TARG, left, right);
2240 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2243 if (SvGMAGICAL(left)) mg_get(left);
2244 if (SvGMAGICAL(right)) mg_get(right);
2245 if (SvNIOKp(left) || SvNIOKp(right)) {
2246 if (PL_op->op_private & HINT_INTEGER) {
2247 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2251 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2256 do_vop(PL_op->op_type, TARG, left, right);
2265 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2268 if (SvGMAGICAL(left)) mg_get(left);
2269 if (SvGMAGICAL(right)) mg_get(right);
2270 if (SvNIOKp(left) || SvNIOKp(right)) {
2271 if (PL_op->op_private & HINT_INTEGER) {
2272 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2276 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2281 do_vop(PL_op->op_type, TARG, left, right);
2290 dSP; dTARGET; tryAMAGICun(neg);
2293 int flags = SvFLAGS(sv);
2296 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2297 /* It's publicly an integer, or privately an integer-not-float */
2300 if (SvIVX(sv) == IV_MIN) {
2301 /* 2s complement assumption. */
2302 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2305 else if (SvUVX(sv) <= IV_MAX) {
2310 else if (SvIVX(sv) != IV_MIN) {
2314 #ifdef PERL_PRESERVE_IVUV
2323 else if (SvPOKp(sv)) {
2325 char *s = SvPV(sv, len);
2326 if (isIDFIRST(*s)) {
2327 sv_setpvn(TARG, "-", 1);
2330 else if (*s == '+' || *s == '-') {
2332 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2334 else if (DO_UTF8(sv)) {
2337 goto oops_its_an_int;
2339 sv_setnv(TARG, -SvNV(sv));
2341 sv_setpvn(TARG, "-", 1);
2348 goto oops_its_an_int;
2349 sv_setnv(TARG, -SvNV(sv));
2361 dSP; tryAMAGICunSET(not);
2362 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2368 dSP; dTARGET; tryAMAGICun(compl);
2374 if (PL_op->op_private & HINT_INTEGER) {
2375 IV i = ~SvIV_nomg(sv);
2379 UV u = ~SvUV_nomg(sv);
2388 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2389 sv_setsv_nomg(TARG, sv);
2390 tmps = (U8*)SvPV_force(TARG, len);
2393 /* Calculate exact length, let's not estimate. */
2402 while (tmps < send) {
2403 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2404 tmps += UTF8SKIP(tmps);
2405 targlen += UNISKIP(~c);
2411 /* Now rewind strings and write them. */
2415 Newz(0, result, targlen + 1, U8);
2416 while (tmps < send) {
2417 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2418 tmps += UTF8SKIP(tmps);
2419 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2423 sv_setpvn(TARG, (char*)result, targlen);
2427 Newz(0, result, nchar + 1, U8);
2428 while (tmps < send) {
2429 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2430 tmps += UTF8SKIP(tmps);
2435 sv_setpvn(TARG, (char*)result, nchar);
2444 register long *tmpl;
2445 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2448 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2453 for ( ; anum > 0; anum--, tmps++)
2462 /* integer versions of some of the above */
2466 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2469 SETi( left * right );
2476 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2480 DIE(aTHX_ "Illegal division by zero");
2481 value = POPi / value;
2490 /* This is the vanilla old i_modulo. */
2491 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2495 DIE(aTHX_ "Illegal modulus zero");
2496 SETi( left % right );
2501 #if defined(__GLIBC__) && IVSIZE == 8
2505 /* This is the i_modulo with the workaround for the _moddi3 bug
2506 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2507 * See below for pp_i_modulo. */
2508 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2512 DIE(aTHX_ "Illegal modulus zero");
2513 SETi( left % PERL_ABS(right) );
2521 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2525 DIE(aTHX_ "Illegal modulus zero");
2526 /* The assumption is to use hereafter the old vanilla version... */
2528 PL_ppaddr[OP_I_MODULO] =
2529 &Perl_pp_i_modulo_0;
2530 /* .. but if we have glibc, we might have a buggy _moddi3
2531 * (at least glicb 2.2.5 is known to have this bug), in other
2532 * words our integer modulus with negative quad as the second
2533 * argument might be broken. Test for this and re-patch the
2534 * opcode dispatch table if that is the case, remembering to
2535 * also apply the workaround so that this first round works
2536 * right, too. See [perl #9402] for more information. */
2537 #if defined(__GLIBC__) && IVSIZE == 8
2541 /* Cannot do this check with inlined IV constants since
2542 * that seems to work correctly even with the buggy glibc. */
2544 /* Yikes, we have the bug.
2545 * Patch in the workaround version. */
2547 PL_ppaddr[OP_I_MODULO] =
2548 &Perl_pp_i_modulo_1;
2549 /* Make certain we work right this time, too. */
2550 right = PERL_ABS(right);
2554 SETi( left % right );
2561 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2564 SETi( left + right );
2571 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2574 SETi( left - right );
2581 dSP; tryAMAGICbinSET(lt,0);
2584 SETs(boolSV(left < right));
2591 dSP; tryAMAGICbinSET(gt,0);
2594 SETs(boolSV(left > right));
2601 dSP; tryAMAGICbinSET(le,0);
2604 SETs(boolSV(left <= right));
2611 dSP; tryAMAGICbinSET(ge,0);
2614 SETs(boolSV(left >= right));
2621 dSP; tryAMAGICbinSET(eq,0);
2624 SETs(boolSV(left == right));
2631 dSP; tryAMAGICbinSET(ne,0);
2634 SETs(boolSV(left != right));
2641 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2648 else if (left < right)
2659 dSP; dTARGET; tryAMAGICun(neg);
2664 /* High falutin' math. */
2668 dSP; dTARGET; tryAMAGICbin(atan2,0);
2671 SETn(Perl_atan2(left, right));
2678 dSP; dTARGET; tryAMAGICun(sin);
2682 value = Perl_sin(value);
2690 dSP; dTARGET; tryAMAGICun(cos);
2694 value = Perl_cos(value);
2700 /* Support Configure command-line overrides for rand() functions.
2701 After 5.005, perhaps we should replace this by Configure support
2702 for drand48(), random(), or rand(). For 5.005, though, maintain
2703 compatibility by calling rand() but allow the user to override it.
2704 See INSTALL for details. --Andy Dougherty 15 July 1998
2706 /* Now it's after 5.005, and Configure supports drand48() and random(),
2707 in addition to rand(). So the overrides should not be needed any more.
2708 --Jarkko Hietaniemi 27 September 1998
2711 #ifndef HAS_DRAND48_PROTO
2712 extern double drand48 (void);
2725 if (!PL_srand_called) {
2726 (void)seedDrand01((Rand_seed_t)seed());
2727 PL_srand_called = TRUE;
2742 (void)seedDrand01((Rand_seed_t)anum);
2743 PL_srand_called = TRUE;
2750 dSP; dTARGET; tryAMAGICun(exp);
2754 value = Perl_exp(value);
2762 dSP; dTARGET; tryAMAGICun(log);
2767 SET_NUMERIC_STANDARD();
2768 DIE(aTHX_ "Can't take log of %"NVgf, value);
2770 value = Perl_log(value);
2778 dSP; dTARGET; tryAMAGICun(sqrt);
2783 SET_NUMERIC_STANDARD();
2784 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2786 value = Perl_sqrt(value);
2794 dSP; dTARGET; tryAMAGICun(int);
2797 IV iv = TOPi; /* attempt to convert to IV if possible. */
2798 /* XXX it's arguable that compiler casting to IV might be subtly
2799 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2800 else preferring IV has introduced a subtle behaviour change bug. OTOH
2801 relying on floating point to be accurate is a bug. */
2805 else if (SvIOK(TOPs)) {
2814 if (value < (NV)UV_MAX + 0.5) {
2817 SETn(Perl_floor(value));
2821 if (value > (NV)IV_MIN - 0.5) {
2824 SETn(Perl_ceil(value));
2834 dSP; dTARGET; tryAMAGICun(abs);
2836 /* This will cache the NV value if string isn't actually integer */
2841 else if (SvIOK(TOPs)) {
2842 /* IVX is precise */
2844 SETu(TOPu); /* force it to be numeric only */
2852 /* 2s complement assumption. Also, not really needed as
2853 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2873 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2879 tmps = (SvPVx(sv, len));
2881 /* If Unicode, try to downgrade
2882 * If not possible, croak. */
2883 SV* tsv = sv_2mortal(newSVsv(sv));
2886 sv_utf8_downgrade(tsv, FALSE);
2889 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2890 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2903 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2909 tmps = (SvPVx(sv, len));
2911 /* If Unicode, try to downgrade
2912 * If not possible, croak. */
2913 SV* tsv = sv_2mortal(newSVsv(sv));
2916 sv_utf8_downgrade(tsv, FALSE);
2919 while (*tmps && len && isSPACE(*tmps))
2924 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2925 else if (*tmps == 'b')
2926 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2928 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2930 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2947 SETi(sv_len_utf8(sv));
2963 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2965 I32 arybase = PL_curcop->cop_arybase;
2969 int num_args = PL_op->op_private & 7;
2970 bool repl_need_utf8_upgrade = FALSE;
2971 bool repl_is_utf8 = FALSE;
2973 SvTAINTED_off(TARG); /* decontaminate */
2974 SvUTF8_off(TARG); /* decontaminate */
2978 repl = SvPV(repl_sv, repl_len);
2979 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2989 sv_utf8_upgrade(sv);
2991 else if (DO_UTF8(sv))
2992 repl_need_utf8_upgrade = TRUE;
2994 tmps = SvPV(sv, curlen);
2996 utf8_curlen = sv_len_utf8(sv);
2997 if (utf8_curlen == curlen)
3000 curlen = utf8_curlen;
3005 if (pos >= arybase) {
3023 else if (len >= 0) {
3025 if (rem > (I32)curlen)
3040 Perl_croak(aTHX_ "substr outside of string");
3041 if (ckWARN(WARN_SUBSTR))
3042 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3049 sv_pos_u2b(sv, &pos, &rem);
3051 /* we either return a PV or an LV. If the TARG hasn't been used
3052 * before, or is of that type, reuse it; otherwise use a mortal
3053 * instead. Note that LVs can have an extended lifetime, so also
3054 * dont reuse if refcount > 1 (bug #20933) */
3055 if (SvTYPE(TARG) > SVt_NULL) {
3056 if ( (SvTYPE(TARG) == SVt_PVLV)
3057 ? (!lvalue || SvREFCNT(TARG) > 1)
3060 TARG = sv_newmortal();
3064 sv_setpvn(TARG, tmps, rem);
3065 #ifdef USE_LOCALE_COLLATE
3066 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3071 SV* repl_sv_copy = NULL;
3073 if (repl_need_utf8_upgrade) {
3074 repl_sv_copy = newSVsv(repl_sv);
3075 sv_utf8_upgrade(repl_sv_copy);
3076 repl = SvPV(repl_sv_copy, repl_len);
3077 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3079 sv_insert(sv, pos, rem, repl, repl_len);
3083 SvREFCNT_dec(repl_sv_copy);
3085 else if (lvalue) { /* it's an lvalue! */
3086 if (!SvGMAGICAL(sv)) {
3090 if (ckWARN(WARN_SUBSTR))
3091 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3092 "Attempt to use reference as lvalue in substr");
3094 if (SvOK(sv)) /* is it defined ? */
3095 (void)SvPOK_only_UTF8(sv);
3097 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3100 if (SvTYPE(TARG) < SVt_PVLV) {
3101 sv_upgrade(TARG, SVt_PVLV);
3102 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3105 (void)SvOK_off(TARG);
3108 if (LvTARG(TARG) != sv) {
3110 SvREFCNT_dec(LvTARG(TARG));
3111 LvTARG(TARG) = SvREFCNT_inc(sv);
3113 LvTARGOFF(TARG) = upos;
3114 LvTARGLEN(TARG) = urem;
3118 PUSHs(TARG); /* avoid SvSETMAGIC here */
3125 register IV size = POPi;
3126 register IV offset = POPi;
3127 register SV *src = POPs;
3128 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3130 SvTAINTED_off(TARG); /* decontaminate */
3131 if (lvalue) { /* it's an lvalue! */
3132 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3133 TARG = sv_newmortal();
3134 if (SvTYPE(TARG) < SVt_PVLV) {
3135 sv_upgrade(TARG, SVt_PVLV);
3136 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3139 if (LvTARG(TARG) != src) {
3141 SvREFCNT_dec(LvTARG(TARG));
3142 LvTARG(TARG) = SvREFCNT_inc(src);
3144 LvTARGOFF(TARG) = offset;
3145 LvTARGLEN(TARG) = size;
3148 sv_setuv(TARG, do_vecget(src, offset, size));
3163 I32 arybase = PL_curcop->cop_arybase;
3168 offset = POPi - arybase;
3171 tmps = SvPV(big, biglen);
3172 if (offset > 0 && DO_UTF8(big))
3173 sv_pos_u2b(big, &offset, 0);
3176 else if (offset > (I32)biglen)
3178 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3179 (unsigned char*)tmps + biglen, little, 0)))
3182 retval = tmps2 - tmps;
3183 if (retval > 0 && DO_UTF8(big))
3184 sv_pos_b2u(big, &retval);
3185 PUSHi(retval + arybase);
3200 I32 arybase = PL_curcop->cop_arybase;
3206 tmps2 = SvPV(little, llen);
3207 tmps = SvPV(big, blen);
3211 if (offset > 0 && DO_UTF8(big))
3212 sv_pos_u2b(big, &offset, 0);
3213 offset = offset - arybase + llen;
3217 else if (offset > (I32)blen)
3219 if (!(tmps2 = rninstr(tmps, tmps + offset,
3220 tmps2, tmps2 + llen)))
3223 retval = tmps2 - tmps;
3224 if (retval > 0 && DO_UTF8(big))
3225 sv_pos_b2u(big, &retval);
3226 PUSHi(retval + arybase);
3232 dSP; dMARK; dORIGMARK; dTARGET;
3233 do_sprintf(TARG, SP-MARK, MARK+1);
3234 TAINT_IF(SvTAINTED(TARG));
3235 if (DO_UTF8(*(MARK+1)))
3247 U8 *s = (U8*)SvPVx(argsv, len);
3250 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3251 tmpsv = sv_2mortal(newSVsv(argsv));
3252 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3256 XPUSHu(DO_UTF8(argsv) ?
3257 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3269 (void)SvUPGRADE(TARG,SVt_PV);
3271 if (value > 255 && !IN_BYTES) {
3272 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3273 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3274 SvCUR_set(TARG, tmps - SvPVX(TARG));
3276 (void)SvPOK_only(TARG);
3285 *tmps++ = (char)value;
3287 (void)SvPOK_only(TARG);
3288 if (PL_encoding && !IN_BYTES) {
3289 sv_recode_to_utf8(TARG, PL_encoding);
3291 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3292 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3296 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3297 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3313 char *tmps = SvPV(left, len);
3315 if (DO_UTF8(left)) {
3316 /* If Unicode, try to downgrade.
3317 * If not possible, croak.
3318 * Yes, we made this up. */
3319 SV* tsv = sv_2mortal(newSVsv(left));
3322 sv_utf8_downgrade(tsv, FALSE);
3325 # ifdef USE_ITHREADS
3327 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3328 /* This should be threadsafe because in ithreads there is only
3329 * one thread per interpreter. If this would not be true,
3330 * we would need a mutex to protect this malloc. */
3331 PL_reentrant_buffer->_crypt_struct_buffer =
3332 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3333 #if defined(__GLIBC__) || defined(__EMX__)
3334 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3335 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3336 /* work around glibc-2.2.5 bug */
3337 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3341 # endif /* HAS_CRYPT_R */
3342 # endif /* USE_ITHREADS */
3344 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3346 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3352 "The crypt() function is unimplemented due to excessive paranoia.");
3365 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3366 UTF8_IS_START(*s)) {
3367 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3371 utf8_to_uvchr(s, &ulen);
3372 toTITLE_utf8(s, tmpbuf, &tculen);
3373 utf8_to_uvchr(tmpbuf, 0);
3375 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3377 /* slen is the byte length of the whole SV.
3378 * ulen is the byte length of the original Unicode character
3379 * stored as UTF-8 at s.
3380 * tculen is the byte length of the freshly titlecased
3381 * Unicode character stored as UTF-8 at tmpbuf.
3382 * We first set the result to be the titlecased character,
3383 * and then append the rest of the SV data. */
3384 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3386 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3391 s = (U8*)SvPV_force_nomg(sv, slen);
3392 Copy(tmpbuf, s, tculen, U8);
3396 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3398 SvUTF8_off(TARG); /* decontaminate */
3399 sv_setsv_nomg(TARG, sv);
3403 s = (U8*)SvPV_force_nomg(sv, slen);
3405 if (IN_LOCALE_RUNTIME) {
3408 *s = toUPPER_LC(*s);
3427 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3428 UTF8_IS_START(*s)) {
3430 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3434 toLOWER_utf8(s, tmpbuf, &ulen);
3435 uv = utf8_to_uvchr(tmpbuf, 0);
3436 tend = uvchr_to_utf8(tmpbuf, uv);
3438 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3440 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3442 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3447 s = (U8*)SvPV_force_nomg(sv, slen);
3448 Copy(tmpbuf, s, ulen, U8);
3452 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3454 SvUTF8_off(TARG); /* decontaminate */
3455 sv_setsv_nomg(TARG, sv);
3459 s = (U8*)SvPV_force_nomg(sv, slen);
3461 if (IN_LOCALE_RUNTIME) {
3464 *s = toLOWER_LC(*s);
3487 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3489 s = (U8*)SvPV_nomg(sv,len);
3491 SvUTF8_off(TARG); /* decontaminate */
3492 sv_setpvn(TARG, "", 0);
3496 STRLEN nchar = utf8_length(s, s + len);
3498 (void)SvUPGRADE(TARG, SVt_PV);
3499 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3500 (void)SvPOK_only(TARG);
3501 d = (U8*)SvPVX(TARG);
3504 toUPPER_utf8(s, tmpbuf, &ulen);
3505 Copy(tmpbuf, d, ulen, U8);
3511 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3516 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3518 SvUTF8_off(TARG); /* decontaminate */
3519 sv_setsv_nomg(TARG, sv);
3523 s = (U8*)SvPV_force_nomg(sv, len);
3525 register U8 *send = s + len;
3527 if (IN_LOCALE_RUNTIME) {
3530 for (; s < send; s++)
3531 *s = toUPPER_LC(*s);
3534 for (; s < send; s++)
3556 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3558 s = (U8*)SvPV_nomg(sv,len);
3560 SvUTF8_off(TARG); /* decontaminate */
3561 sv_setpvn(TARG, "", 0);
3565 STRLEN nchar = utf8_length(s, s + len);
3567 (void)SvUPGRADE(TARG, SVt_PV);
3568 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3569 (void)SvPOK_only(TARG);
3570 d = (U8*)SvPVX(TARG);
3573 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3574 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3575 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3577 * Now if the sigma is NOT followed by
3578 * /$ignorable_sequence$cased_letter/;
3579 * and it IS preceded by
3580 * /$cased_letter$ignorable_sequence/;
3581 * where $ignorable_sequence is
3582 * [\x{2010}\x{AD}\p{Mn}]*
3583 * and $cased_letter is
3584 * [\p{Ll}\p{Lo}\p{Lt}]
3585 * then it should be mapped to 0x03C2,
3586 * (GREEK SMALL LETTER FINAL SIGMA),
3587 * instead of staying 0x03A3.
3588 * See lib/unicore/SpecCase.txt.
3591 Copy(tmpbuf, d, ulen, U8);
3597 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3602 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3604 SvUTF8_off(TARG); /* decontaminate */
3605 sv_setsv_nomg(TARG, sv);
3610 s = (U8*)SvPV_force_nomg(sv, len);
3612 register U8 *send = s + len;
3614 if (IN_LOCALE_RUNTIME) {
3617 for (; s < send; s++)
3618 *s = toLOWER_LC(*s);
3621 for (; s < send; s++)
3635 register char *s = SvPV(sv,len);
3638 SvUTF8_off(TARG); /* decontaminate */
3640 (void)SvUPGRADE(TARG, SVt_PV);
3641 SvGROW(TARG, (len * 2) + 1);
3645 if (UTF8_IS_CONTINUED(*s)) {
3646 STRLEN ulen = UTF8SKIP(s);
3670 SvCUR_set(TARG, d - SvPVX(TARG));
3671 (void)SvPOK_only_UTF8(TARG);
3674 sv_setpvn(TARG, s, len);
3676 if (SvSMAGICAL(TARG))
3685 dSP; dMARK; dORIGMARK;
3687 register AV* av = (AV*)POPs;
3688 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3689 I32 arybase = PL_curcop->cop_arybase;
3692 if (SvTYPE(av) == SVt_PVAV) {
3693 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3695 for (svp = MARK + 1; svp <= SP; svp++) {
3700 if (max > AvMAX(av))
3703 while (++MARK <= SP) {
3704 elem = SvIVx(*MARK);
3708 svp = av_fetch(av, elem, lval);
3710 if (!svp || *svp == &PL_sv_undef)
3711 DIE(aTHX_ PL_no_aelem, elem);
3712 if (PL_op->op_private & OPpLVAL_INTRO)
3713 save_aelem(av, elem, svp);
3715 *MARK = svp ? *svp : &PL_sv_undef;
3718 if (GIMME != G_ARRAY) {
3726 /* Associative arrays. */
3731 HV *hash = (HV*)POPs;
3733 I32 gimme = GIMME_V;
3736 /* might clobber stack_sp */
3737 entry = hv_iternext(hash);
3742 SV* sv = hv_iterkeysv(entry);
3743 PUSHs(sv); /* won't clobber stack_sp */
3744 if (gimme == G_ARRAY) {
3747 /* might clobber stack_sp */
3748 val = hv_iterval(hash, entry);
3753 else if (gimme == G_SCALAR)
3772 I32 gimme = GIMME_V;
3773 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3777 if (PL_op->op_private & OPpSLICE) {
3781 hvtype = SvTYPE(hv);
3782 if (hvtype == SVt_PVHV) { /* hash element */
3783 while (++MARK <= SP) {
3784 sv = hv_delete_ent(hv, *MARK, discard, 0);
3785 *MARK = sv ? sv : &PL_sv_undef;
3788 else if (hvtype == SVt_PVAV) { /* array element */
3789 if (PL_op->op_flags & OPf_SPECIAL) {
3790 while (++MARK <= SP) {
3791 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3792 *MARK = sv ? sv : &PL_sv_undef;
3797 DIE(aTHX_ "Not a HASH reference");
3800 else if (gimme == G_SCALAR) {
3805 *++MARK = &PL_sv_undef;
3812 if (SvTYPE(hv) == SVt_PVHV)
3813 sv = hv_delete_ent(hv, keysv, discard, 0);
3814 else if (SvTYPE(hv) == SVt_PVAV) {
3815 if (PL_op->op_flags & OPf_SPECIAL)
3816 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3818 DIE(aTHX_ "panic: avhv_delete no longer supported");
3821 DIE(aTHX_ "Not a HASH reference");
3836 if (PL_op->op_private & OPpEXISTS_SUB) {
3840 cv = sv_2cv(sv, &hv, &gv, FALSE);
3843 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3849 if (SvTYPE(hv) == SVt_PVHV) {
3850 if (hv_exists_ent(hv, tmpsv, 0))
3853 else if (SvTYPE(hv) == SVt_PVAV) {
3854 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3855 if (av_exists((AV*)hv, SvIV(tmpsv)))
3860 DIE(aTHX_ "Not a HASH reference");
3867 dSP; dMARK; dORIGMARK;
3868 register HV *hv = (HV*)POPs;
3869 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3870 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3871 bool other_magic = FALSE;
3877 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3878 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3879 /* Try to preserve the existenceness of a tied hash
3880 * element by using EXISTS and DELETE if possible.
3881 * Fallback to FETCH and STORE otherwise */
3882 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3883 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3884 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3887 while (++MARK <= SP) {
3891 bool preeminent = FALSE;
3894 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3895 hv_exists_ent(hv, keysv, 0);
3898 he = hv_fetch_ent(hv, keysv, lval, 0);
3899 svp = he ? &HeVAL(he) : 0;
3902 if (!svp || *svp == &PL_sv_undef) {
3904 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3908 save_helem(hv, keysv, svp);
3911 char *key = SvPV(keysv, keylen);
3912 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3916 *MARK = svp ? *svp : &PL_sv_undef;
3918 if (GIMME != G_ARRAY) {
3926 /* List operators. */
3931 if (GIMME != G_ARRAY) {
3933 *MARK = *SP; /* unwanted list, return last item */
3935 *MARK = &PL_sv_undef;
3944 SV **lastrelem = PL_stack_sp;
3945 SV **lastlelem = PL_stack_base + POPMARK;
3946 SV **firstlelem = PL_stack_base + POPMARK + 1;
3947 register SV **firstrelem = lastlelem + 1;
3948 I32 arybase = PL_curcop->cop_arybase;
3949 I32 lval = PL_op->op_flags & OPf_MOD;
3950 I32 is_something_there = lval;
3952 register I32 max = lastrelem - lastlelem;
3953 register SV **lelem;
3956 if (GIMME != G_ARRAY) {
3957 ix = SvIVx(*lastlelem);
3962 if (ix < 0 || ix >= max)
3963 *firstlelem = &PL_sv_undef;
3965 *firstlelem = firstrelem[ix];
3971 SP = firstlelem - 1;
3975 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3981 if (ix < 0 || ix >= max)
3982 *lelem = &PL_sv_undef;
3984 is_something_there = TRUE;
3985 if (!(*lelem = firstrelem[ix]))
3986 *lelem = &PL_sv_undef;
3989 if (is_something_there)
3992 SP = firstlelem - 1;
3998 dSP; dMARK; dORIGMARK;
3999 I32 items = SP - MARK;
4000 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4001 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4008 dSP; dMARK; dORIGMARK;
4009 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4013 SV *val = NEWSV(46, 0);
4015 sv_setsv(val, *++MARK);
4016 else if (ckWARN(WARN_MISC))
4017 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4018 (void)hv_store_ent(hv,key,val,0);
4027 dSP; dMARK; dORIGMARK;
4028 register AV *ary = (AV*)*++MARK;
4032 register I32 offset;
4033 register I32 length;
4040 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4041 *MARK-- = SvTIED_obj((SV*)ary, mg);
4045 call_method("SPLICE",GIMME_V);
4054 offset = i = SvIVx(*MARK);
4056 offset += AvFILLp(ary) + 1;
4058 offset -= PL_curcop->cop_arybase;
4060 DIE(aTHX_ PL_no_aelem, i);
4062 length = SvIVx(*MARK++);
4064 length += AvFILLp(ary) - offset + 1;
4070 length = AvMAX(ary) + 1; /* close enough to infinity */
4074 length = AvMAX(ary) + 1;
4076 if (offset > AvFILLp(ary) + 1) {
4077 if (ckWARN(WARN_MISC))
4078 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4079 offset = AvFILLp(ary) + 1;
4081 after = AvFILLp(ary) + 1 - (offset + length);
4082 if (after < 0) { /* not that much array */
4083 length += after; /* offset+length now in array */
4089 /* At this point, MARK .. SP-1 is our new LIST */
4092 diff = newlen - length;
4093 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4096 if (diff < 0) { /* shrinking the area */
4098 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4099 Copy(MARK, tmparyval, newlen, SV*);
4102 MARK = ORIGMARK + 1;
4103 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4104 MEXTEND(MARK, length);
4105 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4107 EXTEND_MORTAL(length);
4108 for (i = length, dst = MARK; i; i--) {
4109 sv_2mortal(*dst); /* free them eventualy */
4116 *MARK = AvARRAY(ary)[offset+length-1];
4119 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4120 SvREFCNT_dec(*dst++); /* free them now */
4123 AvFILLp(ary) += diff;
4125 /* pull up or down? */
4127 if (offset < after) { /* easier to pull up */
4128 if (offset) { /* esp. if nothing to pull */
4129 src = &AvARRAY(ary)[offset-1];
4130 dst = src - diff; /* diff is negative */
4131 for (i = offset; i > 0; i--) /* can't trust Copy */
4135 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4139 if (after) { /* anything to pull down? */
4140 src = AvARRAY(ary) + offset + length;
4141 dst = src + diff; /* diff is negative */
4142 Move(src, dst, after, SV*);
4144 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4145 /* avoid later double free */
4149 dst[--i] = &PL_sv_undef;
4152 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4154 *dst = NEWSV(46, 0);
4155 sv_setsv(*dst++, *src++);
4157 Safefree(tmparyval);
4160 else { /* no, expanding (or same) */
4162 New(452, tmparyval, length, SV*); /* so remember deletion */
4163 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4166 if (diff > 0) { /* expanding */
4168 /* push up or down? */
4170 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4174 Move(src, dst, offset, SV*);
4176 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4178 AvFILLp(ary) += diff;
4181 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4182 av_extend(ary, AvFILLp(ary) + diff);
4183 AvFILLp(ary) += diff;
4186 dst = AvARRAY(ary) + AvFILLp(ary);
4188 for (i = after; i; i--) {
4195 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4196 *dst = NEWSV(46, 0);
4197 sv_setsv(*dst++, *src++);
4199 MARK = ORIGMARK + 1;
4200 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4202 Copy(tmparyval, MARK, length, SV*);
4204 EXTEND_MORTAL(length);
4205 for (i = length, dst = MARK; i; i--) {
4206 sv_2mortal(*dst); /* free them eventualy */
4210 Safefree(tmparyval);
4214 else if (length--) {
4215 *MARK = tmparyval[length];
4218 while (length-- > 0)
4219 SvREFCNT_dec(tmparyval[length]);
4221 Safefree(tmparyval);
4224 *MARK = &PL_sv_undef;
4232 dSP; dMARK; dORIGMARK; dTARGET;
4233 register AV *ary = (AV*)*++MARK;
4234 register SV *sv = &PL_sv_undef;
4237 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4238 *MARK-- = SvTIED_obj((SV*)ary, mg);
4242 call_method("PUSH",G_SCALAR|G_DISCARD);
4247 /* Why no pre-extend of ary here ? */
4248 for (++MARK; MARK <= SP; MARK++) {
4251 sv_setsv(sv, *MARK);
4256 PUSHi( AvFILL(ary) + 1 );
4264 SV *sv = av_pop(av);
4266 (void)sv_2mortal(sv);
4275 SV *sv = av_shift(av);
4280 (void)sv_2mortal(sv);
4287 dSP; dMARK; dORIGMARK; dTARGET;
4288 register AV *ary = (AV*)*++MARK;
4293 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4294 *MARK-- = SvTIED_obj((SV*)ary, mg);
4298 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4303 av_unshift(ary, SP - MARK);
4306 sv_setsv(sv, *++MARK);
4307 (void)av_store(ary, i++, sv);
4311 PUSHi( AvFILL(ary) + 1 );
4321 if (GIMME == G_ARRAY) {
4328 /* safe as long as stack cannot get extended in the above */
4333 register char *down;
4339 SvUTF8_off(TARG); /* decontaminate */
4341 do_join(TARG, &PL_sv_no, MARK, SP);
4343 sv_setsv(TARG, (SP > MARK)
4345 : (padoff_du = find_rundefsvoffset(),
4346 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4347 ? DEFSV : PAD_SVl(padoff_du)));
4348 up = SvPV_force(TARG, len);
4350 if (DO_UTF8(TARG)) { /* first reverse each character */
4351 U8* s = (U8*)SvPVX(TARG);
4352 U8* send = (U8*)(s + len);
4354 if (UTF8_IS_INVARIANT(*s)) {
4359 if (!utf8_to_uvchr(s, 0))
4363 down = (char*)(s - 1);
4364 /* reverse this character */
4368 *down-- = (char)tmp;
4374 down = SvPVX(TARG) + len - 1;
4378 *down-- = (char)tmp;
4380 (void)SvPOK_only_UTF8(TARG);
4392 register IV limit = POPi; /* note, negative is forever */
4395 register char *s = SvPV(sv, len);
4396 bool do_utf8 = DO_UTF8(sv);
4397 char *strend = s + len;
4399 register REGEXP *rx;
4403 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4404 I32 maxiters = slen + 10;
4407 I32 origlimit = limit;
4410 AV *oldstack = PL_curstack;
4411 I32 gimme = GIMME_V;
4412 I32 oldsave = PL_savestack_ix;
4413 I32 make_mortal = 1;
4414 MAGIC *mg = (MAGIC *) NULL;
4417 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4422 DIE(aTHX_ "panic: pp_split");
4425 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4426 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4428 RX_MATCH_UTF8_set(rx, do_utf8);
4430 if (pm->op_pmreplroot) {
4432 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4434 ary = GvAVn((GV*)pm->op_pmreplroot);
4437 else if (gimme != G_ARRAY)
4438 ary = GvAVn(PL_defgv);
4441 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4447 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4449 XPUSHs(SvTIED_obj((SV*)ary, mg));
4455 for (i = AvFILLp(ary); i >= 0; i--)
4456 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4458 /* temporarily switch stacks */
4459 SWITCHSTACK(PL_curstack, ary);
4460 PL_curstackinfo->si_stack = ary;
4464 base = SP - PL_stack_base;
4466 if (pm->op_pmflags & PMf_SKIPWHITE) {
4467 if (pm->op_pmflags & PMf_LOCALE) {
4468 while (isSPACE_LC(*s))
4476 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4477 SAVEINT(PL_multiline);
4478 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4482 limit = maxiters + 2;
4483 if (pm->op_pmflags & PMf_WHITE) {
4486 while (m < strend &&
4487 !((pm->op_pmflags & PMf_LOCALE)
4488 ? isSPACE_LC(*m) : isSPACE(*m)))
4493 dstr = NEWSV(30, m-s);
4494 sv_setpvn(dstr, s, m-s);
4498 (void)SvUTF8_on(dstr);
4502 while (s < strend &&
4503 ((pm->op_pmflags & PMf_LOCALE)
4504 ? isSPACE_LC(*s) : isSPACE(*s)))
4508 else if (strEQ("^", rx->precomp)) {
4511 for (m = s; m < strend && *m != '\n'; m++) ;
4515 dstr = NEWSV(30, m-s);
4516 sv_setpvn(dstr, s, m-s);
4520 (void)SvUTF8_on(dstr);
4525 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4526 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4527 && (rx->reganch & ROPT_CHECK_ALL)
4528 && !(rx->reganch & ROPT_ANCH)) {
4529 int tail = (rx->reganch & RE_INTUIT_TAIL);
4530 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4533 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4535 char c = *SvPV(csv, n_a);
4538 for (m = s; m < strend && *m != c; m++) ;
4541 dstr = NEWSV(30, m-s);
4542 sv_setpvn(dstr, s, m-s);
4546 (void)SvUTF8_on(dstr);
4548 /* The rx->minlen is in characters but we want to step
4549 * s ahead by bytes. */
4551 s = (char*)utf8_hop((U8*)m, len);
4553 s = m + len; /* Fake \n at the end */
4558 while (s < strend && --limit &&
4559 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4560 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4563 dstr = NEWSV(31, m-s);
4564 sv_setpvn(dstr, s, m-s);
4568 (void)SvUTF8_on(dstr);
4570 /* The rx->minlen is in characters but we want to step
4571 * s ahead by bytes. */
4573 s = (char*)utf8_hop((U8*)m, len);
4575 s = m + len; /* Fake \n at the end */
4580 maxiters += slen * rx->nparens;
4581 while (s < strend && --limit)
4584 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4588 TAINT_IF(RX_MATCH_TAINTED(rx));
4589 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4594 strend = s + (strend - m);
4596 m = rx->startp[0] + orig;
4597 dstr = NEWSV(32, m-s);
4598 sv_setpvn(dstr, s, m-s);
4602 (void)SvUTF8_on(dstr);
4605 for (i = 1; i <= (I32)rx->nparens; i++) {
4606 s = rx->startp[i] + orig;
4607 m = rx->endp[i] + orig;
4609 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4610 parens that didn't match -- they should be set to
4611 undef, not the empty string */
4612 if (m >= orig && s >= orig) {
4613 dstr = NEWSV(33, m-s);
4614 sv_setpvn(dstr, s, m-s);
4617 dstr = &PL_sv_undef; /* undef, not "" */
4621 (void)SvUTF8_on(dstr);
4625 s = rx->endp[0] + orig;
4629 LEAVE_SCOPE(oldsave);
4630 iters = (SP - PL_stack_base) - base;
4631 if (iters > maxiters)
4632 DIE(aTHX_ "Split loop");
4634 /* keep field after final delim? */
4635 if (s < strend || (iters && origlimit)) {
4636 STRLEN l = strend - s;
4637 dstr = NEWSV(34, l);
4638 sv_setpvn(dstr, s, l);
4642 (void)SvUTF8_on(dstr);
4646 else if (!origlimit) {
4647 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4648 if (TOPs && !make_mortal)
4651 *SP-- = &PL_sv_undef;
4657 SWITCHSTACK(ary, oldstack);
4658 PL_curstackinfo->si_stack = oldstack;
4659 if (SvSMAGICAL(ary)) {
4664 if (gimme == G_ARRAY) {
4666 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4674 call_method("PUSH",G_SCALAR|G_DISCARD);
4677 if (gimme == G_ARRAY) {
4678 /* EXTEND should not be needed - we just popped them */
4680 for (i=0; i < iters; i++) {
4681 SV **svp = av_fetch(ary, i, FALSE);
4682 PUSHs((svp) ? *svp : &PL_sv_undef);
4689 if (gimme == G_ARRAY)
4704 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4705 || SvTYPE(retsv) == SVt_PVCV) {
4706 retsv = refto(retsv);
4714 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");