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. */
2812 if (value < (NV)UV_MAX + 0.5) {
2815 SETn(Perl_floor(value));
2819 if (value > (NV)IV_MIN - 0.5) {
2822 SETn(Perl_ceil(value));
2832 dSP; dTARGET; tryAMAGICun(abs);
2834 /* This will cache the NV value if string isn't actually integer */
2838 /* IVX is precise */
2840 SETu(TOPu); /* force it to be numeric only */
2848 /* 2s complement assumption. Also, not really needed as
2849 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2869 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2875 tmps = (SvPVx(sv, len));
2877 /* If Unicode, try to downgrade
2878 * If not possible, croak. */
2879 SV* tsv = sv_2mortal(newSVsv(sv));
2882 sv_utf8_downgrade(tsv, FALSE);
2885 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2886 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2899 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2905 tmps = (SvPVx(sv, len));
2907 /* If Unicode, try to downgrade
2908 * If not possible, croak. */
2909 SV* tsv = sv_2mortal(newSVsv(sv));
2912 sv_utf8_downgrade(tsv, FALSE);
2915 while (*tmps && len && isSPACE(*tmps))
2920 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2921 else if (*tmps == 'b')
2922 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2924 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2926 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2943 SETi(sv_len_utf8(sv));
2959 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2961 I32 arybase = PL_curcop->cop_arybase;
2965 int num_args = PL_op->op_private & 7;
2966 bool repl_need_utf8_upgrade = FALSE;
2967 bool repl_is_utf8 = FALSE;
2969 SvTAINTED_off(TARG); /* decontaminate */
2970 SvUTF8_off(TARG); /* decontaminate */
2974 repl = SvPV(repl_sv, repl_len);
2975 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2985 sv_utf8_upgrade(sv);
2987 else if (DO_UTF8(sv))
2988 repl_need_utf8_upgrade = TRUE;
2990 tmps = SvPV(sv, curlen);
2992 utf8_curlen = sv_len_utf8(sv);
2993 if (utf8_curlen == curlen)
2996 curlen = utf8_curlen;
3001 if (pos >= arybase) {
3019 else if (len >= 0) {
3021 if (rem > (I32)curlen)
3036 Perl_croak(aTHX_ "substr outside of string");
3037 if (ckWARN(WARN_SUBSTR))
3038 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3045 sv_pos_u2b(sv, &pos, &rem);
3047 /* we either return a PV or an LV. If the TARG hasn't been used
3048 * before, or is of that type, reuse it; otherwise use a mortal
3049 * instead. Note that LVs can have an extended lifetime, so also
3050 * dont reuse if refcount > 1 (bug #20933) */
3051 if (SvTYPE(TARG) > SVt_NULL) {
3052 if ( (SvTYPE(TARG) == SVt_PVLV)
3053 ? (!lvalue || SvREFCNT(TARG) > 1)
3056 TARG = sv_newmortal();
3060 sv_setpvn(TARG, tmps, rem);
3061 #ifdef USE_LOCALE_COLLATE
3062 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3067 SV* repl_sv_copy = NULL;
3069 if (repl_need_utf8_upgrade) {
3070 repl_sv_copy = newSVsv(repl_sv);
3071 sv_utf8_upgrade(repl_sv_copy);
3072 repl = SvPV(repl_sv_copy, repl_len);
3073 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3075 sv_insert(sv, pos, rem, repl, repl_len);
3079 SvREFCNT_dec(repl_sv_copy);
3081 else if (lvalue) { /* it's an lvalue! */
3082 if (!SvGMAGICAL(sv)) {
3086 if (ckWARN(WARN_SUBSTR))
3087 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3088 "Attempt to use reference as lvalue in substr");
3090 if (SvOK(sv)) /* is it defined ? */
3091 (void)SvPOK_only_UTF8(sv);
3093 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3096 if (SvTYPE(TARG) < SVt_PVLV) {
3097 sv_upgrade(TARG, SVt_PVLV);
3098 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3101 (void)SvOK_off(TARG);
3104 if (LvTARG(TARG) != sv) {
3106 SvREFCNT_dec(LvTARG(TARG));
3107 LvTARG(TARG) = SvREFCNT_inc(sv);
3109 LvTARGOFF(TARG) = upos;
3110 LvTARGLEN(TARG) = urem;
3114 PUSHs(TARG); /* avoid SvSETMAGIC here */
3121 register IV size = POPi;
3122 register IV offset = POPi;
3123 register SV *src = POPs;
3124 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3126 SvTAINTED_off(TARG); /* decontaminate */
3127 if (lvalue) { /* it's an lvalue! */
3128 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3129 TARG = sv_newmortal();
3130 if (SvTYPE(TARG) < SVt_PVLV) {
3131 sv_upgrade(TARG, SVt_PVLV);
3132 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3135 if (LvTARG(TARG) != src) {
3137 SvREFCNT_dec(LvTARG(TARG));
3138 LvTARG(TARG) = SvREFCNT_inc(src);
3140 LvTARGOFF(TARG) = offset;
3141 LvTARGLEN(TARG) = size;
3144 sv_setuv(TARG, do_vecget(src, offset, size));
3159 I32 arybase = PL_curcop->cop_arybase;
3164 offset = POPi - arybase;
3167 tmps = SvPV(big, biglen);
3168 if (offset > 0 && DO_UTF8(big))
3169 sv_pos_u2b(big, &offset, 0);
3172 else if (offset > (I32)biglen)
3174 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3175 (unsigned char*)tmps + biglen, little, 0)))
3178 retval = tmps2 - tmps;
3179 if (retval > 0 && DO_UTF8(big))
3180 sv_pos_b2u(big, &retval);
3181 PUSHi(retval + arybase);
3196 I32 arybase = PL_curcop->cop_arybase;
3202 tmps2 = SvPV(little, llen);
3203 tmps = SvPV(big, blen);
3207 if (offset > 0 && DO_UTF8(big))
3208 sv_pos_u2b(big, &offset, 0);
3209 offset = offset - arybase + llen;
3213 else if (offset > (I32)blen)
3215 if (!(tmps2 = rninstr(tmps, tmps + offset,
3216 tmps2, tmps2 + llen)))
3219 retval = tmps2 - tmps;
3220 if (retval > 0 && DO_UTF8(big))
3221 sv_pos_b2u(big, &retval);
3222 PUSHi(retval + arybase);
3228 dSP; dMARK; dORIGMARK; dTARGET;
3229 do_sprintf(TARG, SP-MARK, MARK+1);
3230 TAINT_IF(SvTAINTED(TARG));
3231 if (DO_UTF8(*(MARK+1)))
3243 U8 *s = (U8*)SvPVx(argsv, len);
3246 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3247 tmpsv = sv_2mortal(newSVsv(argsv));
3248 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3252 XPUSHu(DO_UTF8(argsv) ?
3253 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3265 (void)SvUPGRADE(TARG,SVt_PV);
3267 if (value > 255 && !IN_BYTES) {
3268 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3269 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3270 SvCUR_set(TARG, tmps - SvPVX(TARG));
3272 (void)SvPOK_only(TARG);
3281 *tmps++ = (char)value;
3283 (void)SvPOK_only(TARG);
3284 if (PL_encoding && !IN_BYTES) {
3285 sv_recode_to_utf8(TARG, PL_encoding);
3287 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3288 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3292 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3293 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3309 char *tmps = SvPV(left, len);
3311 if (DO_UTF8(left)) {
3312 /* If Unicode, try to downgrade.
3313 * If not possible, croak.
3314 * Yes, we made this up. */
3315 SV* tsv = sv_2mortal(newSVsv(left));
3318 sv_utf8_downgrade(tsv, FALSE);
3321 # ifdef USE_ITHREADS
3323 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3324 /* This should be threadsafe because in ithreads there is only
3325 * one thread per interpreter. If this would not be true,
3326 * we would need a mutex to protect this malloc. */
3327 PL_reentrant_buffer->_crypt_struct_buffer =
3328 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3329 #if defined(__GLIBC__) || defined(__EMX__)
3330 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3331 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3332 /* work around glibc-2.2.5 bug */
3333 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3337 # endif /* HAS_CRYPT_R */
3338 # endif /* USE_ITHREADS */
3340 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3342 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3348 "The crypt() function is unimplemented due to excessive paranoia.");
3361 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3362 UTF8_IS_START(*s)) {
3363 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3367 utf8_to_uvchr(s, &ulen);
3368 toTITLE_utf8(s, tmpbuf, &tculen);
3369 utf8_to_uvchr(tmpbuf, 0);
3371 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3373 /* slen is the byte length of the whole SV.
3374 * ulen is the byte length of the original Unicode character
3375 * stored as UTF-8 at s.
3376 * tculen is the byte length of the freshly titlecased
3377 * Unicode character stored as UTF-8 at tmpbuf.
3378 * We first set the result to be the titlecased character,
3379 * and then append the rest of the SV data. */
3380 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3382 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3387 s = (U8*)SvPV_force_nomg(sv, slen);
3388 Copy(tmpbuf, s, tculen, U8);
3392 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3394 SvUTF8_off(TARG); /* decontaminate */
3395 sv_setsv_nomg(TARG, sv);
3399 s = (U8*)SvPV_force_nomg(sv, slen);
3401 if (IN_LOCALE_RUNTIME) {
3404 *s = toUPPER_LC(*s);
3423 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3424 UTF8_IS_START(*s)) {
3426 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3430 toLOWER_utf8(s, tmpbuf, &ulen);
3431 uv = utf8_to_uvchr(tmpbuf, 0);
3432 tend = uvchr_to_utf8(tmpbuf, uv);
3434 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3436 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3438 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3443 s = (U8*)SvPV_force_nomg(sv, slen);
3444 Copy(tmpbuf, s, ulen, U8);
3448 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3450 SvUTF8_off(TARG); /* decontaminate */
3451 sv_setsv_nomg(TARG, sv);
3455 s = (U8*)SvPV_force_nomg(sv, slen);
3457 if (IN_LOCALE_RUNTIME) {
3460 *s = toLOWER_LC(*s);
3483 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3485 s = (U8*)SvPV_nomg(sv,len);
3487 SvUTF8_off(TARG); /* decontaminate */
3488 sv_setpvn(TARG, "", 0);
3492 STRLEN nchar = utf8_length(s, s + len);
3494 (void)SvUPGRADE(TARG, SVt_PV);
3495 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3496 (void)SvPOK_only(TARG);
3497 d = (U8*)SvPVX(TARG);
3500 toUPPER_utf8(s, tmpbuf, &ulen);
3501 Copy(tmpbuf, d, ulen, U8);
3507 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3512 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3514 SvUTF8_off(TARG); /* decontaminate */
3515 sv_setsv_nomg(TARG, sv);
3519 s = (U8*)SvPV_force_nomg(sv, len);
3521 register U8 *send = s + len;
3523 if (IN_LOCALE_RUNTIME) {
3526 for (; s < send; s++)
3527 *s = toUPPER_LC(*s);
3530 for (; s < send; s++)
3552 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3554 s = (U8*)SvPV_nomg(sv,len);
3556 SvUTF8_off(TARG); /* decontaminate */
3557 sv_setpvn(TARG, "", 0);
3561 STRLEN nchar = utf8_length(s, s + len);
3563 (void)SvUPGRADE(TARG, SVt_PV);
3564 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3565 (void)SvPOK_only(TARG);
3566 d = (U8*)SvPVX(TARG);
3569 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3570 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3571 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3573 * Now if the sigma is NOT followed by
3574 * /$ignorable_sequence$cased_letter/;
3575 * and it IS preceded by
3576 * /$cased_letter$ignorable_sequence/;
3577 * where $ignorable_sequence is
3578 * [\x{2010}\x{AD}\p{Mn}]*
3579 * and $cased_letter is
3580 * [\p{Ll}\p{Lo}\p{Lt}]
3581 * then it should be mapped to 0x03C2,
3582 * (GREEK SMALL LETTER FINAL SIGMA),
3583 * instead of staying 0x03A3.
3584 * See lib/unicore/SpecCase.txt.
3587 Copy(tmpbuf, d, ulen, U8);
3593 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3598 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3600 SvUTF8_off(TARG); /* decontaminate */
3601 sv_setsv_nomg(TARG, sv);
3606 s = (U8*)SvPV_force_nomg(sv, len);
3608 register U8 *send = s + len;
3610 if (IN_LOCALE_RUNTIME) {
3613 for (; s < send; s++)
3614 *s = toLOWER_LC(*s);
3617 for (; s < send; s++)
3631 register char *s = SvPV(sv,len);
3634 SvUTF8_off(TARG); /* decontaminate */
3636 (void)SvUPGRADE(TARG, SVt_PV);
3637 SvGROW(TARG, (len * 2) + 1);
3641 if (UTF8_IS_CONTINUED(*s)) {
3642 STRLEN ulen = UTF8SKIP(s);
3666 SvCUR_set(TARG, d - SvPVX(TARG));
3667 (void)SvPOK_only_UTF8(TARG);
3670 sv_setpvn(TARG, s, len);
3672 if (SvSMAGICAL(TARG))
3681 dSP; dMARK; dORIGMARK;
3683 register AV* av = (AV*)POPs;
3684 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3685 I32 arybase = PL_curcop->cop_arybase;
3688 if (SvTYPE(av) == SVt_PVAV) {
3689 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3691 for (svp = MARK + 1; svp <= SP; svp++) {
3696 if (max > AvMAX(av))
3699 while (++MARK <= SP) {
3700 elem = SvIVx(*MARK);
3704 svp = av_fetch(av, elem, lval);
3706 if (!svp || *svp == &PL_sv_undef)
3707 DIE(aTHX_ PL_no_aelem, elem);
3708 if (PL_op->op_private & OPpLVAL_INTRO)
3709 save_aelem(av, elem, svp);
3711 *MARK = svp ? *svp : &PL_sv_undef;
3714 if (GIMME != G_ARRAY) {
3722 /* Associative arrays. */
3727 HV *hash = (HV*)POPs;
3729 I32 gimme = GIMME_V;
3732 /* might clobber stack_sp */
3733 entry = hv_iternext(hash);
3738 SV* sv = hv_iterkeysv(entry);
3739 PUSHs(sv); /* won't clobber stack_sp */
3740 if (gimme == G_ARRAY) {
3743 /* might clobber stack_sp */
3744 val = hv_iterval(hash, entry);
3749 else if (gimme == G_SCALAR)
3768 I32 gimme = GIMME_V;
3769 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3773 if (PL_op->op_private & OPpSLICE) {
3777 hvtype = SvTYPE(hv);
3778 if (hvtype == SVt_PVHV) { /* hash element */
3779 while (++MARK <= SP) {
3780 sv = hv_delete_ent(hv, *MARK, discard, 0);
3781 *MARK = sv ? sv : &PL_sv_undef;
3784 else if (hvtype == SVt_PVAV) { /* array element */
3785 if (PL_op->op_flags & OPf_SPECIAL) {
3786 while (++MARK <= SP) {
3787 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3788 *MARK = sv ? sv : &PL_sv_undef;
3793 DIE(aTHX_ "Not a HASH reference");
3796 else if (gimme == G_SCALAR) {
3801 *++MARK = &PL_sv_undef;
3808 if (SvTYPE(hv) == SVt_PVHV)
3809 sv = hv_delete_ent(hv, keysv, discard, 0);
3810 else if (SvTYPE(hv) == SVt_PVAV) {
3811 if (PL_op->op_flags & OPf_SPECIAL)
3812 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3814 DIE(aTHX_ "panic: avhv_delete no longer supported");
3817 DIE(aTHX_ "Not a HASH reference");
3832 if (PL_op->op_private & OPpEXISTS_SUB) {
3836 cv = sv_2cv(sv, &hv, &gv, FALSE);
3839 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3845 if (SvTYPE(hv) == SVt_PVHV) {
3846 if (hv_exists_ent(hv, tmpsv, 0))
3849 else if (SvTYPE(hv) == SVt_PVAV) {
3850 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3851 if (av_exists((AV*)hv, SvIV(tmpsv)))
3856 DIE(aTHX_ "Not a HASH reference");
3863 dSP; dMARK; dORIGMARK;
3864 register HV *hv = (HV*)POPs;
3865 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3866 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3867 bool other_magic = FALSE;
3873 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3874 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3875 /* Try to preserve the existenceness of a tied hash
3876 * element by using EXISTS and DELETE if possible.
3877 * Fallback to FETCH and STORE otherwise */
3878 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3879 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3880 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3883 while (++MARK <= SP) {
3887 bool preeminent = FALSE;
3890 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3891 hv_exists_ent(hv, keysv, 0);
3894 he = hv_fetch_ent(hv, keysv, lval, 0);
3895 svp = he ? &HeVAL(he) : 0;
3898 if (!svp || *svp == &PL_sv_undef) {
3900 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3904 save_helem(hv, keysv, svp);
3907 char *key = SvPV(keysv, keylen);
3908 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3912 *MARK = svp ? *svp : &PL_sv_undef;
3914 if (GIMME != G_ARRAY) {
3922 /* List operators. */
3927 if (GIMME != G_ARRAY) {
3929 *MARK = *SP; /* unwanted list, return last item */
3931 *MARK = &PL_sv_undef;
3940 SV **lastrelem = PL_stack_sp;
3941 SV **lastlelem = PL_stack_base + POPMARK;
3942 SV **firstlelem = PL_stack_base + POPMARK + 1;
3943 register SV **firstrelem = lastlelem + 1;
3944 I32 arybase = PL_curcop->cop_arybase;
3945 I32 lval = PL_op->op_flags & OPf_MOD;
3946 I32 is_something_there = lval;
3948 register I32 max = lastrelem - lastlelem;
3949 register SV **lelem;
3952 if (GIMME != G_ARRAY) {
3953 ix = SvIVx(*lastlelem);
3958 if (ix < 0 || ix >= max)
3959 *firstlelem = &PL_sv_undef;
3961 *firstlelem = firstrelem[ix];
3967 SP = firstlelem - 1;
3971 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3977 if (ix < 0 || ix >= max)
3978 *lelem = &PL_sv_undef;
3980 is_something_there = TRUE;
3981 if (!(*lelem = firstrelem[ix]))
3982 *lelem = &PL_sv_undef;
3985 if (is_something_there)
3988 SP = firstlelem - 1;
3994 dSP; dMARK; dORIGMARK;
3995 I32 items = SP - MARK;
3996 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3997 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4004 dSP; dMARK; dORIGMARK;
4005 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4009 SV *val = NEWSV(46, 0);
4011 sv_setsv(val, *++MARK);
4012 else if (ckWARN(WARN_MISC))
4013 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4014 (void)hv_store_ent(hv,key,val,0);
4023 dSP; dMARK; dORIGMARK;
4024 register AV *ary = (AV*)*++MARK;
4028 register I32 offset;
4029 register I32 length;
4036 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4037 *MARK-- = SvTIED_obj((SV*)ary, mg);
4041 call_method("SPLICE",GIMME_V);
4050 offset = i = SvIVx(*MARK);
4052 offset += AvFILLp(ary) + 1;
4054 offset -= PL_curcop->cop_arybase;
4056 DIE(aTHX_ PL_no_aelem, i);
4058 length = SvIVx(*MARK++);
4060 length += AvFILLp(ary) - offset + 1;
4066 length = AvMAX(ary) + 1; /* close enough to infinity */
4070 length = AvMAX(ary) + 1;
4072 if (offset > AvFILLp(ary) + 1) {
4073 if (ckWARN(WARN_MISC))
4074 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4075 offset = AvFILLp(ary) + 1;
4077 after = AvFILLp(ary) + 1 - (offset + length);
4078 if (after < 0) { /* not that much array */
4079 length += after; /* offset+length now in array */
4085 /* At this point, MARK .. SP-1 is our new LIST */
4088 diff = newlen - length;
4089 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4092 if (diff < 0) { /* shrinking the area */
4094 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4095 Copy(MARK, tmparyval, newlen, SV*);
4098 MARK = ORIGMARK + 1;
4099 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4100 MEXTEND(MARK, length);
4101 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4103 EXTEND_MORTAL(length);
4104 for (i = length, dst = MARK; i; i--) {
4105 sv_2mortal(*dst); /* free them eventualy */
4112 *MARK = AvARRAY(ary)[offset+length-1];
4115 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4116 SvREFCNT_dec(*dst++); /* free them now */
4119 AvFILLp(ary) += diff;
4121 /* pull up or down? */
4123 if (offset < after) { /* easier to pull up */
4124 if (offset) { /* esp. if nothing to pull */
4125 src = &AvARRAY(ary)[offset-1];
4126 dst = src - diff; /* diff is negative */
4127 for (i = offset; i > 0; i--) /* can't trust Copy */
4131 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4135 if (after) { /* anything to pull down? */
4136 src = AvARRAY(ary) + offset + length;
4137 dst = src + diff; /* diff is negative */
4138 Move(src, dst, after, SV*);
4140 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4141 /* avoid later double free */
4145 dst[--i] = &PL_sv_undef;
4148 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4150 *dst = NEWSV(46, 0);
4151 sv_setsv(*dst++, *src++);
4153 Safefree(tmparyval);
4156 else { /* no, expanding (or same) */
4158 New(452, tmparyval, length, SV*); /* so remember deletion */
4159 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4162 if (diff > 0) { /* expanding */
4164 /* push up or down? */
4166 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4170 Move(src, dst, offset, SV*);
4172 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4174 AvFILLp(ary) += diff;
4177 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4178 av_extend(ary, AvFILLp(ary) + diff);
4179 AvFILLp(ary) += diff;
4182 dst = AvARRAY(ary) + AvFILLp(ary);
4184 for (i = after; i; i--) {
4191 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4192 *dst = NEWSV(46, 0);
4193 sv_setsv(*dst++, *src++);
4195 MARK = ORIGMARK + 1;
4196 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4198 Copy(tmparyval, MARK, length, SV*);
4200 EXTEND_MORTAL(length);
4201 for (i = length, dst = MARK; i; i--) {
4202 sv_2mortal(*dst); /* free them eventualy */
4206 Safefree(tmparyval);
4210 else if (length--) {
4211 *MARK = tmparyval[length];
4214 while (length-- > 0)
4215 SvREFCNT_dec(tmparyval[length]);
4217 Safefree(tmparyval);
4220 *MARK = &PL_sv_undef;
4228 dSP; dMARK; dORIGMARK; dTARGET;
4229 register AV *ary = (AV*)*++MARK;
4230 register SV *sv = &PL_sv_undef;
4233 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4234 *MARK-- = SvTIED_obj((SV*)ary, mg);
4238 call_method("PUSH",G_SCALAR|G_DISCARD);
4243 /* Why no pre-extend of ary here ? */
4244 for (++MARK; MARK <= SP; MARK++) {
4247 sv_setsv(sv, *MARK);
4252 PUSHi( AvFILL(ary) + 1 );
4260 SV *sv = av_pop(av);
4262 (void)sv_2mortal(sv);
4271 SV *sv = av_shift(av);
4276 (void)sv_2mortal(sv);
4283 dSP; dMARK; dORIGMARK; dTARGET;
4284 register AV *ary = (AV*)*++MARK;
4289 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4290 *MARK-- = SvTIED_obj((SV*)ary, mg);
4294 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4299 av_unshift(ary, SP - MARK);
4302 sv_setsv(sv, *++MARK);
4303 (void)av_store(ary, i++, sv);
4307 PUSHi( AvFILL(ary) + 1 );
4317 if (GIMME == G_ARRAY) {
4324 /* safe as long as stack cannot get extended in the above */
4329 register char *down;
4334 SvUTF8_off(TARG); /* decontaminate */
4336 do_join(TARG, &PL_sv_no, MARK, SP);
4338 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4339 up = SvPV_force(TARG, len);
4341 if (DO_UTF8(TARG)) { /* first reverse each character */
4342 U8* s = (U8*)SvPVX(TARG);
4343 U8* send = (U8*)(s + len);
4345 if (UTF8_IS_INVARIANT(*s)) {
4350 if (!utf8_to_uvchr(s, 0))
4354 down = (char*)(s - 1);
4355 /* reverse this character */
4359 *down-- = (char)tmp;
4365 down = SvPVX(TARG) + len - 1;
4369 *down-- = (char)tmp;
4371 (void)SvPOK_only_UTF8(TARG);
4383 register IV limit = POPi; /* note, negative is forever */
4386 register char *s = SvPV(sv, len);
4387 bool do_utf8 = DO_UTF8(sv);
4388 char *strend = s + len;
4390 register REGEXP *rx;
4394 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4395 I32 maxiters = slen + 10;
4398 I32 origlimit = limit;
4401 AV *oldstack = PL_curstack;
4402 I32 gimme = GIMME_V;
4403 I32 oldsave = PL_savestack_ix;
4404 I32 make_mortal = 1;
4405 MAGIC *mg = (MAGIC *) NULL;
4408 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4413 DIE(aTHX_ "panic: pp_split");
4416 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4417 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4419 RX_MATCH_UTF8_set(rx, do_utf8);
4421 if (pm->op_pmreplroot) {
4423 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4425 ary = GvAVn((GV*)pm->op_pmreplroot);
4428 else if (gimme != G_ARRAY)
4429 ary = GvAVn(PL_defgv);
4432 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4438 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4440 XPUSHs(SvTIED_obj((SV*)ary, mg));
4446 for (i = AvFILLp(ary); i >= 0; i--)
4447 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4449 /* temporarily switch stacks */
4450 SWITCHSTACK(PL_curstack, ary);
4451 PL_curstackinfo->si_stack = ary;
4455 base = SP - PL_stack_base;
4457 if (pm->op_pmflags & PMf_SKIPWHITE) {
4458 if (pm->op_pmflags & PMf_LOCALE) {
4459 while (isSPACE_LC(*s))
4467 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4468 SAVEINT(PL_multiline);
4469 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4473 limit = maxiters + 2;
4474 if (pm->op_pmflags & PMf_WHITE) {
4477 while (m < strend &&
4478 !((pm->op_pmflags & PMf_LOCALE)
4479 ? isSPACE_LC(*m) : isSPACE(*m)))
4484 dstr = NEWSV(30, m-s);
4485 sv_setpvn(dstr, s, m-s);
4489 (void)SvUTF8_on(dstr);
4493 while (s < strend &&
4494 ((pm->op_pmflags & PMf_LOCALE)
4495 ? isSPACE_LC(*s) : isSPACE(*s)))
4499 else if (strEQ("^", rx->precomp)) {
4502 for (m = s; m < strend && *m != '\n'; m++) ;
4506 dstr = NEWSV(30, m-s);
4507 sv_setpvn(dstr, s, m-s);
4511 (void)SvUTF8_on(dstr);
4516 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4517 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4518 && (rx->reganch & ROPT_CHECK_ALL)
4519 && !(rx->reganch & ROPT_ANCH)) {
4520 int tail = (rx->reganch & RE_INTUIT_TAIL);
4521 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4524 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4526 char c = *SvPV(csv, n_a);
4529 for (m = s; m < strend && *m != c; m++) ;
4532 dstr = NEWSV(30, m-s);
4533 sv_setpvn(dstr, s, m-s);
4537 (void)SvUTF8_on(dstr);
4539 /* The rx->minlen is in characters but we want to step
4540 * s ahead by bytes. */
4542 s = (char*)utf8_hop((U8*)m, len);
4544 s = m + len; /* Fake \n at the end */
4549 while (s < strend && --limit &&
4550 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4551 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4554 dstr = NEWSV(31, m-s);
4555 sv_setpvn(dstr, s, m-s);
4559 (void)SvUTF8_on(dstr);
4561 /* The rx->minlen is in characters but we want to step
4562 * s ahead by bytes. */
4564 s = (char*)utf8_hop((U8*)m, len);
4566 s = m + len; /* Fake \n at the end */
4571 maxiters += slen * rx->nparens;
4572 while (s < strend && --limit)
4575 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4579 TAINT_IF(RX_MATCH_TAINTED(rx));
4580 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4585 strend = s + (strend - m);
4587 m = rx->startp[0] + orig;
4588 dstr = NEWSV(32, m-s);
4589 sv_setpvn(dstr, s, m-s);
4593 (void)SvUTF8_on(dstr);
4596 for (i = 1; i <= (I32)rx->nparens; i++) {
4597 s = rx->startp[i] + orig;
4598 m = rx->endp[i] + orig;
4600 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4601 parens that didn't match -- they should be set to
4602 undef, not the empty string */
4603 if (m >= orig && s >= orig) {
4604 dstr = NEWSV(33, m-s);
4605 sv_setpvn(dstr, s, m-s);
4608 dstr = &PL_sv_undef; /* undef, not "" */
4612 (void)SvUTF8_on(dstr);
4616 s = rx->endp[0] + orig;
4620 LEAVE_SCOPE(oldsave);
4621 iters = (SP - PL_stack_base) - base;
4622 if (iters > maxiters)
4623 DIE(aTHX_ "Split loop");
4625 /* keep field after final delim? */
4626 if (s < strend || (iters && origlimit)) {
4627 STRLEN l = strend - s;
4628 dstr = NEWSV(34, l);
4629 sv_setpvn(dstr, s, l);
4633 (void)SvUTF8_on(dstr);
4637 else if (!origlimit) {
4638 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4639 if (TOPs && !make_mortal)
4642 *SP-- = &PL_sv_undef;
4648 SWITCHSTACK(ary, oldstack);
4649 PL_curstackinfo->si_stack = oldstack;
4650 if (SvSMAGICAL(ary)) {
4655 if (gimme == G_ARRAY) {
4657 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4665 call_method("PUSH",G_SCALAR|G_DISCARD);
4668 if (gimme == G_ARRAY) {
4669 /* EXTEND should not be needed - we just popped them */
4671 for (i=0; i < iters; i++) {
4672 SV **svp = av_fetch(ary, i, FALSE);
4673 PUSHs((svp) ? *svp : &PL_sv_undef);
4680 if (gimme == G_ARRAY)
4695 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4696 || SvTYPE(retsv) == SVt_PVCV) {
4697 retsv = refto(retsv);
4705 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");