3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
23 /* XXX I can't imagine anyone who doesn't have this actually _needs_
24 it, since pid_t is an integral type.
27 #ifdef NEED_GETPID_PROTO
28 extern Pid_t getpid (void);
31 /* variations on pp_null */
36 if (GIMME_V == G_SCALAR)
52 if (PL_op->op_private & OPpLVAL_INTRO)
53 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
55 if (PL_op->op_flags & OPf_REF) {
59 if (GIMME == G_SCALAR)
60 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
65 if (gimme == G_ARRAY) {
66 I32 maxarg = AvFILL((AV*)TARG) + 1;
68 if (SvMAGICAL(TARG)) {
70 for (i=0; i < (U32)maxarg; i++) {
71 SV **svp = av_fetch((AV*)TARG, i, FALSE);
72 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
76 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
80 else if (gimme == G_SCALAR) {
81 SV* sv = sv_newmortal();
82 I32 maxarg = AvFILL((AV*)TARG) + 1;
95 if (PL_op->op_private & OPpLVAL_INTRO)
96 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
97 if (PL_op->op_flags & OPf_REF)
100 if (GIMME == G_SCALAR)
101 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
105 if (gimme == G_ARRAY) {
108 else if (gimme == G_SCALAR) {
109 SV* sv = 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);
176 if (PL_op->op_flags & OPf_REF ||
177 PL_op->op_private & HINT_STRICT_REFS)
178 DIE(aTHX_ PL_no_usym, "a symbol");
179 if (ckWARN(WARN_UNINITIALIZED))
184 if ((PL_op->op_flags & OPf_SPECIAL) &&
185 !(PL_op->op_flags & OPf_MOD))
187 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
189 && (!is_gv_magical(sym,len,0)
190 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
196 if (PL_op->op_private & HINT_STRICT_REFS)
197 DIE(aTHX_ PL_no_symref, sym, "a symbol");
198 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
202 if (PL_op->op_private & OPpLVAL_INTRO)
203 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
215 tryAMAGICunDEREF(to_sv);
218 switch (SvTYPE(sv)) {
222 DIE(aTHX_ "Not a SCALAR reference");
230 if (SvTYPE(gv) != SVt_PVGV) {
231 if (SvGMAGICAL(sv)) {
237 if (PL_op->op_flags & OPf_REF ||
238 PL_op->op_private & HINT_STRICT_REFS)
239 DIE(aTHX_ PL_no_usym, "a SCALAR");
240 if (ckWARN(WARN_UNINITIALIZED))
245 if ((PL_op->op_flags & OPf_SPECIAL) &&
246 !(PL_op->op_flags & OPf_MOD))
248 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
250 && (!is_gv_magical(sym,len,0)
251 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
257 if (PL_op->op_private & HINT_STRICT_REFS)
258 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
259 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
264 if (PL_op->op_flags & OPf_MOD) {
265 if (PL_op->op_private & OPpLVAL_INTRO) {
266 if (cUNOP->op_first->op_type == OP_NULL)
267 sv = save_scalar((GV*)TOPs);
269 sv = save_scalar(gv);
271 Perl_croak(aTHX_ PL_no_localize_ref);
273 else if (PL_op->op_private & OPpDEREF)
274 vivify_ref(sv, PL_op->op_private & OPpDEREF);
284 SV *sv = AvARYLEN(av);
286 AvARYLEN(av) = sv = NEWSV(0,0);
287 sv_upgrade(sv, SVt_IV);
288 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
296 dSP; dTARGET; dPOPss;
298 if (PL_op->op_flags & OPf_MOD || LVRET) {
299 if (SvTYPE(TARG) < SVt_PVLV) {
300 sv_upgrade(TARG, SVt_PVLV);
301 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
305 if (LvTARG(TARG) != sv) {
307 SvREFCNT_dec(LvTARG(TARG));
308 LvTARG(TARG) = SvREFCNT_inc(sv);
310 PUSHs(TARG); /* no SvSETMAGIC */
316 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
317 mg = mg_find(sv, PERL_MAGIC_regex_global);
318 if (mg && mg->mg_len >= 0) {
322 PUSHi(i + PL_curcop->cop_arybase);
336 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
337 /* (But not in defined().) */
338 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
341 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
342 if ((PL_op->op_private & OPpLVAL_INTRO)) {
343 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
346 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
350 cv = (CV*)&PL_sv_undef;
364 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
365 char *s = SvPVX(TOPs);
366 if (strnEQ(s, "CORE::", 6)) {
369 code = keyword(s + 6, SvCUR(TOPs) - 6);
370 if (code < 0) { /* Overridable. */
371 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
372 int i = 0, n = 0, seen_question = 0;
374 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
376 if (code == -KEY_chop || code == -KEY_chomp)
378 while (i < MAXO) { /* The slow way. */
379 if (strEQ(s + 6, PL_op_name[i])
380 || strEQ(s + 6, PL_op_desc[i]))
386 goto nonesuch; /* Should not happen... */
388 oa = PL_opargs[i] >> OASHIFT;
390 if (oa & OA_OPTIONAL && !seen_question) {
394 else if (n && str[0] == ';' && seen_question)
395 goto set; /* XXXX system, exec */
396 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
397 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
398 /* But globs are already references (kinda) */
399 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
403 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
407 ret = sv_2mortal(newSVpvn(str, n - 1));
409 else if (code) /* Non-Overridable */
411 else { /* None such */
413 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
417 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
419 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
428 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
430 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
446 if (GIMME != G_ARRAY) {
450 *MARK = &PL_sv_undef;
451 *MARK = refto(*MARK);
455 EXTEND_MORTAL(SP - MARK);
457 *MARK = refto(*MARK);
462 S_refto(pTHX_ SV *sv)
466 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
469 if (!(sv = LvTARG(sv)))
472 (void)SvREFCNT_inc(sv);
474 else if (SvTYPE(sv) == SVt_PVAV) {
475 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
478 (void)SvREFCNT_inc(sv);
480 else if (SvPADTMP(sv) && !IS_PADGV(sv))
484 (void)SvREFCNT_inc(sv);
487 sv_upgrade(rv, SVt_RV);
501 if (sv && SvGMAGICAL(sv))
504 if (!sv || !SvROK(sv))
508 pv = sv_reftype(sv,TRUE);
509 PUSHp(pv, strlen(pv));
519 stash = CopSTASH(PL_curcop);
525 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
526 Perl_croak(aTHX_ "Attempt to bless into a reference");
528 if (ckWARN(WARN_MISC) && len == 0)
529 Perl_warner(aTHX_ packWARN(WARN_MISC),
530 "Explicit blessing to '' (assuming package main)");
531 stash = gv_stashpvn(ptr, len, TRUE);
534 (void)sv_bless(TOPs, stash);
548 elem = SvPV(sv, n_a);
552 switch (elem ? *elem : '\0')
555 if (strEQ(elem, "ARRAY"))
556 tmpRef = (SV*)GvAV(gv);
559 if (strEQ(elem, "CODE"))
560 tmpRef = (SV*)GvCVu(gv);
563 if (strEQ(elem, "FILEHANDLE")) {
564 /* finally deprecated in 5.8.0 */
565 deprecate("*glob{FILEHANDLE}");
566 tmpRef = (SV*)GvIOp(gv);
569 if (strEQ(elem, "FORMAT"))
570 tmpRef = (SV*)GvFORM(gv);
573 if (strEQ(elem, "GLOB"))
577 if (strEQ(elem, "HASH"))
578 tmpRef = (SV*)GvHV(gv);
581 if (strEQ(elem, "IO"))
582 tmpRef = (SV*)GvIOp(gv);
585 if (strEQ(elem, "NAME"))
586 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
589 if (strEQ(elem, "PACKAGE")) {
590 if (HvNAME(GvSTASH(gv)))
591 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
593 sv = newSVpv("__ANON__",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)
683 else if (PL_op->op_private & OPpTARGET_MY)
689 TARG = sv_newmortal();
694 /* Lvalue operators. */
706 dSP; dMARK; dTARGET; dORIGMARK;
708 do_chop(TARG, *++MARK);
717 SETi(do_chomp(TOPs));
724 register I32 count = 0;
727 count += do_chomp(POPs);
738 if (!sv || !SvANY(sv))
740 switch (SvTYPE(sv)) {
742 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
743 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
747 if (HvARRAY(sv) || SvGMAGICAL(sv)
748 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
752 if (CvROOT(sv) || CvXSUB(sv))
769 if (!PL_op->op_private) {
778 SV_CHECK_THINKFIRST_COW_DROP(sv);
780 switch (SvTYPE(sv)) {
790 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
791 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
792 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
796 /* let user-undef'd sub keep its identity */
797 GV* gv = CvGV((CV*)sv);
804 SvSetMagicSV(sv, &PL_sv_undef);
808 Newz(602, gp, 1, GP);
809 GvGP(sv) = gp_ref(gp);
810 GvSV(sv) = NEWSV(72,0);
811 GvLINE(sv) = CopLINE(PL_curcop);
817 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
820 SvPV_set(sv, Nullch);
833 if (SvTYPE(TOPs) > SVt_PVLV)
834 DIE(aTHX_ PL_no_modify);
835 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
836 && SvIVX(TOPs) != IV_MIN)
839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
850 if (SvTYPE(TOPs) > SVt_PVLV)
851 DIE(aTHX_ PL_no_modify);
852 sv_setsv(TARG, TOPs);
853 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
854 && SvIVX(TOPs) != IV_MAX)
857 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
862 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
872 if (SvTYPE(TOPs) > SVt_PVLV)
873 DIE(aTHX_ PL_no_modify);
874 sv_setsv(TARG, TOPs);
875 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
876 && SvIVX(TOPs) != IV_MIN)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
888 /* Ordinary operators. */
893 #ifdef PERL_PRESERVE_IVUV
896 tryAMAGICbin(pow,opASSIGN);
897 #ifdef PERL_PRESERVE_IVUV
898 /* For integer to integer power, we do the calculation by hand wherever
899 we're sure it is safe; otherwise we call pow() and try to convert to
900 integer afterwards. */
904 bool baseuok = SvUOK(TOPm1s);
908 baseuv = SvUVX(TOPm1s);
910 IV iv = SvIVX(TOPm1s);
913 baseuok = TRUE; /* effectively it's a UV now */
915 baseuv = -iv; /* abs, baseuok == false records sign */
929 goto float_it; /* Can't do negative powers this way. */
932 /* now we have integer ** positive integer. */
935 /* foo & (foo - 1) is zero only for a power of 2. */
936 if (!(baseuv & (baseuv - 1))) {
937 /* We are raising power-of-2 to a positive integer.
938 The logic here will work for any base (even non-integer
939 bases) but it can be less accurate than
940 pow (base,power) or exp (power * log (base)) when the
941 intermediate values start to spill out of the mantissa.
942 With powers of 2 we know this can't happen.
943 And powers of 2 are the favourite thing for perl
944 programmers to notice ** not doing what they mean. */
946 NV base = baseuok ? baseuv : -(NV)baseuv;
949 for (; power; base *= base, n++) {
950 /* Do I look like I trust gcc with long longs here?
952 UV bit = (UV)1 << (UV)n;
955 /* Only bother to clear the bit if it is set. */
957 /* Avoid squaring base again if we're done. */
958 if (power == 0) break;
966 register unsigned int highbit = 8 * sizeof(UV);
967 register unsigned int lowbit = 0;
968 register unsigned int diff;
969 bool odd_power = (bool)(power & 1);
970 while ((diff = (highbit - lowbit) >> 1)) {
971 if (baseuv & ~((1 << (lowbit + diff)) - 1))
976 /* we now have baseuv < 2 ** highbit */
977 if (power * highbit <= 8 * sizeof(UV)) {
978 /* result will definitely fit in UV, so use UV math
979 on same algorithm as above */
980 register UV result = 1;
981 register UV base = baseuv;
983 for (; power; base *= base, n++) {
984 register UV bit = (UV)1 << (UV)n;
988 if (power == 0) break;
992 if (baseuok || !odd_power)
993 /* answer is positive */
995 else if (result <= (UV)IV_MAX)
996 /* answer negative, fits in IV */
998 else if (result == (UV)IV_MIN)
999 /* 2's complement assumption: special case IV_MIN */
1002 /* answer negative, doesn't fit */
1003 SETn( -(NV)result );
1014 SETn( Perl_pow( left, right) );
1015 #ifdef PERL_PRESERVE_IVUV
1025 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1026 #ifdef PERL_PRESERVE_IVUV
1029 /* Unless the left argument is integer in range we are going to have to
1030 use NV maths. Hence only attempt to coerce the right argument if
1031 we know the left is integer. */
1032 /* Left operand is defined, so is it IV? */
1033 SvIV_please(TOPm1s);
1034 if (SvIOK(TOPm1s)) {
1035 bool auvok = SvUOK(TOPm1s);
1036 bool buvok = SvUOK(TOPs);
1037 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1038 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1045 alow = SvUVX(TOPm1s);
1047 IV aiv = SvIVX(TOPm1s);
1050 auvok = TRUE; /* effectively it's a UV now */
1052 alow = -aiv; /* abs, auvok == false records sign */
1058 IV biv = SvIVX(TOPs);
1061 buvok = TRUE; /* effectively it's a UV now */
1063 blow = -biv; /* abs, buvok == false records sign */
1067 /* If this does sign extension on unsigned it's time for plan B */
1068 ahigh = alow >> (4 * sizeof (UV));
1070 bhigh = blow >> (4 * sizeof (UV));
1072 if (ahigh && bhigh) {
1073 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1074 which is overflow. Drop to NVs below. */
1075 } else if (!ahigh && !bhigh) {
1076 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1077 so the unsigned multiply cannot overflow. */
1078 UV product = alow * blow;
1079 if (auvok == buvok) {
1080 /* -ve * -ve or +ve * +ve gives a +ve result. */
1084 } else if (product <= (UV)IV_MIN) {
1085 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1086 /* -ve result, which could overflow an IV */
1088 SETi( -(IV)product );
1090 } /* else drop to NVs below. */
1092 /* One operand is large, 1 small */
1095 /* swap the operands */
1097 bhigh = blow; /* bhigh now the temp var for the swap */
1101 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1102 multiplies can't overflow. shift can, add can, -ve can. */
1103 product_middle = ahigh * blow;
1104 if (!(product_middle & topmask)) {
1105 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1107 product_middle <<= (4 * sizeof (UV));
1108 product_low = alow * blow;
1110 /* as for pp_add, UV + something mustn't get smaller.
1111 IIRC ANSI mandates this wrapping *behaviour* for
1112 unsigned whatever the actual representation*/
1113 product_low += product_middle;
1114 if (product_low >= product_middle) {
1115 /* didn't overflow */
1116 if (auvok == buvok) {
1117 /* -ve * -ve or +ve * +ve gives a +ve result. */
1119 SETu( product_low );
1121 } else if (product_low <= (UV)IV_MIN) {
1122 /* 2s complement assumption again */
1123 /* -ve result, which could overflow an IV */
1125 SETi( -(IV)product_low );
1127 } /* else drop to NVs below. */
1129 } /* product_middle too large */
1130 } /* ahigh && bhigh */
1131 } /* SvIOK(TOPm1s) */
1136 SETn( left * right );
1143 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1144 /* Only try to do UV divide first
1145 if ((SLOPPYDIVIDE is true) or
1146 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1148 The assumption is that it is better to use floating point divide
1149 whenever possible, only doing integer divide first if we can't be sure.
1150 If NV_PRESERVES_UV is true then we know at compile time that no UV
1151 can be too large to preserve, so don't need to compile the code to
1152 test the size of UVs. */
1155 # define PERL_TRY_UV_DIVIDE
1156 /* ensure that 20./5. == 4. */
1158 # ifdef PERL_PRESERVE_IVUV
1159 # ifndef NV_PRESERVES_UV
1160 # define PERL_TRY_UV_DIVIDE
1165 #ifdef PERL_TRY_UV_DIVIDE
1168 SvIV_please(TOPm1s);
1169 if (SvIOK(TOPm1s)) {
1170 bool left_non_neg = SvUOK(TOPm1s);
1171 bool right_non_neg = SvUOK(TOPs);
1175 if (right_non_neg) {
1176 right = SvUVX(TOPs);
1179 IV biv = SvIVX(TOPs);
1182 right_non_neg = TRUE; /* effectively it's a UV now */
1188 /* historically undef()/0 gives a "Use of uninitialized value"
1189 warning before dieing, hence this test goes here.
1190 If it were immediately before the second SvIV_please, then
1191 DIE() would be invoked before left was even inspected, so
1192 no inpsection would give no warning. */
1194 DIE(aTHX_ "Illegal division by zero");
1197 left = SvUVX(TOPm1s);
1200 IV aiv = SvIVX(TOPm1s);
1203 left_non_neg = TRUE; /* effectively it's a UV now */
1212 /* For sloppy divide we always attempt integer division. */
1214 /* Otherwise we only attempt it if either or both operands
1215 would not be preserved by an NV. If both fit in NVs
1216 we fall through to the NV divide code below. However,
1217 as left >= right to ensure integer result here, we know that
1218 we can skip the test on the right operand - right big
1219 enough not to be preserved can't get here unless left is
1222 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1225 /* Integer division can't overflow, but it can be imprecise. */
1226 UV result = left / right;
1227 if (result * right == left) {
1228 SP--; /* result is valid */
1229 if (left_non_neg == right_non_neg) {
1230 /* signs identical, result is positive. */
1234 /* 2s complement assumption */
1235 if (result <= (UV)IV_MIN)
1236 SETi( -(IV)result );
1238 /* It's exact but too negative for IV. */
1239 SETn( -(NV)result );
1242 } /* tried integer divide but it was not an integer result */
1243 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1244 } /* left wasn't SvIOK */
1245 } /* right wasn't SvIOK */
1246 #endif /* PERL_TRY_UV_DIVIDE */
1250 DIE(aTHX_ "Illegal division by zero");
1251 PUSHn( left / right );
1258 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1262 bool left_neg = FALSE;
1263 bool right_neg = FALSE;
1264 bool use_double = FALSE;
1265 bool dright_valid = FALSE;
1271 right_neg = !SvUOK(TOPs);
1273 right = SvUVX(POPs);
1275 IV biv = SvIVX(POPs);
1278 right_neg = FALSE; /* effectively it's a UV now */
1286 right_neg = dright < 0;
1289 if (dright < UV_MAX_P1) {
1290 right = U_V(dright);
1291 dright_valid = TRUE; /* In case we need to use double below. */
1297 /* At this point use_double is only true if right is out of range for
1298 a UV. In range NV has been rounded down to nearest UV and
1299 use_double false. */
1301 if (!use_double && SvIOK(TOPs)) {
1303 left_neg = !SvUOK(TOPs);
1307 IV aiv = SvIVX(POPs);
1310 left_neg = FALSE; /* effectively it's a UV now */
1319 left_neg = dleft < 0;
1323 /* This should be exactly the 5.6 behaviour - if left and right are
1324 both in range for UV then use U_V() rather than floor. */
1326 if (dleft < UV_MAX_P1) {
1327 /* right was in range, so is dleft, so use UVs not double.
1331 /* left is out of range for UV, right was in range, so promote
1332 right (back) to double. */
1334 /* The +0.5 is used in 5.6 even though it is not strictly
1335 consistent with the implicit +0 floor in the U_V()
1336 inside the #if 1. */
1337 dleft = Perl_floor(dleft + 0.5);
1340 dright = Perl_floor(dright + 0.5);
1350 DIE(aTHX_ "Illegal modulus zero");
1352 dans = Perl_fmod(dleft, dright);
1353 if ((left_neg != right_neg) && dans)
1354 dans = dright - dans;
1357 sv_setnv(TARG, dans);
1363 DIE(aTHX_ "Illegal modulus zero");
1366 if ((left_neg != right_neg) && ans)
1369 /* XXX may warn: unary minus operator applied to unsigned type */
1370 /* could change -foo to be (~foo)+1 instead */
1371 if (ans <= ~((UV)IV_MAX)+1)
1372 sv_setiv(TARG, ~ans+1);
1374 sv_setnv(TARG, -(NV)ans);
1377 sv_setuv(TARG, ans);
1386 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1388 register IV count = POPi;
1389 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1391 I32 items = SP - MARK;
1394 max = items * count;
1399 /* This code was intended to fix 20010809.028:
1402 for (($x =~ /./g) x 2) {
1403 print chop; # "abcdabcd" expected as output.
1406 * but that change (#11635) broke this code:
1408 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1410 * I can't think of a better fix that doesn't introduce
1411 * an efficiency hit by copying the SVs. The stack isn't
1412 * refcounted, and mortalisation obviously doesn't
1413 * Do The Right Thing when the stack has more than
1414 * one pointer to the same mortal value.
1418 *SP = sv_2mortal(newSVsv(*SP));
1428 repeatcpy((char*)(MARK + items), (char*)MARK,
1429 items * sizeof(SV*), count - 1);
1432 else if (count <= 0)
1435 else { /* Note: mark already snarfed by pp_list */
1440 SvSetSV(TARG, tmpstr);
1441 SvPV_force(TARG, len);
1442 isutf = DO_UTF8(TARG);
1447 SvGROW(TARG, (count * len) + 1);
1448 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1449 SvCUR(TARG) *= count;
1451 *SvEND(TARG) = '\0';
1454 (void)SvPOK_only_UTF8(TARG);
1456 (void)SvPOK_only(TARG);
1458 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1459 /* The parser saw this as a list repeat, and there
1460 are probably several items on the stack. But we're
1461 in scalar context, and there's no pp_list to save us
1462 now. So drop the rest of the items -- robin@kitsite.com
1475 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1476 useleft = USE_LEFT(TOPm1s);
1477 #ifdef PERL_PRESERVE_IVUV
1478 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1479 "bad things" happen if you rely on signed integers wrapping. */
1482 /* Unless the left argument is integer in range we are going to have to
1483 use NV maths. Hence only attempt to coerce the right argument if
1484 we know the left is integer. */
1485 register UV auv = 0;
1491 a_valid = auvok = 1;
1492 /* left operand is undef, treat as zero. */
1494 /* Left operand is defined, so is it IV? */
1495 SvIV_please(TOPm1s);
1496 if (SvIOK(TOPm1s)) {
1497 if ((auvok = SvUOK(TOPm1s)))
1498 auv = SvUVX(TOPm1s);
1500 register IV aiv = SvIVX(TOPm1s);
1503 auvok = 1; /* Now acting as a sign flag. */
1504 } else { /* 2s complement assumption for IV_MIN */
1512 bool result_good = 0;
1515 bool buvok = SvUOK(TOPs);
1520 register IV biv = SvIVX(TOPs);
1527 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1528 else "IV" now, independent of how it came in.
1529 if a, b represents positive, A, B negative, a maps to -A etc
1534 all UV maths. negate result if A negative.
1535 subtract if signs same, add if signs differ. */
1537 if (auvok ^ buvok) {
1546 /* Must get smaller */
1551 if (result <= buv) {
1552 /* result really should be -(auv-buv). as its negation
1553 of true value, need to swap our result flag */
1565 if (result <= (UV)IV_MIN)
1566 SETi( -(IV)result );
1568 /* result valid, but out of range for IV. */
1569 SETn( -(NV)result );
1573 } /* Overflow, drop through to NVs. */
1577 useleft = USE_LEFT(TOPm1s);
1581 /* left operand is undef, treat as zero - value */
1585 SETn( TOPn - value );
1592 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1595 if (PL_op->op_private & HINT_INTEGER) {
1609 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1612 if (PL_op->op_private & HINT_INTEGER) {
1626 dSP; tryAMAGICbinSET(lt,0);
1627 #ifdef PERL_PRESERVE_IVUV
1630 SvIV_please(TOPm1s);
1631 if (SvIOK(TOPm1s)) {
1632 bool auvok = SvUOK(TOPm1s);
1633 bool buvok = SvUOK(TOPs);
1635 if (!auvok && !buvok) { /* ## IV < IV ## */
1636 IV aiv = SvIVX(TOPm1s);
1637 IV biv = SvIVX(TOPs);
1640 SETs(boolSV(aiv < biv));
1643 if (auvok && buvok) { /* ## UV < UV ## */
1644 UV auv = SvUVX(TOPm1s);
1645 UV buv = SvUVX(TOPs);
1648 SETs(boolSV(auv < buv));
1651 if (auvok) { /* ## UV < IV ## */
1658 /* As (a) is a UV, it's >=0, so it cannot be < */
1663 SETs(boolSV(auv < (UV)biv));
1666 { /* ## IV < UV ## */
1670 aiv = SvIVX(TOPm1s);
1672 /* As (b) is a UV, it's >=0, so it must be < */
1679 SETs(boolSV((UV)aiv < buv));
1685 #ifndef NV_PRESERVES_UV
1686 #ifdef PERL_PRESERVE_IVUV
1689 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1691 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1697 SETs(boolSV(TOPn < value));
1704 dSP; tryAMAGICbinSET(gt,0);
1705 #ifdef PERL_PRESERVE_IVUV
1708 SvIV_please(TOPm1s);
1709 if (SvIOK(TOPm1s)) {
1710 bool auvok = SvUOK(TOPm1s);
1711 bool buvok = SvUOK(TOPs);
1713 if (!auvok && !buvok) { /* ## IV > IV ## */
1714 IV aiv = SvIVX(TOPm1s);
1715 IV biv = SvIVX(TOPs);
1718 SETs(boolSV(aiv > biv));
1721 if (auvok && buvok) { /* ## UV > UV ## */
1722 UV auv = SvUVX(TOPm1s);
1723 UV buv = SvUVX(TOPs);
1726 SETs(boolSV(auv > buv));
1729 if (auvok) { /* ## UV > IV ## */
1736 /* As (a) is a UV, it's >=0, so it must be > */
1741 SETs(boolSV(auv > (UV)biv));
1744 { /* ## IV > UV ## */
1748 aiv = SvIVX(TOPm1s);
1750 /* As (b) is a UV, it's >=0, so it cannot be > */
1757 SETs(boolSV((UV)aiv > buv));
1763 #ifndef NV_PRESERVES_UV
1764 #ifdef PERL_PRESERVE_IVUV
1767 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1769 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1775 SETs(boolSV(TOPn > value));
1782 dSP; tryAMAGICbinSET(le,0);
1783 #ifdef PERL_PRESERVE_IVUV
1786 SvIV_please(TOPm1s);
1787 if (SvIOK(TOPm1s)) {
1788 bool auvok = SvUOK(TOPm1s);
1789 bool buvok = SvUOK(TOPs);
1791 if (!auvok && !buvok) { /* ## IV <= IV ## */
1792 IV aiv = SvIVX(TOPm1s);
1793 IV biv = SvIVX(TOPs);
1796 SETs(boolSV(aiv <= biv));
1799 if (auvok && buvok) { /* ## UV <= UV ## */
1800 UV auv = SvUVX(TOPm1s);
1801 UV buv = SvUVX(TOPs);
1804 SETs(boolSV(auv <= buv));
1807 if (auvok) { /* ## UV <= IV ## */
1814 /* As (a) is a UV, it's >=0, so a cannot be <= */
1819 SETs(boolSV(auv <= (UV)biv));
1822 { /* ## IV <= UV ## */
1826 aiv = SvIVX(TOPm1s);
1828 /* As (b) is a UV, it's >=0, so a must be <= */
1835 SETs(boolSV((UV)aiv <= buv));
1841 #ifndef NV_PRESERVES_UV
1842 #ifdef PERL_PRESERVE_IVUV
1845 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1847 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1853 SETs(boolSV(TOPn <= value));
1860 dSP; tryAMAGICbinSET(ge,0);
1861 #ifdef PERL_PRESERVE_IVUV
1864 SvIV_please(TOPm1s);
1865 if (SvIOK(TOPm1s)) {
1866 bool auvok = SvUOK(TOPm1s);
1867 bool buvok = SvUOK(TOPs);
1869 if (!auvok && !buvok) { /* ## IV >= IV ## */
1870 IV aiv = SvIVX(TOPm1s);
1871 IV biv = SvIVX(TOPs);
1874 SETs(boolSV(aiv >= biv));
1877 if (auvok && buvok) { /* ## UV >= UV ## */
1878 UV auv = SvUVX(TOPm1s);
1879 UV buv = SvUVX(TOPs);
1882 SETs(boolSV(auv >= buv));
1885 if (auvok) { /* ## UV >= IV ## */
1892 /* As (a) is a UV, it's >=0, so it must be >= */
1897 SETs(boolSV(auv >= (UV)biv));
1900 { /* ## IV >= UV ## */
1904 aiv = SvIVX(TOPm1s);
1906 /* As (b) is a UV, it's >=0, so a cannot be >= */
1913 SETs(boolSV((UV)aiv >= buv));
1919 #ifndef NV_PRESERVES_UV
1920 #ifdef PERL_PRESERVE_IVUV
1923 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1925 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1931 SETs(boolSV(TOPn >= value));
1938 dSP; tryAMAGICbinSET(ne,0);
1939 #ifndef NV_PRESERVES_UV
1940 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1942 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1946 #ifdef PERL_PRESERVE_IVUV
1949 SvIV_please(TOPm1s);
1950 if (SvIOK(TOPm1s)) {
1951 bool auvok = SvUOK(TOPm1s);
1952 bool buvok = SvUOK(TOPs);
1954 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1955 /* Casting IV to UV before comparison isn't going to matter
1956 on 2s complement. On 1s complement or sign&magnitude
1957 (if we have any of them) it could make negative zero
1958 differ from normal zero. As I understand it. (Need to
1959 check - is negative zero implementation defined behaviour
1961 UV buv = SvUVX(POPs);
1962 UV auv = SvUVX(TOPs);
1964 SETs(boolSV(auv != buv));
1967 { /* ## Mixed IV,UV ## */
1971 /* != is commutative so swap if needed (save code) */
1973 /* swap. top of stack (b) is the iv */
1977 /* As (a) is a UV, it's >0, so it cannot be == */
1986 /* As (b) is a UV, it's >0, so it cannot be == */
1990 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1992 SETs(boolSV((UV)iv != uv));
2000 SETs(boolSV(TOPn != value));
2007 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2008 #ifndef NV_PRESERVES_UV
2009 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2010 UV right = PTR2UV(SvRV(POPs));
2011 UV left = PTR2UV(SvRV(TOPs));
2012 SETi((left > right) - (left < right));
2016 #ifdef PERL_PRESERVE_IVUV
2017 /* Fortunately it seems NaN isn't IOK */
2020 SvIV_please(TOPm1s);
2021 if (SvIOK(TOPm1s)) {
2022 bool leftuvok = SvUOK(TOPm1s);
2023 bool rightuvok = SvUOK(TOPs);
2025 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2026 IV leftiv = SvIVX(TOPm1s);
2027 IV rightiv = SvIVX(TOPs);
2029 if (leftiv > rightiv)
2031 else if (leftiv < rightiv)
2035 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2036 UV leftuv = SvUVX(TOPm1s);
2037 UV rightuv = SvUVX(TOPs);
2039 if (leftuv > rightuv)
2041 else if (leftuv < rightuv)
2045 } else if (leftuvok) { /* ## UV <=> IV ## */
2049 rightiv = SvIVX(TOPs);
2051 /* As (a) is a UV, it's >=0, so it cannot be < */
2054 leftuv = SvUVX(TOPm1s);
2055 if (leftuv > (UV)rightiv) {
2057 } else if (leftuv < (UV)rightiv) {
2063 } else { /* ## IV <=> UV ## */
2067 leftiv = SvIVX(TOPm1s);
2069 /* As (b) is a UV, it's >=0, so it must be < */
2072 rightuv = SvUVX(TOPs);
2073 if ((UV)leftiv > rightuv) {
2075 } else if ((UV)leftiv < rightuv) {
2093 if (Perl_isnan(left) || Perl_isnan(right)) {
2097 value = (left > right) - (left < right);
2101 else if (left < right)
2103 else if (left > right)
2117 dSP; tryAMAGICbinSET(slt,0);
2120 int cmp = (IN_LOCALE_RUNTIME
2121 ? sv_cmp_locale(left, right)
2122 : sv_cmp(left, right));
2123 SETs(boolSV(cmp < 0));
2130 dSP; tryAMAGICbinSET(sgt,0);
2133 int cmp = (IN_LOCALE_RUNTIME
2134 ? sv_cmp_locale(left, right)
2135 : sv_cmp(left, right));
2136 SETs(boolSV(cmp > 0));
2143 dSP; tryAMAGICbinSET(sle,0);
2146 int cmp = (IN_LOCALE_RUNTIME
2147 ? sv_cmp_locale(left, right)
2148 : sv_cmp(left, right));
2149 SETs(boolSV(cmp <= 0));
2156 dSP; tryAMAGICbinSET(sge,0);
2159 int cmp = (IN_LOCALE_RUNTIME
2160 ? sv_cmp_locale(left, right)
2161 : sv_cmp(left, right));
2162 SETs(boolSV(cmp >= 0));
2169 dSP; tryAMAGICbinSET(seq,0);
2172 SETs(boolSV(sv_eq(left, right)));
2179 dSP; tryAMAGICbinSET(sne,0);
2182 SETs(boolSV(!sv_eq(left, right)));
2189 dSP; dTARGET; tryAMAGICbin(scmp,0);
2192 int cmp = (IN_LOCALE_RUNTIME
2193 ? sv_cmp_locale(left, right)
2194 : sv_cmp(left, right));
2202 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2205 if (SvGMAGICAL(left)) mg_get(left);
2206 if (SvGMAGICAL(right)) mg_get(right);
2207 if (SvNIOKp(left) || SvNIOKp(right)) {
2208 if (PL_op->op_private & HINT_INTEGER) {
2209 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2213 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2218 do_vop(PL_op->op_type, TARG, left, right);
2227 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2230 if (SvGMAGICAL(left)) mg_get(left);
2231 if (SvGMAGICAL(right)) mg_get(right);
2232 if (SvNIOKp(left) || SvNIOKp(right)) {
2233 if (PL_op->op_private & HINT_INTEGER) {
2234 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2238 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2243 do_vop(PL_op->op_type, TARG, left, right);
2252 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2255 if (SvGMAGICAL(left)) mg_get(left);
2256 if (SvGMAGICAL(right)) mg_get(right);
2257 if (SvNIOKp(left) || SvNIOKp(right)) {
2258 if (PL_op->op_private & HINT_INTEGER) {
2259 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2263 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2268 do_vop(PL_op->op_type, TARG, left, right);
2277 dSP; dTARGET; tryAMAGICun(neg);
2280 int flags = SvFLAGS(sv);
2283 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2284 /* It's publicly an integer, or privately an integer-not-float */
2287 if (SvIVX(sv) == IV_MIN) {
2288 /* 2s complement assumption. */
2289 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2292 else if (SvUVX(sv) <= IV_MAX) {
2297 else if (SvIVX(sv) != IV_MIN) {
2301 #ifdef PERL_PRESERVE_IVUV
2310 else if (SvPOKp(sv)) {
2312 char *s = SvPV(sv, len);
2313 if (isIDFIRST(*s)) {
2314 sv_setpvn(TARG, "-", 1);
2317 else if (*s == '+' || *s == '-') {
2319 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2321 else if (DO_UTF8(sv)) {
2324 goto oops_its_an_int;
2326 sv_setnv(TARG, -SvNV(sv));
2328 sv_setpvn(TARG, "-", 1);
2335 goto oops_its_an_int;
2336 sv_setnv(TARG, -SvNV(sv));
2348 dSP; tryAMAGICunSET(not);
2349 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2355 dSP; dTARGET; tryAMAGICun(compl);
2361 if (PL_op->op_private & HINT_INTEGER) {
2362 IV i = ~SvIV_nomg(sv);
2366 UV u = ~SvUV_nomg(sv);
2375 sv_setsv_nomg(TARG, sv);
2376 tmps = (U8*)SvPV_force(TARG, len);
2379 /* Calculate exact length, let's not estimate. */
2388 while (tmps < send) {
2389 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2390 tmps += UTF8SKIP(tmps);
2391 targlen += UNISKIP(~c);
2397 /* Now rewind strings and write them. */
2401 Newz(0, result, targlen + 1, U8);
2402 while (tmps < send) {
2403 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2404 tmps += UTF8SKIP(tmps);
2405 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2409 sv_setpvn(TARG, (char*)result, targlen);
2413 Newz(0, result, nchar + 1, U8);
2414 while (tmps < send) {
2415 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2416 tmps += UTF8SKIP(tmps);
2421 sv_setpvn(TARG, (char*)result, nchar);
2430 register long *tmpl;
2431 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2434 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2439 for ( ; anum > 0; anum--, tmps++)
2448 /* integer versions of some of the above */
2452 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2455 SETi( left * right );
2462 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2466 DIE(aTHX_ "Illegal division by zero");
2467 value = POPi / value;
2476 /* This is the vanilla old i_modulo. */
2477 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2481 DIE(aTHX_ "Illegal modulus zero");
2482 SETi( left % right );
2487 #if defined(__GLIBC__) && IVSIZE == 8
2491 /* This is the i_modulo with the workaround for the _moddi3 bug
2492 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2493 * See below for pp_i_modulo. */
2494 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2498 DIE(aTHX_ "Illegal modulus zero");
2499 SETi( left % PERL_ABS(right) );
2507 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2511 DIE(aTHX_ "Illegal modulus zero");
2512 /* The assumption is to use hereafter the old vanilla version... */
2514 PL_ppaddr[OP_I_MODULO] =
2515 &Perl_pp_i_modulo_0;
2516 /* .. but if we have glibc, we might have a buggy _moddi3
2517 * (at least glicb 2.2.5 is known to have this bug), in other
2518 * words our integer modulus with negative quad as the second
2519 * argument might be broken. Test for this and re-patch the
2520 * opcode dispatch table if that is the case, remembering to
2521 * also apply the workaround so that this first round works
2522 * right, too. See [perl #9402] for more information. */
2523 #if defined(__GLIBC__) && IVSIZE == 8
2527 /* Cannot do this check with inlined IV constants since
2528 * that seems to work correctly even with the buggy glibc. */
2530 /* Yikes, we have the bug.
2531 * Patch in the workaround version. */
2533 PL_ppaddr[OP_I_MODULO] =
2534 &Perl_pp_i_modulo_1;
2535 /* Make certain we work right this time, too. */
2536 right = PERL_ABS(right);
2540 SETi( left % right );
2547 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2550 SETi( left + right );
2557 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2560 SETi( left - right );
2567 dSP; tryAMAGICbinSET(lt,0);
2570 SETs(boolSV(left < right));
2577 dSP; tryAMAGICbinSET(gt,0);
2580 SETs(boolSV(left > right));
2587 dSP; tryAMAGICbinSET(le,0);
2590 SETs(boolSV(left <= right));
2597 dSP; tryAMAGICbinSET(ge,0);
2600 SETs(boolSV(left >= right));
2607 dSP; tryAMAGICbinSET(eq,0);
2610 SETs(boolSV(left == right));
2617 dSP; tryAMAGICbinSET(ne,0);
2620 SETs(boolSV(left != right));
2627 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2634 else if (left < right)
2645 dSP; dTARGET; tryAMAGICun(neg);
2650 /* High falutin' math. */
2654 dSP; dTARGET; tryAMAGICbin(atan2,0);
2657 SETn(Perl_atan2(left, right));
2664 dSP; dTARGET; tryAMAGICun(sin);
2668 value = Perl_sin(value);
2676 dSP; dTARGET; tryAMAGICun(cos);
2680 value = Perl_cos(value);
2686 /* Support Configure command-line overrides for rand() functions.
2687 After 5.005, perhaps we should replace this by Configure support
2688 for drand48(), random(), or rand(). For 5.005, though, maintain
2689 compatibility by calling rand() but allow the user to override it.
2690 See INSTALL for details. --Andy Dougherty 15 July 1998
2692 /* Now it's after 5.005, and Configure supports drand48() and random(),
2693 in addition to rand(). So the overrides should not be needed any more.
2694 --Jarkko Hietaniemi 27 September 1998
2697 #ifndef HAS_DRAND48_PROTO
2698 extern double drand48 (void);
2711 if (!PL_srand_called) {
2712 (void)seedDrand01((Rand_seed_t)seed());
2713 PL_srand_called = TRUE;
2728 (void)seedDrand01((Rand_seed_t)anum);
2729 PL_srand_called = TRUE;
2736 dSP; dTARGET; tryAMAGICun(exp);
2740 value = Perl_exp(value);
2748 dSP; dTARGET; tryAMAGICun(log);
2753 SET_NUMERIC_STANDARD();
2754 DIE(aTHX_ "Can't take log of %"NVgf, value);
2756 value = Perl_log(value);
2764 dSP; dTARGET; tryAMAGICun(sqrt);
2769 SET_NUMERIC_STANDARD();
2770 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2772 value = Perl_sqrt(value);
2780 dSP; dTARGET; tryAMAGICun(int);
2783 IV iv = TOPi; /* attempt to convert to IV if possible. */
2784 /* XXX it's arguable that compiler casting to IV might be subtly
2785 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2786 else preferring IV has introduced a subtle behaviour change bug. OTOH
2787 relying on floating point to be accurate is a bug. */
2798 if (value < (NV)UV_MAX + 0.5) {
2801 SETn(Perl_floor(value));
2805 if (value > (NV)IV_MIN - 0.5) {
2808 SETn(Perl_ceil(value));
2818 dSP; dTARGET; tryAMAGICun(abs);
2820 /* This will cache the NV value if string isn't actually integer */
2824 /* IVX is precise */
2826 SETu(TOPu); /* force it to be numeric only */
2834 /* 2s complement assumption. Also, not really needed as
2835 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2855 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2861 tmps = (SvPVx(sv, len));
2863 /* If Unicode, try to downgrade
2864 * If not possible, croak. */
2865 SV* tsv = sv_2mortal(newSVsv(sv));
2868 sv_utf8_downgrade(tsv, FALSE);
2871 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2872 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2885 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2891 tmps = (SvPVx(sv, len));
2893 /* If Unicode, try to downgrade
2894 * If not possible, croak. */
2895 SV* tsv = sv_2mortal(newSVsv(sv));
2898 sv_utf8_downgrade(tsv, FALSE);
2901 while (*tmps && len && isSPACE(*tmps))
2906 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2907 else if (*tmps == 'b')
2908 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2910 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2912 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2929 SETi(sv_len_utf8(sv));
2945 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2947 I32 arybase = PL_curcop->cop_arybase;
2951 int num_args = PL_op->op_private & 7;
2952 bool repl_need_utf8_upgrade = FALSE;
2953 bool repl_is_utf8 = FALSE;
2955 SvTAINTED_off(TARG); /* decontaminate */
2956 SvUTF8_off(TARG); /* decontaminate */
2960 repl = SvPV(repl_sv, repl_len);
2961 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2971 sv_utf8_upgrade(sv);
2973 else if (DO_UTF8(sv))
2974 repl_need_utf8_upgrade = TRUE;
2976 tmps = SvPV(sv, curlen);
2978 utf8_curlen = sv_len_utf8(sv);
2979 if (utf8_curlen == curlen)
2982 curlen = utf8_curlen;
2987 if (pos >= arybase) {
3005 else if (len >= 0) {
3007 if (rem > (I32)curlen)
3022 Perl_croak(aTHX_ "substr outside of string");
3023 if (ckWARN(WARN_SUBSTR))
3024 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3031 sv_pos_u2b(sv, &pos, &rem);
3033 sv_setpvn(TARG, tmps, rem);
3034 #ifdef USE_LOCALE_COLLATE
3035 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3040 SV* repl_sv_copy = NULL;
3042 if (repl_need_utf8_upgrade) {
3043 repl_sv_copy = newSVsv(repl_sv);
3044 sv_utf8_upgrade(repl_sv_copy);
3045 repl = SvPV(repl_sv_copy, repl_len);
3046 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3048 sv_insert(sv, pos, rem, repl, repl_len);
3052 SvREFCNT_dec(repl_sv_copy);
3054 else if (lvalue) { /* it's an lvalue! */
3055 if (!SvGMAGICAL(sv)) {
3059 if (ckWARN(WARN_SUBSTR))
3060 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3061 "Attempt to use reference as lvalue in substr");
3063 if (SvOK(sv)) /* is it defined ? */
3064 (void)SvPOK_only_UTF8(sv);
3066 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3069 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3070 TARG = sv_newmortal();
3071 if (SvTYPE(TARG) < SVt_PVLV) {
3072 sv_upgrade(TARG, SVt_PVLV);
3073 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3076 (void)SvOK_off(TARG);
3079 if (LvTARG(TARG) != sv) {
3081 SvREFCNT_dec(LvTARG(TARG));
3082 LvTARG(TARG) = SvREFCNT_inc(sv);
3084 LvTARGOFF(TARG) = upos;
3085 LvTARGLEN(TARG) = urem;
3089 PUSHs(TARG); /* avoid SvSETMAGIC here */
3096 register IV size = POPi;
3097 register IV offset = POPi;
3098 register SV *src = POPs;
3099 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3101 SvTAINTED_off(TARG); /* decontaminate */
3102 if (lvalue) { /* it's an lvalue! */
3103 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3104 TARG = sv_newmortal();
3105 if (SvTYPE(TARG) < SVt_PVLV) {
3106 sv_upgrade(TARG, SVt_PVLV);
3107 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3110 if (LvTARG(TARG) != src) {
3112 SvREFCNT_dec(LvTARG(TARG));
3113 LvTARG(TARG) = SvREFCNT_inc(src);
3115 LvTARGOFF(TARG) = offset;
3116 LvTARGLEN(TARG) = size;
3119 sv_setuv(TARG, do_vecget(src, offset, size));
3134 I32 arybase = PL_curcop->cop_arybase;
3139 offset = POPi - arybase;
3142 tmps = SvPV(big, biglen);
3143 if (offset > 0 && DO_UTF8(big))
3144 sv_pos_u2b(big, &offset, 0);
3147 else if (offset > (I32)biglen)
3149 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3150 (unsigned char*)tmps + biglen, little, 0)))
3153 retval = tmps2 - tmps;
3154 if (retval > 0 && DO_UTF8(big))
3155 sv_pos_b2u(big, &retval);
3156 PUSHi(retval + arybase);
3171 I32 arybase = PL_curcop->cop_arybase;
3177 tmps2 = SvPV(little, llen);
3178 tmps = SvPV(big, blen);
3182 if (offset > 0 && DO_UTF8(big))
3183 sv_pos_u2b(big, &offset, 0);
3184 offset = offset - arybase + llen;
3188 else if (offset > (I32)blen)
3190 if (!(tmps2 = rninstr(tmps, tmps + offset,
3191 tmps2, tmps2 + llen)))
3194 retval = tmps2 - tmps;
3195 if (retval > 0 && DO_UTF8(big))
3196 sv_pos_b2u(big, &retval);
3197 PUSHi(retval + arybase);
3203 dSP; dMARK; dORIGMARK; dTARGET;
3204 do_sprintf(TARG, SP-MARK, MARK+1);
3205 TAINT_IF(SvTAINTED(TARG));
3206 if (DO_UTF8(*(MARK+1)))
3218 U8 *s = (U8*)SvPVx(argsv, len);
3221 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3222 tmpsv = sv_2mortal(newSVsv(argsv));
3223 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3227 XPUSHu(DO_UTF8(argsv) ?
3228 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3240 (void)SvUPGRADE(TARG,SVt_PV);
3242 if (value > 255 && !IN_BYTES) {
3243 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3244 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3245 SvCUR_set(TARG, tmps - SvPVX(TARG));
3247 (void)SvPOK_only(TARG);
3256 *tmps++ = (char)value;
3258 (void)SvPOK_only(TARG);
3259 if (PL_encoding && !IN_BYTES) {
3260 sv_recode_to_utf8(TARG, PL_encoding);
3262 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3263 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3267 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3268 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3284 char *tmps = SvPV(left, len);
3286 if (DO_UTF8(left)) {
3287 /* If Unicode, try to downgrade.
3288 * If not possible, croak.
3289 * Yes, we made this up. */
3290 SV* tsv = sv_2mortal(newSVsv(left));
3293 sv_utf8_downgrade(tsv, FALSE);
3296 # ifdef USE_ITHREADS
3298 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3299 /* This should be threadsafe because in ithreads there is only
3300 * one thread per interpreter. If this would not be true,
3301 * we would need a mutex to protect this malloc. */
3302 PL_reentrant_buffer->_crypt_struct_buffer =
3303 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3304 #if defined(__GLIBC__) || defined(__EMX__)
3305 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3306 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3307 /* work around glibc-2.2.5 bug */
3308 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3312 # endif /* HAS_CRYPT_R */
3313 # endif /* USE_ITHREADS */
3315 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3317 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3323 "The crypt() function is unimplemented due to excessive paranoia.");
3336 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3337 UTF8_IS_START(*s)) {
3338 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3342 utf8_to_uvchr(s, &ulen);
3343 toTITLE_utf8(s, tmpbuf, &tculen);
3344 utf8_to_uvchr(tmpbuf, 0);
3346 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3348 /* slen is the byte length of the whole SV.
3349 * ulen is the byte length of the original Unicode character
3350 * stored as UTF-8 at s.
3351 * tculen is the byte length of the freshly titlecased
3352 * Unicode character stored as UTF-8 at tmpbuf.
3353 * We first set the result to be the titlecased character,
3354 * and then append the rest of the SV data. */
3355 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3357 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3362 s = (U8*)SvPV_force_nomg(sv, slen);
3363 Copy(tmpbuf, s, tculen, U8);
3367 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3369 SvUTF8_off(TARG); /* decontaminate */
3370 sv_setsv_nomg(TARG, sv);
3374 s = (U8*)SvPV_force_nomg(sv, slen);
3376 if (IN_LOCALE_RUNTIME) {
3379 *s = toUPPER_LC(*s);
3398 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3399 UTF8_IS_START(*s)) {
3401 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3405 toLOWER_utf8(s, tmpbuf, &ulen);
3406 uv = utf8_to_uvchr(tmpbuf, 0);
3407 tend = uvchr_to_utf8(tmpbuf, uv);
3409 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3411 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3413 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3418 s = (U8*)SvPV_force_nomg(sv, slen);
3419 Copy(tmpbuf, s, ulen, U8);
3423 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3425 SvUTF8_off(TARG); /* decontaminate */
3426 sv_setsv_nomg(TARG, sv);
3430 s = (U8*)SvPV_force_nomg(sv, slen);
3432 if (IN_LOCALE_RUNTIME) {
3435 *s = toLOWER_LC(*s);
3458 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3460 s = (U8*)SvPV_nomg(sv,len);
3462 SvUTF8_off(TARG); /* decontaminate */
3463 sv_setpvn(TARG, "", 0);
3467 STRLEN nchar = utf8_length(s, s + len);
3469 (void)SvUPGRADE(TARG, SVt_PV);
3470 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3471 (void)SvPOK_only(TARG);
3472 d = (U8*)SvPVX(TARG);
3475 toUPPER_utf8(s, tmpbuf, &ulen);
3476 Copy(tmpbuf, d, ulen, U8);
3482 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3487 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3489 SvUTF8_off(TARG); /* decontaminate */
3490 sv_setsv_nomg(TARG, sv);
3494 s = (U8*)SvPV_force_nomg(sv, len);
3496 register U8 *send = s + len;
3498 if (IN_LOCALE_RUNTIME) {
3501 for (; s < send; s++)
3502 *s = toUPPER_LC(*s);
3505 for (; s < send; s++)
3527 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3529 s = (U8*)SvPV_nomg(sv,len);
3531 SvUTF8_off(TARG); /* decontaminate */
3532 sv_setpvn(TARG, "", 0);
3536 STRLEN nchar = utf8_length(s, s + len);
3538 (void)SvUPGRADE(TARG, SVt_PV);
3539 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3540 (void)SvPOK_only(TARG);
3541 d = (U8*)SvPVX(TARG);
3544 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3545 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3546 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3548 * Now if the sigma is NOT followed by
3549 * /$ignorable_sequence$cased_letter/;
3550 * and it IS preceded by
3551 * /$cased_letter$ignorable_sequence/;
3552 * where $ignorable_sequence is
3553 * [\x{2010}\x{AD}\p{Mn}]*
3554 * and $cased_letter is
3555 * [\p{Ll}\p{Lo}\p{Lt}]
3556 * then it should be mapped to 0x03C2,
3557 * (GREEK SMALL LETTER FINAL SIGMA),
3558 * instead of staying 0x03A3.
3559 * See lib/unicore/SpecCase.txt.
3562 Copy(tmpbuf, d, ulen, U8);
3568 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3573 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3575 SvUTF8_off(TARG); /* decontaminate */
3576 sv_setsv_nomg(TARG, sv);
3581 s = (U8*)SvPV_force_nomg(sv, len);
3583 register U8 *send = s + len;
3585 if (IN_LOCALE_RUNTIME) {
3588 for (; s < send; s++)
3589 *s = toLOWER_LC(*s);
3592 for (; s < send; s++)
3606 register char *s = SvPV(sv,len);
3609 SvUTF8_off(TARG); /* decontaminate */
3611 (void)SvUPGRADE(TARG, SVt_PV);
3612 SvGROW(TARG, (len * 2) + 1);
3616 if (UTF8_IS_CONTINUED(*s)) {
3617 STRLEN ulen = UTF8SKIP(s);
3641 SvCUR_set(TARG, d - SvPVX(TARG));
3642 (void)SvPOK_only_UTF8(TARG);
3645 sv_setpvn(TARG, s, len);
3647 if (SvSMAGICAL(TARG))
3656 dSP; dMARK; dORIGMARK;
3658 register AV* av = (AV*)POPs;
3659 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3660 I32 arybase = PL_curcop->cop_arybase;
3663 if (SvTYPE(av) == SVt_PVAV) {
3664 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3666 for (svp = MARK + 1; svp <= SP; svp++) {
3671 if (max > AvMAX(av))
3674 while (++MARK <= SP) {
3675 elem = SvIVx(*MARK);
3679 svp = av_fetch(av, elem, lval);
3681 if (!svp || *svp == &PL_sv_undef)
3682 DIE(aTHX_ PL_no_aelem, elem);
3683 if (PL_op->op_private & OPpLVAL_INTRO)
3684 save_aelem(av, elem, svp);
3686 *MARK = svp ? *svp : &PL_sv_undef;
3689 if (GIMME != G_ARRAY) {
3697 /* Associative arrays. */
3702 HV *hash = (HV*)POPs;
3704 I32 gimme = GIMME_V;
3707 /* might clobber stack_sp */
3708 entry = hv_iternext(hash);
3713 SV* sv = hv_iterkeysv(entry);
3714 PUSHs(sv); /* won't clobber stack_sp */
3715 if (gimme == G_ARRAY) {
3718 /* might clobber stack_sp */
3719 val = hv_iterval(hash, entry);
3724 else if (gimme == G_SCALAR)
3743 I32 gimme = GIMME_V;
3744 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3748 if (PL_op->op_private & OPpSLICE) {
3752 hvtype = SvTYPE(hv);
3753 if (hvtype == SVt_PVHV) { /* hash element */
3754 while (++MARK <= SP) {
3755 sv = hv_delete_ent(hv, *MARK, discard, 0);
3756 *MARK = sv ? sv : &PL_sv_undef;
3759 else if (hvtype == SVt_PVAV) { /* array element */
3760 if (PL_op->op_flags & OPf_SPECIAL) {
3761 while (++MARK <= SP) {
3762 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3763 *MARK = sv ? sv : &PL_sv_undef;
3768 DIE(aTHX_ "Not a HASH reference");
3771 else if (gimme == G_SCALAR) {
3780 if (SvTYPE(hv) == SVt_PVHV)
3781 sv = hv_delete_ent(hv, keysv, discard, 0);
3782 else if (SvTYPE(hv) == SVt_PVAV) {
3783 if (PL_op->op_flags & OPf_SPECIAL)
3784 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3786 DIE(aTHX_ "panic: avhv_delete no longer supported");
3789 DIE(aTHX_ "Not a HASH reference");
3804 if (PL_op->op_private & OPpEXISTS_SUB) {
3808 cv = sv_2cv(sv, &hv, &gv, FALSE);
3811 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3817 if (SvTYPE(hv) == SVt_PVHV) {
3818 if (hv_exists_ent(hv, tmpsv, 0))
3821 else if (SvTYPE(hv) == SVt_PVAV) {
3822 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3823 if (av_exists((AV*)hv, SvIV(tmpsv)))
3828 DIE(aTHX_ "Not a HASH reference");
3835 dSP; dMARK; dORIGMARK;
3836 register HV *hv = (HV*)POPs;
3837 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3838 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3839 bool other_magic = FALSE;
3845 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3846 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3847 /* Try to preserve the existenceness of a tied hash
3848 * element by using EXISTS and DELETE if possible.
3849 * Fallback to FETCH and STORE otherwise */
3850 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3851 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3852 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3855 while (++MARK <= SP) {
3859 bool preeminent = FALSE;
3862 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3863 hv_exists_ent(hv, keysv, 0);
3866 he = hv_fetch_ent(hv, keysv, lval, 0);
3867 svp = he ? &HeVAL(he) : 0;
3870 if (!svp || *svp == &PL_sv_undef) {
3872 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3876 save_helem(hv, keysv, svp);
3879 char *key = SvPV(keysv, keylen);
3880 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3884 *MARK = svp ? *svp : &PL_sv_undef;
3886 if (GIMME != G_ARRAY) {
3894 /* List operators. */
3899 if (GIMME != G_ARRAY) {
3901 *MARK = *SP; /* unwanted list, return last item */
3903 *MARK = &PL_sv_undef;
3912 SV **lastrelem = PL_stack_sp;
3913 SV **lastlelem = PL_stack_base + POPMARK;
3914 SV **firstlelem = PL_stack_base + POPMARK + 1;
3915 register SV **firstrelem = lastlelem + 1;
3916 I32 arybase = PL_curcop->cop_arybase;
3917 I32 lval = PL_op->op_flags & OPf_MOD;
3918 I32 is_something_there = lval;
3920 register I32 max = lastrelem - lastlelem;
3921 register SV **lelem;
3924 if (GIMME != G_ARRAY) {
3925 ix = SvIVx(*lastlelem);
3930 if (ix < 0 || ix >= max)
3931 *firstlelem = &PL_sv_undef;
3933 *firstlelem = firstrelem[ix];
3939 SP = firstlelem - 1;
3943 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3949 if (ix < 0 || ix >= max)
3950 *lelem = &PL_sv_undef;
3952 is_something_there = TRUE;
3953 if (!(*lelem = firstrelem[ix]))
3954 *lelem = &PL_sv_undef;
3957 if (is_something_there)
3960 SP = firstlelem - 1;
3966 dSP; dMARK; dORIGMARK;
3967 I32 items = SP - MARK;
3968 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3969 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3976 dSP; dMARK; dORIGMARK;
3977 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3981 SV *val = NEWSV(46, 0);
3983 sv_setsv(val, *++MARK);
3984 else if (ckWARN(WARN_MISC))
3985 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3986 (void)hv_store_ent(hv,key,val,0);
3995 dSP; dMARK; dORIGMARK;
3996 register AV *ary = (AV*)*++MARK;
4000 register I32 offset;
4001 register I32 length;
4008 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4009 *MARK-- = SvTIED_obj((SV*)ary, mg);
4013 call_method("SPLICE",GIMME_V);
4022 offset = i = SvIVx(*MARK);
4024 offset += AvFILLp(ary) + 1;
4026 offset -= PL_curcop->cop_arybase;
4028 DIE(aTHX_ PL_no_aelem, i);
4030 length = SvIVx(*MARK++);
4032 length += AvFILLp(ary) - offset + 1;
4038 length = AvMAX(ary) + 1; /* close enough to infinity */
4042 length = AvMAX(ary) + 1;
4044 if (offset > AvFILLp(ary) + 1) {
4045 if (ckWARN(WARN_MISC))
4046 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4047 offset = AvFILLp(ary) + 1;
4049 after = AvFILLp(ary) + 1 - (offset + length);
4050 if (after < 0) { /* not that much array */
4051 length += after; /* offset+length now in array */
4057 /* At this point, MARK .. SP-1 is our new LIST */
4060 diff = newlen - length;
4061 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4064 if (diff < 0) { /* shrinking the area */
4066 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4067 Copy(MARK, tmparyval, newlen, SV*);
4070 MARK = ORIGMARK + 1;
4071 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4072 MEXTEND(MARK, length);
4073 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4075 EXTEND_MORTAL(length);
4076 for (i = length, dst = MARK; i; i--) {
4077 sv_2mortal(*dst); /* free them eventualy */
4084 *MARK = AvARRAY(ary)[offset+length-1];
4087 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4088 SvREFCNT_dec(*dst++); /* free them now */
4091 AvFILLp(ary) += diff;
4093 /* pull up or down? */
4095 if (offset < after) { /* easier to pull up */
4096 if (offset) { /* esp. if nothing to pull */
4097 src = &AvARRAY(ary)[offset-1];
4098 dst = src - diff; /* diff is negative */
4099 for (i = offset; i > 0; i--) /* can't trust Copy */
4103 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4107 if (after) { /* anything to pull down? */
4108 src = AvARRAY(ary) + offset + length;
4109 dst = src + diff; /* diff is negative */
4110 Move(src, dst, after, SV*);
4112 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4113 /* avoid later double free */
4117 dst[--i] = &PL_sv_undef;
4120 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4122 *dst = NEWSV(46, 0);
4123 sv_setsv(*dst++, *src++);
4125 Safefree(tmparyval);
4128 else { /* no, expanding (or same) */
4130 New(452, tmparyval, length, SV*); /* so remember deletion */
4131 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4134 if (diff > 0) { /* expanding */
4136 /* push up or down? */
4138 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4142 Move(src, dst, offset, SV*);
4144 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4146 AvFILLp(ary) += diff;
4149 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4150 av_extend(ary, AvFILLp(ary) + diff);
4151 AvFILLp(ary) += diff;
4154 dst = AvARRAY(ary) + AvFILLp(ary);
4156 for (i = after; i; i--) {
4163 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4164 *dst = NEWSV(46, 0);
4165 sv_setsv(*dst++, *src++);
4167 MARK = ORIGMARK + 1;
4168 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4170 Copy(tmparyval, MARK, length, SV*);
4172 EXTEND_MORTAL(length);
4173 for (i = length, dst = MARK; i; i--) {
4174 sv_2mortal(*dst); /* free them eventualy */
4178 Safefree(tmparyval);
4182 else if (length--) {
4183 *MARK = tmparyval[length];
4186 while (length-- > 0)
4187 SvREFCNT_dec(tmparyval[length]);
4189 Safefree(tmparyval);
4192 *MARK = &PL_sv_undef;
4200 dSP; dMARK; dORIGMARK; dTARGET;
4201 register AV *ary = (AV*)*++MARK;
4202 register SV *sv = &PL_sv_undef;
4205 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4206 *MARK-- = SvTIED_obj((SV*)ary, mg);
4210 call_method("PUSH",G_SCALAR|G_DISCARD);
4215 /* Why no pre-extend of ary here ? */
4216 for (++MARK; MARK <= SP; MARK++) {
4219 sv_setsv(sv, *MARK);
4224 PUSHi( AvFILL(ary) + 1 );
4232 SV *sv = av_pop(av);
4234 (void)sv_2mortal(sv);
4243 SV *sv = av_shift(av);
4248 (void)sv_2mortal(sv);
4255 dSP; dMARK; dORIGMARK; dTARGET;
4256 register AV *ary = (AV*)*++MARK;
4261 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4262 *MARK-- = SvTIED_obj((SV*)ary, mg);
4266 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4271 av_unshift(ary, SP - MARK);
4274 sv_setsv(sv, *++MARK);
4275 (void)av_store(ary, i++, sv);
4279 PUSHi( AvFILL(ary) + 1 );
4289 if (GIMME == G_ARRAY) {
4296 /* safe as long as stack cannot get extended in the above */
4301 register char *down;
4306 SvUTF8_off(TARG); /* decontaminate */
4308 do_join(TARG, &PL_sv_no, MARK, SP);
4310 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4311 up = SvPV_force(TARG, len);
4313 if (DO_UTF8(TARG)) { /* first reverse each character */
4314 U8* s = (U8*)SvPVX(TARG);
4315 U8* send = (U8*)(s + len);
4317 if (UTF8_IS_INVARIANT(*s)) {
4322 if (!utf8_to_uvchr(s, 0))
4326 down = (char*)(s - 1);
4327 /* reverse this character */
4331 *down-- = (char)tmp;
4337 down = SvPVX(TARG) + len - 1;
4341 *down-- = (char)tmp;
4343 (void)SvPOK_only_UTF8(TARG);
4355 register IV limit = POPi; /* note, negative is forever */
4358 register char *s = SvPV(sv, len);
4359 bool do_utf8 = DO_UTF8(sv);
4360 char *strend = s + len;
4362 register REGEXP *rx;
4366 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4367 I32 maxiters = slen + 10;
4370 I32 origlimit = limit;
4373 AV *oldstack = PL_curstack;
4374 I32 gimme = GIMME_V;
4375 I32 oldsave = PL_savestack_ix;
4376 I32 make_mortal = 1;
4377 MAGIC *mg = (MAGIC *) NULL;
4380 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4385 DIE(aTHX_ "panic: pp_split");
4388 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4389 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4391 RX_MATCH_UTF8_set(rx, do_utf8);
4393 if (pm->op_pmreplroot) {
4395 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4397 ary = GvAVn((GV*)pm->op_pmreplroot);
4400 else if (gimme != G_ARRAY)
4401 ary = GvAVn(PL_defgv);
4404 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4410 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4412 XPUSHs(SvTIED_obj((SV*)ary, mg));
4418 for (i = AvFILLp(ary); i >= 0; i--)
4419 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4421 /* temporarily switch stacks */
4422 SWITCHSTACK(PL_curstack, ary);
4423 PL_curstackinfo->si_stack = ary;
4427 base = SP - PL_stack_base;
4429 if (pm->op_pmflags & PMf_SKIPWHITE) {
4430 if (pm->op_pmflags & PMf_LOCALE) {
4431 while (isSPACE_LC(*s))
4439 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4440 SAVEINT(PL_multiline);
4441 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4445 limit = maxiters + 2;
4446 if (pm->op_pmflags & PMf_WHITE) {
4449 while (m < strend &&
4450 !((pm->op_pmflags & PMf_LOCALE)
4451 ? isSPACE_LC(*m) : isSPACE(*m)))
4456 dstr = NEWSV(30, m-s);
4457 sv_setpvn(dstr, s, m-s);
4461 (void)SvUTF8_on(dstr);
4465 while (s < strend &&
4466 ((pm->op_pmflags & PMf_LOCALE)
4467 ? isSPACE_LC(*s) : isSPACE(*s)))
4471 else if (strEQ("^", rx->precomp)) {
4474 for (m = s; m < strend && *m != '\n'; m++) ;
4478 dstr = NEWSV(30, m-s);
4479 sv_setpvn(dstr, s, m-s);
4483 (void)SvUTF8_on(dstr);
4488 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4489 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4490 && (rx->reganch & ROPT_CHECK_ALL)
4491 && !(rx->reganch & ROPT_ANCH)) {
4492 int tail = (rx->reganch & RE_INTUIT_TAIL);
4493 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4496 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4498 char c = *SvPV(csv, n_a);
4501 for (m = s; m < strend && *m != c; m++) ;
4504 dstr = NEWSV(30, m-s);
4505 sv_setpvn(dstr, s, m-s);
4509 (void)SvUTF8_on(dstr);
4511 /* The rx->minlen is in characters but we want to step
4512 * s ahead by bytes. */
4514 s = (char*)utf8_hop((U8*)m, len);
4516 s = m + len; /* Fake \n at the end */
4521 while (s < strend && --limit &&
4522 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4523 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4526 dstr = NEWSV(31, m-s);
4527 sv_setpvn(dstr, s, m-s);
4531 (void)SvUTF8_on(dstr);
4533 /* The rx->minlen is in characters but we want to step
4534 * s ahead by bytes. */
4536 s = (char*)utf8_hop((U8*)m, len);
4538 s = m + len; /* Fake \n at the end */
4543 maxiters += slen * rx->nparens;
4544 while (s < strend && --limit)
4547 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4551 TAINT_IF(RX_MATCH_TAINTED(rx));
4552 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4557 strend = s + (strend - m);
4559 m = rx->startp[0] + orig;
4560 dstr = NEWSV(32, m-s);
4561 sv_setpvn(dstr, s, m-s);
4565 (void)SvUTF8_on(dstr);
4568 for (i = 1; i <= (I32)rx->nparens; i++) {
4569 s = rx->startp[i] + orig;
4570 m = rx->endp[i] + orig;
4572 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4573 parens that didn't match -- they should be set to
4574 undef, not the empty string */
4575 if (m >= orig && s >= orig) {
4576 dstr = NEWSV(33, m-s);
4577 sv_setpvn(dstr, s, m-s);
4580 dstr = &PL_sv_undef; /* undef, not "" */
4584 (void)SvUTF8_on(dstr);
4588 s = rx->endp[0] + orig;
4592 LEAVE_SCOPE(oldsave);
4593 iters = (SP - PL_stack_base) - base;
4594 if (iters > maxiters)
4595 DIE(aTHX_ "Split loop");
4597 /* keep field after final delim? */
4598 if (s < strend || (iters && origlimit)) {
4599 STRLEN l = strend - s;
4600 dstr = NEWSV(34, l);
4601 sv_setpvn(dstr, s, l);
4605 (void)SvUTF8_on(dstr);
4609 else if (!origlimit) {
4610 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4611 if (TOPs && !make_mortal)
4620 SWITCHSTACK(ary, oldstack);
4621 PL_curstackinfo->si_stack = oldstack;
4622 if (SvSMAGICAL(ary)) {
4627 if (gimme == G_ARRAY) {
4629 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4637 call_method("PUSH",G_SCALAR|G_DISCARD);
4640 if (gimme == G_ARRAY) {
4641 /* EXTEND should not be needed - we just popped them */
4643 for (i=0; i < iters; i++) {
4644 SV **svp = av_fetch(ary, i, FALSE);
4645 PUSHs((svp) ? *svp : &PL_sv_undef);
4652 if (gimme == G_ARRAY)
4667 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4668 || SvTYPE(retsv) == SVt_PVCV) {
4669 retsv = refto(retsv);
4677 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");