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)
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);
860 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
870 if (SvTYPE(TOPs) > SVt_PVLV)
871 DIE(aTHX_ PL_no_modify);
872 sv_setsv(TARG, TOPs);
873 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
874 && SvIVX(TOPs) != IV_MIN)
877 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
886 /* Ordinary operators. */
891 #ifdef PERL_PRESERVE_IVUV
894 tryAMAGICbin(pow,opASSIGN);
895 #ifdef PERL_PRESERVE_IVUV
896 /* For integer to integer power, we do the calculation by hand wherever
897 we're sure it is safe; otherwise we call pow() and try to convert to
898 integer afterwards. */
902 bool baseuok = SvUOK(TOPm1s);
906 baseuv = SvUVX(TOPm1s);
908 IV iv = SvIVX(TOPm1s);
911 baseuok = TRUE; /* effectively it's a UV now */
913 baseuv = -iv; /* abs, baseuok == false records sign */
927 goto float_it; /* Can't do negative powers this way. */
930 /* now we have integer ** positive integer. */
933 /* foo & (foo - 1) is zero only for a power of 2. */
934 if (!(baseuv & (baseuv - 1))) {
935 /* We are raising power-of-2 to a positive integer.
936 The logic here will work for any base (even non-integer
937 bases) but it can be less accurate than
938 pow (base,power) or exp (power * log (base)) when the
939 intermediate values start to spill out of the mantissa.
940 With powers of 2 we know this can't happen.
941 And powers of 2 are the favourite thing for perl
942 programmers to notice ** not doing what they mean. */
944 NV base = baseuok ? baseuv : -(NV)baseuv;
947 for (; power; base *= base, n++) {
948 /* Do I look like I trust gcc with long longs here?
950 UV bit = (UV)1 << (UV)n;
953 /* Only bother to clear the bit if it is set. */
955 /* Avoid squaring base again if we're done. */
956 if (power == 0) break;
964 register unsigned int highbit = 8 * sizeof(UV);
965 register unsigned int lowbit = 0;
966 register unsigned int diff;
967 bool odd_power = (bool)(power & 1);
968 while ((diff = (highbit - lowbit) >> 1)) {
969 if (baseuv & ~((1 << (lowbit + diff)) - 1))
974 /* we now have baseuv < 2 ** highbit */
975 if (power * highbit <= 8 * sizeof(UV)) {
976 /* result will definitely fit in UV, so use UV math
977 on same algorithm as above */
978 register UV result = 1;
979 register UV base = baseuv;
981 for (; power; base *= base, n++) {
982 register UV bit = (UV)1 << (UV)n;
986 if (power == 0) break;
990 if (baseuok || !odd_power)
991 /* answer is positive */
993 else if (result <= (UV)IV_MAX)
994 /* answer negative, fits in IV */
996 else if (result == (UV)IV_MIN)
997 /* 2's complement assumption: special case IV_MIN */
1000 /* answer negative, doesn't fit */
1001 SETn( -(NV)result );
1012 SETn( Perl_pow( left, right) );
1013 #ifdef PERL_PRESERVE_IVUV
1023 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1024 #ifdef PERL_PRESERVE_IVUV
1027 /* Unless the left argument is integer in range we are going to have to
1028 use NV maths. Hence only attempt to coerce the right argument if
1029 we know the left is integer. */
1030 /* Left operand is defined, so is it IV? */
1031 SvIV_please(TOPm1s);
1032 if (SvIOK(TOPm1s)) {
1033 bool auvok = SvUOK(TOPm1s);
1034 bool buvok = SvUOK(TOPs);
1035 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1036 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1043 alow = SvUVX(TOPm1s);
1045 IV aiv = SvIVX(TOPm1s);
1048 auvok = TRUE; /* effectively it's a UV now */
1050 alow = -aiv; /* abs, auvok == false records sign */
1056 IV biv = SvIVX(TOPs);
1059 buvok = TRUE; /* effectively it's a UV now */
1061 blow = -biv; /* abs, buvok == false records sign */
1065 /* If this does sign extension on unsigned it's time for plan B */
1066 ahigh = alow >> (4 * sizeof (UV));
1068 bhigh = blow >> (4 * sizeof (UV));
1070 if (ahigh && bhigh) {
1071 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1072 which is overflow. Drop to NVs below. */
1073 } else if (!ahigh && !bhigh) {
1074 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1075 so the unsigned multiply cannot overflow. */
1076 UV product = alow * blow;
1077 if (auvok == buvok) {
1078 /* -ve * -ve or +ve * +ve gives a +ve result. */
1082 } else if (product <= (UV)IV_MIN) {
1083 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1084 /* -ve result, which could overflow an IV */
1086 SETi( -(IV)product );
1088 } /* else drop to NVs below. */
1090 /* One operand is large, 1 small */
1093 /* swap the operands */
1095 bhigh = blow; /* bhigh now the temp var for the swap */
1099 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1100 multiplies can't overflow. shift can, add can, -ve can. */
1101 product_middle = ahigh * blow;
1102 if (!(product_middle & topmask)) {
1103 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1105 product_middle <<= (4 * sizeof (UV));
1106 product_low = alow * blow;
1108 /* as for pp_add, UV + something mustn't get smaller.
1109 IIRC ANSI mandates this wrapping *behaviour* for
1110 unsigned whatever the actual representation*/
1111 product_low += product_middle;
1112 if (product_low >= product_middle) {
1113 /* didn't overflow */
1114 if (auvok == buvok) {
1115 /* -ve * -ve or +ve * +ve gives a +ve result. */
1117 SETu( product_low );
1119 } else if (product_low <= (UV)IV_MIN) {
1120 /* 2s complement assumption again */
1121 /* -ve result, which could overflow an IV */
1123 SETi( -(IV)product_low );
1125 } /* else drop to NVs below. */
1127 } /* product_middle too large */
1128 } /* ahigh && bhigh */
1129 } /* SvIOK(TOPm1s) */
1134 SETn( left * right );
1141 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1142 /* Only try to do UV divide first
1143 if ((SLOPPYDIVIDE is true) or
1144 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1146 The assumption is that it is better to use floating point divide
1147 whenever possible, only doing integer divide first if we can't be sure.
1148 If NV_PRESERVES_UV is true then we know at compile time that no UV
1149 can be too large to preserve, so don't need to compile the code to
1150 test the size of UVs. */
1153 # define PERL_TRY_UV_DIVIDE
1154 /* ensure that 20./5. == 4. */
1156 # ifdef PERL_PRESERVE_IVUV
1157 # ifndef NV_PRESERVES_UV
1158 # define PERL_TRY_UV_DIVIDE
1163 #ifdef PERL_TRY_UV_DIVIDE
1166 SvIV_please(TOPm1s);
1167 if (SvIOK(TOPm1s)) {
1168 bool left_non_neg = SvUOK(TOPm1s);
1169 bool right_non_neg = SvUOK(TOPs);
1173 if (right_non_neg) {
1174 right = SvUVX(TOPs);
1177 IV biv = SvIVX(TOPs);
1180 right_non_neg = TRUE; /* effectively it's a UV now */
1186 /* historically undef()/0 gives a "Use of uninitialized value"
1187 warning before dieing, hence this test goes here.
1188 If it were immediately before the second SvIV_please, then
1189 DIE() would be invoked before left was even inspected, so
1190 no inpsection would give no warning. */
1192 DIE(aTHX_ "Illegal division by zero");
1195 left = SvUVX(TOPm1s);
1198 IV aiv = SvIVX(TOPm1s);
1201 left_non_neg = TRUE; /* effectively it's a UV now */
1210 /* For sloppy divide we always attempt integer division. */
1212 /* Otherwise we only attempt it if either or both operands
1213 would not be preserved by an NV. If both fit in NVs
1214 we fall through to the NV divide code below. However,
1215 as left >= right to ensure integer result here, we know that
1216 we can skip the test on the right operand - right big
1217 enough not to be preserved can't get here unless left is
1220 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1223 /* Integer division can't overflow, but it can be imprecise. */
1224 UV result = left / right;
1225 if (result * right == left) {
1226 SP--; /* result is valid */
1227 if (left_non_neg == right_non_neg) {
1228 /* signs identical, result is positive. */
1232 /* 2s complement assumption */
1233 if (result <= (UV)IV_MIN)
1234 SETi( -(IV)result );
1236 /* It's exact but too negative for IV. */
1237 SETn( -(NV)result );
1240 } /* tried integer divide but it was not an integer result */
1241 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1242 } /* left wasn't SvIOK */
1243 } /* right wasn't SvIOK */
1244 #endif /* PERL_TRY_UV_DIVIDE */
1248 DIE(aTHX_ "Illegal division by zero");
1249 PUSHn( left / right );
1256 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1260 bool left_neg = FALSE;
1261 bool right_neg = FALSE;
1262 bool use_double = FALSE;
1263 bool dright_valid = FALSE;
1269 right_neg = !SvUOK(TOPs);
1271 right = SvUVX(POPs);
1273 IV biv = SvIVX(POPs);
1276 right_neg = FALSE; /* effectively it's a UV now */
1284 right_neg = dright < 0;
1287 if (dright < UV_MAX_P1) {
1288 right = U_V(dright);
1289 dright_valid = TRUE; /* In case we need to use double below. */
1295 /* At this point use_double is only true if right is out of range for
1296 a UV. In range NV has been rounded down to nearest UV and
1297 use_double false. */
1299 if (!use_double && SvIOK(TOPs)) {
1301 left_neg = !SvUOK(TOPs);
1305 IV aiv = SvIVX(POPs);
1308 left_neg = FALSE; /* effectively it's a UV now */
1317 left_neg = dleft < 0;
1321 /* This should be exactly the 5.6 behaviour - if left and right are
1322 both in range for UV then use U_V() rather than floor. */
1324 if (dleft < UV_MAX_P1) {
1325 /* right was in range, so is dleft, so use UVs not double.
1329 /* left is out of range for UV, right was in range, so promote
1330 right (back) to double. */
1332 /* The +0.5 is used in 5.6 even though it is not strictly
1333 consistent with the implicit +0 floor in the U_V()
1334 inside the #if 1. */
1335 dleft = Perl_floor(dleft + 0.5);
1338 dright = Perl_floor(dright + 0.5);
1348 DIE(aTHX_ "Illegal modulus zero");
1350 dans = Perl_fmod(dleft, dright);
1351 if ((left_neg != right_neg) && dans)
1352 dans = dright - dans;
1355 sv_setnv(TARG, dans);
1361 DIE(aTHX_ "Illegal modulus zero");
1364 if ((left_neg != right_neg) && ans)
1367 /* XXX may warn: unary minus operator applied to unsigned type */
1368 /* could change -foo to be (~foo)+1 instead */
1369 if (ans <= ~((UV)IV_MAX)+1)
1370 sv_setiv(TARG, ~ans+1);
1372 sv_setnv(TARG, -(NV)ans);
1375 sv_setuv(TARG, ans);
1384 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1386 register IV count = POPi;
1387 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1389 I32 items = SP - MARK;
1392 max = items * count;
1397 /* This code was intended to fix 20010809.028:
1400 for (($x =~ /./g) x 2) {
1401 print chop; # "abcdabcd" expected as output.
1404 * but that change (#11635) broke this code:
1406 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1408 * I can't think of a better fix that doesn't introduce
1409 * an efficiency hit by copying the SVs. The stack isn't
1410 * refcounted, and mortalisation obviously doesn't
1411 * Do The Right Thing when the stack has more than
1412 * one pointer to the same mortal value.
1416 *SP = sv_2mortal(newSVsv(*SP));
1426 repeatcpy((char*)(MARK + items), (char*)MARK,
1427 items * sizeof(SV*), count - 1);
1430 else if (count <= 0)
1433 else { /* Note: mark already snarfed by pp_list */
1438 SvSetSV(TARG, tmpstr);
1439 SvPV_force(TARG, len);
1440 isutf = DO_UTF8(TARG);
1445 SvGROW(TARG, (count * len) + 1);
1446 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1447 SvCUR(TARG) *= count;
1449 *SvEND(TARG) = '\0';
1452 (void)SvPOK_only_UTF8(TARG);
1454 (void)SvPOK_only(TARG);
1456 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1457 /* The parser saw this as a list repeat, and there
1458 are probably several items on the stack. But we're
1459 in scalar context, and there's no pp_list to save us
1460 now. So drop the rest of the items -- robin@kitsite.com
1473 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1474 useleft = USE_LEFT(TOPm1s);
1475 #ifdef PERL_PRESERVE_IVUV
1476 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1477 "bad things" happen if you rely on signed integers wrapping. */
1480 /* Unless the left argument is integer in range we are going to have to
1481 use NV maths. Hence only attempt to coerce the right argument if
1482 we know the left is integer. */
1483 register UV auv = 0;
1489 a_valid = auvok = 1;
1490 /* left operand is undef, treat as zero. */
1492 /* Left operand is defined, so is it IV? */
1493 SvIV_please(TOPm1s);
1494 if (SvIOK(TOPm1s)) {
1495 if ((auvok = SvUOK(TOPm1s)))
1496 auv = SvUVX(TOPm1s);
1498 register IV aiv = SvIVX(TOPm1s);
1501 auvok = 1; /* Now acting as a sign flag. */
1502 } else { /* 2s complement assumption for IV_MIN */
1510 bool result_good = 0;
1513 bool buvok = SvUOK(TOPs);
1518 register IV biv = SvIVX(TOPs);
1525 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1526 else "IV" now, independent of how it came in.
1527 if a, b represents positive, A, B negative, a maps to -A etc
1532 all UV maths. negate result if A negative.
1533 subtract if signs same, add if signs differ. */
1535 if (auvok ^ buvok) {
1544 /* Must get smaller */
1549 if (result <= buv) {
1550 /* result really should be -(auv-buv). as its negation
1551 of true value, need to swap our result flag */
1563 if (result <= (UV)IV_MIN)
1564 SETi( -(IV)result );
1566 /* result valid, but out of range for IV. */
1567 SETn( -(NV)result );
1571 } /* Overflow, drop through to NVs. */
1575 useleft = USE_LEFT(TOPm1s);
1579 /* left operand is undef, treat as zero - value */
1583 SETn( TOPn - value );
1590 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1593 if (PL_op->op_private & HINT_INTEGER) {
1607 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1610 if (PL_op->op_private & HINT_INTEGER) {
1624 dSP; tryAMAGICbinSET(lt,0);
1625 #ifdef PERL_PRESERVE_IVUV
1628 SvIV_please(TOPm1s);
1629 if (SvIOK(TOPm1s)) {
1630 bool auvok = SvUOK(TOPm1s);
1631 bool buvok = SvUOK(TOPs);
1633 if (!auvok && !buvok) { /* ## IV < IV ## */
1634 IV aiv = SvIVX(TOPm1s);
1635 IV biv = SvIVX(TOPs);
1638 SETs(boolSV(aiv < biv));
1641 if (auvok && buvok) { /* ## UV < UV ## */
1642 UV auv = SvUVX(TOPm1s);
1643 UV buv = SvUVX(TOPs);
1646 SETs(boolSV(auv < buv));
1649 if (auvok) { /* ## UV < IV ## */
1656 /* As (a) is a UV, it's >=0, so it cannot be < */
1661 SETs(boolSV(auv < (UV)biv));
1664 { /* ## IV < UV ## */
1668 aiv = SvIVX(TOPm1s);
1670 /* As (b) is a UV, it's >=0, so it must be < */
1677 SETs(boolSV((UV)aiv < buv));
1683 #ifndef NV_PRESERVES_UV
1684 #ifdef PERL_PRESERVE_IVUV
1687 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1689 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1695 SETs(boolSV(TOPn < value));
1702 dSP; tryAMAGICbinSET(gt,0);
1703 #ifdef PERL_PRESERVE_IVUV
1706 SvIV_please(TOPm1s);
1707 if (SvIOK(TOPm1s)) {
1708 bool auvok = SvUOK(TOPm1s);
1709 bool buvok = SvUOK(TOPs);
1711 if (!auvok && !buvok) { /* ## IV > IV ## */
1712 IV aiv = SvIVX(TOPm1s);
1713 IV biv = SvIVX(TOPs);
1716 SETs(boolSV(aiv > biv));
1719 if (auvok && buvok) { /* ## UV > UV ## */
1720 UV auv = SvUVX(TOPm1s);
1721 UV buv = SvUVX(TOPs);
1724 SETs(boolSV(auv > buv));
1727 if (auvok) { /* ## UV > IV ## */
1734 /* As (a) is a UV, it's >=0, so it must be > */
1739 SETs(boolSV(auv > (UV)biv));
1742 { /* ## IV > UV ## */
1746 aiv = SvIVX(TOPm1s);
1748 /* As (b) is a UV, it's >=0, so it cannot be > */
1755 SETs(boolSV((UV)aiv > buv));
1761 #ifndef NV_PRESERVES_UV
1762 #ifdef PERL_PRESERVE_IVUV
1765 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1767 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1773 SETs(boolSV(TOPn > value));
1780 dSP; tryAMAGICbinSET(le,0);
1781 #ifdef PERL_PRESERVE_IVUV
1784 SvIV_please(TOPm1s);
1785 if (SvIOK(TOPm1s)) {
1786 bool auvok = SvUOK(TOPm1s);
1787 bool buvok = SvUOK(TOPs);
1789 if (!auvok && !buvok) { /* ## IV <= IV ## */
1790 IV aiv = SvIVX(TOPm1s);
1791 IV biv = SvIVX(TOPs);
1794 SETs(boolSV(aiv <= biv));
1797 if (auvok && buvok) { /* ## UV <= UV ## */
1798 UV auv = SvUVX(TOPm1s);
1799 UV buv = SvUVX(TOPs);
1802 SETs(boolSV(auv <= buv));
1805 if (auvok) { /* ## UV <= IV ## */
1812 /* As (a) is a UV, it's >=0, so a cannot be <= */
1817 SETs(boolSV(auv <= (UV)biv));
1820 { /* ## IV <= UV ## */
1824 aiv = SvIVX(TOPm1s);
1826 /* As (b) is a UV, it's >=0, so a must be <= */
1833 SETs(boolSV((UV)aiv <= buv));
1839 #ifndef NV_PRESERVES_UV
1840 #ifdef PERL_PRESERVE_IVUV
1843 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1845 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1851 SETs(boolSV(TOPn <= value));
1858 dSP; tryAMAGICbinSET(ge,0);
1859 #ifdef PERL_PRESERVE_IVUV
1862 SvIV_please(TOPm1s);
1863 if (SvIOK(TOPm1s)) {
1864 bool auvok = SvUOK(TOPm1s);
1865 bool buvok = SvUOK(TOPs);
1867 if (!auvok && !buvok) { /* ## IV >= IV ## */
1868 IV aiv = SvIVX(TOPm1s);
1869 IV biv = SvIVX(TOPs);
1872 SETs(boolSV(aiv >= biv));
1875 if (auvok && buvok) { /* ## UV >= UV ## */
1876 UV auv = SvUVX(TOPm1s);
1877 UV buv = SvUVX(TOPs);
1880 SETs(boolSV(auv >= buv));
1883 if (auvok) { /* ## UV >= IV ## */
1890 /* As (a) is a UV, it's >=0, so it must be >= */
1895 SETs(boolSV(auv >= (UV)biv));
1898 { /* ## IV >= UV ## */
1902 aiv = SvIVX(TOPm1s);
1904 /* As (b) is a UV, it's >=0, so a cannot be >= */
1911 SETs(boolSV((UV)aiv >= buv));
1917 #ifndef NV_PRESERVES_UV
1918 #ifdef PERL_PRESERVE_IVUV
1921 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1923 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1929 SETs(boolSV(TOPn >= value));
1936 dSP; tryAMAGICbinSET(ne,0);
1937 #ifndef NV_PRESERVES_UV
1938 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1940 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1944 #ifdef PERL_PRESERVE_IVUV
1947 SvIV_please(TOPm1s);
1948 if (SvIOK(TOPm1s)) {
1949 bool auvok = SvUOK(TOPm1s);
1950 bool buvok = SvUOK(TOPs);
1952 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1953 /* Casting IV to UV before comparison isn't going to matter
1954 on 2s complement. On 1s complement or sign&magnitude
1955 (if we have any of them) it could make negative zero
1956 differ from normal zero. As I understand it. (Need to
1957 check - is negative zero implementation defined behaviour
1959 UV buv = SvUVX(POPs);
1960 UV auv = SvUVX(TOPs);
1962 SETs(boolSV(auv != buv));
1965 { /* ## Mixed IV,UV ## */
1969 /* != is commutative so swap if needed (save code) */
1971 /* swap. top of stack (b) is the iv */
1975 /* As (a) is a UV, it's >0, so it cannot be == */
1984 /* As (b) is a UV, it's >0, so it cannot be == */
1988 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1990 SETs(boolSV((UV)iv != uv));
1998 SETs(boolSV(TOPn != value));
2005 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2006 #ifndef NV_PRESERVES_UV
2007 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2008 UV right = PTR2UV(SvRV(POPs));
2009 UV left = PTR2UV(SvRV(TOPs));
2010 SETi((left > right) - (left < right));
2014 #ifdef PERL_PRESERVE_IVUV
2015 /* Fortunately it seems NaN isn't IOK */
2018 SvIV_please(TOPm1s);
2019 if (SvIOK(TOPm1s)) {
2020 bool leftuvok = SvUOK(TOPm1s);
2021 bool rightuvok = SvUOK(TOPs);
2023 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2024 IV leftiv = SvIVX(TOPm1s);
2025 IV rightiv = SvIVX(TOPs);
2027 if (leftiv > rightiv)
2029 else if (leftiv < rightiv)
2033 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2034 UV leftuv = SvUVX(TOPm1s);
2035 UV rightuv = SvUVX(TOPs);
2037 if (leftuv > rightuv)
2039 else if (leftuv < rightuv)
2043 } else if (leftuvok) { /* ## UV <=> IV ## */
2047 rightiv = SvIVX(TOPs);
2049 /* As (a) is a UV, it's >=0, so it cannot be < */
2052 leftuv = SvUVX(TOPm1s);
2053 if (leftuv > (UV)rightiv) {
2055 } else if (leftuv < (UV)rightiv) {
2061 } else { /* ## IV <=> UV ## */
2065 leftiv = SvIVX(TOPm1s);
2067 /* As (b) is a UV, it's >=0, so it must be < */
2070 rightuv = SvUVX(TOPs);
2071 if ((UV)leftiv > rightuv) {
2073 } else if ((UV)leftiv < rightuv) {
2091 if (Perl_isnan(left) || Perl_isnan(right)) {
2095 value = (left > right) - (left < right);
2099 else if (left < right)
2101 else if (left > right)
2115 dSP; tryAMAGICbinSET(slt,0);
2118 int cmp = (IN_LOCALE_RUNTIME
2119 ? sv_cmp_locale(left, right)
2120 : sv_cmp(left, right));
2121 SETs(boolSV(cmp < 0));
2128 dSP; tryAMAGICbinSET(sgt,0);
2131 int cmp = (IN_LOCALE_RUNTIME
2132 ? sv_cmp_locale(left, right)
2133 : sv_cmp(left, right));
2134 SETs(boolSV(cmp > 0));
2141 dSP; tryAMAGICbinSET(sle,0);
2144 int cmp = (IN_LOCALE_RUNTIME
2145 ? sv_cmp_locale(left, right)
2146 : sv_cmp(left, right));
2147 SETs(boolSV(cmp <= 0));
2154 dSP; tryAMAGICbinSET(sge,0);
2157 int cmp = (IN_LOCALE_RUNTIME
2158 ? sv_cmp_locale(left, right)
2159 : sv_cmp(left, right));
2160 SETs(boolSV(cmp >= 0));
2167 dSP; tryAMAGICbinSET(seq,0);
2170 SETs(boolSV(sv_eq(left, right)));
2177 dSP; tryAMAGICbinSET(sne,0);
2180 SETs(boolSV(!sv_eq(left, right)));
2187 dSP; dTARGET; tryAMAGICbin(scmp,0);
2190 int cmp = (IN_LOCALE_RUNTIME
2191 ? sv_cmp_locale(left, right)
2192 : sv_cmp(left, right));
2200 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2203 if (SvGMAGICAL(left)) mg_get(left);
2204 if (SvGMAGICAL(right)) mg_get(right);
2205 if (SvNIOKp(left) || SvNIOKp(right)) {
2206 if (PL_op->op_private & HINT_INTEGER) {
2207 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2211 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2216 do_vop(PL_op->op_type, TARG, left, right);
2225 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2228 if (SvGMAGICAL(left)) mg_get(left);
2229 if (SvGMAGICAL(right)) mg_get(right);
2230 if (SvNIOKp(left) || SvNIOKp(right)) {
2231 if (PL_op->op_private & HINT_INTEGER) {
2232 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2236 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2241 do_vop(PL_op->op_type, TARG, left, right);
2250 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2253 if (SvGMAGICAL(left)) mg_get(left);
2254 if (SvGMAGICAL(right)) mg_get(right);
2255 if (SvNIOKp(left) || SvNIOKp(right)) {
2256 if (PL_op->op_private & HINT_INTEGER) {
2257 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2261 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2266 do_vop(PL_op->op_type, TARG, left, right);
2275 dSP; dTARGET; tryAMAGICun(neg);
2278 int flags = SvFLAGS(sv);
2281 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2282 /* It's publicly an integer, or privately an integer-not-float */
2285 if (SvIVX(sv) == IV_MIN) {
2286 /* 2s complement assumption. */
2287 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2290 else if (SvUVX(sv) <= IV_MAX) {
2295 else if (SvIVX(sv) != IV_MIN) {
2299 #ifdef PERL_PRESERVE_IVUV
2308 else if (SvPOKp(sv)) {
2310 char *s = SvPV(sv, len);
2311 if (isIDFIRST(*s)) {
2312 sv_setpvn(TARG, "-", 1);
2315 else if (*s == '+' || *s == '-') {
2317 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2319 else if (DO_UTF8(sv)) {
2322 goto oops_its_an_int;
2324 sv_setnv(TARG, -SvNV(sv));
2326 sv_setpvn(TARG, "-", 1);
2333 goto oops_its_an_int;
2334 sv_setnv(TARG, -SvNV(sv));
2346 dSP; tryAMAGICunSET(not);
2347 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2353 dSP; dTARGET; tryAMAGICun(compl);
2359 if (PL_op->op_private & HINT_INTEGER) {
2360 IV i = ~SvIV_nomg(sv);
2364 UV u = ~SvUV_nomg(sv);
2373 sv_setsv_nomg(TARG, sv);
2374 tmps = (U8*)SvPV_force(TARG, len);
2377 /* Calculate exact length, let's not estimate. */
2386 while (tmps < send) {
2387 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2388 tmps += UTF8SKIP(tmps);
2389 targlen += UNISKIP(~c);
2395 /* Now rewind strings and write them. */
2399 Newz(0, result, targlen + 1, U8);
2400 while (tmps < send) {
2401 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2402 tmps += UTF8SKIP(tmps);
2403 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2407 sv_setpvn(TARG, (char*)result, targlen);
2411 Newz(0, result, nchar + 1, U8);
2412 while (tmps < send) {
2413 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2414 tmps += UTF8SKIP(tmps);
2419 sv_setpvn(TARG, (char*)result, nchar);
2427 register long *tmpl;
2428 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2431 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2436 for ( ; anum > 0; anum--, tmps++)
2445 /* integer versions of some of the above */
2449 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2452 SETi( left * right );
2459 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2463 DIE(aTHX_ "Illegal division by zero");
2464 value = POPi / value;
2473 /* This is the vanilla old i_modulo. */
2474 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2478 DIE(aTHX_ "Illegal modulus zero");
2479 SETi( left % right );
2484 #if defined(__GLIBC__) && IVSIZE == 8
2488 /* This is the i_modulo with the workaround for the _moddi3 bug
2489 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2490 * See below for pp_i_modulo. */
2491 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2495 DIE(aTHX_ "Illegal modulus zero");
2496 SETi( left % PERL_ABS(right) );
2504 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2508 DIE(aTHX_ "Illegal modulus zero");
2509 /* The assumption is to use hereafter the old vanilla version... */
2511 PL_ppaddr[OP_I_MODULO] =
2512 &Perl_pp_i_modulo_0;
2513 /* .. but if we have glibc, we might have a buggy _moddi3
2514 * (at least glicb 2.2.5 is known to have this bug), in other
2515 * words our integer modulus with negative quad as the second
2516 * argument might be broken. Test for this and re-patch the
2517 * opcode dispatch table if that is the case, remembering to
2518 * also apply the workaround so that this first round works
2519 * right, too. See [perl #9402] for more information. */
2520 #if defined(__GLIBC__) && IVSIZE == 8
2524 /* Cannot do this check with inlined IV constants since
2525 * that seems to work correctly even with the buggy glibc. */
2527 /* Yikes, we have the bug.
2528 * Patch in the workaround version. */
2530 PL_ppaddr[OP_I_MODULO] =
2531 &Perl_pp_i_modulo_1;
2532 /* Make certain we work right this time, too. */
2533 right = PERL_ABS(right);
2537 SETi( left % right );
2544 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2547 SETi( left + right );
2554 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2557 SETi( left - right );
2564 dSP; tryAMAGICbinSET(lt,0);
2567 SETs(boolSV(left < right));
2574 dSP; tryAMAGICbinSET(gt,0);
2577 SETs(boolSV(left > right));
2584 dSP; tryAMAGICbinSET(le,0);
2587 SETs(boolSV(left <= right));
2594 dSP; tryAMAGICbinSET(ge,0);
2597 SETs(boolSV(left >= right));
2604 dSP; tryAMAGICbinSET(eq,0);
2607 SETs(boolSV(left == right));
2614 dSP; tryAMAGICbinSET(ne,0);
2617 SETs(boolSV(left != right));
2624 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2631 else if (left < right)
2642 dSP; dTARGET; tryAMAGICun(neg);
2647 /* High falutin' math. */
2651 dSP; dTARGET; tryAMAGICbin(atan2,0);
2654 SETn(Perl_atan2(left, right));
2661 dSP; dTARGET; tryAMAGICun(sin);
2665 value = Perl_sin(value);
2673 dSP; dTARGET; tryAMAGICun(cos);
2677 value = Perl_cos(value);
2683 /* Support Configure command-line overrides for rand() functions.
2684 After 5.005, perhaps we should replace this by Configure support
2685 for drand48(), random(), or rand(). For 5.005, though, maintain
2686 compatibility by calling rand() but allow the user to override it.
2687 See INSTALL for details. --Andy Dougherty 15 July 1998
2689 /* Now it's after 5.005, and Configure supports drand48() and random(),
2690 in addition to rand(). So the overrides should not be needed any more.
2691 --Jarkko Hietaniemi 27 September 1998
2694 #ifndef HAS_DRAND48_PROTO
2695 extern double drand48 (void);
2708 if (!PL_srand_called) {
2709 (void)seedDrand01((Rand_seed_t)seed());
2710 PL_srand_called = TRUE;
2725 (void)seedDrand01((Rand_seed_t)anum);
2726 PL_srand_called = TRUE;
2733 dSP; dTARGET; tryAMAGICun(exp);
2737 value = Perl_exp(value);
2745 dSP; dTARGET; tryAMAGICun(log);
2750 SET_NUMERIC_STANDARD();
2751 DIE(aTHX_ "Can't take log of %"NVgf, value);
2753 value = Perl_log(value);
2761 dSP; dTARGET; tryAMAGICun(sqrt);
2766 SET_NUMERIC_STANDARD();
2767 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2769 value = Perl_sqrt(value);
2777 dSP; dTARGET; tryAMAGICun(int);
2780 IV iv = TOPi; /* attempt to convert to IV if possible. */
2781 /* XXX it's arguable that compiler casting to IV might be subtly
2782 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2783 else preferring IV has introduced a subtle behaviour change bug. OTOH
2784 relying on floating point to be accurate is a bug. */
2795 if (value < (NV)UV_MAX + 0.5) {
2798 SETn(Perl_floor(value));
2802 if (value > (NV)IV_MIN - 0.5) {
2805 SETn(Perl_ceil(value));
2815 dSP; dTARGET; tryAMAGICun(abs);
2817 /* This will cache the NV value if string isn't actually integer */
2821 /* IVX is precise */
2823 SETu(TOPu); /* force it to be numeric only */
2831 /* 2s complement assumption. Also, not really needed as
2832 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2852 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2858 tmps = (SvPVx(sv, len));
2860 /* If Unicode, try to downgrade
2861 * If not possible, croak. */
2862 SV* tsv = sv_2mortal(newSVsv(sv));
2865 sv_utf8_downgrade(tsv, FALSE);
2868 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2869 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2882 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2888 tmps = (SvPVx(sv, len));
2890 /* If Unicode, try to downgrade
2891 * If not possible, croak. */
2892 SV* tsv = sv_2mortal(newSVsv(sv));
2895 sv_utf8_downgrade(tsv, FALSE);
2898 while (*tmps && len && isSPACE(*tmps))
2903 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2904 else if (*tmps == 'b')
2905 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2907 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2909 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2926 SETi(sv_len_utf8(sv));
2942 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2944 I32 arybase = PL_curcop->cop_arybase;
2948 int num_args = PL_op->op_private & 7;
2949 bool repl_need_utf8_upgrade = FALSE;
2950 bool repl_is_utf8 = FALSE;
2952 SvTAINTED_off(TARG); /* decontaminate */
2953 SvUTF8_off(TARG); /* decontaminate */
2957 repl = SvPV(repl_sv, repl_len);
2958 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2968 sv_utf8_upgrade(sv);
2970 else if (DO_UTF8(sv))
2971 repl_need_utf8_upgrade = TRUE;
2973 tmps = SvPV(sv, curlen);
2975 utf8_curlen = sv_len_utf8(sv);
2976 if (utf8_curlen == curlen)
2979 curlen = utf8_curlen;
2984 if (pos >= arybase) {
3002 else if (len >= 0) {
3004 if (rem > (I32)curlen)
3019 Perl_croak(aTHX_ "substr outside of string");
3020 if (ckWARN(WARN_SUBSTR))
3021 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3028 sv_pos_u2b(sv, &pos, &rem);
3030 sv_setpvn(TARG, tmps, rem);
3031 #ifdef USE_LOCALE_COLLATE
3032 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3037 SV* repl_sv_copy = NULL;
3039 if (repl_need_utf8_upgrade) {
3040 repl_sv_copy = newSVsv(repl_sv);
3041 sv_utf8_upgrade(repl_sv_copy);
3042 repl = SvPV(repl_sv_copy, repl_len);
3043 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3045 sv_insert(sv, pos, rem, repl, repl_len);
3049 SvREFCNT_dec(repl_sv_copy);
3051 else if (lvalue) { /* it's an lvalue! */
3052 if (!SvGMAGICAL(sv)) {
3056 if (ckWARN(WARN_SUBSTR))
3057 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3058 "Attempt to use reference as lvalue in substr");
3060 if (SvOK(sv)) /* is it defined ? */
3061 (void)SvPOK_only_UTF8(sv);
3063 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3066 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3067 TARG = sv_newmortal();
3068 if (SvTYPE(TARG) < SVt_PVLV) {
3069 sv_upgrade(TARG, SVt_PVLV);
3070 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3073 (void)SvOK_off(TARG);
3076 if (LvTARG(TARG) != sv) {
3078 SvREFCNT_dec(LvTARG(TARG));
3079 LvTARG(TARG) = SvREFCNT_inc(sv);
3081 LvTARGOFF(TARG) = upos;
3082 LvTARGLEN(TARG) = urem;
3086 PUSHs(TARG); /* avoid SvSETMAGIC here */
3093 register IV size = POPi;
3094 register IV offset = POPi;
3095 register SV *src = POPs;
3096 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3098 SvTAINTED_off(TARG); /* decontaminate */
3099 if (lvalue) { /* it's an lvalue! */
3100 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3101 TARG = sv_newmortal();
3102 if (SvTYPE(TARG) < SVt_PVLV) {
3103 sv_upgrade(TARG, SVt_PVLV);
3104 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3107 if (LvTARG(TARG) != src) {
3109 SvREFCNT_dec(LvTARG(TARG));
3110 LvTARG(TARG) = SvREFCNT_inc(src);
3112 LvTARGOFF(TARG) = offset;
3113 LvTARGLEN(TARG) = size;
3116 sv_setuv(TARG, do_vecget(src, offset, size));
3131 I32 arybase = PL_curcop->cop_arybase;
3136 offset = POPi - arybase;
3139 tmps = SvPV(big, biglen);
3140 if (offset > 0 && DO_UTF8(big))
3141 sv_pos_u2b(big, &offset, 0);
3144 else if (offset > (I32)biglen)
3146 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3147 (unsigned char*)tmps + biglen, little, 0)))
3150 retval = tmps2 - tmps;
3151 if (retval > 0 && DO_UTF8(big))
3152 sv_pos_b2u(big, &retval);
3153 PUSHi(retval + arybase);
3168 I32 arybase = PL_curcop->cop_arybase;
3174 tmps2 = SvPV(little, llen);
3175 tmps = SvPV(big, blen);
3179 if (offset > 0 && DO_UTF8(big))
3180 sv_pos_u2b(big, &offset, 0);
3181 offset = offset - arybase + llen;
3185 else if (offset > (I32)blen)
3187 if (!(tmps2 = rninstr(tmps, tmps + offset,
3188 tmps2, tmps2 + llen)))
3191 retval = tmps2 - tmps;
3192 if (retval > 0 && DO_UTF8(big))
3193 sv_pos_b2u(big, &retval);
3194 PUSHi(retval + arybase);
3200 dSP; dMARK; dORIGMARK; dTARGET;
3201 do_sprintf(TARG, SP-MARK, MARK+1);
3202 TAINT_IF(SvTAINTED(TARG));
3203 if (DO_UTF8(*(MARK+1)))
3215 U8 *s = (U8*)SvPVx(argsv, len);
3218 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3219 tmpsv = sv_2mortal(newSVsv(argsv));
3220 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3224 XPUSHu(DO_UTF8(argsv) ?
3225 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3237 (void)SvUPGRADE(TARG,SVt_PV);
3239 if (value > 255 && !IN_BYTES) {
3240 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3241 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3242 SvCUR_set(TARG, tmps - SvPVX(TARG));
3244 (void)SvPOK_only(TARG);
3253 *tmps++ = (char)value;
3255 (void)SvPOK_only(TARG);
3256 if (PL_encoding && !IN_BYTES) {
3257 sv_recode_to_utf8(TARG, PL_encoding);
3259 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3260 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3264 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3265 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3281 char *tmps = SvPV(left, len);
3283 if (DO_UTF8(left)) {
3284 /* If Unicode, try to downgrade.
3285 * If not possible, croak.
3286 * Yes, we made this up. */
3287 SV* tsv = sv_2mortal(newSVsv(left));
3290 sv_utf8_downgrade(tsv, FALSE);
3293 # ifdef USE_ITHREADS
3295 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3296 /* This should be threadsafe because in ithreads there is only
3297 * one thread per interpreter. If this would not be true,
3298 * we would need a mutex to protect this malloc. */
3299 PL_reentrant_buffer->_crypt_struct_buffer =
3300 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3301 #if defined(__GLIBC__) || defined(__EMX__)
3302 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3303 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3304 /* work around glibc-2.2.5 bug */
3305 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3309 # endif /* HAS_CRYPT_R */
3310 # endif /* USE_ITHREADS */
3312 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3314 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3320 "The crypt() function is unimplemented due to excessive paranoia.");
3333 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3334 UTF8_IS_START(*s)) {
3335 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3339 utf8_to_uvchr(s, &ulen);
3340 toTITLE_utf8(s, tmpbuf, &tculen);
3341 utf8_to_uvchr(tmpbuf, 0);
3343 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3345 /* slen is the byte length of the whole SV.
3346 * ulen is the byte length of the original Unicode character
3347 * stored as UTF-8 at s.
3348 * tculen is the byte length of the freshly titlecased
3349 * Unicode character stored as UTF-8 at tmpbuf.
3350 * We first set the result to be the titlecased character,
3351 * and then append the rest of the SV data. */
3352 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3354 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3359 s = (U8*)SvPV_force_nomg(sv, slen);
3360 Copy(tmpbuf, s, tculen, U8);
3364 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3366 SvUTF8_off(TARG); /* decontaminate */
3367 sv_setsv_nomg(TARG, sv);
3371 s = (U8*)SvPV_force_nomg(sv, slen);
3373 if (IN_LOCALE_RUNTIME) {
3376 *s = toUPPER_LC(*s);
3395 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3396 UTF8_IS_START(*s)) {
3398 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3402 toLOWER_utf8(s, tmpbuf, &ulen);
3403 uv = utf8_to_uvchr(tmpbuf, 0);
3404 tend = uvchr_to_utf8(tmpbuf, uv);
3406 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3408 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3410 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3415 s = (U8*)SvPV_force_nomg(sv, slen);
3416 Copy(tmpbuf, s, ulen, U8);
3420 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3422 SvUTF8_off(TARG); /* decontaminate */
3423 sv_setsv_nomg(TARG, sv);
3427 s = (U8*)SvPV_force_nomg(sv, slen);
3429 if (IN_LOCALE_RUNTIME) {
3432 *s = toLOWER_LC(*s);
3455 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3457 s = (U8*)SvPV_nomg(sv,len);
3459 SvUTF8_off(TARG); /* decontaminate */
3460 sv_setpvn(TARG, "", 0);
3464 STRLEN nchar = utf8_length(s, s + len);
3466 (void)SvUPGRADE(TARG, SVt_PV);
3467 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3468 (void)SvPOK_only(TARG);
3469 d = (U8*)SvPVX(TARG);
3472 toUPPER_utf8(s, tmpbuf, &ulen);
3473 Copy(tmpbuf, d, ulen, U8);
3479 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3484 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3486 SvUTF8_off(TARG); /* decontaminate */
3487 sv_setsv_nomg(TARG, sv);
3491 s = (U8*)SvPV_force_nomg(sv, len);
3493 register U8 *send = s + len;
3495 if (IN_LOCALE_RUNTIME) {
3498 for (; s < send; s++)
3499 *s = toUPPER_LC(*s);
3502 for (; s < send; s++)
3524 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3526 s = (U8*)SvPV_nomg(sv,len);
3528 SvUTF8_off(TARG); /* decontaminate */
3529 sv_setpvn(TARG, "", 0);
3533 STRLEN nchar = utf8_length(s, s + len);
3535 (void)SvUPGRADE(TARG, SVt_PV);
3536 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3537 (void)SvPOK_only(TARG);
3538 d = (U8*)SvPVX(TARG);
3541 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3542 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3543 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3545 * Now if the sigma is NOT followed by
3546 * /$ignorable_sequence$cased_letter/;
3547 * and it IS preceded by
3548 * /$cased_letter$ignorable_sequence/;
3549 * where $ignorable_sequence is
3550 * [\x{2010}\x{AD}\p{Mn}]*
3551 * and $cased_letter is
3552 * [\p{Ll}\p{Lo}\p{Lt}]
3553 * then it should be mapped to 0x03C2,
3554 * (GREEK SMALL LETTER FINAL SIGMA),
3555 * instead of staying 0x03A3.
3556 * See lib/unicore/SpecCase.txt.
3559 Copy(tmpbuf, d, ulen, U8);
3565 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3570 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3572 SvUTF8_off(TARG); /* decontaminate */
3573 sv_setsv_nomg(TARG, sv);
3578 s = (U8*)SvPV_force_nomg(sv, len);
3580 register U8 *send = s + len;
3582 if (IN_LOCALE_RUNTIME) {
3585 for (; s < send; s++)
3586 *s = toLOWER_LC(*s);
3589 for (; s < send; s++)
3603 register char *s = SvPV(sv,len);
3606 SvUTF8_off(TARG); /* decontaminate */
3608 (void)SvUPGRADE(TARG, SVt_PV);
3609 SvGROW(TARG, (len * 2) + 1);
3613 if (UTF8_IS_CONTINUED(*s)) {
3614 STRLEN ulen = UTF8SKIP(s);
3638 SvCUR_set(TARG, d - SvPVX(TARG));
3639 (void)SvPOK_only_UTF8(TARG);
3642 sv_setpvn(TARG, s, len);
3644 if (SvSMAGICAL(TARG))
3653 dSP; dMARK; dORIGMARK;
3655 register AV* av = (AV*)POPs;
3656 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3657 I32 arybase = PL_curcop->cop_arybase;
3660 if (SvTYPE(av) == SVt_PVAV) {
3661 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3663 for (svp = MARK + 1; svp <= SP; svp++) {
3668 if (max > AvMAX(av))
3671 while (++MARK <= SP) {
3672 elem = SvIVx(*MARK);
3676 svp = av_fetch(av, elem, lval);
3678 if (!svp || *svp == &PL_sv_undef)
3679 DIE(aTHX_ PL_no_aelem, elem);
3680 if (PL_op->op_private & OPpLVAL_INTRO)
3681 save_aelem(av, elem, svp);
3683 *MARK = svp ? *svp : &PL_sv_undef;
3686 if (GIMME != G_ARRAY) {
3694 /* Associative arrays. */
3699 HV *hash = (HV*)POPs;
3701 I32 gimme = GIMME_V;
3704 /* might clobber stack_sp */
3705 entry = hv_iternext(hash);
3710 SV* sv = hv_iterkeysv(entry);
3711 PUSHs(sv); /* won't clobber stack_sp */
3712 if (gimme == G_ARRAY) {
3715 /* might clobber stack_sp */
3716 val = hv_iterval(hash, entry);
3721 else if (gimme == G_SCALAR)
3740 I32 gimme = GIMME_V;
3741 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3745 if (PL_op->op_private & OPpSLICE) {
3749 hvtype = SvTYPE(hv);
3750 if (hvtype == SVt_PVHV) { /* hash element */
3751 while (++MARK <= SP) {
3752 sv = hv_delete_ent(hv, *MARK, discard, 0);
3753 *MARK = sv ? sv : &PL_sv_undef;
3756 else if (hvtype == SVt_PVAV) { /* array element */
3757 if (PL_op->op_flags & OPf_SPECIAL) {
3758 while (++MARK <= SP) {
3759 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3760 *MARK = sv ? sv : &PL_sv_undef;
3765 DIE(aTHX_ "Not a HASH reference");
3768 else if (gimme == G_SCALAR) {
3777 if (SvTYPE(hv) == SVt_PVHV)
3778 sv = hv_delete_ent(hv, keysv, discard, 0);
3779 else if (SvTYPE(hv) == SVt_PVAV) {
3780 if (PL_op->op_flags & OPf_SPECIAL)
3781 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3783 DIE(aTHX_ "panic: avhv_delete no longer supported");
3786 DIE(aTHX_ "Not a HASH reference");
3801 if (PL_op->op_private & OPpEXISTS_SUB) {
3805 cv = sv_2cv(sv, &hv, &gv, FALSE);
3808 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3814 if (SvTYPE(hv) == SVt_PVHV) {
3815 if (hv_exists_ent(hv, tmpsv, 0))
3818 else if (SvTYPE(hv) == SVt_PVAV) {
3819 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3820 if (av_exists((AV*)hv, SvIV(tmpsv)))
3825 DIE(aTHX_ "Not a HASH reference");
3832 dSP; dMARK; dORIGMARK;
3833 register HV *hv = (HV*)POPs;
3834 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3835 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3836 bool other_magic = FALSE;
3842 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3843 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3844 /* Try to preserve the existenceness of a tied hash
3845 * element by using EXISTS and DELETE if possible.
3846 * Fallback to FETCH and STORE otherwise */
3847 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3848 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3849 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3852 while (++MARK <= SP) {
3856 bool preeminent = FALSE;
3859 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3860 hv_exists_ent(hv, keysv, 0);
3863 he = hv_fetch_ent(hv, keysv, lval, 0);
3864 svp = he ? &HeVAL(he) : 0;
3867 if (!svp || *svp == &PL_sv_undef) {
3869 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3873 save_helem(hv, keysv, svp);
3876 char *key = SvPV(keysv, keylen);
3877 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3881 *MARK = svp ? *svp : &PL_sv_undef;
3883 if (GIMME != G_ARRAY) {
3891 /* List operators. */
3896 if (GIMME != G_ARRAY) {
3898 *MARK = *SP; /* unwanted list, return last item */
3900 *MARK = &PL_sv_undef;
3909 SV **lastrelem = PL_stack_sp;
3910 SV **lastlelem = PL_stack_base + POPMARK;
3911 SV **firstlelem = PL_stack_base + POPMARK + 1;
3912 register SV **firstrelem = lastlelem + 1;
3913 I32 arybase = PL_curcop->cop_arybase;
3914 I32 lval = PL_op->op_flags & OPf_MOD;
3915 I32 is_something_there = lval;
3917 register I32 max = lastrelem - lastlelem;
3918 register SV **lelem;
3921 if (GIMME != G_ARRAY) {
3922 ix = SvIVx(*lastlelem);
3927 if (ix < 0 || ix >= max)
3928 *firstlelem = &PL_sv_undef;
3930 *firstlelem = firstrelem[ix];
3936 SP = firstlelem - 1;
3940 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3946 if (ix < 0 || ix >= max)
3947 *lelem = &PL_sv_undef;
3949 is_something_there = TRUE;
3950 if (!(*lelem = firstrelem[ix]))
3951 *lelem = &PL_sv_undef;
3954 if (is_something_there)
3957 SP = firstlelem - 1;
3963 dSP; dMARK; dORIGMARK;
3964 I32 items = SP - MARK;
3965 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3966 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3973 dSP; dMARK; dORIGMARK;
3974 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3978 SV *val = NEWSV(46, 0);
3980 sv_setsv(val, *++MARK);
3981 else if (ckWARN(WARN_MISC))
3982 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3983 (void)hv_store_ent(hv,key,val,0);
3992 dSP; dMARK; dORIGMARK;
3993 register AV *ary = (AV*)*++MARK;
3997 register I32 offset;
3998 register I32 length;
4005 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4006 *MARK-- = SvTIED_obj((SV*)ary, mg);
4010 call_method("SPLICE",GIMME_V);
4019 offset = i = SvIVx(*MARK);
4021 offset += AvFILLp(ary) + 1;
4023 offset -= PL_curcop->cop_arybase;
4025 DIE(aTHX_ PL_no_aelem, i);
4027 length = SvIVx(*MARK++);
4029 length += AvFILLp(ary) - offset + 1;
4035 length = AvMAX(ary) + 1; /* close enough to infinity */
4039 length = AvMAX(ary) + 1;
4041 if (offset > AvFILLp(ary) + 1) {
4042 if (ckWARN(WARN_MISC))
4043 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4044 offset = AvFILLp(ary) + 1;
4046 after = AvFILLp(ary) + 1 - (offset + length);
4047 if (after < 0) { /* not that much array */
4048 length += after; /* offset+length now in array */
4054 /* At this point, MARK .. SP-1 is our new LIST */
4057 diff = newlen - length;
4058 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4061 if (diff < 0) { /* shrinking the area */
4063 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4064 Copy(MARK, tmparyval, newlen, SV*);
4067 MARK = ORIGMARK + 1;
4068 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4069 MEXTEND(MARK, length);
4070 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4072 EXTEND_MORTAL(length);
4073 for (i = length, dst = MARK; i; i--) {
4074 sv_2mortal(*dst); /* free them eventualy */
4081 *MARK = AvARRAY(ary)[offset+length-1];
4084 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4085 SvREFCNT_dec(*dst++); /* free them now */
4088 AvFILLp(ary) += diff;
4090 /* pull up or down? */
4092 if (offset < after) { /* easier to pull up */
4093 if (offset) { /* esp. if nothing to pull */
4094 src = &AvARRAY(ary)[offset-1];
4095 dst = src - diff; /* diff is negative */
4096 for (i = offset; i > 0; i--) /* can't trust Copy */
4100 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4104 if (after) { /* anything to pull down? */
4105 src = AvARRAY(ary) + offset + length;
4106 dst = src + diff; /* diff is negative */
4107 Move(src, dst, after, SV*);
4109 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4110 /* avoid later double free */
4114 dst[--i] = &PL_sv_undef;
4117 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4119 *dst = NEWSV(46, 0);
4120 sv_setsv(*dst++, *src++);
4122 Safefree(tmparyval);
4125 else { /* no, expanding (or same) */
4127 New(452, tmparyval, length, SV*); /* so remember deletion */
4128 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4131 if (diff > 0) { /* expanding */
4133 /* push up or down? */
4135 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4139 Move(src, dst, offset, SV*);
4141 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4143 AvFILLp(ary) += diff;
4146 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4147 av_extend(ary, AvFILLp(ary) + diff);
4148 AvFILLp(ary) += diff;
4151 dst = AvARRAY(ary) + AvFILLp(ary);
4153 for (i = after; i; i--) {
4160 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4161 *dst = NEWSV(46, 0);
4162 sv_setsv(*dst++, *src++);
4164 MARK = ORIGMARK + 1;
4165 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4167 Copy(tmparyval, MARK, length, SV*);
4169 EXTEND_MORTAL(length);
4170 for (i = length, dst = MARK; i; i--) {
4171 sv_2mortal(*dst); /* free them eventualy */
4175 Safefree(tmparyval);
4179 else if (length--) {
4180 *MARK = tmparyval[length];
4183 while (length-- > 0)
4184 SvREFCNT_dec(tmparyval[length]);
4186 Safefree(tmparyval);
4189 *MARK = &PL_sv_undef;
4197 dSP; dMARK; dORIGMARK; dTARGET;
4198 register AV *ary = (AV*)*++MARK;
4199 register SV *sv = &PL_sv_undef;
4202 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4203 *MARK-- = SvTIED_obj((SV*)ary, mg);
4207 call_method("PUSH",G_SCALAR|G_DISCARD);
4212 /* Why no pre-extend of ary here ? */
4213 for (++MARK; MARK <= SP; MARK++) {
4216 sv_setsv(sv, *MARK);
4221 PUSHi( AvFILL(ary) + 1 );
4229 SV *sv = av_pop(av);
4231 (void)sv_2mortal(sv);
4240 SV *sv = av_shift(av);
4245 (void)sv_2mortal(sv);
4252 dSP; dMARK; dORIGMARK; dTARGET;
4253 register AV *ary = (AV*)*++MARK;
4258 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4259 *MARK-- = SvTIED_obj((SV*)ary, mg);
4263 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4268 av_unshift(ary, SP - MARK);
4271 sv_setsv(sv, *++MARK);
4272 (void)av_store(ary, i++, sv);
4276 PUSHi( AvFILL(ary) + 1 );
4286 if (GIMME == G_ARRAY) {
4293 /* safe as long as stack cannot get extended in the above */
4298 register char *down;
4303 SvUTF8_off(TARG); /* decontaminate */
4305 do_join(TARG, &PL_sv_no, MARK, SP);
4307 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4308 up = SvPV_force(TARG, len);
4310 if (DO_UTF8(TARG)) { /* first reverse each character */
4311 U8* s = (U8*)SvPVX(TARG);
4312 U8* send = (U8*)(s + len);
4314 if (UTF8_IS_INVARIANT(*s)) {
4319 if (!utf8_to_uvchr(s, 0))
4323 down = (char*)(s - 1);
4324 /* reverse this character */
4328 *down-- = (char)tmp;
4334 down = SvPVX(TARG) + len - 1;
4338 *down-- = (char)tmp;
4340 (void)SvPOK_only_UTF8(TARG);
4352 register IV limit = POPi; /* note, negative is forever */
4355 register char *s = SvPV(sv, len);
4356 bool do_utf8 = DO_UTF8(sv);
4357 char *strend = s + len;
4359 register REGEXP *rx;
4363 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4364 I32 maxiters = slen + 10;
4367 I32 origlimit = limit;
4370 AV *oldstack = PL_curstack;
4371 I32 gimme = GIMME_V;
4372 I32 oldsave = PL_savestack_ix;
4373 I32 make_mortal = 1;
4374 MAGIC *mg = (MAGIC *) NULL;
4377 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4382 DIE(aTHX_ "panic: pp_split");
4385 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4386 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4388 RX_MATCH_UTF8_set(rx, do_utf8);
4390 if (pm->op_pmreplroot) {
4392 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4394 ary = GvAVn((GV*)pm->op_pmreplroot);
4397 else if (gimme != G_ARRAY)
4398 ary = GvAVn(PL_defgv);
4401 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4407 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4409 XPUSHs(SvTIED_obj((SV*)ary, mg));
4415 for (i = AvFILLp(ary); i >= 0; i--)
4416 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4418 /* temporarily switch stacks */
4419 SWITCHSTACK(PL_curstack, ary);
4420 PL_curstackinfo->si_stack = ary;
4424 base = SP - PL_stack_base;
4426 if (pm->op_pmflags & PMf_SKIPWHITE) {
4427 if (pm->op_pmflags & PMf_LOCALE) {
4428 while (isSPACE_LC(*s))
4436 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4437 SAVEINT(PL_multiline);
4438 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4442 limit = maxiters + 2;
4443 if (pm->op_pmflags & PMf_WHITE) {
4446 while (m < strend &&
4447 !((pm->op_pmflags & PMf_LOCALE)
4448 ? isSPACE_LC(*m) : isSPACE(*m)))
4453 dstr = NEWSV(30, m-s);
4454 sv_setpvn(dstr, s, m-s);
4458 (void)SvUTF8_on(dstr);
4462 while (s < strend &&
4463 ((pm->op_pmflags & PMf_LOCALE)
4464 ? isSPACE_LC(*s) : isSPACE(*s)))
4468 else if (strEQ("^", rx->precomp)) {
4471 for (m = s; m < strend && *m != '\n'; m++) ;
4475 dstr = NEWSV(30, m-s);
4476 sv_setpvn(dstr, s, m-s);
4480 (void)SvUTF8_on(dstr);
4485 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4486 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4487 && (rx->reganch & ROPT_CHECK_ALL)
4488 && !(rx->reganch & ROPT_ANCH)) {
4489 int tail = (rx->reganch & RE_INTUIT_TAIL);
4490 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4493 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4495 char c = *SvPV(csv, n_a);
4498 for (m = s; m < strend && *m != c; m++) ;
4501 dstr = NEWSV(30, m-s);
4502 sv_setpvn(dstr, s, m-s);
4506 (void)SvUTF8_on(dstr);
4508 /* The rx->minlen is in characters but we want to step
4509 * s ahead by bytes. */
4511 s = (char*)utf8_hop((U8*)m, len);
4513 s = m + len; /* Fake \n at the end */
4518 while (s < strend && --limit &&
4519 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4520 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4523 dstr = NEWSV(31, m-s);
4524 sv_setpvn(dstr, s, m-s);
4528 (void)SvUTF8_on(dstr);
4530 /* The rx->minlen is in characters but we want to step
4531 * s ahead by bytes. */
4533 s = (char*)utf8_hop((U8*)m, len);
4535 s = m + len; /* Fake \n at the end */
4540 maxiters += slen * rx->nparens;
4541 while (s < strend && --limit)
4544 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4548 TAINT_IF(RX_MATCH_TAINTED(rx));
4549 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4554 strend = s + (strend - m);
4556 m = rx->startp[0] + orig;
4557 dstr = NEWSV(32, m-s);
4558 sv_setpvn(dstr, s, m-s);
4562 (void)SvUTF8_on(dstr);
4565 for (i = 1; i <= (I32)rx->nparens; i++) {
4566 s = rx->startp[i] + orig;
4567 m = rx->endp[i] + orig;
4569 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4570 parens that didn't match -- they should be set to
4571 undef, not the empty string */
4572 if (m >= orig && s >= orig) {
4573 dstr = NEWSV(33, m-s);
4574 sv_setpvn(dstr, s, m-s);
4577 dstr = &PL_sv_undef; /* undef, not "" */
4581 (void)SvUTF8_on(dstr);
4585 s = rx->endp[0] + orig;
4589 LEAVE_SCOPE(oldsave);
4590 iters = (SP - PL_stack_base) - base;
4591 if (iters > maxiters)
4592 DIE(aTHX_ "Split loop");
4594 /* keep field after final delim? */
4595 if (s < strend || (iters && origlimit)) {
4596 STRLEN l = strend - s;
4597 dstr = NEWSV(34, l);
4598 sv_setpvn(dstr, s, l);
4602 (void)SvUTF8_on(dstr);
4606 else if (!origlimit) {
4607 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4608 if (TOPs && !make_mortal)
4617 SWITCHSTACK(ary, oldstack);
4618 PL_curstackinfo->si_stack = oldstack;
4619 if (SvSMAGICAL(ary)) {
4624 if (gimme == G_ARRAY) {
4626 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4634 call_method("PUSH",G_SCALAR|G_DISCARD);
4637 if (gimme == G_ARRAY) {
4638 /* EXTEND should not be needed - we just popped them */
4640 for (i=0; i < iters; i++) {
4641 SV **svp = av_fetch(ary, i, FALSE);
4642 PUSHs((svp) ? *svp : &PL_sv_undef);
4649 if (gimme == G_ARRAY)
4664 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4665 || SvTYPE(retsv) == SVt_PVCV) {
4666 retsv = refto(retsv);
4674 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");