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);
1402 count = IV_MAX; /* The best we can do? */
1413 else if (SvNOKp(sv)) {
1422 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1424 I32 items = SP - MARK;
1426 static const char oom_list_extend[] =
1427 "Out of memory during list extend";
1429 max = items * count;
1430 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1431 /* Did the max computation overflow? */
1432 if (items > 0 && max > 0 && (max < items || max < count))
1433 Perl_croak(aTHX_ oom_list_extend);
1438 /* This code was intended to fix 20010809.028:
1441 for (($x =~ /./g) x 2) {
1442 print chop; # "abcdabcd" expected as output.
1445 * but that change (#11635) broke this code:
1447 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1449 * I can't think of a better fix that doesn't introduce
1450 * an efficiency hit by copying the SVs. The stack isn't
1451 * refcounted, and mortalisation obviously doesn't
1452 * Do The Right Thing when the stack has more than
1453 * one pointer to the same mortal value.
1457 *SP = sv_2mortal(newSVsv(*SP));
1467 repeatcpy((char*)(MARK + items), (char*)MARK,
1468 items * sizeof(SV*), count - 1);
1471 else if (count <= 0)
1474 else { /* Note: mark already snarfed by pp_list */
1478 static const char oom_string_extend[] =
1479 "Out of memory during string extend";
1481 SvSetSV(TARG, tmpstr);
1482 SvPV_force(TARG, len);
1483 isutf = DO_UTF8(TARG);
1488 IV max = count * len;
1489 if (len > ((MEM_SIZE)~0)/count)
1490 Perl_croak(aTHX_ oom_string_extend);
1491 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1492 SvGROW(TARG, (count * len) + 1);
1493 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1494 SvCUR(TARG) *= count;
1496 *SvEND(TARG) = '\0';
1499 (void)SvPOK_only_UTF8(TARG);
1501 (void)SvPOK_only(TARG);
1503 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1504 /* The parser saw this as a list repeat, and there
1505 are probably several items on the stack. But we're
1506 in scalar context, and there's no pp_list to save us
1507 now. So drop the rest of the items -- robin@kitsite.com
1520 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1521 useleft = USE_LEFT(TOPm1s);
1522 #ifdef PERL_PRESERVE_IVUV
1523 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1524 "bad things" happen if you rely on signed integers wrapping. */
1527 /* Unless the left argument is integer in range we are going to have to
1528 use NV maths. Hence only attempt to coerce the right argument if
1529 we know the left is integer. */
1530 register UV auv = 0;
1536 a_valid = auvok = 1;
1537 /* left operand is undef, treat as zero. */
1539 /* Left operand is defined, so is it IV? */
1540 SvIV_please(TOPm1s);
1541 if (SvIOK(TOPm1s)) {
1542 if ((auvok = SvUOK(TOPm1s)))
1543 auv = SvUVX(TOPm1s);
1545 register IV aiv = SvIVX(TOPm1s);
1548 auvok = 1; /* Now acting as a sign flag. */
1549 } else { /* 2s complement assumption for IV_MIN */
1557 bool result_good = 0;
1560 bool buvok = SvUOK(TOPs);
1565 register IV biv = SvIVX(TOPs);
1572 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1573 else "IV" now, independent of how it came in.
1574 if a, b represents positive, A, B negative, a maps to -A etc
1579 all UV maths. negate result if A negative.
1580 subtract if signs same, add if signs differ. */
1582 if (auvok ^ buvok) {
1591 /* Must get smaller */
1596 if (result <= buv) {
1597 /* result really should be -(auv-buv). as its negation
1598 of true value, need to swap our result flag */
1610 if (result <= (UV)IV_MIN)
1611 SETi( -(IV)result );
1613 /* result valid, but out of range for IV. */
1614 SETn( -(NV)result );
1618 } /* Overflow, drop through to NVs. */
1622 useleft = USE_LEFT(TOPm1s);
1626 /* left operand is undef, treat as zero - value */
1630 SETn( TOPn - value );
1637 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1640 if (PL_op->op_private & HINT_INTEGER) {
1654 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1657 if (PL_op->op_private & HINT_INTEGER) {
1671 dSP; tryAMAGICbinSET(lt,0);
1672 #ifdef PERL_PRESERVE_IVUV
1675 SvIV_please(TOPm1s);
1676 if (SvIOK(TOPm1s)) {
1677 bool auvok = SvUOK(TOPm1s);
1678 bool buvok = SvUOK(TOPs);
1680 if (!auvok && !buvok) { /* ## IV < IV ## */
1681 IV aiv = SvIVX(TOPm1s);
1682 IV biv = SvIVX(TOPs);
1685 SETs(boolSV(aiv < biv));
1688 if (auvok && buvok) { /* ## UV < UV ## */
1689 UV auv = SvUVX(TOPm1s);
1690 UV buv = SvUVX(TOPs);
1693 SETs(boolSV(auv < buv));
1696 if (auvok) { /* ## UV < IV ## */
1703 /* As (a) is a UV, it's >=0, so it cannot be < */
1708 SETs(boolSV(auv < (UV)biv));
1711 { /* ## IV < UV ## */
1715 aiv = SvIVX(TOPm1s);
1717 /* As (b) is a UV, it's >=0, so it must be < */
1724 SETs(boolSV((UV)aiv < buv));
1730 #ifndef NV_PRESERVES_UV
1731 #ifdef PERL_PRESERVE_IVUV
1734 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1736 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1742 SETs(boolSV(TOPn < value));
1749 dSP; tryAMAGICbinSET(gt,0);
1750 #ifdef PERL_PRESERVE_IVUV
1753 SvIV_please(TOPm1s);
1754 if (SvIOK(TOPm1s)) {
1755 bool auvok = SvUOK(TOPm1s);
1756 bool buvok = SvUOK(TOPs);
1758 if (!auvok && !buvok) { /* ## IV > IV ## */
1759 IV aiv = SvIVX(TOPm1s);
1760 IV biv = SvIVX(TOPs);
1763 SETs(boolSV(aiv > biv));
1766 if (auvok && buvok) { /* ## UV > UV ## */
1767 UV auv = SvUVX(TOPm1s);
1768 UV buv = SvUVX(TOPs);
1771 SETs(boolSV(auv > buv));
1774 if (auvok) { /* ## UV > IV ## */
1781 /* As (a) is a UV, it's >=0, so it must be > */
1786 SETs(boolSV(auv > (UV)biv));
1789 { /* ## IV > UV ## */
1793 aiv = SvIVX(TOPm1s);
1795 /* As (b) is a UV, it's >=0, so it cannot be > */
1802 SETs(boolSV((UV)aiv > buv));
1808 #ifndef NV_PRESERVES_UV
1809 #ifdef PERL_PRESERVE_IVUV
1812 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1814 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1820 SETs(boolSV(TOPn > value));
1827 dSP; tryAMAGICbinSET(le,0);
1828 #ifdef PERL_PRESERVE_IVUV
1831 SvIV_please(TOPm1s);
1832 if (SvIOK(TOPm1s)) {
1833 bool auvok = SvUOK(TOPm1s);
1834 bool buvok = SvUOK(TOPs);
1836 if (!auvok && !buvok) { /* ## IV <= IV ## */
1837 IV aiv = SvIVX(TOPm1s);
1838 IV biv = SvIVX(TOPs);
1841 SETs(boolSV(aiv <= biv));
1844 if (auvok && buvok) { /* ## UV <= UV ## */
1845 UV auv = SvUVX(TOPm1s);
1846 UV buv = SvUVX(TOPs);
1849 SETs(boolSV(auv <= buv));
1852 if (auvok) { /* ## UV <= IV ## */
1859 /* As (a) is a UV, it's >=0, so a cannot be <= */
1864 SETs(boolSV(auv <= (UV)biv));
1867 { /* ## IV <= UV ## */
1871 aiv = SvIVX(TOPm1s);
1873 /* As (b) is a UV, it's >=0, so a must be <= */
1880 SETs(boolSV((UV)aiv <= buv));
1886 #ifndef NV_PRESERVES_UV
1887 #ifdef PERL_PRESERVE_IVUV
1890 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1892 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1898 SETs(boolSV(TOPn <= value));
1905 dSP; tryAMAGICbinSET(ge,0);
1906 #ifdef PERL_PRESERVE_IVUV
1909 SvIV_please(TOPm1s);
1910 if (SvIOK(TOPm1s)) {
1911 bool auvok = SvUOK(TOPm1s);
1912 bool buvok = SvUOK(TOPs);
1914 if (!auvok && !buvok) { /* ## IV >= IV ## */
1915 IV aiv = SvIVX(TOPm1s);
1916 IV biv = SvIVX(TOPs);
1919 SETs(boolSV(aiv >= biv));
1922 if (auvok && buvok) { /* ## UV >= UV ## */
1923 UV auv = SvUVX(TOPm1s);
1924 UV buv = SvUVX(TOPs);
1927 SETs(boolSV(auv >= buv));
1930 if (auvok) { /* ## UV >= IV ## */
1937 /* As (a) is a UV, it's >=0, so it must be >= */
1942 SETs(boolSV(auv >= (UV)biv));
1945 { /* ## IV >= UV ## */
1949 aiv = SvIVX(TOPm1s);
1951 /* As (b) is a UV, it's >=0, so a cannot be >= */
1958 SETs(boolSV((UV)aiv >= buv));
1964 #ifndef NV_PRESERVES_UV
1965 #ifdef PERL_PRESERVE_IVUV
1968 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1970 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1976 SETs(boolSV(TOPn >= value));
1983 dSP; tryAMAGICbinSET(ne,0);
1984 #ifndef NV_PRESERVES_UV
1985 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1987 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1991 #ifdef PERL_PRESERVE_IVUV
1994 SvIV_please(TOPm1s);
1995 if (SvIOK(TOPm1s)) {
1996 bool auvok = SvUOK(TOPm1s);
1997 bool buvok = SvUOK(TOPs);
1999 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2000 /* Casting IV to UV before comparison isn't going to matter
2001 on 2s complement. On 1s complement or sign&magnitude
2002 (if we have any of them) it could make negative zero
2003 differ from normal zero. As I understand it. (Need to
2004 check - is negative zero implementation defined behaviour
2006 UV buv = SvUVX(POPs);
2007 UV auv = SvUVX(TOPs);
2009 SETs(boolSV(auv != buv));
2012 { /* ## Mixed IV,UV ## */
2016 /* != is commutative so swap if needed (save code) */
2018 /* swap. top of stack (b) is the iv */
2022 /* As (a) is a UV, it's >0, so it cannot be == */
2031 /* As (b) is a UV, it's >0, so it cannot be == */
2035 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2037 SETs(boolSV((UV)iv != uv));
2045 SETs(boolSV(TOPn != value));
2052 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2053 #ifndef NV_PRESERVES_UV
2054 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2055 UV right = PTR2UV(SvRV(POPs));
2056 UV left = PTR2UV(SvRV(TOPs));
2057 SETi((left > right) - (left < right));
2061 #ifdef PERL_PRESERVE_IVUV
2062 /* Fortunately it seems NaN isn't IOK */
2065 SvIV_please(TOPm1s);
2066 if (SvIOK(TOPm1s)) {
2067 bool leftuvok = SvUOK(TOPm1s);
2068 bool rightuvok = SvUOK(TOPs);
2070 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2071 IV leftiv = SvIVX(TOPm1s);
2072 IV rightiv = SvIVX(TOPs);
2074 if (leftiv > rightiv)
2076 else if (leftiv < rightiv)
2080 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2081 UV leftuv = SvUVX(TOPm1s);
2082 UV rightuv = SvUVX(TOPs);
2084 if (leftuv > rightuv)
2086 else if (leftuv < rightuv)
2090 } else if (leftuvok) { /* ## UV <=> IV ## */
2094 rightiv = SvIVX(TOPs);
2096 /* As (a) is a UV, it's >=0, so it cannot be < */
2099 leftuv = SvUVX(TOPm1s);
2100 if (leftuv > (UV)rightiv) {
2102 } else if (leftuv < (UV)rightiv) {
2108 } else { /* ## IV <=> UV ## */
2112 leftiv = SvIVX(TOPm1s);
2114 /* As (b) is a UV, it's >=0, so it must be < */
2117 rightuv = SvUVX(TOPs);
2118 if ((UV)leftiv > rightuv) {
2120 } else if ((UV)leftiv < rightuv) {
2138 if (Perl_isnan(left) || Perl_isnan(right)) {
2142 value = (left > right) - (left < right);
2146 else if (left < right)
2148 else if (left > right)
2162 dSP; tryAMAGICbinSET(slt,0);
2165 int cmp = (IN_LOCALE_RUNTIME
2166 ? sv_cmp_locale(left, right)
2167 : sv_cmp(left, right));
2168 SETs(boolSV(cmp < 0));
2175 dSP; tryAMAGICbinSET(sgt,0);
2178 int cmp = (IN_LOCALE_RUNTIME
2179 ? sv_cmp_locale(left, right)
2180 : sv_cmp(left, right));
2181 SETs(boolSV(cmp > 0));
2188 dSP; tryAMAGICbinSET(sle,0);
2191 int cmp = (IN_LOCALE_RUNTIME
2192 ? sv_cmp_locale(left, right)
2193 : sv_cmp(left, right));
2194 SETs(boolSV(cmp <= 0));
2201 dSP; tryAMAGICbinSET(sge,0);
2204 int cmp = (IN_LOCALE_RUNTIME
2205 ? sv_cmp_locale(left, right)
2206 : sv_cmp(left, right));
2207 SETs(boolSV(cmp >= 0));
2214 dSP; tryAMAGICbinSET(seq,0);
2217 SETs(boolSV(sv_eq(left, right)));
2224 dSP; tryAMAGICbinSET(sne,0);
2227 SETs(boolSV(!sv_eq(left, right)));
2234 dSP; dTARGET; tryAMAGICbin(scmp,0);
2237 int cmp = (IN_LOCALE_RUNTIME
2238 ? sv_cmp_locale(left, right)
2239 : sv_cmp(left, right));
2247 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2250 if (SvGMAGICAL(left)) mg_get(left);
2251 if (SvGMAGICAL(right)) mg_get(right);
2252 if (SvNIOKp(left) || SvNIOKp(right)) {
2253 if (PL_op->op_private & HINT_INTEGER) {
2254 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2258 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2263 do_vop(PL_op->op_type, TARG, left, right);
2272 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2275 if (SvGMAGICAL(left)) mg_get(left);
2276 if (SvGMAGICAL(right)) mg_get(right);
2277 if (SvNIOKp(left) || SvNIOKp(right)) {
2278 if (PL_op->op_private & HINT_INTEGER) {
2279 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2283 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2288 do_vop(PL_op->op_type, TARG, left, right);
2297 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2300 if (SvGMAGICAL(left)) mg_get(left);
2301 if (SvGMAGICAL(right)) mg_get(right);
2302 if (SvNIOKp(left) || SvNIOKp(right)) {
2303 if (PL_op->op_private & HINT_INTEGER) {
2304 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2308 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2313 do_vop(PL_op->op_type, TARG, left, right);
2322 dSP; dTARGET; tryAMAGICun(neg);
2325 int flags = SvFLAGS(sv);
2328 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2329 /* It's publicly an integer, or privately an integer-not-float */
2332 if (SvIVX(sv) == IV_MIN) {
2333 /* 2s complement assumption. */
2334 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2337 else if (SvUVX(sv) <= IV_MAX) {
2342 else if (SvIVX(sv) != IV_MIN) {
2346 #ifdef PERL_PRESERVE_IVUV
2355 else if (SvPOKp(sv)) {
2357 char *s = SvPV(sv, len);
2358 if (isIDFIRST(*s)) {
2359 sv_setpvn(TARG, "-", 1);
2362 else if (*s == '+' || *s == '-') {
2364 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2366 else if (DO_UTF8(sv)) {
2369 goto oops_its_an_int;
2371 sv_setnv(TARG, -SvNV(sv));
2373 sv_setpvn(TARG, "-", 1);
2380 goto oops_its_an_int;
2381 sv_setnv(TARG, -SvNV(sv));
2393 dSP; tryAMAGICunSET(not);
2394 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2400 dSP; dTARGET; tryAMAGICun(compl);
2406 if (PL_op->op_private & HINT_INTEGER) {
2407 IV i = ~SvIV_nomg(sv);
2411 UV u = ~SvUV_nomg(sv);
2420 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2421 sv_setsv_nomg(TARG, sv);
2422 tmps = (U8*)SvPV_force(TARG, len);
2425 /* Calculate exact length, let's not estimate. */
2434 while (tmps < send) {
2435 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2436 tmps += UTF8SKIP(tmps);
2437 targlen += UNISKIP(~c);
2443 /* Now rewind strings and write them. */
2447 Newz(0, result, targlen + 1, U8);
2448 while (tmps < send) {
2449 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2450 tmps += UTF8SKIP(tmps);
2451 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2455 sv_setpvn(TARG, (char*)result, targlen);
2459 Newz(0, result, nchar + 1, U8);
2460 while (tmps < send) {
2461 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2462 tmps += UTF8SKIP(tmps);
2467 sv_setpvn(TARG, (char*)result, nchar);
2476 register long *tmpl;
2477 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2480 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2485 for ( ; anum > 0; anum--, tmps++)
2494 /* integer versions of some of the above */
2498 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2501 SETi( left * right );
2508 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2512 DIE(aTHX_ "Illegal division by zero");
2513 value = POPi / value;
2522 /* This is the vanilla old i_modulo. */
2523 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2527 DIE(aTHX_ "Illegal modulus zero");
2528 SETi( left % right );
2533 #if defined(__GLIBC__) && IVSIZE == 8
2537 /* This is the i_modulo with the workaround for the _moddi3 bug
2538 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2539 * See below for pp_i_modulo. */
2540 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2544 DIE(aTHX_ "Illegal modulus zero");
2545 SETi( left % PERL_ABS(right) );
2553 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2557 DIE(aTHX_ "Illegal modulus zero");
2558 /* The assumption is to use hereafter the old vanilla version... */
2560 PL_ppaddr[OP_I_MODULO] =
2561 &Perl_pp_i_modulo_0;
2562 /* .. but if we have glibc, we might have a buggy _moddi3
2563 * (at least glicb 2.2.5 is known to have this bug), in other
2564 * words our integer modulus with negative quad as the second
2565 * argument might be broken. Test for this and re-patch the
2566 * opcode dispatch table if that is the case, remembering to
2567 * also apply the workaround so that this first round works
2568 * right, too. See [perl #9402] for more information. */
2569 #if defined(__GLIBC__) && IVSIZE == 8
2573 /* Cannot do this check with inlined IV constants since
2574 * that seems to work correctly even with the buggy glibc. */
2576 /* Yikes, we have the bug.
2577 * Patch in the workaround version. */
2579 PL_ppaddr[OP_I_MODULO] =
2580 &Perl_pp_i_modulo_1;
2581 /* Make certain we work right this time, too. */
2582 right = PERL_ABS(right);
2586 SETi( left % right );
2593 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2596 SETi( left + right );
2603 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2606 SETi( left - right );
2613 dSP; tryAMAGICbinSET(lt,0);
2616 SETs(boolSV(left < right));
2623 dSP; tryAMAGICbinSET(gt,0);
2626 SETs(boolSV(left > right));
2633 dSP; tryAMAGICbinSET(le,0);
2636 SETs(boolSV(left <= right));
2643 dSP; tryAMAGICbinSET(ge,0);
2646 SETs(boolSV(left >= right));
2653 dSP; tryAMAGICbinSET(eq,0);
2656 SETs(boolSV(left == right));
2663 dSP; tryAMAGICbinSET(ne,0);
2666 SETs(boolSV(left != right));
2673 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2680 else if (left < right)
2691 dSP; dTARGET; tryAMAGICun(neg);
2696 /* High falutin' math. */
2700 dSP; dTARGET; tryAMAGICbin(atan2,0);
2703 SETn(Perl_atan2(left, right));
2710 dSP; dTARGET; tryAMAGICun(sin);
2714 value = Perl_sin(value);
2722 dSP; dTARGET; tryAMAGICun(cos);
2726 value = Perl_cos(value);
2732 /* Support Configure command-line overrides for rand() functions.
2733 After 5.005, perhaps we should replace this by Configure support
2734 for drand48(), random(), or rand(). For 5.005, though, maintain
2735 compatibility by calling rand() but allow the user to override it.
2736 See INSTALL for details. --Andy Dougherty 15 July 1998
2738 /* Now it's after 5.005, and Configure supports drand48() and random(),
2739 in addition to rand(). So the overrides should not be needed any more.
2740 --Jarkko Hietaniemi 27 September 1998
2743 #ifndef HAS_DRAND48_PROTO
2744 extern double drand48 (void);
2757 if (!PL_srand_called) {
2758 (void)seedDrand01((Rand_seed_t)seed());
2759 PL_srand_called = TRUE;
2774 (void)seedDrand01((Rand_seed_t)anum);
2775 PL_srand_called = TRUE;
2782 dSP; dTARGET; tryAMAGICun(exp);
2786 value = Perl_exp(value);
2794 dSP; dTARGET; tryAMAGICun(log);
2799 SET_NUMERIC_STANDARD();
2800 DIE(aTHX_ "Can't take log of %"NVgf, value);
2802 value = Perl_log(value);
2810 dSP; dTARGET; tryAMAGICun(sqrt);
2815 SET_NUMERIC_STANDARD();
2816 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2818 value = Perl_sqrt(value);
2826 dSP; dTARGET; tryAMAGICun(int);
2829 IV iv = TOPi; /* attempt to convert to IV if possible. */
2830 /* XXX it's arguable that compiler casting to IV might be subtly
2831 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2832 else preferring IV has introduced a subtle behaviour change bug. OTOH
2833 relying on floating point to be accurate is a bug. */
2837 else if (SvIOK(TOPs)) {
2846 if (value < (NV)UV_MAX + 0.5) {
2849 SETn(Perl_floor(value));
2853 if (value > (NV)IV_MIN - 0.5) {
2856 SETn(Perl_ceil(value));
2866 dSP; dTARGET; tryAMAGICun(abs);
2868 /* This will cache the NV value if string isn't actually integer */
2873 else if (SvIOK(TOPs)) {
2874 /* IVX is precise */
2876 SETu(TOPu); /* force it to be numeric only */
2884 /* 2s complement assumption. Also, not really needed as
2885 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2905 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2911 tmps = (SvPVx(sv, len));
2913 /* If Unicode, try to downgrade
2914 * If not possible, croak. */
2915 SV* tsv = sv_2mortal(newSVsv(sv));
2918 sv_utf8_downgrade(tsv, FALSE);
2921 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2922 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2935 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2941 tmps = (SvPVx(sv, len));
2943 /* If Unicode, try to downgrade
2944 * If not possible, croak. */
2945 SV* tsv = sv_2mortal(newSVsv(sv));
2948 sv_utf8_downgrade(tsv, FALSE);
2951 while (*tmps && len && isSPACE(*tmps))
2956 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2957 else if (*tmps == 'b')
2958 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2960 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2962 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2979 SETi(sv_len_utf8(sv));
2995 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2997 I32 arybase = PL_curcop->cop_arybase;
3001 int num_args = PL_op->op_private & 7;
3002 bool repl_need_utf8_upgrade = FALSE;
3003 bool repl_is_utf8 = FALSE;
3005 SvTAINTED_off(TARG); /* decontaminate */
3006 SvUTF8_off(TARG); /* decontaminate */
3010 repl = SvPV(repl_sv, repl_len);
3011 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3021 sv_utf8_upgrade(sv);
3023 else if (DO_UTF8(sv))
3024 repl_need_utf8_upgrade = TRUE;
3026 tmps = SvPV(sv, curlen);
3028 utf8_curlen = sv_len_utf8(sv);
3029 if (utf8_curlen == curlen)
3032 curlen = utf8_curlen;
3037 if (pos >= arybase) {
3055 else if (len >= 0) {
3057 if (rem > (I32)curlen)
3072 Perl_croak(aTHX_ "substr outside of string");
3073 if (ckWARN(WARN_SUBSTR))
3074 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3081 sv_pos_u2b(sv, &pos, &rem);
3083 /* we either return a PV or an LV. If the TARG hasn't been used
3084 * before, or is of that type, reuse it; otherwise use a mortal
3085 * instead. Note that LVs can have an extended lifetime, so also
3086 * dont reuse if refcount > 1 (bug #20933) */
3087 if (SvTYPE(TARG) > SVt_NULL) {
3088 if ( (SvTYPE(TARG) == SVt_PVLV)
3089 ? (!lvalue || SvREFCNT(TARG) > 1)
3092 TARG = sv_newmortal();
3096 sv_setpvn(TARG, tmps, rem);
3097 #ifdef USE_LOCALE_COLLATE
3098 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3103 SV* repl_sv_copy = NULL;
3105 if (repl_need_utf8_upgrade) {
3106 repl_sv_copy = newSVsv(repl_sv);
3107 sv_utf8_upgrade(repl_sv_copy);
3108 repl = SvPV(repl_sv_copy, repl_len);
3109 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3111 sv_insert(sv, pos, rem, repl, repl_len);
3115 SvREFCNT_dec(repl_sv_copy);
3117 else if (lvalue) { /* it's an lvalue! */
3118 if (!SvGMAGICAL(sv)) {
3122 if (ckWARN(WARN_SUBSTR))
3123 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3124 "Attempt to use reference as lvalue in substr");
3126 if (SvOK(sv)) /* is it defined ? */
3127 (void)SvPOK_only_UTF8(sv);
3129 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3132 if (SvTYPE(TARG) < SVt_PVLV) {
3133 sv_upgrade(TARG, SVt_PVLV);
3134 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3137 (void)SvOK_off(TARG);
3140 if (LvTARG(TARG) != sv) {
3142 SvREFCNT_dec(LvTARG(TARG));
3143 LvTARG(TARG) = SvREFCNT_inc(sv);
3145 LvTARGOFF(TARG) = upos;
3146 LvTARGLEN(TARG) = urem;
3150 PUSHs(TARG); /* avoid SvSETMAGIC here */
3157 register IV size = POPi;
3158 register IV offset = POPi;
3159 register SV *src = POPs;
3160 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3162 SvTAINTED_off(TARG); /* decontaminate */
3163 if (lvalue) { /* it's an lvalue! */
3164 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3165 TARG = sv_newmortal();
3166 if (SvTYPE(TARG) < SVt_PVLV) {
3167 sv_upgrade(TARG, SVt_PVLV);
3168 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3171 if (LvTARG(TARG) != src) {
3173 SvREFCNT_dec(LvTARG(TARG));
3174 LvTARG(TARG) = SvREFCNT_inc(src);
3176 LvTARGOFF(TARG) = offset;
3177 LvTARGLEN(TARG) = size;
3180 sv_setuv(TARG, do_vecget(src, offset, size));
3195 I32 arybase = PL_curcop->cop_arybase;
3200 offset = POPi - arybase;
3203 tmps = SvPV(big, biglen);
3204 if (offset > 0 && DO_UTF8(big))
3205 sv_pos_u2b(big, &offset, 0);
3208 else if (offset > (I32)biglen)
3210 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3211 (unsigned char*)tmps + biglen, little, 0)))
3214 retval = tmps2 - tmps;
3215 if (retval > 0 && DO_UTF8(big))
3216 sv_pos_b2u(big, &retval);
3217 PUSHi(retval + arybase);
3232 I32 arybase = PL_curcop->cop_arybase;
3238 tmps2 = SvPV(little, llen);
3239 tmps = SvPV(big, blen);
3243 if (offset > 0 && DO_UTF8(big))
3244 sv_pos_u2b(big, &offset, 0);
3245 offset = offset - arybase + llen;
3249 else if (offset > (I32)blen)
3251 if (!(tmps2 = rninstr(tmps, tmps + offset,
3252 tmps2, tmps2 + llen)))
3255 retval = tmps2 - tmps;
3256 if (retval > 0 && DO_UTF8(big))
3257 sv_pos_b2u(big, &retval);
3258 PUSHi(retval + arybase);
3264 dSP; dMARK; dORIGMARK; dTARGET;
3265 do_sprintf(TARG, SP-MARK, MARK+1);
3266 TAINT_IF(SvTAINTED(TARG));
3267 if (DO_UTF8(*(MARK+1)))
3279 U8 *s = (U8*)SvPVx(argsv, len);
3282 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3283 tmpsv = sv_2mortal(newSVsv(argsv));
3284 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3288 XPUSHu(DO_UTF8(argsv) ?
3289 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3301 (void)SvUPGRADE(TARG,SVt_PV);
3303 if (value > 255 && !IN_BYTES) {
3304 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3305 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3306 SvCUR_set(TARG, tmps - SvPVX(TARG));
3308 (void)SvPOK_only(TARG);
3317 *tmps++ = (char)value;
3319 (void)SvPOK_only(TARG);
3320 if (PL_encoding && !IN_BYTES) {
3321 sv_recode_to_utf8(TARG, PL_encoding);
3323 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3324 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3328 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3329 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3345 char *tmps = SvPV(left, len);
3347 if (DO_UTF8(left)) {
3348 /* If Unicode, try to downgrade.
3349 * If not possible, croak.
3350 * Yes, we made this up. */
3351 SV* tsv = sv_2mortal(newSVsv(left));
3354 sv_utf8_downgrade(tsv, FALSE);
3357 # ifdef USE_ITHREADS
3359 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3360 /* This should be threadsafe because in ithreads there is only
3361 * one thread per interpreter. If this would not be true,
3362 * we would need a mutex to protect this malloc. */
3363 PL_reentrant_buffer->_crypt_struct_buffer =
3364 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3365 #if defined(__GLIBC__) || defined(__EMX__)
3366 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3367 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3368 /* work around glibc-2.2.5 bug */
3369 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3373 # endif /* HAS_CRYPT_R */
3374 # endif /* USE_ITHREADS */
3376 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3378 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3384 "The crypt() function is unimplemented due to excessive paranoia.");
3397 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3398 UTF8_IS_START(*s)) {
3399 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3403 utf8_to_uvchr(s, &ulen);
3404 toTITLE_utf8(s, tmpbuf, &tculen);
3405 utf8_to_uvchr(tmpbuf, 0);
3407 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3409 /* slen is the byte length of the whole SV.
3410 * ulen is the byte length of the original Unicode character
3411 * stored as UTF-8 at s.
3412 * tculen is the byte length of the freshly titlecased
3413 * Unicode character stored as UTF-8 at tmpbuf.
3414 * We first set the result to be the titlecased character,
3415 * and then append the rest of the SV data. */
3416 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3418 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3423 s = (U8*)SvPV_force_nomg(sv, slen);
3424 Copy(tmpbuf, s, tculen, U8);
3428 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3430 SvUTF8_off(TARG); /* decontaminate */
3431 sv_setsv_nomg(TARG, sv);
3435 s = (U8*)SvPV_force_nomg(sv, slen);
3437 if (IN_LOCALE_RUNTIME) {
3440 *s = toUPPER_LC(*s);
3459 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3460 UTF8_IS_START(*s)) {
3462 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3466 toLOWER_utf8(s, tmpbuf, &ulen);
3467 uv = utf8_to_uvchr(tmpbuf, 0);
3468 tend = uvchr_to_utf8(tmpbuf, uv);
3470 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3472 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3474 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3479 s = (U8*)SvPV_force_nomg(sv, slen);
3480 Copy(tmpbuf, s, ulen, U8);
3484 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3486 SvUTF8_off(TARG); /* decontaminate */
3487 sv_setsv_nomg(TARG, sv);
3491 s = (U8*)SvPV_force_nomg(sv, slen);
3493 if (IN_LOCALE_RUNTIME) {
3496 *s = toLOWER_LC(*s);
3519 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3521 s = (U8*)SvPV_nomg(sv,len);
3523 SvUTF8_off(TARG); /* decontaminate */
3524 sv_setpvn(TARG, "", 0);
3528 STRLEN nchar = utf8_length(s, s + len);
3530 (void)SvUPGRADE(TARG, SVt_PV);
3531 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3532 (void)SvPOK_only(TARG);
3533 d = (U8*)SvPVX(TARG);
3536 toUPPER_utf8(s, tmpbuf, &ulen);
3537 Copy(tmpbuf, d, ulen, U8);
3543 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3548 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3550 SvUTF8_off(TARG); /* decontaminate */
3551 sv_setsv_nomg(TARG, sv);
3555 s = (U8*)SvPV_force_nomg(sv, len);
3557 register U8 *send = s + len;
3559 if (IN_LOCALE_RUNTIME) {
3562 for (; s < send; s++)
3563 *s = toUPPER_LC(*s);
3566 for (; s < send; s++)
3588 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3590 s = (U8*)SvPV_nomg(sv,len);
3592 SvUTF8_off(TARG); /* decontaminate */
3593 sv_setpvn(TARG, "", 0);
3597 STRLEN nchar = utf8_length(s, s + len);
3599 (void)SvUPGRADE(TARG, SVt_PV);
3600 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3601 (void)SvPOK_only(TARG);
3602 d = (U8*)SvPVX(TARG);
3605 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3606 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3607 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3609 * Now if the sigma is NOT followed by
3610 * /$ignorable_sequence$cased_letter/;
3611 * and it IS preceded by
3612 * /$cased_letter$ignorable_sequence/;
3613 * where $ignorable_sequence is
3614 * [\x{2010}\x{AD}\p{Mn}]*
3615 * and $cased_letter is
3616 * [\p{Ll}\p{Lo}\p{Lt}]
3617 * then it should be mapped to 0x03C2,
3618 * (GREEK SMALL LETTER FINAL SIGMA),
3619 * instead of staying 0x03A3.
3620 * See lib/unicore/SpecCase.txt.
3623 Copy(tmpbuf, d, ulen, U8);
3629 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3634 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3636 SvUTF8_off(TARG); /* decontaminate */
3637 sv_setsv_nomg(TARG, sv);
3642 s = (U8*)SvPV_force_nomg(sv, len);
3644 register U8 *send = s + len;
3646 if (IN_LOCALE_RUNTIME) {
3649 for (; s < send; s++)
3650 *s = toLOWER_LC(*s);
3653 for (; s < send; s++)
3667 register char *s = SvPV(sv,len);
3670 SvUTF8_off(TARG); /* decontaminate */
3672 (void)SvUPGRADE(TARG, SVt_PV);
3673 SvGROW(TARG, (len * 2) + 1);
3677 if (UTF8_IS_CONTINUED(*s)) {
3678 STRLEN ulen = UTF8SKIP(s);
3702 SvCUR_set(TARG, d - SvPVX(TARG));
3703 (void)SvPOK_only_UTF8(TARG);
3706 sv_setpvn(TARG, s, len);
3708 if (SvSMAGICAL(TARG))
3717 dSP; dMARK; dORIGMARK;
3719 register AV* av = (AV*)POPs;
3720 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3721 I32 arybase = PL_curcop->cop_arybase;
3724 if (SvTYPE(av) == SVt_PVAV) {
3725 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3727 for (svp = MARK + 1; svp <= SP; svp++) {
3732 if (max > AvMAX(av))
3735 while (++MARK <= SP) {
3736 elem = SvIVx(*MARK);
3740 svp = av_fetch(av, elem, lval);
3742 if (!svp || *svp == &PL_sv_undef)
3743 DIE(aTHX_ PL_no_aelem, elem);
3744 if (PL_op->op_private & OPpLVAL_INTRO)
3745 save_aelem(av, elem, svp);
3747 *MARK = svp ? *svp : &PL_sv_undef;
3750 if (GIMME != G_ARRAY) {
3752 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3758 /* Associative arrays. */
3763 HV *hash = (HV*)POPs;
3765 I32 gimme = GIMME_V;
3768 /* might clobber stack_sp */
3769 entry = hv_iternext(hash);
3774 SV* sv = hv_iterkeysv(entry);
3775 PUSHs(sv); /* won't clobber stack_sp */
3776 if (gimme == G_ARRAY) {
3779 /* might clobber stack_sp */
3780 val = hv_iterval(hash, entry);
3785 else if (gimme == G_SCALAR)
3804 I32 gimme = GIMME_V;
3805 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3809 if (PL_op->op_private & OPpSLICE) {
3813 hvtype = SvTYPE(hv);
3814 if (hvtype == SVt_PVHV) { /* hash element */
3815 while (++MARK <= SP) {
3816 sv = hv_delete_ent(hv, *MARK, discard, 0);
3817 *MARK = sv ? sv : &PL_sv_undef;
3820 else if (hvtype == SVt_PVAV) { /* array element */
3821 if (PL_op->op_flags & OPf_SPECIAL) {
3822 while (++MARK <= SP) {
3823 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3824 *MARK = sv ? sv : &PL_sv_undef;
3829 DIE(aTHX_ "Not a HASH reference");
3832 else if (gimme == G_SCALAR) {
3837 *++MARK = &PL_sv_undef;
3844 if (SvTYPE(hv) == SVt_PVHV)
3845 sv = hv_delete_ent(hv, keysv, discard, 0);
3846 else if (SvTYPE(hv) == SVt_PVAV) {
3847 if (PL_op->op_flags & OPf_SPECIAL)
3848 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3850 DIE(aTHX_ "panic: avhv_delete no longer supported");
3853 DIE(aTHX_ "Not a HASH reference");
3868 if (PL_op->op_private & OPpEXISTS_SUB) {
3872 cv = sv_2cv(sv, &hv, &gv, FALSE);
3875 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3881 if (SvTYPE(hv) == SVt_PVHV) {
3882 if (hv_exists_ent(hv, tmpsv, 0))
3885 else if (SvTYPE(hv) == SVt_PVAV) {
3886 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3887 if (av_exists((AV*)hv, SvIV(tmpsv)))
3892 DIE(aTHX_ "Not a HASH reference");
3899 dSP; dMARK; dORIGMARK;
3900 register HV *hv = (HV*)POPs;
3901 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3902 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3903 bool other_magic = FALSE;
3909 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3910 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3911 /* Try to preserve the existenceness of a tied hash
3912 * element by using EXISTS and DELETE if possible.
3913 * Fallback to FETCH and STORE otherwise */
3914 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3915 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3916 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3919 while (++MARK <= SP) {
3923 bool preeminent = FALSE;
3926 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3927 hv_exists_ent(hv, keysv, 0);
3930 he = hv_fetch_ent(hv, keysv, lval, 0);
3931 svp = he ? &HeVAL(he) : 0;
3934 if (!svp || *svp == &PL_sv_undef) {
3936 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3940 save_helem(hv, keysv, svp);
3943 char *key = SvPV(keysv, keylen);
3944 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3948 *MARK = svp ? *svp : &PL_sv_undef;
3950 if (GIMME != G_ARRAY) {
3952 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3958 /* List operators. */
3963 if (GIMME != G_ARRAY) {
3965 *MARK = *SP; /* unwanted list, return last item */
3967 *MARK = &PL_sv_undef;
3976 SV **lastrelem = PL_stack_sp;
3977 SV **lastlelem = PL_stack_base + POPMARK;
3978 SV **firstlelem = PL_stack_base + POPMARK + 1;
3979 register SV **firstrelem = lastlelem + 1;
3980 I32 arybase = PL_curcop->cop_arybase;
3981 I32 lval = PL_op->op_flags & OPf_MOD;
3982 I32 is_something_there = lval;
3984 register I32 max = lastrelem - lastlelem;
3985 register SV **lelem;
3988 if (GIMME != G_ARRAY) {
3989 ix = SvIVx(*lastlelem);
3994 if (ix < 0 || ix >= max)
3995 *firstlelem = &PL_sv_undef;
3997 *firstlelem = firstrelem[ix];
4003 SP = firstlelem - 1;
4007 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4013 if (ix < 0 || ix >= max)
4014 *lelem = &PL_sv_undef;
4016 is_something_there = TRUE;
4017 if (!(*lelem = firstrelem[ix]))
4018 *lelem = &PL_sv_undef;
4021 if (is_something_there)
4024 SP = firstlelem - 1;
4030 dSP; dMARK; dORIGMARK;
4031 I32 items = SP - MARK;
4032 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4033 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4040 dSP; dMARK; dORIGMARK;
4041 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4045 SV *val = NEWSV(46, 0);
4047 sv_setsv(val, *++MARK);
4048 else if (ckWARN(WARN_MISC))
4049 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4050 (void)hv_store_ent(hv,key,val,0);
4059 dSP; dMARK; dORIGMARK;
4060 register AV *ary = (AV*)*++MARK;
4064 register I32 offset;
4065 register I32 length;
4072 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4073 *MARK-- = SvTIED_obj((SV*)ary, mg);
4077 call_method("SPLICE",GIMME_V);
4086 offset = i = SvIVx(*MARK);
4088 offset += AvFILLp(ary) + 1;
4090 offset -= PL_curcop->cop_arybase;
4092 DIE(aTHX_ PL_no_aelem, i);
4094 length = SvIVx(*MARK++);
4096 length += AvFILLp(ary) - offset + 1;
4102 length = AvMAX(ary) + 1; /* close enough to infinity */
4106 length = AvMAX(ary) + 1;
4108 if (offset > AvFILLp(ary) + 1) {
4109 if (ckWARN(WARN_MISC))
4110 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4111 offset = AvFILLp(ary) + 1;
4113 after = AvFILLp(ary) + 1 - (offset + length);
4114 if (after < 0) { /* not that much array */
4115 length += after; /* offset+length now in array */
4121 /* At this point, MARK .. SP-1 is our new LIST */
4124 diff = newlen - length;
4125 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4128 /* make new elements SVs now: avoid problems if they're from the array */
4129 for (dst = MARK, i = newlen; i; i--) {
4131 *dst = NEWSV(46, 0);
4132 sv_setsv(*dst++, h);
4135 if (diff < 0) { /* shrinking the area */
4137 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4138 Copy(MARK, tmparyval, newlen, SV*);
4141 MARK = ORIGMARK + 1;
4142 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4143 MEXTEND(MARK, length);
4144 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4146 EXTEND_MORTAL(length);
4147 for (i = length, dst = MARK; i; i--) {
4148 sv_2mortal(*dst); /* free them eventualy */
4155 *MARK = AvARRAY(ary)[offset+length-1];
4158 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4159 SvREFCNT_dec(*dst++); /* free them now */
4162 AvFILLp(ary) += diff;
4164 /* pull up or down? */
4166 if (offset < after) { /* easier to pull up */
4167 if (offset) { /* esp. if nothing to pull */
4168 src = &AvARRAY(ary)[offset-1];
4169 dst = src - diff; /* diff is negative */
4170 for (i = offset; i > 0; i--) /* can't trust Copy */
4174 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4178 if (after) { /* anything to pull down? */
4179 src = AvARRAY(ary) + offset + length;
4180 dst = src + diff; /* diff is negative */
4181 Move(src, dst, after, SV*);
4183 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4184 /* avoid later double free */
4188 dst[--i] = &PL_sv_undef;
4191 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4192 Safefree(tmparyval);
4195 else { /* no, expanding (or same) */
4197 New(452, tmparyval, length, SV*); /* so remember deletion */
4198 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4201 if (diff > 0) { /* expanding */
4203 /* push up or down? */
4205 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4209 Move(src, dst, offset, SV*);
4211 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4213 AvFILLp(ary) += diff;
4216 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4217 av_extend(ary, AvFILLp(ary) + diff);
4218 AvFILLp(ary) += diff;
4221 dst = AvARRAY(ary) + AvFILLp(ary);
4223 for (i = after; i; i--) {
4231 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4234 MARK = ORIGMARK + 1;
4235 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4237 Copy(tmparyval, MARK, length, SV*);
4239 EXTEND_MORTAL(length);
4240 for (i = length, dst = MARK; i; i--) {
4241 sv_2mortal(*dst); /* free them eventualy */
4245 Safefree(tmparyval);
4249 else if (length--) {
4250 *MARK = tmparyval[length];
4253 while (length-- > 0)
4254 SvREFCNT_dec(tmparyval[length]);
4256 Safefree(tmparyval);
4259 *MARK = &PL_sv_undef;
4267 dSP; dMARK; dORIGMARK; dTARGET;
4268 register AV *ary = (AV*)*++MARK;
4269 register SV *sv = &PL_sv_undef;
4272 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4273 *MARK-- = SvTIED_obj((SV*)ary, mg);
4277 call_method("PUSH",G_SCALAR|G_DISCARD);
4282 /* Why no pre-extend of ary here ? */
4283 for (++MARK; MARK <= SP; MARK++) {
4286 sv_setsv(sv, *MARK);
4291 PUSHi( AvFILL(ary) + 1 );
4299 SV *sv = av_pop(av);
4301 (void)sv_2mortal(sv);
4310 SV *sv = av_shift(av);
4315 (void)sv_2mortal(sv);
4322 dSP; dMARK; dORIGMARK; dTARGET;
4323 register AV *ary = (AV*)*++MARK;
4328 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4329 *MARK-- = SvTIED_obj((SV*)ary, mg);
4333 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4338 av_unshift(ary, SP - MARK);
4341 sv_setsv(sv, *++MARK);
4342 (void)av_store(ary, i++, sv);
4346 PUSHi( AvFILL(ary) + 1 );
4356 if (GIMME == G_ARRAY) {
4363 /* safe as long as stack cannot get extended in the above */
4368 register char *down;
4374 SvUTF8_off(TARG); /* decontaminate */
4376 do_join(TARG, &PL_sv_no, MARK, SP);
4378 sv_setsv(TARG, (SP > MARK)
4380 : (padoff_du = find_rundefsvoffset(),
4381 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4382 ? DEFSV : PAD_SVl(padoff_du)));
4383 up = SvPV_force(TARG, len);
4385 if (DO_UTF8(TARG)) { /* first reverse each character */
4386 U8* s = (U8*)SvPVX(TARG);
4387 U8* send = (U8*)(s + len);
4389 if (UTF8_IS_INVARIANT(*s)) {
4394 if (!utf8_to_uvchr(s, 0))
4398 down = (char*)(s - 1);
4399 /* reverse this character */
4403 *down-- = (char)tmp;
4409 down = SvPVX(TARG) + len - 1;
4413 *down-- = (char)tmp;
4415 (void)SvPOK_only_UTF8(TARG);
4427 register IV limit = POPi; /* note, negative is forever */
4430 register char *s = SvPV(sv, len);
4431 bool do_utf8 = DO_UTF8(sv);
4432 char *strend = s + len;
4434 register REGEXP *rx;
4438 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4439 I32 maxiters = slen + 10;
4442 I32 origlimit = limit;
4445 I32 gimme = GIMME_V;
4446 I32 oldsave = PL_savestack_ix;
4447 I32 make_mortal = 1;
4448 MAGIC *mg = (MAGIC *) NULL;
4451 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4456 DIE(aTHX_ "panic: pp_split");
4459 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4460 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4462 RX_MATCH_UTF8_set(rx, do_utf8);
4464 if (pm->op_pmreplroot) {
4466 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4468 ary = GvAVn((GV*)pm->op_pmreplroot);
4471 else if (gimme != G_ARRAY)
4472 ary = GvAVn(PL_defgv);
4475 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4481 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4483 XPUSHs(SvTIED_obj((SV*)ary, mg));
4489 for (i = AvFILLp(ary); i >= 0; i--)
4490 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4492 /* temporarily switch stacks */
4493 SAVESWITCHSTACK(PL_curstack, ary);
4497 base = SP - PL_stack_base;
4499 if (pm->op_pmflags & PMf_SKIPWHITE) {
4500 if (pm->op_pmflags & PMf_LOCALE) {
4501 while (isSPACE_LC(*s))
4509 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4510 SAVEINT(PL_multiline);
4511 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4515 limit = maxiters + 2;
4516 if (pm->op_pmflags & PMf_WHITE) {
4519 while (m < strend &&
4520 !((pm->op_pmflags & PMf_LOCALE)
4521 ? isSPACE_LC(*m) : isSPACE(*m)))
4526 dstr = NEWSV(30, m-s);
4527 sv_setpvn(dstr, s, m-s);
4531 (void)SvUTF8_on(dstr);
4535 while (s < strend &&
4536 ((pm->op_pmflags & PMf_LOCALE)
4537 ? isSPACE_LC(*s) : isSPACE(*s)))
4541 else if (strEQ("^", rx->precomp)) {
4544 for (m = s; m < strend && *m != '\n'; m++) ;
4548 dstr = NEWSV(30, m-s);
4549 sv_setpvn(dstr, s, m-s);
4553 (void)SvUTF8_on(dstr);
4558 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4559 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4560 && (rx->reganch & ROPT_CHECK_ALL)
4561 && !(rx->reganch & ROPT_ANCH)) {
4562 int tail = (rx->reganch & RE_INTUIT_TAIL);
4563 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4566 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4568 char c = *SvPV(csv, n_a);
4571 for (m = s; m < strend && *m != c; m++) ;
4574 dstr = NEWSV(30, m-s);
4575 sv_setpvn(dstr, s, m-s);
4579 (void)SvUTF8_on(dstr);
4581 /* The rx->minlen is in characters but we want to step
4582 * s ahead by bytes. */
4584 s = (char*)utf8_hop((U8*)m, len);
4586 s = m + len; /* Fake \n at the end */
4591 while (s < strend && --limit &&
4592 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4593 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4596 dstr = NEWSV(31, m-s);
4597 sv_setpvn(dstr, s, m-s);
4601 (void)SvUTF8_on(dstr);
4603 /* The rx->minlen is in characters but we want to step
4604 * s ahead by bytes. */
4606 s = (char*)utf8_hop((U8*)m, len);
4608 s = m + len; /* Fake \n at the end */
4613 maxiters += slen * rx->nparens;
4614 while (s < strend && --limit)
4617 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4621 TAINT_IF(RX_MATCH_TAINTED(rx));
4622 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4627 strend = s + (strend - m);
4629 m = rx->startp[0] + orig;
4630 dstr = NEWSV(32, m-s);
4631 sv_setpvn(dstr, s, m-s);
4635 (void)SvUTF8_on(dstr);
4638 for (i = 1; i <= (I32)rx->nparens; i++) {
4639 s = rx->startp[i] + orig;
4640 m = rx->endp[i] + orig;
4642 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4643 parens that didn't match -- they should be set to
4644 undef, not the empty string */
4645 if (m >= orig && s >= orig) {
4646 dstr = NEWSV(33, m-s);
4647 sv_setpvn(dstr, s, m-s);
4650 dstr = &PL_sv_undef; /* undef, not "" */
4654 (void)SvUTF8_on(dstr);
4658 s = rx->endp[0] + orig;
4662 iters = (SP - PL_stack_base) - base;
4663 if (iters > maxiters)
4664 DIE(aTHX_ "Split loop");
4666 /* keep field after final delim? */
4667 if (s < strend || (iters && origlimit)) {
4668 STRLEN l = strend - s;
4669 dstr = NEWSV(34, l);
4670 sv_setpvn(dstr, s, l);
4674 (void)SvUTF8_on(dstr);
4678 else if (!origlimit) {
4679 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4680 if (TOPs && !make_mortal)
4683 *SP-- = &PL_sv_undef;
4688 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4692 if (SvSMAGICAL(ary)) {
4697 if (gimme == G_ARRAY) {
4699 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4707 call_method("PUSH",G_SCALAR|G_DISCARD);
4710 if (gimme == G_ARRAY) {
4711 /* EXTEND should not be needed - we just popped them */
4713 for (i=0; i < iters; i++) {
4714 SV **svp = av_fetch(ary, i, FALSE);
4715 PUSHs((svp) ? *svp : &PL_sv_undef);
4722 if (gimme == G_ARRAY)
4737 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4738 || SvTYPE(retsv) == SVt_PVCV) {
4739 retsv = refto(retsv);
4747 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");