3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
23 /* XXX I can't imagine anyone who doesn't have this actually _needs_
24 it, since pid_t is an integral type.
27 #ifdef NEED_GETPID_PROTO
28 extern Pid_t getpid (void);
31 /* variations on pp_null */
36 if (GIMME_V == G_SCALAR)
52 if (PL_op->op_private & OPpLVAL_INTRO)
53 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
55 if (PL_op->op_flags & OPf_REF) {
59 if (GIMME == G_SCALAR)
60 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
65 if (gimme == G_ARRAY) {
66 I32 maxarg = AvFILL((AV*)TARG) + 1;
68 if (SvMAGICAL(TARG)) {
70 for (i=0; i < (U32)maxarg; i++) {
71 SV **svp = av_fetch((AV*)TARG, i, FALSE);
72 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
76 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
80 else if (gimme == G_SCALAR) {
81 SV* sv = sv_newmortal();
82 I32 maxarg = AvFILL((AV*)TARG) + 1;
95 if (PL_op->op_private & OPpLVAL_INTRO)
96 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
97 if (PL_op->op_flags & OPf_REF)
100 if (GIMME == G_SCALAR)
101 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
105 if (gimme == G_ARRAY) {
108 else if (gimme == G_SCALAR) {
109 SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
117 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
128 tryAMAGICunDEREF(to_gv);
131 if (SvTYPE(sv) == SVt_PVIO) {
132 GV *gv = (GV*) sv_newmortal();
133 gv_init(gv, 0, "", 0, 0);
134 GvIOp(gv) = (IO *)sv;
135 (void)SvREFCNT_inc(sv);
138 else if (SvTYPE(sv) != SVt_PVGV)
139 DIE(aTHX_ "Not a GLOB reference");
142 if (SvTYPE(sv) != SVt_PVGV) {
146 if (SvGMAGICAL(sv)) {
151 if (!SvOK(sv) && sv != &PL_sv_undef) {
152 /* If this is a 'my' scalar and flag is set then vivify
155 if (PL_op->op_private & OPpDEREF) {
158 if (cUNOP->op_targ) {
160 SV *namesv = PAD_SV(cUNOP->op_targ);
161 name = SvPV(namesv, len);
162 gv = (GV*)NEWSV(0,0);
163 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
166 name = CopSTASHPV(PL_curcop);
169 if (SvTYPE(sv) < SVt_RV)
170 sv_upgrade(sv, SVt_RV);
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_PVGV && 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_PVGV && 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_PVGV && 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;
1391 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1393 I32 items = SP - MARK;
1395 static const char list_extend[] = "panic: list extend";
1397 max = items * count;
1398 MEM_WRAP_CHECK_1(max, SV*, list_extend);
1399 if (items > 0 && max > 0 && (max < items || max < count))
1400 Perl_croak(aTHX_ list_extend);
1405 /* This code was intended to fix 20010809.028:
1408 for (($x =~ /./g) x 2) {
1409 print chop; # "abcdabcd" expected as output.
1412 * but that change (#11635) broke this code:
1414 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1416 * I can't think of a better fix that doesn't introduce
1417 * an efficiency hit by copying the SVs. The stack isn't
1418 * refcounted, and mortalisation obviously doesn't
1419 * Do The Right Thing when the stack has more than
1420 * one pointer to the same mortal value.
1424 *SP = sv_2mortal(newSVsv(*SP));
1434 repeatcpy((char*)(MARK + items), (char*)MARK,
1435 items * sizeof(SV*), count - 1);
1438 else if (count <= 0)
1441 else { /* Note: mark already snarfed by pp_list */
1446 SvSetSV(TARG, tmpstr);
1447 SvPV_force(TARG, len);
1448 isutf = DO_UTF8(TARG);
1453 MEM_WRAP_CHECK_1(count, len, "panic: string extend");
1454 SvGROW(TARG, (count * len) + 1);
1455 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1456 SvCUR(TARG) *= count;
1458 *SvEND(TARG) = '\0';
1461 (void)SvPOK_only_UTF8(TARG);
1463 (void)SvPOK_only(TARG);
1465 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1466 /* The parser saw this as a list repeat, and there
1467 are probably several items on the stack. But we're
1468 in scalar context, and there's no pp_list to save us
1469 now. So drop the rest of the items -- robin@kitsite.com
1482 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1483 useleft = USE_LEFT(TOPm1s);
1484 #ifdef PERL_PRESERVE_IVUV
1485 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1486 "bad things" happen if you rely on signed integers wrapping. */
1489 /* Unless the left argument is integer in range we are going to have to
1490 use NV maths. Hence only attempt to coerce the right argument if
1491 we know the left is integer. */
1492 register UV auv = 0;
1498 a_valid = auvok = 1;
1499 /* left operand is undef, treat as zero. */
1501 /* Left operand is defined, so is it IV? */
1502 SvIV_please(TOPm1s);
1503 if (SvIOK(TOPm1s)) {
1504 if ((auvok = SvUOK(TOPm1s)))
1505 auv = SvUVX(TOPm1s);
1507 register IV aiv = SvIVX(TOPm1s);
1510 auvok = 1; /* Now acting as a sign flag. */
1511 } else { /* 2s complement assumption for IV_MIN */
1519 bool result_good = 0;
1522 bool buvok = SvUOK(TOPs);
1527 register IV biv = SvIVX(TOPs);
1534 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1535 else "IV" now, independent of how it came in.
1536 if a, b represents positive, A, B negative, a maps to -A etc
1541 all UV maths. negate result if A negative.
1542 subtract if signs same, add if signs differ. */
1544 if (auvok ^ buvok) {
1553 /* Must get smaller */
1558 if (result <= buv) {
1559 /* result really should be -(auv-buv). as its negation
1560 of true value, need to swap our result flag */
1572 if (result <= (UV)IV_MIN)
1573 SETi( -(IV)result );
1575 /* result valid, but out of range for IV. */
1576 SETn( -(NV)result );
1580 } /* Overflow, drop through to NVs. */
1584 useleft = USE_LEFT(TOPm1s);
1588 /* left operand is undef, treat as zero - value */
1592 SETn( TOPn - value );
1599 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1602 if (PL_op->op_private & HINT_INTEGER) {
1616 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1619 if (PL_op->op_private & HINT_INTEGER) {
1633 dSP; tryAMAGICbinSET(lt,0);
1634 #ifdef PERL_PRESERVE_IVUV
1637 SvIV_please(TOPm1s);
1638 if (SvIOK(TOPm1s)) {
1639 bool auvok = SvUOK(TOPm1s);
1640 bool buvok = SvUOK(TOPs);
1642 if (!auvok && !buvok) { /* ## IV < IV ## */
1643 IV aiv = SvIVX(TOPm1s);
1644 IV biv = SvIVX(TOPs);
1647 SETs(boolSV(aiv < biv));
1650 if (auvok && buvok) { /* ## UV < UV ## */
1651 UV auv = SvUVX(TOPm1s);
1652 UV buv = SvUVX(TOPs);
1655 SETs(boolSV(auv < buv));
1658 if (auvok) { /* ## UV < IV ## */
1665 /* As (a) is a UV, it's >=0, so it cannot be < */
1670 SETs(boolSV(auv < (UV)biv));
1673 { /* ## IV < UV ## */
1677 aiv = SvIVX(TOPm1s);
1679 /* As (b) is a UV, it's >=0, so it must be < */
1686 SETs(boolSV((UV)aiv < buv));
1692 #ifndef NV_PRESERVES_UV
1693 #ifdef PERL_PRESERVE_IVUV
1696 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1698 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1704 SETs(boolSV(TOPn < value));
1711 dSP; tryAMAGICbinSET(gt,0);
1712 #ifdef PERL_PRESERVE_IVUV
1715 SvIV_please(TOPm1s);
1716 if (SvIOK(TOPm1s)) {
1717 bool auvok = SvUOK(TOPm1s);
1718 bool buvok = SvUOK(TOPs);
1720 if (!auvok && !buvok) { /* ## IV > IV ## */
1721 IV aiv = SvIVX(TOPm1s);
1722 IV biv = SvIVX(TOPs);
1725 SETs(boolSV(aiv > biv));
1728 if (auvok && buvok) { /* ## UV > UV ## */
1729 UV auv = SvUVX(TOPm1s);
1730 UV buv = SvUVX(TOPs);
1733 SETs(boolSV(auv > buv));
1736 if (auvok) { /* ## UV > IV ## */
1743 /* As (a) is a UV, it's >=0, so it must be > */
1748 SETs(boolSV(auv > (UV)biv));
1751 { /* ## IV > UV ## */
1755 aiv = SvIVX(TOPm1s);
1757 /* As (b) is a UV, it's >=0, so it cannot be > */
1764 SETs(boolSV((UV)aiv > buv));
1770 #ifndef NV_PRESERVES_UV
1771 #ifdef PERL_PRESERVE_IVUV
1774 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1776 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1782 SETs(boolSV(TOPn > value));
1789 dSP; tryAMAGICbinSET(le,0);
1790 #ifdef PERL_PRESERVE_IVUV
1793 SvIV_please(TOPm1s);
1794 if (SvIOK(TOPm1s)) {
1795 bool auvok = SvUOK(TOPm1s);
1796 bool buvok = SvUOK(TOPs);
1798 if (!auvok && !buvok) { /* ## IV <= IV ## */
1799 IV aiv = SvIVX(TOPm1s);
1800 IV biv = SvIVX(TOPs);
1803 SETs(boolSV(aiv <= biv));
1806 if (auvok && buvok) { /* ## UV <= UV ## */
1807 UV auv = SvUVX(TOPm1s);
1808 UV buv = SvUVX(TOPs);
1811 SETs(boolSV(auv <= buv));
1814 if (auvok) { /* ## UV <= IV ## */
1821 /* As (a) is a UV, it's >=0, so a cannot be <= */
1826 SETs(boolSV(auv <= (UV)biv));
1829 { /* ## IV <= UV ## */
1833 aiv = SvIVX(TOPm1s);
1835 /* As (b) is a UV, it's >=0, so a must be <= */
1842 SETs(boolSV((UV)aiv <= buv));
1848 #ifndef NV_PRESERVES_UV
1849 #ifdef PERL_PRESERVE_IVUV
1852 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1854 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1860 SETs(boolSV(TOPn <= value));
1867 dSP; tryAMAGICbinSET(ge,0);
1868 #ifdef PERL_PRESERVE_IVUV
1871 SvIV_please(TOPm1s);
1872 if (SvIOK(TOPm1s)) {
1873 bool auvok = SvUOK(TOPm1s);
1874 bool buvok = SvUOK(TOPs);
1876 if (!auvok && !buvok) { /* ## IV >= IV ## */
1877 IV aiv = SvIVX(TOPm1s);
1878 IV biv = SvIVX(TOPs);
1881 SETs(boolSV(aiv >= biv));
1884 if (auvok && buvok) { /* ## UV >= UV ## */
1885 UV auv = SvUVX(TOPm1s);
1886 UV buv = SvUVX(TOPs);
1889 SETs(boolSV(auv >= buv));
1892 if (auvok) { /* ## UV >= IV ## */
1899 /* As (a) is a UV, it's >=0, so it must be >= */
1904 SETs(boolSV(auv >= (UV)biv));
1907 { /* ## IV >= UV ## */
1911 aiv = SvIVX(TOPm1s);
1913 /* As (b) is a UV, it's >=0, so a cannot be >= */
1920 SETs(boolSV((UV)aiv >= buv));
1926 #ifndef NV_PRESERVES_UV
1927 #ifdef PERL_PRESERVE_IVUV
1930 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1932 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1938 SETs(boolSV(TOPn >= value));
1945 dSP; tryAMAGICbinSET(ne,0);
1946 #ifndef NV_PRESERVES_UV
1947 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1949 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1953 #ifdef PERL_PRESERVE_IVUV
1956 SvIV_please(TOPm1s);
1957 if (SvIOK(TOPm1s)) {
1958 bool auvok = SvUOK(TOPm1s);
1959 bool buvok = SvUOK(TOPs);
1961 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1962 /* Casting IV to UV before comparison isn't going to matter
1963 on 2s complement. On 1s complement or sign&magnitude
1964 (if we have any of them) it could make negative zero
1965 differ from normal zero. As I understand it. (Need to
1966 check - is negative zero implementation defined behaviour
1968 UV buv = SvUVX(POPs);
1969 UV auv = SvUVX(TOPs);
1971 SETs(boolSV(auv != buv));
1974 { /* ## Mixed IV,UV ## */
1978 /* != is commutative so swap if needed (save code) */
1980 /* swap. top of stack (b) is the iv */
1984 /* As (a) is a UV, it's >0, so it cannot be == */
1993 /* As (b) is a UV, it's >0, so it cannot be == */
1997 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1999 SETs(boolSV((UV)iv != uv));
2007 SETs(boolSV(TOPn != value));
2014 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2015 #ifndef NV_PRESERVES_UV
2016 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2017 UV right = PTR2UV(SvRV(POPs));
2018 UV left = PTR2UV(SvRV(TOPs));
2019 SETi((left > right) - (left < right));
2023 #ifdef PERL_PRESERVE_IVUV
2024 /* Fortunately it seems NaN isn't IOK */
2027 SvIV_please(TOPm1s);
2028 if (SvIOK(TOPm1s)) {
2029 bool leftuvok = SvUOK(TOPm1s);
2030 bool rightuvok = SvUOK(TOPs);
2032 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2033 IV leftiv = SvIVX(TOPm1s);
2034 IV rightiv = SvIVX(TOPs);
2036 if (leftiv > rightiv)
2038 else if (leftiv < rightiv)
2042 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2043 UV leftuv = SvUVX(TOPm1s);
2044 UV rightuv = SvUVX(TOPs);
2046 if (leftuv > rightuv)
2048 else if (leftuv < rightuv)
2052 } else if (leftuvok) { /* ## UV <=> IV ## */
2056 rightiv = SvIVX(TOPs);
2058 /* As (a) is a UV, it's >=0, so it cannot be < */
2061 leftuv = SvUVX(TOPm1s);
2062 if (leftuv > (UV)rightiv) {
2064 } else if (leftuv < (UV)rightiv) {
2070 } else { /* ## IV <=> UV ## */
2074 leftiv = SvIVX(TOPm1s);
2076 /* As (b) is a UV, it's >=0, so it must be < */
2079 rightuv = SvUVX(TOPs);
2080 if ((UV)leftiv > rightuv) {
2082 } else if ((UV)leftiv < rightuv) {
2100 if (Perl_isnan(left) || Perl_isnan(right)) {
2104 value = (left > right) - (left < right);
2108 else if (left < right)
2110 else if (left > right)
2124 dSP; tryAMAGICbinSET(slt,0);
2127 int cmp = (IN_LOCALE_RUNTIME
2128 ? sv_cmp_locale(left, right)
2129 : sv_cmp(left, right));
2130 SETs(boolSV(cmp < 0));
2137 dSP; tryAMAGICbinSET(sgt,0);
2140 int cmp = (IN_LOCALE_RUNTIME
2141 ? sv_cmp_locale(left, right)
2142 : sv_cmp(left, right));
2143 SETs(boolSV(cmp > 0));
2150 dSP; tryAMAGICbinSET(sle,0);
2153 int cmp = (IN_LOCALE_RUNTIME
2154 ? sv_cmp_locale(left, right)
2155 : sv_cmp(left, right));
2156 SETs(boolSV(cmp <= 0));
2163 dSP; tryAMAGICbinSET(sge,0);
2166 int cmp = (IN_LOCALE_RUNTIME
2167 ? sv_cmp_locale(left, right)
2168 : sv_cmp(left, right));
2169 SETs(boolSV(cmp >= 0));
2176 dSP; tryAMAGICbinSET(seq,0);
2179 SETs(boolSV(sv_eq(left, right)));
2186 dSP; tryAMAGICbinSET(sne,0);
2189 SETs(boolSV(!sv_eq(left, right)));
2196 dSP; dTARGET; tryAMAGICbin(scmp,0);
2199 int cmp = (IN_LOCALE_RUNTIME
2200 ? sv_cmp_locale(left, right)
2201 : sv_cmp(left, right));
2209 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2212 if (SvGMAGICAL(left)) mg_get(left);
2213 if (SvGMAGICAL(right)) mg_get(right);
2214 if (SvNIOKp(left) || SvNIOKp(right)) {
2215 if (PL_op->op_private & HINT_INTEGER) {
2216 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2220 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2225 do_vop(PL_op->op_type, TARG, left, right);
2234 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2237 if (SvGMAGICAL(left)) mg_get(left);
2238 if (SvGMAGICAL(right)) mg_get(right);
2239 if (SvNIOKp(left) || SvNIOKp(right)) {
2240 if (PL_op->op_private & HINT_INTEGER) {
2241 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2245 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2250 do_vop(PL_op->op_type, TARG, left, right);
2259 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2262 if (SvGMAGICAL(left)) mg_get(left);
2263 if (SvGMAGICAL(right)) mg_get(right);
2264 if (SvNIOKp(left) || SvNIOKp(right)) {
2265 if (PL_op->op_private & HINT_INTEGER) {
2266 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2270 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2275 do_vop(PL_op->op_type, TARG, left, right);
2284 dSP; dTARGET; tryAMAGICun(neg);
2287 int flags = SvFLAGS(sv);
2290 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2291 /* It's publicly an integer, or privately an integer-not-float */
2294 if (SvIVX(sv) == IV_MIN) {
2295 /* 2s complement assumption. */
2296 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2299 else if (SvUVX(sv) <= IV_MAX) {
2304 else if (SvIVX(sv) != IV_MIN) {
2308 #ifdef PERL_PRESERVE_IVUV
2317 else if (SvPOKp(sv)) {
2319 char *s = SvPV(sv, len);
2320 if (isIDFIRST(*s)) {
2321 sv_setpvn(TARG, "-", 1);
2324 else if (*s == '+' || *s == '-') {
2326 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2328 else if (DO_UTF8(sv)) {
2331 goto oops_its_an_int;
2333 sv_setnv(TARG, -SvNV(sv));
2335 sv_setpvn(TARG, "-", 1);
2342 goto oops_its_an_int;
2343 sv_setnv(TARG, -SvNV(sv));
2355 dSP; tryAMAGICunSET(not);
2356 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2362 dSP; dTARGET; tryAMAGICun(compl);
2368 if (PL_op->op_private & HINT_INTEGER) {
2369 IV i = ~SvIV_nomg(sv);
2373 UV u = ~SvUV_nomg(sv);
2382 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2383 sv_setsv_nomg(TARG, sv);
2384 tmps = (U8*)SvPV_force(TARG, len);
2387 /* Calculate exact length, let's not estimate. */
2396 while (tmps < send) {
2397 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2398 tmps += UTF8SKIP(tmps);
2399 targlen += UNISKIP(~c);
2405 /* Now rewind strings and write them. */
2409 Newz(0, result, targlen + 1, U8);
2410 while (tmps < send) {
2411 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2412 tmps += UTF8SKIP(tmps);
2413 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2417 sv_setpvn(TARG, (char*)result, targlen);
2421 Newz(0, result, nchar + 1, U8);
2422 while (tmps < send) {
2423 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2424 tmps += UTF8SKIP(tmps);
2429 sv_setpvn(TARG, (char*)result, nchar);
2438 register long *tmpl;
2439 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2442 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2447 for ( ; anum > 0; anum--, tmps++)
2456 /* integer versions of some of the above */
2460 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2463 SETi( left * right );
2470 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2474 DIE(aTHX_ "Illegal division by zero");
2475 value = POPi / value;
2484 /* This is the vanilla old i_modulo. */
2485 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2489 DIE(aTHX_ "Illegal modulus zero");
2490 SETi( left % right );
2495 #if defined(__GLIBC__) && IVSIZE == 8
2499 /* This is the i_modulo with the workaround for the _moddi3 bug
2500 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2501 * See below for pp_i_modulo. */
2502 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2506 DIE(aTHX_ "Illegal modulus zero");
2507 SETi( left % PERL_ABS(right) );
2515 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2519 DIE(aTHX_ "Illegal modulus zero");
2520 /* The assumption is to use hereafter the old vanilla version... */
2522 PL_ppaddr[OP_I_MODULO] =
2523 &Perl_pp_i_modulo_0;
2524 /* .. but if we have glibc, we might have a buggy _moddi3
2525 * (at least glicb 2.2.5 is known to have this bug), in other
2526 * words our integer modulus with negative quad as the second
2527 * argument might be broken. Test for this and re-patch the
2528 * opcode dispatch table if that is the case, remembering to
2529 * also apply the workaround so that this first round works
2530 * right, too. See [perl #9402] for more information. */
2531 #if defined(__GLIBC__) && IVSIZE == 8
2535 /* Cannot do this check with inlined IV constants since
2536 * that seems to work correctly even with the buggy glibc. */
2538 /* Yikes, we have the bug.
2539 * Patch in the workaround version. */
2541 PL_ppaddr[OP_I_MODULO] =
2542 &Perl_pp_i_modulo_1;
2543 /* Make certain we work right this time, too. */
2544 right = PERL_ABS(right);
2548 SETi( left % right );
2555 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2558 SETi( left + right );
2565 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2568 SETi( left - right );
2575 dSP; tryAMAGICbinSET(lt,0);
2578 SETs(boolSV(left < right));
2585 dSP; tryAMAGICbinSET(gt,0);
2588 SETs(boolSV(left > right));
2595 dSP; tryAMAGICbinSET(le,0);
2598 SETs(boolSV(left <= right));
2605 dSP; tryAMAGICbinSET(ge,0);
2608 SETs(boolSV(left >= right));
2615 dSP; tryAMAGICbinSET(eq,0);
2618 SETs(boolSV(left == right));
2625 dSP; tryAMAGICbinSET(ne,0);
2628 SETs(boolSV(left != right));
2635 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2642 else if (left < right)
2653 dSP; dTARGET; tryAMAGICun(neg);
2658 /* High falutin' math. */
2662 dSP; dTARGET; tryAMAGICbin(atan2,0);
2665 SETn(Perl_atan2(left, right));
2672 dSP; dTARGET; tryAMAGICun(sin);
2676 value = Perl_sin(value);
2684 dSP; dTARGET; tryAMAGICun(cos);
2688 value = Perl_cos(value);
2694 /* Support Configure command-line overrides for rand() functions.
2695 After 5.005, perhaps we should replace this by Configure support
2696 for drand48(), random(), or rand(). For 5.005, though, maintain
2697 compatibility by calling rand() but allow the user to override it.
2698 See INSTALL for details. --Andy Dougherty 15 July 1998
2700 /* Now it's after 5.005, and Configure supports drand48() and random(),
2701 in addition to rand(). So the overrides should not be needed any more.
2702 --Jarkko Hietaniemi 27 September 1998
2705 #ifndef HAS_DRAND48_PROTO
2706 extern double drand48 (void);
2719 if (!PL_srand_called) {
2720 (void)seedDrand01((Rand_seed_t)seed());
2721 PL_srand_called = TRUE;
2736 (void)seedDrand01((Rand_seed_t)anum);
2737 PL_srand_called = TRUE;
2744 dSP; dTARGET; tryAMAGICun(exp);
2748 value = Perl_exp(value);
2756 dSP; dTARGET; tryAMAGICun(log);
2761 SET_NUMERIC_STANDARD();
2762 DIE(aTHX_ "Can't take log of %"NVgf, value);
2764 value = Perl_log(value);
2772 dSP; dTARGET; tryAMAGICun(sqrt);
2777 SET_NUMERIC_STANDARD();
2778 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2780 value = Perl_sqrt(value);
2788 dSP; dTARGET; tryAMAGICun(int);
2791 IV iv = TOPi; /* attempt to convert to IV if possible. */
2792 /* XXX it's arguable that compiler casting to IV might be subtly
2793 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2794 else preferring IV has introduced a subtle behaviour change bug. OTOH
2795 relying on floating point to be accurate is a bug. */
2806 if (value < (NV)UV_MAX + 0.5) {
2809 SETn(Perl_floor(value));
2813 if (value > (NV)IV_MIN - 0.5) {
2816 SETn(Perl_ceil(value));
2826 dSP; dTARGET; tryAMAGICun(abs);
2828 /* This will cache the NV value if string isn't actually integer */
2832 /* IVX is precise */
2834 SETu(TOPu); /* force it to be numeric only */
2842 /* 2s complement assumption. Also, not really needed as
2843 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2863 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2869 tmps = (SvPVx(sv, len));
2871 /* If Unicode, try to downgrade
2872 * If not possible, croak. */
2873 SV* tsv = sv_2mortal(newSVsv(sv));
2876 sv_utf8_downgrade(tsv, FALSE);
2879 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2880 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2893 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2899 tmps = (SvPVx(sv, len));
2901 /* If Unicode, try to downgrade
2902 * If not possible, croak. */
2903 SV* tsv = sv_2mortal(newSVsv(sv));
2906 sv_utf8_downgrade(tsv, FALSE);
2909 while (*tmps && len && isSPACE(*tmps))
2914 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2915 else if (*tmps == 'b')
2916 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2918 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2920 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2937 SETi(sv_len_utf8(sv));
2953 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2955 I32 arybase = PL_curcop->cop_arybase;
2959 int num_args = PL_op->op_private & 7;
2960 bool repl_need_utf8_upgrade = FALSE;
2961 bool repl_is_utf8 = FALSE;
2963 SvTAINTED_off(TARG); /* decontaminate */
2964 SvUTF8_off(TARG); /* decontaminate */
2968 repl = SvPV(repl_sv, repl_len);
2969 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2979 sv_utf8_upgrade(sv);
2981 else if (DO_UTF8(sv))
2982 repl_need_utf8_upgrade = TRUE;
2984 tmps = SvPV(sv, curlen);
2986 utf8_curlen = sv_len_utf8(sv);
2987 if (utf8_curlen == curlen)
2990 curlen = utf8_curlen;
2995 if (pos >= arybase) {
3013 else if (len >= 0) {
3015 if (rem > (I32)curlen)
3030 Perl_croak(aTHX_ "substr outside of string");
3031 if (ckWARN(WARN_SUBSTR))
3032 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3039 sv_pos_u2b(sv, &pos, &rem);
3041 sv_setpvn(TARG, tmps, rem);
3042 #ifdef USE_LOCALE_COLLATE
3043 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3048 SV* repl_sv_copy = NULL;
3050 if (repl_need_utf8_upgrade) {
3051 repl_sv_copy = newSVsv(repl_sv);
3052 sv_utf8_upgrade(repl_sv_copy);
3053 repl = SvPV(repl_sv_copy, repl_len);
3054 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3056 sv_insert(sv, pos, rem, repl, repl_len);
3060 SvREFCNT_dec(repl_sv_copy);
3062 else if (lvalue) { /* it's an lvalue! */
3063 if (!SvGMAGICAL(sv)) {
3067 if (ckWARN(WARN_SUBSTR))
3068 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3069 "Attempt to use reference as lvalue in substr");
3071 if (SvOK(sv)) /* is it defined ? */
3072 (void)SvPOK_only_UTF8(sv);
3074 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3077 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3078 TARG = sv_newmortal();
3079 if (SvTYPE(TARG) < SVt_PVLV) {
3080 sv_upgrade(TARG, SVt_PVLV);
3081 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3084 (void)SvOK_off(TARG);
3087 if (LvTARG(TARG) != sv) {
3089 SvREFCNT_dec(LvTARG(TARG));
3090 LvTARG(TARG) = SvREFCNT_inc(sv);
3092 LvTARGOFF(TARG) = upos;
3093 LvTARGLEN(TARG) = urem;
3097 PUSHs(TARG); /* avoid SvSETMAGIC here */
3104 register IV size = POPi;
3105 register IV offset = POPi;
3106 register SV *src = POPs;
3107 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3109 SvTAINTED_off(TARG); /* decontaminate */
3110 if (lvalue) { /* it's an lvalue! */
3111 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3112 TARG = sv_newmortal();
3113 if (SvTYPE(TARG) < SVt_PVLV) {
3114 sv_upgrade(TARG, SVt_PVLV);
3115 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3118 if (LvTARG(TARG) != src) {
3120 SvREFCNT_dec(LvTARG(TARG));
3121 LvTARG(TARG) = SvREFCNT_inc(src);
3123 LvTARGOFF(TARG) = offset;
3124 LvTARGLEN(TARG) = size;
3127 sv_setuv(TARG, do_vecget(src, offset, size));
3142 I32 arybase = PL_curcop->cop_arybase;
3147 offset = POPi - arybase;
3150 tmps = SvPV(big, biglen);
3151 if (offset > 0 && DO_UTF8(big))
3152 sv_pos_u2b(big, &offset, 0);
3155 else if (offset > (I32)biglen)
3157 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3158 (unsigned char*)tmps + biglen, little, 0)))
3161 retval = tmps2 - tmps;
3162 if (retval > 0 && DO_UTF8(big))
3163 sv_pos_b2u(big, &retval);
3164 PUSHi(retval + arybase);
3179 I32 arybase = PL_curcop->cop_arybase;
3185 tmps2 = SvPV(little, llen);
3186 tmps = SvPV(big, blen);
3190 if (offset > 0 && DO_UTF8(big))
3191 sv_pos_u2b(big, &offset, 0);
3192 offset = offset - arybase + llen;
3196 else if (offset > (I32)blen)
3198 if (!(tmps2 = rninstr(tmps, tmps + offset,
3199 tmps2, tmps2 + llen)))
3202 retval = tmps2 - tmps;
3203 if (retval > 0 && DO_UTF8(big))
3204 sv_pos_b2u(big, &retval);
3205 PUSHi(retval + arybase);
3211 dSP; dMARK; dORIGMARK; dTARGET;
3212 do_sprintf(TARG, SP-MARK, MARK+1);
3213 TAINT_IF(SvTAINTED(TARG));
3214 if (DO_UTF8(*(MARK+1)))
3226 U8 *s = (U8*)SvPVx(argsv, len);
3229 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3230 tmpsv = sv_2mortal(newSVsv(argsv));
3231 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3235 XPUSHu(DO_UTF8(argsv) ?
3236 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3248 (void)SvUPGRADE(TARG,SVt_PV);
3250 if (value > 255 && !IN_BYTES) {
3251 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3252 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3253 SvCUR_set(TARG, tmps - SvPVX(TARG));
3255 (void)SvPOK_only(TARG);
3264 *tmps++ = (char)value;
3266 (void)SvPOK_only(TARG);
3267 if (PL_encoding && !IN_BYTES) {
3268 sv_recode_to_utf8(TARG, PL_encoding);
3270 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3271 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3275 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3276 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3292 char *tmps = SvPV(left, len);
3294 if (DO_UTF8(left)) {
3295 /* If Unicode, try to downgrade.
3296 * If not possible, croak.
3297 * Yes, we made this up. */
3298 SV* tsv = sv_2mortal(newSVsv(left));
3301 sv_utf8_downgrade(tsv, FALSE);
3304 # ifdef USE_ITHREADS
3306 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3307 /* This should be threadsafe because in ithreads there is only
3308 * one thread per interpreter. If this would not be true,
3309 * we would need a mutex to protect this malloc. */
3310 PL_reentrant_buffer->_crypt_struct_buffer =
3311 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3312 #if defined(__GLIBC__) || defined(__EMX__)
3313 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3314 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3315 /* work around glibc-2.2.5 bug */
3316 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3320 # endif /* HAS_CRYPT_R */
3321 # endif /* USE_ITHREADS */
3323 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3325 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3331 "The crypt() function is unimplemented due to excessive paranoia.");
3344 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3345 UTF8_IS_START(*s)) {
3346 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3350 utf8_to_uvchr(s, &ulen);
3351 toTITLE_utf8(s, tmpbuf, &tculen);
3352 utf8_to_uvchr(tmpbuf, 0);
3354 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3356 /* slen is the byte length of the whole SV.
3357 * ulen is the byte length of the original Unicode character
3358 * stored as UTF-8 at s.
3359 * tculen is the byte length of the freshly titlecased
3360 * Unicode character stored as UTF-8 at tmpbuf.
3361 * We first set the result to be the titlecased character,
3362 * and then append the rest of the SV data. */
3363 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3365 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3370 s = (U8*)SvPV_force_nomg(sv, slen);
3371 Copy(tmpbuf, s, tculen, U8);
3375 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3377 SvUTF8_off(TARG); /* decontaminate */
3378 sv_setsv_nomg(TARG, sv);
3382 s = (U8*)SvPV_force_nomg(sv, slen);
3384 if (IN_LOCALE_RUNTIME) {
3387 *s = toUPPER_LC(*s);
3406 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3407 UTF8_IS_START(*s)) {
3409 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3413 toLOWER_utf8(s, tmpbuf, &ulen);
3414 uv = utf8_to_uvchr(tmpbuf, 0);
3415 tend = uvchr_to_utf8(tmpbuf, uv);
3417 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3419 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3421 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3426 s = (U8*)SvPV_force_nomg(sv, slen);
3427 Copy(tmpbuf, s, ulen, U8);
3431 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3433 SvUTF8_off(TARG); /* decontaminate */
3434 sv_setsv_nomg(TARG, sv);
3438 s = (U8*)SvPV_force_nomg(sv, slen);
3440 if (IN_LOCALE_RUNTIME) {
3443 *s = toLOWER_LC(*s);
3466 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3468 s = (U8*)SvPV_nomg(sv,len);
3470 SvUTF8_off(TARG); /* decontaminate */
3471 sv_setpvn(TARG, "", 0);
3475 STRLEN nchar = utf8_length(s, s + len);
3477 (void)SvUPGRADE(TARG, SVt_PV);
3478 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3479 (void)SvPOK_only(TARG);
3480 d = (U8*)SvPVX(TARG);
3483 toUPPER_utf8(s, tmpbuf, &ulen);
3484 Copy(tmpbuf, d, ulen, U8);
3490 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3495 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3497 SvUTF8_off(TARG); /* decontaminate */
3498 sv_setsv_nomg(TARG, sv);
3502 s = (U8*)SvPV_force_nomg(sv, len);
3504 register U8 *send = s + len;
3506 if (IN_LOCALE_RUNTIME) {
3509 for (; s < send; s++)
3510 *s = toUPPER_LC(*s);
3513 for (; s < send; s++)
3535 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3537 s = (U8*)SvPV_nomg(sv,len);
3539 SvUTF8_off(TARG); /* decontaminate */
3540 sv_setpvn(TARG, "", 0);
3544 STRLEN nchar = utf8_length(s, s + len);
3546 (void)SvUPGRADE(TARG, SVt_PV);
3547 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3548 (void)SvPOK_only(TARG);
3549 d = (U8*)SvPVX(TARG);
3552 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3553 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3554 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3556 * Now if the sigma is NOT followed by
3557 * /$ignorable_sequence$cased_letter/;
3558 * and it IS preceded by
3559 * /$cased_letter$ignorable_sequence/;
3560 * where $ignorable_sequence is
3561 * [\x{2010}\x{AD}\p{Mn}]*
3562 * and $cased_letter is
3563 * [\p{Ll}\p{Lo}\p{Lt}]
3564 * then it should be mapped to 0x03C2,
3565 * (GREEK SMALL LETTER FINAL SIGMA),
3566 * instead of staying 0x03A3.
3567 * See lib/unicore/SpecCase.txt.
3570 Copy(tmpbuf, d, ulen, U8);
3576 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3581 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3583 SvUTF8_off(TARG); /* decontaminate */
3584 sv_setsv_nomg(TARG, sv);
3589 s = (U8*)SvPV_force_nomg(sv, len);
3591 register U8 *send = s + len;
3593 if (IN_LOCALE_RUNTIME) {
3596 for (; s < send; s++)
3597 *s = toLOWER_LC(*s);
3600 for (; s < send; s++)
3614 register char *s = SvPV(sv,len);
3617 SvUTF8_off(TARG); /* decontaminate */
3619 (void)SvUPGRADE(TARG, SVt_PV);
3620 SvGROW(TARG, (len * 2) + 1);
3624 if (UTF8_IS_CONTINUED(*s)) {
3625 STRLEN ulen = UTF8SKIP(s);
3649 SvCUR_set(TARG, d - SvPVX(TARG));
3650 (void)SvPOK_only_UTF8(TARG);
3653 sv_setpvn(TARG, s, len);
3655 if (SvSMAGICAL(TARG))
3664 dSP; dMARK; dORIGMARK;
3666 register AV* av = (AV*)POPs;
3667 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3668 I32 arybase = PL_curcop->cop_arybase;
3671 if (SvTYPE(av) == SVt_PVAV) {
3672 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3674 for (svp = MARK + 1; svp <= SP; svp++) {
3679 if (max > AvMAX(av))
3682 while (++MARK <= SP) {
3683 elem = SvIVx(*MARK);
3687 svp = av_fetch(av, elem, lval);
3689 if (!svp || *svp == &PL_sv_undef)
3690 DIE(aTHX_ PL_no_aelem, elem);
3691 if (PL_op->op_private & OPpLVAL_INTRO)
3692 save_aelem(av, elem, svp);
3694 *MARK = svp ? *svp : &PL_sv_undef;
3697 if (GIMME != G_ARRAY) {
3705 /* Associative arrays. */
3710 HV *hash = (HV*)POPs;
3712 I32 gimme = GIMME_V;
3715 /* might clobber stack_sp */
3716 entry = hv_iternext(hash);
3721 SV* sv = hv_iterkeysv(entry);
3722 PUSHs(sv); /* won't clobber stack_sp */
3723 if (gimme == G_ARRAY) {
3726 /* might clobber stack_sp */
3727 val = hv_iterval(hash, entry);
3732 else if (gimme == G_SCALAR)
3751 I32 gimme = GIMME_V;
3752 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3756 if (PL_op->op_private & OPpSLICE) {
3760 hvtype = SvTYPE(hv);
3761 if (hvtype == SVt_PVHV) { /* hash element */
3762 while (++MARK <= SP) {
3763 sv = hv_delete_ent(hv, *MARK, discard, 0);
3764 *MARK = sv ? sv : &PL_sv_undef;
3767 else if (hvtype == SVt_PVAV) { /* array element */
3768 if (PL_op->op_flags & OPf_SPECIAL) {
3769 while (++MARK <= SP) {
3770 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3771 *MARK = sv ? sv : &PL_sv_undef;
3776 DIE(aTHX_ "Not a HASH reference");
3779 else if (gimme == G_SCALAR) {
3788 if (SvTYPE(hv) == SVt_PVHV)
3789 sv = hv_delete_ent(hv, keysv, discard, 0);
3790 else if (SvTYPE(hv) == SVt_PVAV) {
3791 if (PL_op->op_flags & OPf_SPECIAL)
3792 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3794 DIE(aTHX_ "panic: avhv_delete no longer supported");
3797 DIE(aTHX_ "Not a HASH reference");
3812 if (PL_op->op_private & OPpEXISTS_SUB) {
3816 cv = sv_2cv(sv, &hv, &gv, FALSE);
3819 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3825 if (SvTYPE(hv) == SVt_PVHV) {
3826 if (hv_exists_ent(hv, tmpsv, 0))
3829 else if (SvTYPE(hv) == SVt_PVAV) {
3830 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3831 if (av_exists((AV*)hv, SvIV(tmpsv)))
3836 DIE(aTHX_ "Not a HASH reference");
3843 dSP; dMARK; dORIGMARK;
3844 register HV *hv = (HV*)POPs;
3845 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3846 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3847 bool other_magic = FALSE;
3853 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3854 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3855 /* Try to preserve the existenceness of a tied hash
3856 * element by using EXISTS and DELETE if possible.
3857 * Fallback to FETCH and STORE otherwise */
3858 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3859 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3860 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3863 while (++MARK <= SP) {
3867 bool preeminent = FALSE;
3870 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3871 hv_exists_ent(hv, keysv, 0);
3874 he = hv_fetch_ent(hv, keysv, lval, 0);
3875 svp = he ? &HeVAL(he) : 0;
3878 if (!svp || *svp == &PL_sv_undef) {
3880 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3884 save_helem(hv, keysv, svp);
3887 char *key = SvPV(keysv, keylen);
3888 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3892 *MARK = svp ? *svp : &PL_sv_undef;
3894 if (GIMME != G_ARRAY) {
3902 /* List operators. */
3907 if (GIMME != G_ARRAY) {
3909 *MARK = *SP; /* unwanted list, return last item */
3911 *MARK = &PL_sv_undef;
3920 SV **lastrelem = PL_stack_sp;
3921 SV **lastlelem = PL_stack_base + POPMARK;
3922 SV **firstlelem = PL_stack_base + POPMARK + 1;
3923 register SV **firstrelem = lastlelem + 1;
3924 I32 arybase = PL_curcop->cop_arybase;
3925 I32 lval = PL_op->op_flags & OPf_MOD;
3926 I32 is_something_there = lval;
3928 register I32 max = lastrelem - lastlelem;
3929 register SV **lelem;
3932 if (GIMME != G_ARRAY) {
3933 ix = SvIVx(*lastlelem);
3938 if (ix < 0 || ix >= max)
3939 *firstlelem = &PL_sv_undef;
3941 *firstlelem = firstrelem[ix];
3947 SP = firstlelem - 1;
3951 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3957 if (ix < 0 || ix >= max)
3958 *lelem = &PL_sv_undef;
3960 is_something_there = TRUE;
3961 if (!(*lelem = firstrelem[ix]))
3962 *lelem = &PL_sv_undef;
3965 if (is_something_there)
3968 SP = firstlelem - 1;
3974 dSP; dMARK; dORIGMARK;
3975 I32 items = SP - MARK;
3976 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3977 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3984 dSP; dMARK; dORIGMARK;
3985 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3989 SV *val = NEWSV(46, 0);
3991 sv_setsv(val, *++MARK);
3992 else if (ckWARN(WARN_MISC))
3993 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3994 (void)hv_store_ent(hv,key,val,0);
4003 dSP; dMARK; dORIGMARK;
4004 register AV *ary = (AV*)*++MARK;
4008 register I32 offset;
4009 register I32 length;
4016 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4017 *MARK-- = SvTIED_obj((SV*)ary, mg);
4021 call_method("SPLICE",GIMME_V);
4030 offset = i = SvIVx(*MARK);
4032 offset += AvFILLp(ary) + 1;
4034 offset -= PL_curcop->cop_arybase;
4036 DIE(aTHX_ PL_no_aelem, i);
4038 length = SvIVx(*MARK++);
4040 length += AvFILLp(ary) - offset + 1;
4046 length = AvMAX(ary) + 1; /* close enough to infinity */
4050 length = AvMAX(ary) + 1;
4052 if (offset > AvFILLp(ary) + 1) {
4053 if (ckWARN(WARN_MISC))
4054 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4055 offset = AvFILLp(ary) + 1;
4057 after = AvFILLp(ary) + 1 - (offset + length);
4058 if (after < 0) { /* not that much array */
4059 length += after; /* offset+length now in array */
4065 /* At this point, MARK .. SP-1 is our new LIST */
4068 diff = newlen - length;
4069 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4072 if (diff < 0) { /* shrinking the area */
4074 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4075 Copy(MARK, tmparyval, newlen, SV*);
4078 MARK = ORIGMARK + 1;
4079 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4080 MEXTEND(MARK, length);
4081 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4083 EXTEND_MORTAL(length);
4084 for (i = length, dst = MARK; i; i--) {
4085 sv_2mortal(*dst); /* free them eventualy */
4092 *MARK = AvARRAY(ary)[offset+length-1];
4095 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4096 SvREFCNT_dec(*dst++); /* free them now */
4099 AvFILLp(ary) += diff;
4101 /* pull up or down? */
4103 if (offset < after) { /* easier to pull up */
4104 if (offset) { /* esp. if nothing to pull */
4105 src = &AvARRAY(ary)[offset-1];
4106 dst = src - diff; /* diff is negative */
4107 for (i = offset; i > 0; i--) /* can't trust Copy */
4111 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4115 if (after) { /* anything to pull down? */
4116 src = AvARRAY(ary) + offset + length;
4117 dst = src + diff; /* diff is negative */
4118 Move(src, dst, after, SV*);
4120 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4121 /* avoid later double free */
4125 dst[--i] = &PL_sv_undef;
4128 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4130 *dst = NEWSV(46, 0);
4131 sv_setsv(*dst++, *src++);
4133 Safefree(tmparyval);
4136 else { /* no, expanding (or same) */
4138 New(452, tmparyval, length, SV*); /* so remember deletion */
4139 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4142 if (diff > 0) { /* expanding */
4144 /* push up or down? */
4146 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4150 Move(src, dst, offset, SV*);
4152 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4154 AvFILLp(ary) += diff;
4157 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4158 av_extend(ary, AvFILLp(ary) + diff);
4159 AvFILLp(ary) += diff;
4162 dst = AvARRAY(ary) + AvFILLp(ary);
4164 for (i = after; i; i--) {
4171 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4172 *dst = NEWSV(46, 0);
4173 sv_setsv(*dst++, *src++);
4175 MARK = ORIGMARK + 1;
4176 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4178 Copy(tmparyval, MARK, length, SV*);
4180 EXTEND_MORTAL(length);
4181 for (i = length, dst = MARK; i; i--) {
4182 sv_2mortal(*dst); /* free them eventualy */
4186 Safefree(tmparyval);
4190 else if (length--) {
4191 *MARK = tmparyval[length];
4194 while (length-- > 0)
4195 SvREFCNT_dec(tmparyval[length]);
4197 Safefree(tmparyval);
4200 *MARK = &PL_sv_undef;
4208 dSP; dMARK; dORIGMARK; dTARGET;
4209 register AV *ary = (AV*)*++MARK;
4210 register SV *sv = &PL_sv_undef;
4213 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4214 *MARK-- = SvTIED_obj((SV*)ary, mg);
4218 call_method("PUSH",G_SCALAR|G_DISCARD);
4223 /* Why no pre-extend of ary here ? */
4224 for (++MARK; MARK <= SP; MARK++) {
4227 sv_setsv(sv, *MARK);
4232 PUSHi( AvFILL(ary) + 1 );
4240 SV *sv = av_pop(av);
4242 (void)sv_2mortal(sv);
4251 SV *sv = av_shift(av);
4256 (void)sv_2mortal(sv);
4263 dSP; dMARK; dORIGMARK; dTARGET;
4264 register AV *ary = (AV*)*++MARK;
4269 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4270 *MARK-- = SvTIED_obj((SV*)ary, mg);
4274 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4279 av_unshift(ary, SP - MARK);
4282 sv_setsv(sv, *++MARK);
4283 (void)av_store(ary, i++, sv);
4287 PUSHi( AvFILL(ary) + 1 );
4297 if (GIMME == G_ARRAY) {
4304 /* safe as long as stack cannot get extended in the above */
4309 register char *down;
4314 SvUTF8_off(TARG); /* decontaminate */
4316 do_join(TARG, &PL_sv_no, MARK, SP);
4318 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4319 up = SvPV_force(TARG, len);
4321 if (DO_UTF8(TARG)) { /* first reverse each character */
4322 U8* s = (U8*)SvPVX(TARG);
4323 U8* send = (U8*)(s + len);
4325 if (UTF8_IS_INVARIANT(*s)) {
4330 if (!utf8_to_uvchr(s, 0))
4334 down = (char*)(s - 1);
4335 /* reverse this character */
4339 *down-- = (char)tmp;
4345 down = SvPVX(TARG) + len - 1;
4349 *down-- = (char)tmp;
4351 (void)SvPOK_only_UTF8(TARG);
4363 register IV limit = POPi; /* note, negative is forever */
4366 register char *s = SvPV(sv, len);
4367 bool do_utf8 = DO_UTF8(sv);
4368 char *strend = s + len;
4370 register REGEXP *rx;
4374 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4375 I32 maxiters = slen + 10;
4378 I32 origlimit = limit;
4381 AV *oldstack = PL_curstack;
4382 I32 gimme = GIMME_V;
4383 I32 oldsave = PL_savestack_ix;
4384 I32 make_mortal = 1;
4385 MAGIC *mg = (MAGIC *) NULL;
4388 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4393 DIE(aTHX_ "panic: pp_split");
4396 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4397 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4399 RX_MATCH_UTF8_set(rx, do_utf8);
4401 if (pm->op_pmreplroot) {
4403 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4405 ary = GvAVn((GV*)pm->op_pmreplroot);
4408 else if (gimme != G_ARRAY)
4409 ary = GvAVn(PL_defgv);
4412 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4418 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4420 XPUSHs(SvTIED_obj((SV*)ary, mg));
4426 for (i = AvFILLp(ary); i >= 0; i--)
4427 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4429 /* temporarily switch stacks */
4430 SWITCHSTACK(PL_curstack, ary);
4431 PL_curstackinfo->si_stack = ary;
4435 base = SP - PL_stack_base;
4437 if (pm->op_pmflags & PMf_SKIPWHITE) {
4438 if (pm->op_pmflags & PMf_LOCALE) {
4439 while (isSPACE_LC(*s))
4447 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4448 SAVEINT(PL_multiline);
4449 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4453 limit = maxiters + 2;
4454 if (pm->op_pmflags & PMf_WHITE) {
4457 while (m < strend &&
4458 !((pm->op_pmflags & PMf_LOCALE)
4459 ? isSPACE_LC(*m) : isSPACE(*m)))
4464 dstr = NEWSV(30, m-s);
4465 sv_setpvn(dstr, s, m-s);
4469 (void)SvUTF8_on(dstr);
4473 while (s < strend &&
4474 ((pm->op_pmflags & PMf_LOCALE)
4475 ? isSPACE_LC(*s) : isSPACE(*s)))
4479 else if (strEQ("^", rx->precomp)) {
4482 for (m = s; m < strend && *m != '\n'; m++) ;
4486 dstr = NEWSV(30, m-s);
4487 sv_setpvn(dstr, s, m-s);
4491 (void)SvUTF8_on(dstr);
4496 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4497 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4498 && (rx->reganch & ROPT_CHECK_ALL)
4499 && !(rx->reganch & ROPT_ANCH)) {
4500 int tail = (rx->reganch & RE_INTUIT_TAIL);
4501 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4504 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4506 char c = *SvPV(csv, n_a);
4509 for (m = s; m < strend && *m != c; m++) ;
4512 dstr = NEWSV(30, m-s);
4513 sv_setpvn(dstr, s, m-s);
4517 (void)SvUTF8_on(dstr);
4519 /* The rx->minlen is in characters but we want to step
4520 * s ahead by bytes. */
4522 s = (char*)utf8_hop((U8*)m, len);
4524 s = m + len; /* Fake \n at the end */
4529 while (s < strend && --limit &&
4530 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4531 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4534 dstr = NEWSV(31, m-s);
4535 sv_setpvn(dstr, s, m-s);
4539 (void)SvUTF8_on(dstr);
4541 /* The rx->minlen is in characters but we want to step
4542 * s ahead by bytes. */
4544 s = (char*)utf8_hop((U8*)m, len);
4546 s = m + len; /* Fake \n at the end */
4551 maxiters += slen * rx->nparens;
4552 while (s < strend && --limit)
4555 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4559 TAINT_IF(RX_MATCH_TAINTED(rx));
4560 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4565 strend = s + (strend - m);
4567 m = rx->startp[0] + orig;
4568 dstr = NEWSV(32, m-s);
4569 sv_setpvn(dstr, s, m-s);
4573 (void)SvUTF8_on(dstr);
4576 for (i = 1; i <= (I32)rx->nparens; i++) {
4577 s = rx->startp[i] + orig;
4578 m = rx->endp[i] + orig;
4580 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4581 parens that didn't match -- they should be set to
4582 undef, not the empty string */
4583 if (m >= orig && s >= orig) {
4584 dstr = NEWSV(33, m-s);
4585 sv_setpvn(dstr, s, m-s);
4588 dstr = &PL_sv_undef; /* undef, not "" */
4592 (void)SvUTF8_on(dstr);
4596 s = rx->endp[0] + orig;
4600 LEAVE_SCOPE(oldsave);
4601 iters = (SP - PL_stack_base) - base;
4602 if (iters > maxiters)
4603 DIE(aTHX_ "Split loop");
4605 /* keep field after final delim? */
4606 if (s < strend || (iters && origlimit)) {
4607 STRLEN l = strend - s;
4608 dstr = NEWSV(34, l);
4609 sv_setpvn(dstr, s, l);
4613 (void)SvUTF8_on(dstr);
4617 else if (!origlimit) {
4618 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4619 if (TOPs && !make_mortal)
4628 SWITCHSTACK(ary, oldstack);
4629 PL_curstackinfo->si_stack = oldstack;
4630 if (SvSMAGICAL(ary)) {
4635 if (gimme == G_ARRAY) {
4637 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4645 call_method("PUSH",G_SCALAR|G_DISCARD);
4648 if (gimme == G_ARRAY) {
4649 /* EXTEND should not be needed - we just popped them */
4651 for (i=0; i < iters; i++) {
4652 SV **svp = av_fetch(ary, i, FALSE);
4653 PUSHs((svp) ? *svp : &PL_sv_undef);
4660 if (gimme == G_ARRAY)
4675 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4676 || SvTYPE(retsv) == SVt_PVCV) {
4677 retsv = refto(retsv);
4685 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");