3 * Copyright (c) 1991-2003, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
22 /* XXX I can't imagine anyone who doesn't have this actually _needs_
23 it, since pid_t is an integral type.
26 #ifdef NEED_GETPID_PROTO
27 extern Pid_t getpid (void);
30 /* variations on pp_null */
35 if (GIMME_V == G_SCALAR)
51 if (PL_op->op_private & OPpLVAL_INTRO)
52 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
54 if (PL_op->op_flags & OPf_REF) {
58 if (GIMME == G_SCALAR)
59 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
64 if (gimme == G_ARRAY) {
65 I32 maxarg = AvFILL((AV*)TARG) + 1;
67 if (SvMAGICAL(TARG)) {
69 for (i=0; i < (U32)maxarg; i++) {
70 SV **svp = av_fetch((AV*)TARG, i, FALSE);
71 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
75 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
79 else if (gimme == G_SCALAR) {
80 SV* sv = sv_newmortal();
81 I32 maxarg = AvFILL((AV*)TARG) + 1;
94 if (PL_op->op_private & OPpLVAL_INTRO)
95 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
96 if (PL_op->op_flags & OPf_REF)
99 if (GIMME == G_SCALAR)
100 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
104 if (gimme == G_ARRAY) {
107 else if (gimme == G_SCALAR) {
108 SV* sv = sv_newmortal();
109 if (HvFILL((HV*)TARG))
110 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
111 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
121 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
132 tryAMAGICunDEREF(to_gv);
135 if (SvTYPE(sv) == SVt_PVIO) {
136 GV *gv = (GV*) sv_newmortal();
137 gv_init(gv, 0, "", 0, 0);
138 GvIOp(gv) = (IO *)sv;
139 (void)SvREFCNT_inc(sv);
142 else if (SvTYPE(sv) != SVt_PVGV)
143 DIE(aTHX_ "Not a GLOB reference");
146 if (SvTYPE(sv) != SVt_PVGV) {
150 if (SvGMAGICAL(sv)) {
155 if (!SvOK(sv) && sv != &PL_sv_undef) {
156 /* If this is a 'my' scalar and flag is set then vivify
159 if (PL_op->op_private & OPpDEREF) {
162 if (cUNOP->op_targ) {
164 SV *namesv = PAD_SV(cUNOP->op_targ);
165 name = SvPV(namesv, len);
166 gv = (GV*)NEWSV(0,0);
167 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
170 name = CopSTASHPV(PL_curcop);
173 if (SvTYPE(sv) < SVt_RV)
174 sv_upgrade(sv, SVt_RV);
180 if (PL_op->op_flags & OPf_REF ||
181 PL_op->op_private & HINT_STRICT_REFS)
182 DIE(aTHX_ PL_no_usym, "a symbol");
183 if (ckWARN(WARN_UNINITIALIZED))
188 if ((PL_op->op_flags & OPf_SPECIAL) &&
189 !(PL_op->op_flags & OPf_MOD))
191 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
193 && (!is_gv_magical(sym,len,0)
194 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
200 if (PL_op->op_private & HINT_STRICT_REFS)
201 DIE(aTHX_ PL_no_symref, sym, "a symbol");
202 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
206 if (PL_op->op_private & OPpLVAL_INTRO)
207 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
219 tryAMAGICunDEREF(to_sv);
222 switch (SvTYPE(sv)) {
226 DIE(aTHX_ "Not a SCALAR reference");
234 if (SvTYPE(gv) != SVt_PVGV) {
235 if (SvGMAGICAL(sv)) {
241 if (PL_op->op_flags & OPf_REF ||
242 PL_op->op_private & HINT_STRICT_REFS)
243 DIE(aTHX_ PL_no_usym, "a SCALAR");
244 if (ckWARN(WARN_UNINITIALIZED))
249 if ((PL_op->op_flags & OPf_SPECIAL) &&
250 !(PL_op->op_flags & OPf_MOD))
252 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
254 && (!is_gv_magical(sym,len,0)
255 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
261 if (PL_op->op_private & HINT_STRICT_REFS)
262 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
263 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
268 if (PL_op->op_flags & OPf_MOD) {
269 if (PL_op->op_private & OPpLVAL_INTRO) {
270 if (cUNOP->op_first->op_type == OP_NULL)
271 sv = save_scalar((GV*)TOPs);
273 sv = save_scalar(gv);
275 Perl_croak(aTHX_ PL_no_localize_ref);
277 else if (PL_op->op_private & OPpDEREF)
278 vivify_ref(sv, PL_op->op_private & OPpDEREF);
288 SV *sv = AvARYLEN(av);
290 AvARYLEN(av) = sv = NEWSV(0,0);
291 sv_upgrade(sv, SVt_IV);
292 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
300 dSP; dTARGET; dPOPss;
302 if (PL_op->op_flags & OPf_MOD || LVRET) {
303 if (SvTYPE(TARG) < SVt_PVLV) {
304 sv_upgrade(TARG, SVt_PVLV);
305 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
309 if (LvTARG(TARG) != sv) {
311 SvREFCNT_dec(LvTARG(TARG));
312 LvTARG(TARG) = SvREFCNT_inc(sv);
314 PUSHs(TARG); /* no SvSETMAGIC */
320 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
321 mg = mg_find(sv, PERL_MAGIC_regex_global);
322 if (mg && mg->mg_len >= 0) {
326 PUSHi(i + PL_curcop->cop_arybase);
340 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
341 /* (But not in defined().) */
342 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
345 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
346 if ((PL_op->op_private & OPpLVAL_INTRO)) {
347 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
350 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
354 cv = (CV*)&PL_sv_undef;
368 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
369 char *s = SvPVX(TOPs);
370 if (strnEQ(s, "CORE::", 6)) {
373 code = keyword(s + 6, SvCUR(TOPs) - 6);
374 if (code < 0) { /* Overridable. */
375 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
376 int i = 0, n = 0, seen_question = 0;
378 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
380 if (code == -KEY_chop || code == -KEY_chomp)
382 while (i < MAXO) { /* The slow way. */
383 if (strEQ(s + 6, PL_op_name[i])
384 || strEQ(s + 6, PL_op_desc[i]))
390 goto nonesuch; /* Should not happen... */
392 oa = PL_opargs[i] >> OASHIFT;
394 if (oa & OA_OPTIONAL && !seen_question) {
398 else if (n && str[0] == ';' && seen_question)
399 goto set; /* XXXX system, exec */
400 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
401 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
402 /* But globs are already references (kinda) */
403 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
407 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
411 ret = sv_2mortal(newSVpvn(str, n - 1));
413 else if (code) /* Non-Overridable */
415 else { /* None such */
417 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
421 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
423 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
432 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
434 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
450 if (GIMME != G_ARRAY) {
454 *MARK = &PL_sv_undef;
455 *MARK = refto(*MARK);
459 EXTEND_MORTAL(SP - MARK);
461 *MARK = refto(*MARK);
466 S_refto(pTHX_ SV *sv)
470 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
473 if (!(sv = LvTARG(sv)))
476 (void)SvREFCNT_inc(sv);
478 else if (SvTYPE(sv) == SVt_PVAV) {
479 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
482 (void)SvREFCNT_inc(sv);
484 else if (SvPADTMP(sv) && !IS_PADGV(sv))
488 (void)SvREFCNT_inc(sv);
491 sv_upgrade(rv, SVt_RV);
505 if (sv && SvGMAGICAL(sv))
508 if (!sv || !SvROK(sv))
512 pv = sv_reftype(sv,TRUE);
513 PUSHp(pv, strlen(pv));
523 stash = CopSTASH(PL_curcop);
529 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
530 Perl_croak(aTHX_ "Attempt to bless into a reference");
532 if (ckWARN(WARN_MISC) && len == 0)
533 Perl_warner(aTHX_ packWARN(WARN_MISC),
534 "Explicit blessing to '' (assuming package main)");
535 stash = gv_stashpvn(ptr, len, TRUE);
538 (void)sv_bless(TOPs, stash);
552 elem = SvPV(sv, n_a);
556 switch (elem ? *elem : '\0')
559 if (strEQ(elem, "ARRAY"))
560 tmpRef = (SV*)GvAV(gv);
563 if (strEQ(elem, "CODE"))
564 tmpRef = (SV*)GvCVu(gv);
567 if (strEQ(elem, "FILEHANDLE")) {
568 /* finally deprecated in 5.8.0 */
569 deprecate("*glob{FILEHANDLE}");
570 tmpRef = (SV*)GvIOp(gv);
573 if (strEQ(elem, "FORMAT"))
574 tmpRef = (SV*)GvFORM(gv);
577 if (strEQ(elem, "GLOB"))
581 if (strEQ(elem, "HASH"))
582 tmpRef = (SV*)GvHV(gv);
585 if (strEQ(elem, "IO"))
586 tmpRef = (SV*)GvIOp(gv);
589 if (strEQ(elem, "NAME"))
590 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
593 if (strEQ(elem, "PACKAGE"))
594 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
597 if (strEQ(elem, "SCALAR"))
611 /* Pattern matching */
616 register unsigned char *s;
619 register I32 *sfirst;
623 if (sv == PL_lastscream) {
629 SvSCREAM_off(PL_lastscream);
630 SvREFCNT_dec(PL_lastscream);
632 PL_lastscream = SvREFCNT_inc(sv);
635 s = (unsigned char*)(SvPV(sv, len));
639 if (pos > PL_maxscream) {
640 if (PL_maxscream < 0) {
641 PL_maxscream = pos + 80;
642 New(301, PL_screamfirst, 256, I32);
643 New(302, PL_screamnext, PL_maxscream, I32);
646 PL_maxscream = pos + pos / 4;
647 Renew(PL_screamnext, PL_maxscream, I32);
651 sfirst = PL_screamfirst;
652 snext = PL_screamnext;
654 if (!sfirst || !snext)
655 DIE(aTHX_ "do_study: out of memory");
657 for (ch = 256; ch; --ch)
664 snext[pos] = sfirst[ch] - pos;
671 /* piggyback on m//g magic */
672 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
681 if (PL_op->op_flags & OPf_STACKED)
687 TARG = sv_newmortal();
692 /* Lvalue operators. */
704 dSP; dMARK; dTARGET; dORIGMARK;
706 do_chop(TARG, *++MARK);
715 SETi(do_chomp(TOPs));
722 register I32 count = 0;
725 count += do_chomp(POPs);
736 if (!sv || !SvANY(sv))
738 switch (SvTYPE(sv)) {
740 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
741 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
745 if (HvARRAY(sv) || SvGMAGICAL(sv)
746 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
750 if (CvROOT(sv) || CvXSUB(sv))
767 if (!PL_op->op_private) {
776 SV_CHECK_THINKFIRST_COW_DROP(sv);
778 switch (SvTYPE(sv)) {
788 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
789 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
790 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
794 /* let user-undef'd sub keep its identity */
795 GV* gv = CvGV((CV*)sv);
802 SvSetMagicSV(sv, &PL_sv_undef);
806 Newz(602, gp, 1, GP);
807 GvGP(sv) = gp_ref(gp);
808 GvSV(sv) = NEWSV(72,0);
809 GvLINE(sv) = CopLINE(PL_curcop);
815 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
818 SvPV_set(sv, Nullch);
831 if (SvTYPE(TOPs) > SVt_PVLV)
832 DIE(aTHX_ PL_no_modify);
833 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
834 && SvIVX(TOPs) != IV_MIN)
837 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
848 if (SvTYPE(TOPs) > SVt_PVLV)
849 DIE(aTHX_ PL_no_modify);
850 sv_setsv(TARG, TOPs);
851 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
852 && SvIVX(TOPs) != IV_MAX)
855 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
869 if (SvTYPE(TOPs) > SVt_PVLV)
870 DIE(aTHX_ PL_no_modify);
871 sv_setsv(TARG, TOPs);
872 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
873 && SvIVX(TOPs) != IV_MIN)
876 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
885 /* Ordinary operators. */
890 #ifdef PERL_PRESERVE_IVUV
893 tryAMAGICbin(pow,opASSIGN);
894 #ifdef PERL_PRESERVE_IVUV
895 /* For integer to integer power, we do the calculation by hand wherever
896 we're sure it is safe; otherwise we call pow() and try to convert to
897 integer afterwards. */
901 bool baseuok = SvUOK(TOPm1s);
905 baseuv = SvUVX(TOPm1s);
907 IV iv = SvIVX(TOPm1s);
910 baseuok = TRUE; /* effectively it's a UV now */
912 baseuv = -iv; /* abs, baseuok == false records sign */
926 goto float_it; /* Can't do negative powers this way. */
929 /* now we have integer ** positive integer. */
932 /* foo & (foo - 1) is zero only for a power of 2. */
933 if (!(baseuv & (baseuv - 1))) {
934 /* We are raising power-of-2 to a positive integer.
935 The logic here will work for any base (even non-integer
936 bases) but it can be less accurate than
937 pow (base,power) or exp (power * log (base)) when the
938 intermediate values start to spill out of the mantissa.
939 With powers of 2 we know this can't happen.
940 And powers of 2 are the favourite thing for perl
941 programmers to notice ** not doing what they mean. */
943 NV base = baseuok ? baseuv : -(NV)baseuv;
946 for (; power; base *= base, n++) {
947 /* Do I look like I trust gcc with long longs here?
949 UV bit = (UV)1 << (UV)n;
952 /* Only bother to clear the bit if it is set. */
954 /* Avoid squaring base again if we're done. */
955 if (power == 0) break;
963 register unsigned int highbit = 8 * sizeof(UV);
964 register unsigned int lowbit = 0;
965 register unsigned int diff;
966 while ((diff = (highbit - lowbit) >> 1)) {
967 if (baseuv & ~((1 << (lowbit + diff)) - 1))
972 /* we now have baseuv < 2 ** highbit */
973 if (power * highbit <= 8 * sizeof(UV)) {
974 /* result will definitely fit in UV, so use UV math
975 on same algorithm as above */
976 register UV result = 1;
977 register UV base = baseuv;
979 for (; power; base *= base, n++) {
980 register UV bit = (UV)1 << (UV)n;
984 if (power == 0) break;
988 if (baseuok || !(power & 1))
989 /* answer is positive */
991 else if (result <= (UV)IV_MAX)
992 /* answer negative, fits in IV */
994 else if (result == (UV)IV_MIN)
995 /* 2's complement assumption: special case IV_MIN */
998 /* answer negative, doesn't fit */
1010 SETn( Perl_pow( left, right) );
1011 #ifdef PERL_PRESERVE_IVUV
1021 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1022 #ifdef PERL_PRESERVE_IVUV
1025 /* Unless the left argument is integer in range we are going to have to
1026 use NV maths. Hence only attempt to coerce the right argument if
1027 we know the left is integer. */
1028 /* Left operand is defined, so is it IV? */
1029 SvIV_please(TOPm1s);
1030 if (SvIOK(TOPm1s)) {
1031 bool auvok = SvUOK(TOPm1s);
1032 bool buvok = SvUOK(TOPs);
1033 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1034 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1041 alow = SvUVX(TOPm1s);
1043 IV aiv = SvIVX(TOPm1s);
1046 auvok = TRUE; /* effectively it's a UV now */
1048 alow = -aiv; /* abs, auvok == false records sign */
1054 IV biv = SvIVX(TOPs);
1057 buvok = TRUE; /* effectively it's a UV now */
1059 blow = -biv; /* abs, buvok == false records sign */
1063 /* If this does sign extension on unsigned it's time for plan B */
1064 ahigh = alow >> (4 * sizeof (UV));
1066 bhigh = blow >> (4 * sizeof (UV));
1068 if (ahigh && bhigh) {
1069 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1070 which is overflow. Drop to NVs below. */
1071 } else if (!ahigh && !bhigh) {
1072 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1073 so the unsigned multiply cannot overflow. */
1074 UV product = alow * blow;
1075 if (auvok == buvok) {
1076 /* -ve * -ve or +ve * +ve gives a +ve result. */
1080 } else if (product <= (UV)IV_MIN) {
1081 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1082 /* -ve result, which could overflow an IV */
1084 SETi( -(IV)product );
1086 } /* else drop to NVs below. */
1088 /* One operand is large, 1 small */
1091 /* swap the operands */
1093 bhigh = blow; /* bhigh now the temp var for the swap */
1097 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1098 multiplies can't overflow. shift can, add can, -ve can. */
1099 product_middle = ahigh * blow;
1100 if (!(product_middle & topmask)) {
1101 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1103 product_middle <<= (4 * sizeof (UV));
1104 product_low = alow * blow;
1106 /* as for pp_add, UV + something mustn't get smaller.
1107 IIRC ANSI mandates this wrapping *behaviour* for
1108 unsigned whatever the actual representation*/
1109 product_low += product_middle;
1110 if (product_low >= product_middle) {
1111 /* didn't overflow */
1112 if (auvok == buvok) {
1113 /* -ve * -ve or +ve * +ve gives a +ve result. */
1115 SETu( product_low );
1117 } else if (product_low <= (UV)IV_MIN) {
1118 /* 2s complement assumption again */
1119 /* -ve result, which could overflow an IV */
1121 SETi( -(IV)product_low );
1123 } /* else drop to NVs below. */
1125 } /* product_middle too large */
1126 } /* ahigh && bhigh */
1127 } /* SvIOK(TOPm1s) */
1132 SETn( left * right );
1139 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1140 /* Only try to do UV divide first
1141 if ((SLOPPYDIVIDE is true) or
1142 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1144 The assumption is that it is better to use floating point divide
1145 whenever possible, only doing integer divide first if we can't be sure.
1146 If NV_PRESERVES_UV is true then we know at compile time that no UV
1147 can be too large to preserve, so don't need to compile the code to
1148 test the size of UVs. */
1151 # define PERL_TRY_UV_DIVIDE
1152 /* ensure that 20./5. == 4. */
1154 # ifdef PERL_PRESERVE_IVUV
1155 # ifndef NV_PRESERVES_UV
1156 # define PERL_TRY_UV_DIVIDE
1161 #ifdef PERL_TRY_UV_DIVIDE
1164 SvIV_please(TOPm1s);
1165 if (SvIOK(TOPm1s)) {
1166 bool left_non_neg = SvUOK(TOPm1s);
1167 bool right_non_neg = SvUOK(TOPs);
1171 if (right_non_neg) {
1172 right = SvUVX(TOPs);
1175 IV biv = SvIVX(TOPs);
1178 right_non_neg = TRUE; /* effectively it's a UV now */
1184 /* historically undef()/0 gives a "Use of uninitialized value"
1185 warning before dieing, hence this test goes here.
1186 If it were immediately before the second SvIV_please, then
1187 DIE() would be invoked before left was even inspected, so
1188 no inpsection would give no warning. */
1190 DIE(aTHX_ "Illegal division by zero");
1193 left = SvUVX(TOPm1s);
1196 IV aiv = SvIVX(TOPm1s);
1199 left_non_neg = TRUE; /* effectively it's a UV now */
1208 /* For sloppy divide we always attempt integer division. */
1210 /* Otherwise we only attempt it if either or both operands
1211 would not be preserved by an NV. If both fit in NVs
1212 we fall through to the NV divide code below. However,
1213 as left >= right to ensure integer result here, we know that
1214 we can skip the test on the right operand - right big
1215 enough not to be preserved can't get here unless left is
1218 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1221 /* Integer division can't overflow, but it can be imprecise. */
1222 UV result = left / right;
1223 if (result * right == left) {
1224 SP--; /* result is valid */
1225 if (left_non_neg == right_non_neg) {
1226 /* signs identical, result is positive. */
1230 /* 2s complement assumption */
1231 if (result <= (UV)IV_MIN)
1232 SETi( -(IV)result );
1234 /* It's exact but too negative for IV. */
1235 SETn( -(NV)result );
1238 } /* tried integer divide but it was not an integer result */
1239 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1240 } /* left wasn't SvIOK */
1241 } /* right wasn't SvIOK */
1242 #endif /* PERL_TRY_UV_DIVIDE */
1246 DIE(aTHX_ "Illegal division by zero");
1247 PUSHn( left / right );
1254 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1258 bool left_neg = FALSE;
1259 bool right_neg = FALSE;
1260 bool use_double = FALSE;
1261 bool dright_valid = FALSE;
1267 right_neg = !SvUOK(TOPs);
1269 right = SvUVX(POPs);
1271 IV biv = SvIVX(POPs);
1274 right_neg = FALSE; /* effectively it's a UV now */
1282 right_neg = dright < 0;
1285 if (dright < UV_MAX_P1) {
1286 right = U_V(dright);
1287 dright_valid = TRUE; /* In case we need to use double below. */
1293 /* At this point use_double is only true if right is out of range for
1294 a UV. In range NV has been rounded down to nearest UV and
1295 use_double false. */
1297 if (!use_double && SvIOK(TOPs)) {
1299 left_neg = !SvUOK(TOPs);
1303 IV aiv = SvIVX(POPs);
1306 left_neg = FALSE; /* effectively it's a UV now */
1315 left_neg = dleft < 0;
1319 /* This should be exactly the 5.6 behaviour - if left and right are
1320 both in range for UV then use U_V() rather than floor. */
1322 if (dleft < UV_MAX_P1) {
1323 /* right was in range, so is dleft, so use UVs not double.
1327 /* left is out of range for UV, right was in range, so promote
1328 right (back) to double. */
1330 /* The +0.5 is used in 5.6 even though it is not strictly
1331 consistent with the implicit +0 floor in the U_V()
1332 inside the #if 1. */
1333 dleft = Perl_floor(dleft + 0.5);
1336 dright = Perl_floor(dright + 0.5);
1346 DIE(aTHX_ "Illegal modulus zero");
1348 dans = Perl_fmod(dleft, dright);
1349 if ((left_neg != right_neg) && dans)
1350 dans = dright - dans;
1353 sv_setnv(TARG, dans);
1359 DIE(aTHX_ "Illegal modulus zero");
1362 if ((left_neg != right_neg) && ans)
1365 /* XXX may warn: unary minus operator applied to unsigned type */
1366 /* could change -foo to be (~foo)+1 instead */
1367 if (ans <= ~((UV)IV_MAX)+1)
1368 sv_setiv(TARG, ~ans+1);
1370 sv_setnv(TARG, -(NV)ans);
1373 sv_setuv(TARG, ans);
1382 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1384 register IV count = POPi;
1385 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1387 I32 items = SP - MARK;
1390 max = items * count;
1395 /* This code was intended to fix 20010809.028:
1398 for (($x =~ /./g) x 2) {
1399 print chop; # "abcdabcd" expected as output.
1402 * but that change (#11635) broke this code:
1404 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1406 * I can't think of a better fix that doesn't introduce
1407 * an efficiency hit by copying the SVs. The stack isn't
1408 * refcounted, and mortalisation obviously doesn't
1409 * Do The Right Thing when the stack has more than
1410 * one pointer to the same mortal value.
1414 *SP = sv_2mortal(newSVsv(*SP));
1424 repeatcpy((char*)(MARK + items), (char*)MARK,
1425 items * sizeof(SV*), count - 1);
1428 else if (count <= 0)
1431 else { /* Note: mark already snarfed by pp_list */
1436 SvSetSV(TARG, tmpstr);
1437 SvPV_force(TARG, len);
1438 isutf = DO_UTF8(TARG);
1443 SvGROW(TARG, (count * len) + 1);
1444 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1445 SvCUR(TARG) *= count;
1447 *SvEND(TARG) = '\0';
1450 (void)SvPOK_only_UTF8(TARG);
1452 (void)SvPOK_only(TARG);
1454 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1455 /* The parser saw this as a list repeat, and there
1456 are probably several items on the stack. But we're
1457 in scalar context, and there's no pp_list to save us
1458 now. So drop the rest of the items -- robin@kitsite.com
1471 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1472 useleft = USE_LEFT(TOPm1s);
1473 #ifdef PERL_PRESERVE_IVUV
1474 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1475 "bad things" happen if you rely on signed integers wrapping. */
1478 /* Unless the left argument is integer in range we are going to have to
1479 use NV maths. Hence only attempt to coerce the right argument if
1480 we know the left is integer. */
1481 register UV auv = 0;
1487 a_valid = auvok = 1;
1488 /* left operand is undef, treat as zero. */
1490 /* Left operand is defined, so is it IV? */
1491 SvIV_please(TOPm1s);
1492 if (SvIOK(TOPm1s)) {
1493 if ((auvok = SvUOK(TOPm1s)))
1494 auv = SvUVX(TOPm1s);
1496 register IV aiv = SvIVX(TOPm1s);
1499 auvok = 1; /* Now acting as a sign flag. */
1500 } else { /* 2s complement assumption for IV_MIN */
1508 bool result_good = 0;
1511 bool buvok = SvUOK(TOPs);
1516 register IV biv = SvIVX(TOPs);
1523 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1524 else "IV" now, independent of how it came in.
1525 if a, b represents positive, A, B negative, a maps to -A etc
1530 all UV maths. negate result if A negative.
1531 subtract if signs same, add if signs differ. */
1533 if (auvok ^ buvok) {
1542 /* Must get smaller */
1547 if (result <= buv) {
1548 /* result really should be -(auv-buv). as its negation
1549 of true value, need to swap our result flag */
1561 if (result <= (UV)IV_MIN)
1562 SETi( -(IV)result );
1564 /* result valid, but out of range for IV. */
1565 SETn( -(NV)result );
1569 } /* Overflow, drop through to NVs. */
1573 useleft = USE_LEFT(TOPm1s);
1577 /* left operand is undef, treat as zero - value */
1581 SETn( TOPn - value );
1588 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1591 if (PL_op->op_private & HINT_INTEGER) {
1605 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1608 if (PL_op->op_private & HINT_INTEGER) {
1622 dSP; tryAMAGICbinSET(lt,0);
1623 #ifdef PERL_PRESERVE_IVUV
1626 SvIV_please(TOPm1s);
1627 if (SvIOK(TOPm1s)) {
1628 bool auvok = SvUOK(TOPm1s);
1629 bool buvok = SvUOK(TOPs);
1631 if (!auvok && !buvok) { /* ## IV < IV ## */
1632 IV aiv = SvIVX(TOPm1s);
1633 IV biv = SvIVX(TOPs);
1636 SETs(boolSV(aiv < biv));
1639 if (auvok && buvok) { /* ## UV < UV ## */
1640 UV auv = SvUVX(TOPm1s);
1641 UV buv = SvUVX(TOPs);
1644 SETs(boolSV(auv < buv));
1647 if (auvok) { /* ## UV < IV ## */
1654 /* As (a) is a UV, it's >=0, so it cannot be < */
1659 SETs(boolSV(auv < (UV)biv));
1662 { /* ## IV < UV ## */
1666 aiv = SvIVX(TOPm1s);
1668 /* As (b) is a UV, it's >=0, so it must be < */
1675 SETs(boolSV((UV)aiv < buv));
1681 #ifndef NV_PRESERVES_UV
1682 #ifdef PERL_PRESERVE_IVUV
1685 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1687 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1693 SETs(boolSV(TOPn < value));
1700 dSP; tryAMAGICbinSET(gt,0);
1701 #ifdef PERL_PRESERVE_IVUV
1704 SvIV_please(TOPm1s);
1705 if (SvIOK(TOPm1s)) {
1706 bool auvok = SvUOK(TOPm1s);
1707 bool buvok = SvUOK(TOPs);
1709 if (!auvok && !buvok) { /* ## IV > IV ## */
1710 IV aiv = SvIVX(TOPm1s);
1711 IV biv = SvIVX(TOPs);
1714 SETs(boolSV(aiv > biv));
1717 if (auvok && buvok) { /* ## UV > UV ## */
1718 UV auv = SvUVX(TOPm1s);
1719 UV buv = SvUVX(TOPs);
1722 SETs(boolSV(auv > buv));
1725 if (auvok) { /* ## UV > IV ## */
1732 /* As (a) is a UV, it's >=0, so it must be > */
1737 SETs(boolSV(auv > (UV)biv));
1740 { /* ## IV > UV ## */
1744 aiv = SvIVX(TOPm1s);
1746 /* As (b) is a UV, it's >=0, so it cannot be > */
1753 SETs(boolSV((UV)aiv > buv));
1759 #ifndef NV_PRESERVES_UV
1760 #ifdef PERL_PRESERVE_IVUV
1763 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1765 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1771 SETs(boolSV(TOPn > value));
1778 dSP; tryAMAGICbinSET(le,0);
1779 #ifdef PERL_PRESERVE_IVUV
1782 SvIV_please(TOPm1s);
1783 if (SvIOK(TOPm1s)) {
1784 bool auvok = SvUOK(TOPm1s);
1785 bool buvok = SvUOK(TOPs);
1787 if (!auvok && !buvok) { /* ## IV <= IV ## */
1788 IV aiv = SvIVX(TOPm1s);
1789 IV biv = SvIVX(TOPs);
1792 SETs(boolSV(aiv <= biv));
1795 if (auvok && buvok) { /* ## UV <= UV ## */
1796 UV auv = SvUVX(TOPm1s);
1797 UV buv = SvUVX(TOPs);
1800 SETs(boolSV(auv <= buv));
1803 if (auvok) { /* ## UV <= IV ## */
1810 /* As (a) is a UV, it's >=0, so a cannot be <= */
1815 SETs(boolSV(auv <= (UV)biv));
1818 { /* ## IV <= UV ## */
1822 aiv = SvIVX(TOPm1s);
1824 /* As (b) is a UV, it's >=0, so a must be <= */
1831 SETs(boolSV((UV)aiv <= buv));
1837 #ifndef NV_PRESERVES_UV
1838 #ifdef PERL_PRESERVE_IVUV
1841 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1843 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1849 SETs(boolSV(TOPn <= value));
1856 dSP; tryAMAGICbinSET(ge,0);
1857 #ifdef PERL_PRESERVE_IVUV
1860 SvIV_please(TOPm1s);
1861 if (SvIOK(TOPm1s)) {
1862 bool auvok = SvUOK(TOPm1s);
1863 bool buvok = SvUOK(TOPs);
1865 if (!auvok && !buvok) { /* ## IV >= IV ## */
1866 IV aiv = SvIVX(TOPm1s);
1867 IV biv = SvIVX(TOPs);
1870 SETs(boolSV(aiv >= biv));
1873 if (auvok && buvok) { /* ## UV >= UV ## */
1874 UV auv = SvUVX(TOPm1s);
1875 UV buv = SvUVX(TOPs);
1878 SETs(boolSV(auv >= buv));
1881 if (auvok) { /* ## UV >= IV ## */
1888 /* As (a) is a UV, it's >=0, so it must be >= */
1893 SETs(boolSV(auv >= (UV)biv));
1896 { /* ## IV >= UV ## */
1900 aiv = SvIVX(TOPm1s);
1902 /* As (b) is a UV, it's >=0, so a cannot be >= */
1909 SETs(boolSV((UV)aiv >= buv));
1915 #ifndef NV_PRESERVES_UV
1916 #ifdef PERL_PRESERVE_IVUV
1919 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1921 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1927 SETs(boolSV(TOPn >= value));
1934 dSP; tryAMAGICbinSET(ne,0);
1935 #ifndef NV_PRESERVES_UV
1936 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1938 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1942 #ifdef PERL_PRESERVE_IVUV
1945 SvIV_please(TOPm1s);
1946 if (SvIOK(TOPm1s)) {
1947 bool auvok = SvUOK(TOPm1s);
1948 bool buvok = SvUOK(TOPs);
1950 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1951 /* Casting IV to UV before comparison isn't going to matter
1952 on 2s complement. On 1s complement or sign&magnitude
1953 (if we have any of them) it could make negative zero
1954 differ from normal zero. As I understand it. (Need to
1955 check - is negative zero implementation defined behaviour
1957 UV buv = SvUVX(POPs);
1958 UV auv = SvUVX(TOPs);
1960 SETs(boolSV(auv != buv));
1963 { /* ## Mixed IV,UV ## */
1967 /* != is commutative so swap if needed (save code) */
1969 /* swap. top of stack (b) is the iv */
1973 /* As (a) is a UV, it's >0, so it cannot be == */
1982 /* As (b) is a UV, it's >0, so it cannot be == */
1986 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1988 SETs(boolSV((UV)iv != uv));
1996 SETs(boolSV(TOPn != value));
2003 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2004 #ifndef NV_PRESERVES_UV
2005 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2006 UV right = PTR2UV(SvRV(POPs));
2007 UV left = PTR2UV(SvRV(TOPs));
2008 SETi((left > right) - (left < right));
2012 #ifdef PERL_PRESERVE_IVUV
2013 /* Fortunately it seems NaN isn't IOK */
2016 SvIV_please(TOPm1s);
2017 if (SvIOK(TOPm1s)) {
2018 bool leftuvok = SvUOK(TOPm1s);
2019 bool rightuvok = SvUOK(TOPs);
2021 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2022 IV leftiv = SvIVX(TOPm1s);
2023 IV rightiv = SvIVX(TOPs);
2025 if (leftiv > rightiv)
2027 else if (leftiv < rightiv)
2031 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2032 UV leftuv = SvUVX(TOPm1s);
2033 UV rightuv = SvUVX(TOPs);
2035 if (leftuv > rightuv)
2037 else if (leftuv < rightuv)
2041 } else if (leftuvok) { /* ## UV <=> IV ## */
2045 rightiv = SvIVX(TOPs);
2047 /* As (a) is a UV, it's >=0, so it cannot be < */
2050 leftuv = SvUVX(TOPm1s);
2051 if (leftuv > (UV)rightiv) {
2053 } else if (leftuv < (UV)rightiv) {
2059 } else { /* ## IV <=> UV ## */
2063 leftiv = SvIVX(TOPm1s);
2065 /* As (b) is a UV, it's >=0, so it must be < */
2068 rightuv = SvUVX(TOPs);
2069 if ((UV)leftiv > rightuv) {
2071 } else if ((UV)leftiv < rightuv) {
2089 if (Perl_isnan(left) || Perl_isnan(right)) {
2093 value = (left > right) - (left < right);
2097 else if (left < right)
2099 else if (left > right)
2113 dSP; tryAMAGICbinSET(slt,0);
2116 int cmp = (IN_LOCALE_RUNTIME
2117 ? sv_cmp_locale(left, right)
2118 : sv_cmp(left, right));
2119 SETs(boolSV(cmp < 0));
2126 dSP; tryAMAGICbinSET(sgt,0);
2129 int cmp = (IN_LOCALE_RUNTIME
2130 ? sv_cmp_locale(left, right)
2131 : sv_cmp(left, right));
2132 SETs(boolSV(cmp > 0));
2139 dSP; tryAMAGICbinSET(sle,0);
2142 int cmp = (IN_LOCALE_RUNTIME
2143 ? sv_cmp_locale(left, right)
2144 : sv_cmp(left, right));
2145 SETs(boolSV(cmp <= 0));
2152 dSP; tryAMAGICbinSET(sge,0);
2155 int cmp = (IN_LOCALE_RUNTIME
2156 ? sv_cmp_locale(left, right)
2157 : sv_cmp(left, right));
2158 SETs(boolSV(cmp >= 0));
2165 dSP; tryAMAGICbinSET(seq,0);
2168 SETs(boolSV(sv_eq(left, right)));
2175 dSP; tryAMAGICbinSET(sne,0);
2178 SETs(boolSV(!sv_eq(left, right)));
2185 dSP; dTARGET; tryAMAGICbin(scmp,0);
2188 int cmp = (IN_LOCALE_RUNTIME
2189 ? sv_cmp_locale(left, right)
2190 : sv_cmp(left, right));
2198 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2201 if (SvNIOKp(left) || SvNIOKp(right)) {
2202 if (PL_op->op_private & HINT_INTEGER) {
2203 IV i = SvIV(left) & SvIV(right);
2207 UV u = SvUV(left) & SvUV(right);
2212 do_vop(PL_op->op_type, TARG, left, right);
2221 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2224 if (SvNIOKp(left) || SvNIOKp(right)) {
2225 if (PL_op->op_private & HINT_INTEGER) {
2226 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2230 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2235 do_vop(PL_op->op_type, TARG, left, right);
2244 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2247 if (SvNIOKp(left) || SvNIOKp(right)) {
2248 if (PL_op->op_private & HINT_INTEGER) {
2249 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2253 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2258 do_vop(PL_op->op_type, TARG, left, right);
2267 dSP; dTARGET; tryAMAGICun(neg);
2270 int flags = SvFLAGS(sv);
2273 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2274 /* It's publicly an integer, or privately an integer-not-float */
2277 if (SvIVX(sv) == IV_MIN) {
2278 /* 2s complement assumption. */
2279 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2282 else if (SvUVX(sv) <= IV_MAX) {
2287 else if (SvIVX(sv) != IV_MIN) {
2291 #ifdef PERL_PRESERVE_IVUV
2300 else if (SvPOKp(sv)) {
2302 char *s = SvPV(sv, len);
2303 if (isIDFIRST(*s)) {
2304 sv_setpvn(TARG, "-", 1);
2307 else if (*s == '+' || *s == '-') {
2309 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2311 else if (DO_UTF8(sv)) {
2314 goto oops_its_an_int;
2316 sv_setnv(TARG, -SvNV(sv));
2318 sv_setpvn(TARG, "-", 1);
2325 goto oops_its_an_int;
2326 sv_setnv(TARG, -SvNV(sv));
2338 dSP; tryAMAGICunSET(not);
2339 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2345 dSP; dTARGET; tryAMAGICun(compl);
2349 if (PL_op->op_private & HINT_INTEGER) {
2364 tmps = (U8*)SvPV_force(TARG, len);
2367 /* Calculate exact length, let's not estimate. */
2376 while (tmps < send) {
2377 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2378 tmps += UTF8SKIP(tmps);
2379 targlen += UNISKIP(~c);
2385 /* Now rewind strings and write them. */
2389 Newz(0, result, targlen + 1, U8);
2390 while (tmps < send) {
2391 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2392 tmps += UTF8SKIP(tmps);
2393 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2397 sv_setpvn(TARG, (char*)result, targlen);
2401 Newz(0, result, nchar + 1, U8);
2402 while (tmps < send) {
2403 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2404 tmps += UTF8SKIP(tmps);
2409 sv_setpvn(TARG, (char*)result, nchar);
2417 register long *tmpl;
2418 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2421 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2426 for ( ; anum > 0; anum--, tmps++)
2435 /* integer versions of some of the above */
2439 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2442 SETi( left * right );
2449 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2453 DIE(aTHX_ "Illegal division by zero");
2454 value = POPi / value;
2463 /* This is the vanilla old i_modulo. */
2464 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2468 DIE(aTHX_ "Illegal modulus zero");
2469 SETi( left % right );
2478 /* This is the i_modulo with the workaround for the _moddi3 bug
2479 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2480 * See below for pp_i_modulo. */
2481 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2485 DIE(aTHX_ "Illegal modulus zero");
2486 SETi( left % PERL_ABS(right) );
2494 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2498 DIE(aTHX_ "Illegal modulus zero");
2499 /* The assumption is to use hereafter the old vanilla version... */
2501 PL_ppaddr[OP_I_MODULO] =
2502 &Perl_pp_i_modulo_0;
2503 /* .. but if we have glibc, we might have a buggy _moddi3
2504 * (at least glicb 2.2.5 is known to have this bug), in other
2505 * words our integer modulus with negative quad as the second
2506 * argument might be broken. Test for this and re-patch the
2507 * opcode dispatch table if that is the case, remembering to
2508 * also apply the workaround so that this first round works
2509 * right, too. See [perl #9402] for more information. */
2510 #if defined(__GLIBC__) && IVSIZE == 8
2514 /* Cannot do this check with inlined IV constants since
2515 * that seems to work correctly even with the buggy glibc. */
2517 /* Yikes, we have the bug.
2518 * Patch in the workaround version. */
2520 PL_ppaddr[OP_I_MODULO] =
2521 &Perl_pp_i_modulo_1;
2522 /* Make certain we work right this time, too. */
2523 right = PERL_ABS(right);
2527 SETi( left % right );
2534 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2537 SETi( left + right );
2544 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2547 SETi( left - right );
2554 dSP; tryAMAGICbinSET(lt,0);
2557 SETs(boolSV(left < right));
2564 dSP; tryAMAGICbinSET(gt,0);
2567 SETs(boolSV(left > right));
2574 dSP; tryAMAGICbinSET(le,0);
2577 SETs(boolSV(left <= right));
2584 dSP; tryAMAGICbinSET(ge,0);
2587 SETs(boolSV(left >= right));
2594 dSP; tryAMAGICbinSET(eq,0);
2597 SETs(boolSV(left == right));
2604 dSP; tryAMAGICbinSET(ne,0);
2607 SETs(boolSV(left != right));
2614 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2621 else if (left < right)
2632 dSP; dTARGET; tryAMAGICun(neg);
2637 /* High falutin' math. */
2641 dSP; dTARGET; tryAMAGICbin(atan2,0);
2644 SETn(Perl_atan2(left, right));
2651 dSP; dTARGET; tryAMAGICun(sin);
2655 value = Perl_sin(value);
2663 dSP; dTARGET; tryAMAGICun(cos);
2667 value = Perl_cos(value);
2673 /* Support Configure command-line overrides for rand() functions.
2674 After 5.005, perhaps we should replace this by Configure support
2675 for drand48(), random(), or rand(). For 5.005, though, maintain
2676 compatibility by calling rand() but allow the user to override it.
2677 See INSTALL for details. --Andy Dougherty 15 July 1998
2679 /* Now it's after 5.005, and Configure supports drand48() and random(),
2680 in addition to rand(). So the overrides should not be needed any more.
2681 --Jarkko Hietaniemi 27 September 1998
2684 #ifndef HAS_DRAND48_PROTO
2685 extern double drand48 (void);
2698 if (!PL_srand_called) {
2699 (void)seedDrand01((Rand_seed_t)seed());
2700 PL_srand_called = TRUE;
2715 (void)seedDrand01((Rand_seed_t)anum);
2716 PL_srand_called = TRUE;
2725 * This is really just a quick hack which grabs various garbage
2726 * values. It really should be a real hash algorithm which
2727 * spreads the effect of every input bit onto every output bit,
2728 * if someone who knows about such things would bother to write it.
2729 * Might be a good idea to add that function to CORE as well.
2730 * No numbers below come from careful analysis or anything here,
2731 * except they are primes and SEED_C1 > 1E6 to get a full-width
2732 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2733 * probably be bigger too.
2736 # define SEED_C1 1000003
2737 #define SEED_C4 73819
2739 # define SEED_C1 25747
2740 #define SEED_C4 20639
2744 #define SEED_C5 26107
2746 #ifndef PERL_NO_DEV_RANDOM
2751 # include <starlet.h>
2752 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2753 * in 100-ns units, typically incremented ever 10 ms. */
2754 unsigned int when[2];
2756 # ifdef HAS_GETTIMEOFDAY
2757 struct timeval when;
2763 /* This test is an escape hatch, this symbol isn't set by Configure. */
2764 #ifndef PERL_NO_DEV_RANDOM
2765 #ifndef PERL_RANDOM_DEVICE
2766 /* /dev/random isn't used by default because reads from it will block
2767 * if there isn't enough entropy available. You can compile with
2768 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2769 * is enough real entropy to fill the seed. */
2770 # define PERL_RANDOM_DEVICE "/dev/urandom"
2772 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2774 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2783 _ckvmssts(sys$gettim(when));
2784 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2786 # ifdef HAS_GETTIMEOFDAY
2787 PerlProc_gettimeofday(&when,NULL);
2788 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2791 u = (U32)SEED_C1 * when;
2794 u += SEED_C3 * (U32)PerlProc_getpid();
2795 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2796 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2797 u += SEED_C5 * (U32)PTR2UV(&when);
2804 dSP; dTARGET; tryAMAGICun(exp);
2808 value = Perl_exp(value);
2816 dSP; dTARGET; tryAMAGICun(log);
2821 SET_NUMERIC_STANDARD();
2822 DIE(aTHX_ "Can't take log of %"NVgf, value);
2824 value = Perl_log(value);
2832 dSP; dTARGET; tryAMAGICun(sqrt);
2837 SET_NUMERIC_STANDARD();
2838 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2840 value = Perl_sqrt(value);
2847 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2848 * These need to be revisited when a newer toolchain becomes available.
2850 #if defined(__sparc64__) && defined(__GNUC__)
2851 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2852 # undef SPARC64_MODF_WORKAROUND
2853 # define SPARC64_MODF_WORKAROUND 1
2857 #if defined(SPARC64_MODF_WORKAROUND)
2859 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2862 ret = Perl_modf(theVal, &res);
2870 dSP; dTARGET; tryAMAGICun(int);
2873 IV iv = TOPi; /* attempt to convert to IV if possible. */
2874 /* XXX it's arguable that compiler casting to IV might be subtly
2875 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2876 else preferring IV has introduced a subtle behaviour change bug. OTOH
2877 relying on floating point to be accurate is a bug. */
2888 if (value < (NV)UV_MAX + 0.5) {
2891 #if defined(SPARC64_MODF_WORKAROUND)
2892 (void)sparc64_workaround_modf(value, &value);
2894 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2895 # ifdef HAS_MODFL_POW32_BUG
2896 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2898 NV offset = Perl_modf(value, &value);
2899 (void)Perl_modf(offset, &offset);
2903 (void)Perl_modf(value, &value);
2906 double tmp = (double)value;
2907 (void)Perl_modf(tmp, &tmp);
2915 if (value > (NV)IV_MIN - 0.5) {
2918 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2919 # ifdef HAS_MODFL_POW32_BUG
2920 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2922 NV offset = Perl_modf(-value, &value);
2923 (void)Perl_modf(offset, &offset);
2927 (void)Perl_modf(-value, &value);
2931 double tmp = (double)value;
2932 (void)Perl_modf(-tmp, &tmp);
2945 dSP; dTARGET; tryAMAGICun(abs);
2947 /* This will cache the NV value if string isn't actually integer */
2951 /* IVX is precise */
2953 SETu(TOPu); /* force it to be numeric only */
2961 /* 2s complement assumption. Also, not really needed as
2962 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2982 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2988 tmps = (SvPVx(sv, len));
2990 /* If Unicode, try to downgrade
2991 * If not possible, croak. */
2992 SV* tsv = sv_2mortal(newSVsv(sv));
2995 sv_utf8_downgrade(tsv, FALSE);
2998 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2999 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3012 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3018 tmps = (SvPVx(sv, len));
3020 /* If Unicode, try to downgrade
3021 * If not possible, croak. */
3022 SV* tsv = sv_2mortal(newSVsv(sv));
3025 sv_utf8_downgrade(tsv, FALSE);
3028 while (*tmps && len && isSPACE(*tmps))
3033 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3034 else if (*tmps == 'b')
3035 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3037 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3039 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3056 SETi(sv_len_utf8(sv));
3072 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3074 I32 arybase = PL_curcop->cop_arybase;
3078 int num_args = PL_op->op_private & 7;
3079 bool repl_need_utf8_upgrade = FALSE;
3080 bool repl_is_utf8 = FALSE;
3082 SvTAINTED_off(TARG); /* decontaminate */
3083 SvUTF8_off(TARG); /* decontaminate */
3087 repl = SvPV(repl_sv, repl_len);
3088 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3098 sv_utf8_upgrade(sv);
3100 else if (DO_UTF8(sv))
3101 repl_need_utf8_upgrade = TRUE;
3103 tmps = SvPV(sv, curlen);
3105 utf8_curlen = sv_len_utf8(sv);
3106 if (utf8_curlen == curlen)
3109 curlen = utf8_curlen;
3114 if (pos >= arybase) {
3132 else if (len >= 0) {
3134 if (rem > (I32)curlen)
3149 Perl_croak(aTHX_ "substr outside of string");
3150 if (ckWARN(WARN_SUBSTR))
3151 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3158 sv_pos_u2b(sv, &pos, &rem);
3160 sv_setpvn(TARG, tmps, rem);
3161 #ifdef USE_LOCALE_COLLATE
3162 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3167 SV* repl_sv_copy = NULL;
3169 if (repl_need_utf8_upgrade) {
3170 repl_sv_copy = newSVsv(repl_sv);
3171 sv_utf8_upgrade(repl_sv_copy);
3172 repl = SvPV(repl_sv_copy, repl_len);
3173 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3175 sv_insert(sv, pos, rem, repl, repl_len);
3179 SvREFCNT_dec(repl_sv_copy);
3181 else if (lvalue) { /* it's an lvalue! */
3182 if (!SvGMAGICAL(sv)) {
3186 if (ckWARN(WARN_SUBSTR))
3187 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3188 "Attempt to use reference as lvalue in substr");
3190 if (SvOK(sv)) /* is it defined ? */
3191 (void)SvPOK_only_UTF8(sv);
3193 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3196 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3197 TARG = sv_newmortal();
3198 if (SvTYPE(TARG) < SVt_PVLV) {
3199 sv_upgrade(TARG, SVt_PVLV);
3200 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3204 if (LvTARG(TARG) != sv) {
3206 SvREFCNT_dec(LvTARG(TARG));
3207 LvTARG(TARG) = SvREFCNT_inc(sv);
3209 LvTARGOFF(TARG) = upos;
3210 LvTARGLEN(TARG) = urem;
3214 PUSHs(TARG); /* avoid SvSETMAGIC here */
3221 register IV size = POPi;
3222 register IV offset = POPi;
3223 register SV *src = POPs;
3224 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3226 SvTAINTED_off(TARG); /* decontaminate */
3227 if (lvalue) { /* it's an lvalue! */
3228 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3229 TARG = sv_newmortal();
3230 if (SvTYPE(TARG) < SVt_PVLV) {
3231 sv_upgrade(TARG, SVt_PVLV);
3232 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3235 if (LvTARG(TARG) != src) {
3237 SvREFCNT_dec(LvTARG(TARG));
3238 LvTARG(TARG) = SvREFCNT_inc(src);
3240 LvTARGOFF(TARG) = offset;
3241 LvTARGLEN(TARG) = size;
3244 sv_setuv(TARG, do_vecget(src, offset, size));
3259 I32 arybase = PL_curcop->cop_arybase;
3264 offset = POPi - arybase;
3267 tmps = SvPV(big, biglen);
3268 if (offset > 0 && DO_UTF8(big))
3269 sv_pos_u2b(big, &offset, 0);
3272 else if (offset > (I32)biglen)
3274 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3275 (unsigned char*)tmps + biglen, little, 0)))
3278 retval = tmps2 - tmps;
3279 if (retval > 0 && DO_UTF8(big))
3280 sv_pos_b2u(big, &retval);
3281 PUSHi(retval + arybase);
3296 I32 arybase = PL_curcop->cop_arybase;
3302 tmps2 = SvPV(little, llen);
3303 tmps = SvPV(big, blen);
3307 if (offset > 0 && DO_UTF8(big))
3308 sv_pos_u2b(big, &offset, 0);
3309 offset = offset - arybase + llen;
3313 else if (offset > (I32)blen)
3315 if (!(tmps2 = rninstr(tmps, tmps + offset,
3316 tmps2, tmps2 + llen)))
3319 retval = tmps2 - tmps;
3320 if (retval > 0 && DO_UTF8(big))
3321 sv_pos_b2u(big, &retval);
3322 PUSHi(retval + arybase);
3328 dSP; dMARK; dORIGMARK; dTARGET;
3329 do_sprintf(TARG, SP-MARK, MARK+1);
3330 TAINT_IF(SvTAINTED(TARG));
3331 if (DO_UTF8(*(MARK+1)))
3343 U8 *s = (U8*)SvPVx(argsv, len);
3346 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3347 tmpsv = sv_2mortal(newSVsv(argsv));
3348 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3352 XPUSHu(DO_UTF8(argsv) ?
3353 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3365 (void)SvUPGRADE(TARG,SVt_PV);
3367 if (value > 255 && !IN_BYTES) {
3368 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3369 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3370 SvCUR_set(TARG, tmps - SvPVX(TARG));
3372 (void)SvPOK_only(TARG);
3381 *tmps++ = (char)value;
3383 (void)SvPOK_only(TARG);
3384 if (PL_encoding && !IN_BYTES) {
3385 sv_recode_to_utf8(TARG, PL_encoding);
3387 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3388 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3391 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3392 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3408 char *tmps = SvPV(left, len);
3410 if (DO_UTF8(left)) {
3411 /* If Unicode, try to downgrade.
3412 * If not possible, croak.
3413 * Yes, we made this up. */
3414 SV* tsv = sv_2mortal(newSVsv(left));
3417 sv_utf8_downgrade(tsv, FALSE);
3421 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3423 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3429 "The crypt() function is unimplemented due to excessive paranoia.");
3442 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3443 UTF8_IS_START(*s)) {
3444 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3448 utf8_to_uvchr(s, &ulen);
3449 toTITLE_utf8(s, tmpbuf, &tculen);
3450 utf8_to_uvchr(tmpbuf, 0);
3452 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3454 /* slen is the byte length of the whole SV.
3455 * ulen is the byte length of the original Unicode character
3456 * stored as UTF-8 at s.
3457 * tculen is the byte length of the freshly titlecased
3458 * Unicode character stored as UTF-8 at tmpbuf.
3459 * We first set the result to be the titlecased character,
3460 * and then append the rest of the SV data. */
3461 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3463 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3468 s = (U8*)SvPV_force_nomg(sv, slen);
3469 Copy(tmpbuf, s, tculen, U8);
3473 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3475 SvUTF8_off(TARG); /* decontaminate */
3476 sv_setsv_nomg(TARG, sv);
3480 s = (U8*)SvPV_force_nomg(sv, slen);
3482 if (IN_LOCALE_RUNTIME) {
3485 *s = toUPPER_LC(*s);
3504 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3505 UTF8_IS_START(*s)) {
3507 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3511 toLOWER_utf8(s, tmpbuf, &ulen);
3512 uv = utf8_to_uvchr(tmpbuf, 0);
3513 tend = uvchr_to_utf8(tmpbuf, uv);
3515 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3517 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3519 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3524 s = (U8*)SvPV_force_nomg(sv, slen);
3525 Copy(tmpbuf, s, ulen, U8);
3529 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3531 SvUTF8_off(TARG); /* decontaminate */
3532 sv_setsv_nomg(TARG, sv);
3536 s = (U8*)SvPV_force_nomg(sv, slen);
3538 if (IN_LOCALE_RUNTIME) {
3541 *s = toLOWER_LC(*s);
3564 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3566 s = (U8*)SvPV_nomg(sv,len);
3568 SvUTF8_off(TARG); /* decontaminate */
3569 sv_setpvn(TARG, "", 0);
3573 STRLEN nchar = utf8_length(s, s + len);
3575 (void)SvUPGRADE(TARG, SVt_PV);
3576 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3577 (void)SvPOK_only(TARG);
3578 d = (U8*)SvPVX(TARG);
3581 toUPPER_utf8(s, tmpbuf, &ulen);
3582 Copy(tmpbuf, d, ulen, U8);
3588 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3593 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3595 SvUTF8_off(TARG); /* decontaminate */
3596 sv_setsv_nomg(TARG, sv);
3600 s = (U8*)SvPV_force_nomg(sv, len);
3602 register U8 *send = s + len;
3604 if (IN_LOCALE_RUNTIME) {
3607 for (; s < send; s++)
3608 *s = toUPPER_LC(*s);
3611 for (; s < send; s++)
3633 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3635 s = (U8*)SvPV_nomg(sv,len);
3637 SvUTF8_off(TARG); /* decontaminate */
3638 sv_setpvn(TARG, "", 0);
3642 STRLEN nchar = utf8_length(s, s + len);
3644 (void)SvUPGRADE(TARG, SVt_PV);
3645 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3646 (void)SvPOK_only(TARG);
3647 d = (U8*)SvPVX(TARG);
3650 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3651 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3652 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3654 * Now if the sigma is NOT followed by
3655 * /$ignorable_sequence$cased_letter/;
3656 * and it IS preceded by
3657 * /$cased_letter$ignorable_sequence/;
3658 * where $ignorable_sequence is
3659 * [\x{2010}\x{AD}\p{Mn}]*
3660 * and $cased_letter is
3661 * [\p{Ll}\p{Lo}\p{Lt}]
3662 * then it should be mapped to 0x03C2,
3663 * (GREEK SMALL LETTER FINAL SIGMA),
3664 * instead of staying 0x03A3.
3665 * See lib/unicore/SpecCase.txt.
3668 Copy(tmpbuf, d, ulen, U8);
3674 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3679 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3681 SvUTF8_off(TARG); /* decontaminate */
3682 sv_setsv_nomg(TARG, sv);
3687 s = (U8*)SvPV_force_nomg(sv, len);
3689 register U8 *send = s + len;
3691 if (IN_LOCALE_RUNTIME) {
3694 for (; s < send; s++)
3695 *s = toLOWER_LC(*s);
3698 for (; s < send; s++)
3712 register char *s = SvPV(sv,len);
3715 SvUTF8_off(TARG); /* decontaminate */
3717 (void)SvUPGRADE(TARG, SVt_PV);
3718 SvGROW(TARG, (len * 2) + 1);
3722 if (UTF8_IS_CONTINUED(*s)) {
3723 STRLEN ulen = UTF8SKIP(s);
3747 SvCUR_set(TARG, d - SvPVX(TARG));
3748 (void)SvPOK_only_UTF8(TARG);
3751 sv_setpvn(TARG, s, len);
3753 if (SvSMAGICAL(TARG))
3762 dSP; dMARK; dORIGMARK;
3764 register AV* av = (AV*)POPs;
3765 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3766 I32 arybase = PL_curcop->cop_arybase;
3769 if (SvTYPE(av) == SVt_PVAV) {
3770 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3772 for (svp = MARK + 1; svp <= SP; svp++) {
3777 if (max > AvMAX(av))
3780 while (++MARK <= SP) {
3781 elem = SvIVx(*MARK);
3785 svp = av_fetch(av, elem, lval);
3787 if (!svp || *svp == &PL_sv_undef)
3788 DIE(aTHX_ PL_no_aelem, elem);
3789 if (PL_op->op_private & OPpLVAL_INTRO)
3790 save_aelem(av, elem, svp);
3792 *MARK = svp ? *svp : &PL_sv_undef;
3795 if (GIMME != G_ARRAY) {
3803 /* Associative arrays. */
3808 HV *hash = (HV*)POPs;
3810 I32 gimme = GIMME_V;
3813 /* might clobber stack_sp */
3814 entry = hv_iternext(hash);
3819 SV* sv = hv_iterkeysv(entry);
3820 PUSHs(sv); /* won't clobber stack_sp */
3821 if (gimme == G_ARRAY) {
3824 /* might clobber stack_sp */
3825 val = hv_iterval(hash, entry);
3830 else if (gimme == G_SCALAR)
3849 I32 gimme = GIMME_V;
3850 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3854 if (PL_op->op_private & OPpSLICE) {
3858 hvtype = SvTYPE(hv);
3859 if (hvtype == SVt_PVHV) { /* hash element */
3860 while (++MARK <= SP) {
3861 sv = hv_delete_ent(hv, *MARK, discard, 0);
3862 *MARK = sv ? sv : &PL_sv_undef;
3865 else if (hvtype == SVt_PVAV) { /* array element */
3866 if (PL_op->op_flags & OPf_SPECIAL) {
3867 while (++MARK <= SP) {
3868 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3869 *MARK = sv ? sv : &PL_sv_undef;
3874 DIE(aTHX_ "Not a HASH reference");
3877 else if (gimme == G_SCALAR) {
3886 if (SvTYPE(hv) == SVt_PVHV)
3887 sv = hv_delete_ent(hv, keysv, discard, 0);
3888 else if (SvTYPE(hv) == SVt_PVAV) {
3889 if (PL_op->op_flags & OPf_SPECIAL)
3890 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3892 DIE(aTHX_ "panic: avhv_delete no longer supported");
3895 DIE(aTHX_ "Not a HASH reference");
3910 if (PL_op->op_private & OPpEXISTS_SUB) {
3914 cv = sv_2cv(sv, &hv, &gv, FALSE);
3917 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3923 if (SvTYPE(hv) == SVt_PVHV) {
3924 if (hv_exists_ent(hv, tmpsv, 0))
3927 else if (SvTYPE(hv) == SVt_PVAV) {
3928 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3929 if (av_exists((AV*)hv, SvIV(tmpsv)))
3934 DIE(aTHX_ "Not a HASH reference");
3941 dSP; dMARK; dORIGMARK;
3942 register HV *hv = (HV*)POPs;
3943 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3944 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3945 bool other_magic = FALSE;
3951 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3952 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3953 /* Try to preserve the existenceness of a tied hash
3954 * element by using EXISTS and DELETE if possible.
3955 * Fallback to FETCH and STORE otherwise */
3956 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3957 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3958 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3961 while (++MARK <= SP) {
3965 bool preeminent = FALSE;
3968 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3969 hv_exists_ent(hv, keysv, 0);
3972 he = hv_fetch_ent(hv, keysv, lval, 0);
3973 svp = he ? &HeVAL(he) : 0;
3976 if (!svp || *svp == &PL_sv_undef) {
3978 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3982 save_helem(hv, keysv, svp);
3985 char *key = SvPV(keysv, keylen);
3986 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3990 *MARK = svp ? *svp : &PL_sv_undef;
3992 if (GIMME != G_ARRAY) {
4000 /* List operators. */
4005 if (GIMME != G_ARRAY) {
4007 *MARK = *SP; /* unwanted list, return last item */
4009 *MARK = &PL_sv_undef;
4018 SV **lastrelem = PL_stack_sp;
4019 SV **lastlelem = PL_stack_base + POPMARK;
4020 SV **firstlelem = PL_stack_base + POPMARK + 1;
4021 register SV **firstrelem = lastlelem + 1;
4022 I32 arybase = PL_curcop->cop_arybase;
4023 I32 lval = PL_op->op_flags & OPf_MOD;
4024 I32 is_something_there = lval;
4026 register I32 max = lastrelem - lastlelem;
4027 register SV **lelem;
4030 if (GIMME != G_ARRAY) {
4031 ix = SvIVx(*lastlelem);
4036 if (ix < 0 || ix >= max)
4037 *firstlelem = &PL_sv_undef;
4039 *firstlelem = firstrelem[ix];
4045 SP = firstlelem - 1;
4049 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4055 if (ix < 0 || ix >= max)
4056 *lelem = &PL_sv_undef;
4058 is_something_there = TRUE;
4059 if (!(*lelem = firstrelem[ix]))
4060 *lelem = &PL_sv_undef;
4063 if (is_something_there)
4066 SP = firstlelem - 1;
4072 dSP; dMARK; dORIGMARK;
4073 I32 items = SP - MARK;
4074 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4075 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4082 dSP; dMARK; dORIGMARK;
4083 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4087 SV *val = NEWSV(46, 0);
4089 sv_setsv(val, *++MARK);
4090 else if (ckWARN(WARN_MISC))
4091 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4092 (void)hv_store_ent(hv,key,val,0);
4101 dSP; dMARK; dORIGMARK;
4102 register AV *ary = (AV*)*++MARK;
4106 register I32 offset;
4107 register I32 length;
4114 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4115 *MARK-- = SvTIED_obj((SV*)ary, mg);
4119 call_method("SPLICE",GIMME_V);
4128 offset = i = SvIVx(*MARK);
4130 offset += AvFILLp(ary) + 1;
4132 offset -= PL_curcop->cop_arybase;
4134 DIE(aTHX_ PL_no_aelem, i);
4136 length = SvIVx(*MARK++);
4138 length += AvFILLp(ary) - offset + 1;
4144 length = AvMAX(ary) + 1; /* close enough to infinity */
4148 length = AvMAX(ary) + 1;
4150 if (offset > AvFILLp(ary) + 1) {
4151 if (ckWARN(WARN_MISC))
4152 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4153 offset = AvFILLp(ary) + 1;
4155 after = AvFILLp(ary) + 1 - (offset + length);
4156 if (after < 0) { /* not that much array */
4157 length += after; /* offset+length now in array */
4163 /* At this point, MARK .. SP-1 is our new LIST */
4166 diff = newlen - length;
4167 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4170 if (diff < 0) { /* shrinking the area */
4172 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4173 Copy(MARK, tmparyval, newlen, SV*);
4176 MARK = ORIGMARK + 1;
4177 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4178 MEXTEND(MARK, length);
4179 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4181 EXTEND_MORTAL(length);
4182 for (i = length, dst = MARK; i; i--) {
4183 sv_2mortal(*dst); /* free them eventualy */
4190 *MARK = AvARRAY(ary)[offset+length-1];
4193 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4194 SvREFCNT_dec(*dst++); /* free them now */
4197 AvFILLp(ary) += diff;
4199 /* pull up or down? */
4201 if (offset < after) { /* easier to pull up */
4202 if (offset) { /* esp. if nothing to pull */
4203 src = &AvARRAY(ary)[offset-1];
4204 dst = src - diff; /* diff is negative */
4205 for (i = offset; i > 0; i--) /* can't trust Copy */
4209 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4213 if (after) { /* anything to pull down? */
4214 src = AvARRAY(ary) + offset + length;
4215 dst = src + diff; /* diff is negative */
4216 Move(src, dst, after, SV*);
4218 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4219 /* avoid later double free */
4223 dst[--i] = &PL_sv_undef;
4226 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4228 *dst = NEWSV(46, 0);
4229 sv_setsv(*dst++, *src++);
4231 Safefree(tmparyval);
4234 else { /* no, expanding (or same) */
4236 New(452, tmparyval, length, SV*); /* so remember deletion */
4237 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4240 if (diff > 0) { /* expanding */
4242 /* push up or down? */
4244 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4248 Move(src, dst, offset, SV*);
4250 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4252 AvFILLp(ary) += diff;
4255 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4256 av_extend(ary, AvFILLp(ary) + diff);
4257 AvFILLp(ary) += diff;
4260 dst = AvARRAY(ary) + AvFILLp(ary);
4262 for (i = after; i; i--) {
4269 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4270 *dst = NEWSV(46, 0);
4271 sv_setsv(*dst++, *src++);
4273 MARK = ORIGMARK + 1;
4274 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4276 Copy(tmparyval, MARK, length, SV*);
4278 EXTEND_MORTAL(length);
4279 for (i = length, dst = MARK; i; i--) {
4280 sv_2mortal(*dst); /* free them eventualy */
4284 Safefree(tmparyval);
4288 else if (length--) {
4289 *MARK = tmparyval[length];
4292 while (length-- > 0)
4293 SvREFCNT_dec(tmparyval[length]);
4295 Safefree(tmparyval);
4298 *MARK = &PL_sv_undef;
4306 dSP; dMARK; dORIGMARK; dTARGET;
4307 register AV *ary = (AV*)*++MARK;
4308 register SV *sv = &PL_sv_undef;
4311 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4312 *MARK-- = SvTIED_obj((SV*)ary, mg);
4316 call_method("PUSH",G_SCALAR|G_DISCARD);
4321 /* Why no pre-extend of ary here ? */
4322 for (++MARK; MARK <= SP; MARK++) {
4325 sv_setsv(sv, *MARK);
4330 PUSHi( AvFILL(ary) + 1 );
4338 SV *sv = av_pop(av);
4340 (void)sv_2mortal(sv);
4349 SV *sv = av_shift(av);
4354 (void)sv_2mortal(sv);
4361 dSP; dMARK; dORIGMARK; dTARGET;
4362 register AV *ary = (AV*)*++MARK;
4367 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4368 *MARK-- = SvTIED_obj((SV*)ary, mg);
4372 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4377 av_unshift(ary, SP - MARK);
4380 sv_setsv(sv, *++MARK);
4381 (void)av_store(ary, i++, sv);
4385 PUSHi( AvFILL(ary) + 1 );
4395 if (GIMME == G_ARRAY) {
4402 /* safe as long as stack cannot get extended in the above */
4407 register char *down;
4412 SvUTF8_off(TARG); /* decontaminate */
4414 do_join(TARG, &PL_sv_no, MARK, SP);
4416 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4417 up = SvPV_force(TARG, len);
4419 if (DO_UTF8(TARG)) { /* first reverse each character */
4420 U8* s = (U8*)SvPVX(TARG);
4421 U8* send = (U8*)(s + len);
4423 if (UTF8_IS_INVARIANT(*s)) {
4428 if (!utf8_to_uvchr(s, 0))
4432 down = (char*)(s - 1);
4433 /* reverse this character */
4437 *down-- = (char)tmp;
4443 down = SvPVX(TARG) + len - 1;
4447 *down-- = (char)tmp;
4449 (void)SvPOK_only_UTF8(TARG);
4461 register IV limit = POPi; /* note, negative is forever */
4464 register char *s = SvPV(sv, len);
4465 bool do_utf8 = DO_UTF8(sv);
4466 char *strend = s + len;
4468 register REGEXP *rx;
4472 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4473 I32 maxiters = slen + 10;
4476 I32 origlimit = limit;
4479 AV *oldstack = PL_curstack;
4480 I32 gimme = GIMME_V;
4481 I32 oldsave = PL_savestack_ix;
4482 I32 make_mortal = 1;
4483 MAGIC *mg = (MAGIC *) NULL;
4486 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4491 DIE(aTHX_ "panic: pp_split");
4494 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4495 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4497 RX_MATCH_UTF8_set(rx, do_utf8);
4499 if (pm->op_pmreplroot) {
4501 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4503 ary = GvAVn((GV*)pm->op_pmreplroot);
4506 else if (gimme != G_ARRAY)
4507 ary = GvAVn(PL_defgv);
4510 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4516 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4518 XPUSHs(SvTIED_obj((SV*)ary, mg));
4524 for (i = AvFILLp(ary); i >= 0; i--)
4525 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4527 /* temporarily switch stacks */
4528 SWITCHSTACK(PL_curstack, ary);
4529 PL_curstackinfo->si_stack = ary;
4533 base = SP - PL_stack_base;
4535 if (pm->op_pmflags & PMf_SKIPWHITE) {
4536 if (pm->op_pmflags & PMf_LOCALE) {
4537 while (isSPACE_LC(*s))
4545 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4546 SAVEINT(PL_multiline);
4547 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4551 limit = maxiters + 2;
4552 if (pm->op_pmflags & PMf_WHITE) {
4555 while (m < strend &&
4556 !((pm->op_pmflags & PMf_LOCALE)
4557 ? isSPACE_LC(*m) : isSPACE(*m)))
4562 dstr = NEWSV(30, m-s);
4563 sv_setpvn(dstr, s, m-s);
4567 (void)SvUTF8_on(dstr);
4571 while (s < strend &&
4572 ((pm->op_pmflags & PMf_LOCALE)
4573 ? isSPACE_LC(*s) : isSPACE(*s)))
4577 else if (strEQ("^", rx->precomp)) {
4580 for (m = s; m < strend && *m != '\n'; m++) ;
4584 dstr = NEWSV(30, m-s);
4585 sv_setpvn(dstr, s, m-s);
4589 (void)SvUTF8_on(dstr);
4594 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4595 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4596 && (rx->reganch & ROPT_CHECK_ALL)
4597 && !(rx->reganch & ROPT_ANCH)) {
4598 int tail = (rx->reganch & RE_INTUIT_TAIL);
4599 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4602 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4604 char c = *SvPV(csv, n_a);
4607 for (m = s; m < strend && *m != c; m++) ;
4610 dstr = NEWSV(30, m-s);
4611 sv_setpvn(dstr, s, m-s);
4615 (void)SvUTF8_on(dstr);
4617 /* The rx->minlen is in characters but we want to step
4618 * s ahead by bytes. */
4620 s = (char*)utf8_hop((U8*)m, len);
4622 s = m + len; /* Fake \n at the end */
4627 while (s < strend && --limit &&
4628 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4629 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4632 dstr = NEWSV(31, m-s);
4633 sv_setpvn(dstr, s, m-s);
4637 (void)SvUTF8_on(dstr);
4639 /* The rx->minlen is in characters but we want to step
4640 * s ahead by bytes. */
4642 s = (char*)utf8_hop((U8*)m, len);
4644 s = m + len; /* Fake \n at the end */
4649 maxiters += slen * rx->nparens;
4650 while (s < strend && --limit
4651 /* && (!rx->check_substr
4652 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4654 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4655 1 /* minend */, sv, NULL, 0))
4657 TAINT_IF(RX_MATCH_TAINTED(rx));
4658 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4663 strend = s + (strend - m);
4665 m = rx->startp[0] + orig;
4666 dstr = NEWSV(32, m-s);
4667 sv_setpvn(dstr, s, m-s);
4671 (void)SvUTF8_on(dstr);
4674 for (i = 1; i <= (I32)rx->nparens; i++) {
4675 s = rx->startp[i] + orig;
4676 m = rx->endp[i] + orig;
4678 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4679 parens that didn't match -- they should be set to
4680 undef, not the empty string */
4681 if (m >= orig && s >= orig) {
4682 dstr = NEWSV(33, m-s);
4683 sv_setpvn(dstr, s, m-s);
4686 dstr = &PL_sv_undef; /* undef, not "" */
4690 (void)SvUTF8_on(dstr);
4694 s = rx->endp[0] + orig;
4699 LEAVE_SCOPE(oldsave);
4700 iters = (SP - PL_stack_base) - base;
4701 if (iters > maxiters)
4702 DIE(aTHX_ "Split loop");
4704 /* keep field after final delim? */
4705 if (s < strend || (iters && origlimit)) {
4706 STRLEN l = strend - s;
4707 dstr = NEWSV(34, l);
4708 sv_setpvn(dstr, s, l);
4712 (void)SvUTF8_on(dstr);
4716 else if (!origlimit) {
4717 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4718 if (TOPs && !make_mortal)
4727 SWITCHSTACK(ary, oldstack);
4728 PL_curstackinfo->si_stack = oldstack;
4729 if (SvSMAGICAL(ary)) {
4734 if (gimme == G_ARRAY) {
4736 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4744 call_method("PUSH",G_SCALAR|G_DISCARD);
4747 if (gimme == G_ARRAY) {
4748 /* EXTEND should not be needed - we just popped them */
4750 for (i=0; i < iters; i++) {
4751 SV **svp = av_fetch(ary, i, FALSE);
4752 PUSHs((svp) ? *svp : &PL_sv_undef);
4759 if (gimme == G_ARRAY)
4762 if (iters || !pm->op_pmreplroot) {
4776 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4777 || SvTYPE(retsv) == SVt_PVCV) {
4778 retsv = refto(retsv);
4786 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");