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 /* we either return a PV or an LV. If the TARG hasn't been used
3042 * before, or is of that type, reuse it; otherwise use a mortal
3043 * instead. Note that LVs can have an extended lifetime, so also
3044 * dont reuse if refcount > 1 (bug #20933) */
3045 if (SvTYPE(TARG) > SVt_NULL) {
3046 if ( (SvTYPE(TARG) == SVt_PVLV)
3047 ? (!lvalue || SvREFCNT(TARG) > 1)
3050 TARG = sv_newmortal();
3054 sv_setpvn(TARG, tmps, rem);
3055 #ifdef USE_LOCALE_COLLATE
3056 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3061 SV* repl_sv_copy = NULL;
3063 if (repl_need_utf8_upgrade) {
3064 repl_sv_copy = newSVsv(repl_sv);
3065 sv_utf8_upgrade(repl_sv_copy);
3066 repl = SvPV(repl_sv_copy, repl_len);
3067 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3069 sv_insert(sv, pos, rem, repl, repl_len);
3073 SvREFCNT_dec(repl_sv_copy);
3075 else if (lvalue) { /* it's an lvalue! */
3076 if (!SvGMAGICAL(sv)) {
3080 if (ckWARN(WARN_SUBSTR))
3081 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3082 "Attempt to use reference as lvalue in substr");
3084 if (SvOK(sv)) /* is it defined ? */
3085 (void)SvPOK_only_UTF8(sv);
3087 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3090 if (SvTYPE(TARG) < SVt_PVLV) {
3091 sv_upgrade(TARG, SVt_PVLV);
3092 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3095 (void)SvOK_off(TARG);
3098 if (LvTARG(TARG) != sv) {
3100 SvREFCNT_dec(LvTARG(TARG));
3101 LvTARG(TARG) = SvREFCNT_inc(sv);
3103 LvTARGOFF(TARG) = upos;
3104 LvTARGLEN(TARG) = urem;
3108 PUSHs(TARG); /* avoid SvSETMAGIC here */
3115 register IV size = POPi;
3116 register IV offset = POPi;
3117 register SV *src = POPs;
3118 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3120 SvTAINTED_off(TARG); /* decontaminate */
3121 if (lvalue) { /* it's an lvalue! */
3122 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3123 TARG = sv_newmortal();
3124 if (SvTYPE(TARG) < SVt_PVLV) {
3125 sv_upgrade(TARG, SVt_PVLV);
3126 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3129 if (LvTARG(TARG) != src) {
3131 SvREFCNT_dec(LvTARG(TARG));
3132 LvTARG(TARG) = SvREFCNT_inc(src);
3134 LvTARGOFF(TARG) = offset;
3135 LvTARGLEN(TARG) = size;
3138 sv_setuv(TARG, do_vecget(src, offset, size));
3153 I32 arybase = PL_curcop->cop_arybase;
3158 offset = POPi - arybase;
3161 tmps = SvPV(big, biglen);
3162 if (offset > 0 && DO_UTF8(big))
3163 sv_pos_u2b(big, &offset, 0);
3166 else if (offset > (I32)biglen)
3168 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3169 (unsigned char*)tmps + biglen, little, 0)))
3172 retval = tmps2 - tmps;
3173 if (retval > 0 && DO_UTF8(big))
3174 sv_pos_b2u(big, &retval);
3175 PUSHi(retval + arybase);
3190 I32 arybase = PL_curcop->cop_arybase;
3196 tmps2 = SvPV(little, llen);
3197 tmps = SvPV(big, blen);
3201 if (offset > 0 && DO_UTF8(big))
3202 sv_pos_u2b(big, &offset, 0);
3203 offset = offset - arybase + llen;
3207 else if (offset > (I32)blen)
3209 if (!(tmps2 = rninstr(tmps, tmps + offset,
3210 tmps2, tmps2 + llen)))
3213 retval = tmps2 - tmps;
3214 if (retval > 0 && DO_UTF8(big))
3215 sv_pos_b2u(big, &retval);
3216 PUSHi(retval + arybase);
3222 dSP; dMARK; dORIGMARK; dTARGET;
3223 do_sprintf(TARG, SP-MARK, MARK+1);
3224 TAINT_IF(SvTAINTED(TARG));
3225 if (DO_UTF8(*(MARK+1)))
3237 U8 *s = (U8*)SvPVx(argsv, len);
3240 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3241 tmpsv = sv_2mortal(newSVsv(argsv));
3242 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3246 XPUSHu(DO_UTF8(argsv) ?
3247 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3259 (void)SvUPGRADE(TARG,SVt_PV);
3261 if (value > 255 && !IN_BYTES) {
3262 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3263 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3264 SvCUR_set(TARG, tmps - SvPVX(TARG));
3266 (void)SvPOK_only(TARG);
3275 *tmps++ = (char)value;
3277 (void)SvPOK_only(TARG);
3278 if (PL_encoding && !IN_BYTES) {
3279 sv_recode_to_utf8(TARG, PL_encoding);
3281 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3282 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3286 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3287 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3303 char *tmps = SvPV(left, len);
3305 if (DO_UTF8(left)) {
3306 /* If Unicode, try to downgrade.
3307 * If not possible, croak.
3308 * Yes, we made this up. */
3309 SV* tsv = sv_2mortal(newSVsv(left));
3312 sv_utf8_downgrade(tsv, FALSE);
3315 # ifdef USE_ITHREADS
3317 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3318 /* This should be threadsafe because in ithreads there is only
3319 * one thread per interpreter. If this would not be true,
3320 * we would need a mutex to protect this malloc. */
3321 PL_reentrant_buffer->_crypt_struct_buffer =
3322 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3323 #if defined(__GLIBC__) || defined(__EMX__)
3324 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3325 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3326 /* work around glibc-2.2.5 bug */
3327 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3331 # endif /* HAS_CRYPT_R */
3332 # endif /* USE_ITHREADS */
3334 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3336 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3342 "The crypt() function is unimplemented due to excessive paranoia.");
3355 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3356 UTF8_IS_START(*s)) {
3357 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3361 utf8_to_uvchr(s, &ulen);
3362 toTITLE_utf8(s, tmpbuf, &tculen);
3363 utf8_to_uvchr(tmpbuf, 0);
3365 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3367 /* slen is the byte length of the whole SV.
3368 * ulen is the byte length of the original Unicode character
3369 * stored as UTF-8 at s.
3370 * tculen is the byte length of the freshly titlecased
3371 * Unicode character stored as UTF-8 at tmpbuf.
3372 * We first set the result to be the titlecased character,
3373 * and then append the rest of the SV data. */
3374 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3376 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3381 s = (U8*)SvPV_force_nomg(sv, slen);
3382 Copy(tmpbuf, s, tculen, U8);
3386 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3388 SvUTF8_off(TARG); /* decontaminate */
3389 sv_setsv_nomg(TARG, sv);
3393 s = (U8*)SvPV_force_nomg(sv, slen);
3395 if (IN_LOCALE_RUNTIME) {
3398 *s = toUPPER_LC(*s);
3417 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3418 UTF8_IS_START(*s)) {
3420 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3424 toLOWER_utf8(s, tmpbuf, &ulen);
3425 uv = utf8_to_uvchr(tmpbuf, 0);
3426 tend = uvchr_to_utf8(tmpbuf, uv);
3428 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3430 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3432 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3437 s = (U8*)SvPV_force_nomg(sv, slen);
3438 Copy(tmpbuf, s, ulen, U8);
3442 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3444 SvUTF8_off(TARG); /* decontaminate */
3445 sv_setsv_nomg(TARG, sv);
3449 s = (U8*)SvPV_force_nomg(sv, slen);
3451 if (IN_LOCALE_RUNTIME) {
3454 *s = toLOWER_LC(*s);
3477 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3479 s = (U8*)SvPV_nomg(sv,len);
3481 SvUTF8_off(TARG); /* decontaminate */
3482 sv_setpvn(TARG, "", 0);
3486 STRLEN nchar = utf8_length(s, s + len);
3488 (void)SvUPGRADE(TARG, SVt_PV);
3489 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3490 (void)SvPOK_only(TARG);
3491 d = (U8*)SvPVX(TARG);
3494 toUPPER_utf8(s, tmpbuf, &ulen);
3495 Copy(tmpbuf, d, ulen, U8);
3501 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3506 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3508 SvUTF8_off(TARG); /* decontaminate */
3509 sv_setsv_nomg(TARG, sv);
3513 s = (U8*)SvPV_force_nomg(sv, len);
3515 register U8 *send = s + len;
3517 if (IN_LOCALE_RUNTIME) {
3520 for (; s < send; s++)
3521 *s = toUPPER_LC(*s);
3524 for (; s < send; s++)
3546 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3548 s = (U8*)SvPV_nomg(sv,len);
3550 SvUTF8_off(TARG); /* decontaminate */
3551 sv_setpvn(TARG, "", 0);
3555 STRLEN nchar = utf8_length(s, s + len);
3557 (void)SvUPGRADE(TARG, SVt_PV);
3558 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3559 (void)SvPOK_only(TARG);
3560 d = (U8*)SvPVX(TARG);
3563 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3564 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3565 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3567 * Now if the sigma is NOT followed by
3568 * /$ignorable_sequence$cased_letter/;
3569 * and it IS preceded by
3570 * /$cased_letter$ignorable_sequence/;
3571 * where $ignorable_sequence is
3572 * [\x{2010}\x{AD}\p{Mn}]*
3573 * and $cased_letter is
3574 * [\p{Ll}\p{Lo}\p{Lt}]
3575 * then it should be mapped to 0x03C2,
3576 * (GREEK SMALL LETTER FINAL SIGMA),
3577 * instead of staying 0x03A3.
3578 * See lib/unicore/SpecCase.txt.
3581 Copy(tmpbuf, d, ulen, U8);
3587 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3592 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3594 SvUTF8_off(TARG); /* decontaminate */
3595 sv_setsv_nomg(TARG, sv);
3600 s = (U8*)SvPV_force_nomg(sv, len);
3602 register U8 *send = s + len;
3604 if (IN_LOCALE_RUNTIME) {
3607 for (; s < send; s++)
3608 *s = toLOWER_LC(*s);
3611 for (; s < send; s++)
3625 register char *s = SvPV(sv,len);
3628 SvUTF8_off(TARG); /* decontaminate */
3630 (void)SvUPGRADE(TARG, SVt_PV);
3631 SvGROW(TARG, (len * 2) + 1);
3635 if (UTF8_IS_CONTINUED(*s)) {
3636 STRLEN ulen = UTF8SKIP(s);
3660 SvCUR_set(TARG, d - SvPVX(TARG));
3661 (void)SvPOK_only_UTF8(TARG);
3664 sv_setpvn(TARG, s, len);
3666 if (SvSMAGICAL(TARG))
3675 dSP; dMARK; dORIGMARK;
3677 register AV* av = (AV*)POPs;
3678 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3679 I32 arybase = PL_curcop->cop_arybase;
3682 if (SvTYPE(av) == SVt_PVAV) {
3683 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3685 for (svp = MARK + 1; svp <= SP; svp++) {
3690 if (max > AvMAX(av))
3693 while (++MARK <= SP) {
3694 elem = SvIVx(*MARK);
3698 svp = av_fetch(av, elem, lval);
3700 if (!svp || *svp == &PL_sv_undef)
3701 DIE(aTHX_ PL_no_aelem, elem);
3702 if (PL_op->op_private & OPpLVAL_INTRO)
3703 save_aelem(av, elem, svp);
3705 *MARK = svp ? *svp : &PL_sv_undef;
3708 if (GIMME != G_ARRAY) {
3716 /* Associative arrays. */
3721 HV *hash = (HV*)POPs;
3723 I32 gimme = GIMME_V;
3726 /* might clobber stack_sp */
3727 entry = hv_iternext(hash);
3732 SV* sv = hv_iterkeysv(entry);
3733 PUSHs(sv); /* won't clobber stack_sp */
3734 if (gimme == G_ARRAY) {
3737 /* might clobber stack_sp */
3738 val = hv_iterval(hash, entry);
3743 else if (gimme == G_SCALAR)
3762 I32 gimme = GIMME_V;
3763 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3767 if (PL_op->op_private & OPpSLICE) {
3771 hvtype = SvTYPE(hv);
3772 if (hvtype == SVt_PVHV) { /* hash element */
3773 while (++MARK <= SP) {
3774 sv = hv_delete_ent(hv, *MARK, discard, 0);
3775 *MARK = sv ? sv : &PL_sv_undef;
3778 else if (hvtype == SVt_PVAV) { /* array element */
3779 if (PL_op->op_flags & OPf_SPECIAL) {
3780 while (++MARK <= SP) {
3781 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3782 *MARK = sv ? sv : &PL_sv_undef;
3787 DIE(aTHX_ "Not a HASH reference");
3790 else if (gimme == G_SCALAR) {
3799 if (SvTYPE(hv) == SVt_PVHV)
3800 sv = hv_delete_ent(hv, keysv, discard, 0);
3801 else if (SvTYPE(hv) == SVt_PVAV) {
3802 if (PL_op->op_flags & OPf_SPECIAL)
3803 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3805 DIE(aTHX_ "panic: avhv_delete no longer supported");
3808 DIE(aTHX_ "Not a HASH reference");
3823 if (PL_op->op_private & OPpEXISTS_SUB) {
3827 cv = sv_2cv(sv, &hv, &gv, FALSE);
3830 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3836 if (SvTYPE(hv) == SVt_PVHV) {
3837 if (hv_exists_ent(hv, tmpsv, 0))
3840 else if (SvTYPE(hv) == SVt_PVAV) {
3841 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3842 if (av_exists((AV*)hv, SvIV(tmpsv)))
3847 DIE(aTHX_ "Not a HASH reference");
3854 dSP; dMARK; dORIGMARK;
3855 register HV *hv = (HV*)POPs;
3856 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3857 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3858 bool other_magic = FALSE;
3864 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3865 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3866 /* Try to preserve the existenceness of a tied hash
3867 * element by using EXISTS and DELETE if possible.
3868 * Fallback to FETCH and STORE otherwise */
3869 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3870 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3871 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3874 while (++MARK <= SP) {
3878 bool preeminent = FALSE;
3881 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3882 hv_exists_ent(hv, keysv, 0);
3885 he = hv_fetch_ent(hv, keysv, lval, 0);
3886 svp = he ? &HeVAL(he) : 0;
3889 if (!svp || *svp == &PL_sv_undef) {
3891 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3895 save_helem(hv, keysv, svp);
3898 char *key = SvPV(keysv, keylen);
3899 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3903 *MARK = svp ? *svp : &PL_sv_undef;
3905 if (GIMME != G_ARRAY) {
3913 /* List operators. */
3918 if (GIMME != G_ARRAY) {
3920 *MARK = *SP; /* unwanted list, return last item */
3922 *MARK = &PL_sv_undef;
3931 SV **lastrelem = PL_stack_sp;
3932 SV **lastlelem = PL_stack_base + POPMARK;
3933 SV **firstlelem = PL_stack_base + POPMARK + 1;
3934 register SV **firstrelem = lastlelem + 1;
3935 I32 arybase = PL_curcop->cop_arybase;
3936 I32 lval = PL_op->op_flags & OPf_MOD;
3937 I32 is_something_there = lval;
3939 register I32 max = lastrelem - lastlelem;
3940 register SV **lelem;
3943 if (GIMME != G_ARRAY) {
3944 ix = SvIVx(*lastlelem);
3949 if (ix < 0 || ix >= max)
3950 *firstlelem = &PL_sv_undef;
3952 *firstlelem = firstrelem[ix];
3958 SP = firstlelem - 1;
3962 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3968 if (ix < 0 || ix >= max)
3969 *lelem = &PL_sv_undef;
3971 is_something_there = TRUE;
3972 if (!(*lelem = firstrelem[ix]))
3973 *lelem = &PL_sv_undef;
3976 if (is_something_there)
3979 SP = firstlelem - 1;
3985 dSP; dMARK; dORIGMARK;
3986 I32 items = SP - MARK;
3987 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3988 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3995 dSP; dMARK; dORIGMARK;
3996 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4000 SV *val = NEWSV(46, 0);
4002 sv_setsv(val, *++MARK);
4003 else if (ckWARN(WARN_MISC))
4004 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4005 (void)hv_store_ent(hv,key,val,0);
4014 dSP; dMARK; dORIGMARK;
4015 register AV *ary = (AV*)*++MARK;
4019 register I32 offset;
4020 register I32 length;
4027 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4028 *MARK-- = SvTIED_obj((SV*)ary, mg);
4032 call_method("SPLICE",GIMME_V);
4041 offset = i = SvIVx(*MARK);
4043 offset += AvFILLp(ary) + 1;
4045 offset -= PL_curcop->cop_arybase;
4047 DIE(aTHX_ PL_no_aelem, i);
4049 length = SvIVx(*MARK++);
4051 length += AvFILLp(ary) - offset + 1;
4057 length = AvMAX(ary) + 1; /* close enough to infinity */
4061 length = AvMAX(ary) + 1;
4063 if (offset > AvFILLp(ary) + 1) {
4064 if (ckWARN(WARN_MISC))
4065 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4066 offset = AvFILLp(ary) + 1;
4068 after = AvFILLp(ary) + 1 - (offset + length);
4069 if (after < 0) { /* not that much array */
4070 length += after; /* offset+length now in array */
4076 /* At this point, MARK .. SP-1 is our new LIST */
4079 diff = newlen - length;
4080 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4083 if (diff < 0) { /* shrinking the area */
4085 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4086 Copy(MARK, tmparyval, newlen, SV*);
4089 MARK = ORIGMARK + 1;
4090 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4091 MEXTEND(MARK, length);
4092 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4094 EXTEND_MORTAL(length);
4095 for (i = length, dst = MARK; i; i--) {
4096 sv_2mortal(*dst); /* free them eventualy */
4103 *MARK = AvARRAY(ary)[offset+length-1];
4106 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4107 SvREFCNT_dec(*dst++); /* free them now */
4110 AvFILLp(ary) += diff;
4112 /* pull up or down? */
4114 if (offset < after) { /* easier to pull up */
4115 if (offset) { /* esp. if nothing to pull */
4116 src = &AvARRAY(ary)[offset-1];
4117 dst = src - diff; /* diff is negative */
4118 for (i = offset; i > 0; i--) /* can't trust Copy */
4122 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4126 if (after) { /* anything to pull down? */
4127 src = AvARRAY(ary) + offset + length;
4128 dst = src + diff; /* diff is negative */
4129 Move(src, dst, after, SV*);
4131 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4132 /* avoid later double free */
4136 dst[--i] = &PL_sv_undef;
4139 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4141 *dst = NEWSV(46, 0);
4142 sv_setsv(*dst++, *src++);
4144 Safefree(tmparyval);
4147 else { /* no, expanding (or same) */
4149 New(452, tmparyval, length, SV*); /* so remember deletion */
4150 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4153 if (diff > 0) { /* expanding */
4155 /* push up or down? */
4157 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4161 Move(src, dst, offset, SV*);
4163 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4165 AvFILLp(ary) += diff;
4168 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4169 av_extend(ary, AvFILLp(ary) + diff);
4170 AvFILLp(ary) += diff;
4173 dst = AvARRAY(ary) + AvFILLp(ary);
4175 for (i = after; i; i--) {
4182 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4183 *dst = NEWSV(46, 0);
4184 sv_setsv(*dst++, *src++);
4186 MARK = ORIGMARK + 1;
4187 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4189 Copy(tmparyval, MARK, length, SV*);
4191 EXTEND_MORTAL(length);
4192 for (i = length, dst = MARK; i; i--) {
4193 sv_2mortal(*dst); /* free them eventualy */
4197 Safefree(tmparyval);
4201 else if (length--) {
4202 *MARK = tmparyval[length];
4205 while (length-- > 0)
4206 SvREFCNT_dec(tmparyval[length]);
4208 Safefree(tmparyval);
4211 *MARK = &PL_sv_undef;
4219 dSP; dMARK; dORIGMARK; dTARGET;
4220 register AV *ary = (AV*)*++MARK;
4221 register SV *sv = &PL_sv_undef;
4224 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4225 *MARK-- = SvTIED_obj((SV*)ary, mg);
4229 call_method("PUSH",G_SCALAR|G_DISCARD);
4234 /* Why no pre-extend of ary here ? */
4235 for (++MARK; MARK <= SP; MARK++) {
4238 sv_setsv(sv, *MARK);
4243 PUSHi( AvFILL(ary) + 1 );
4251 SV *sv = av_pop(av);
4253 (void)sv_2mortal(sv);
4262 SV *sv = av_shift(av);
4267 (void)sv_2mortal(sv);
4274 dSP; dMARK; dORIGMARK; dTARGET;
4275 register AV *ary = (AV*)*++MARK;
4280 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4281 *MARK-- = SvTIED_obj((SV*)ary, mg);
4285 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4290 av_unshift(ary, SP - MARK);
4293 sv_setsv(sv, *++MARK);
4294 (void)av_store(ary, i++, sv);
4298 PUSHi( AvFILL(ary) + 1 );
4308 if (GIMME == G_ARRAY) {
4315 /* safe as long as stack cannot get extended in the above */
4320 register char *down;
4325 SvUTF8_off(TARG); /* decontaminate */
4327 do_join(TARG, &PL_sv_no, MARK, SP);
4329 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4330 up = SvPV_force(TARG, len);
4332 if (DO_UTF8(TARG)) { /* first reverse each character */
4333 U8* s = (U8*)SvPVX(TARG);
4334 U8* send = (U8*)(s + len);
4336 if (UTF8_IS_INVARIANT(*s)) {
4341 if (!utf8_to_uvchr(s, 0))
4345 down = (char*)(s - 1);
4346 /* reverse this character */
4350 *down-- = (char)tmp;
4356 down = SvPVX(TARG) + len - 1;
4360 *down-- = (char)tmp;
4362 (void)SvPOK_only_UTF8(TARG);
4374 register IV limit = POPi; /* note, negative is forever */
4377 register char *s = SvPV(sv, len);
4378 bool do_utf8 = DO_UTF8(sv);
4379 char *strend = s + len;
4381 register REGEXP *rx;
4385 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4386 I32 maxiters = slen + 10;
4389 I32 origlimit = limit;
4392 AV *oldstack = PL_curstack;
4393 I32 gimme = GIMME_V;
4394 I32 oldsave = PL_savestack_ix;
4395 I32 make_mortal = 1;
4396 MAGIC *mg = (MAGIC *) NULL;
4399 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4404 DIE(aTHX_ "panic: pp_split");
4407 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4408 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4410 RX_MATCH_UTF8_set(rx, do_utf8);
4412 if (pm->op_pmreplroot) {
4414 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4416 ary = GvAVn((GV*)pm->op_pmreplroot);
4419 else if (gimme != G_ARRAY)
4420 ary = GvAVn(PL_defgv);
4423 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4429 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4431 XPUSHs(SvTIED_obj((SV*)ary, mg));
4437 for (i = AvFILLp(ary); i >= 0; i--)
4438 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4440 /* temporarily switch stacks */
4441 SWITCHSTACK(PL_curstack, ary);
4442 PL_curstackinfo->si_stack = ary;
4446 base = SP - PL_stack_base;
4448 if (pm->op_pmflags & PMf_SKIPWHITE) {
4449 if (pm->op_pmflags & PMf_LOCALE) {
4450 while (isSPACE_LC(*s))
4458 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4459 SAVEINT(PL_multiline);
4460 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4464 limit = maxiters + 2;
4465 if (pm->op_pmflags & PMf_WHITE) {
4468 while (m < strend &&
4469 !((pm->op_pmflags & PMf_LOCALE)
4470 ? isSPACE_LC(*m) : isSPACE(*m)))
4475 dstr = NEWSV(30, m-s);
4476 sv_setpvn(dstr, s, m-s);
4480 (void)SvUTF8_on(dstr);
4484 while (s < strend &&
4485 ((pm->op_pmflags & PMf_LOCALE)
4486 ? isSPACE_LC(*s) : isSPACE(*s)))
4490 else if (strEQ("^", rx->precomp)) {
4493 for (m = s; m < strend && *m != '\n'; m++) ;
4497 dstr = NEWSV(30, m-s);
4498 sv_setpvn(dstr, s, m-s);
4502 (void)SvUTF8_on(dstr);
4507 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4508 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4509 && (rx->reganch & ROPT_CHECK_ALL)
4510 && !(rx->reganch & ROPT_ANCH)) {
4511 int tail = (rx->reganch & RE_INTUIT_TAIL);
4512 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4515 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4517 char c = *SvPV(csv, n_a);
4520 for (m = s; m < strend && *m != c; m++) ;
4523 dstr = NEWSV(30, 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 while (s < strend && --limit &&
4541 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4542 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4545 dstr = NEWSV(31, m-s);
4546 sv_setpvn(dstr, s, m-s);
4550 (void)SvUTF8_on(dstr);
4552 /* The rx->minlen is in characters but we want to step
4553 * s ahead by bytes. */
4555 s = (char*)utf8_hop((U8*)m, len);
4557 s = m + len; /* Fake \n at the end */
4562 maxiters += slen * rx->nparens;
4563 while (s < strend && --limit)
4566 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4570 TAINT_IF(RX_MATCH_TAINTED(rx));
4571 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4576 strend = s + (strend - m);
4578 m = rx->startp[0] + orig;
4579 dstr = NEWSV(32, m-s);
4580 sv_setpvn(dstr, s, m-s);
4584 (void)SvUTF8_on(dstr);
4587 for (i = 1; i <= (I32)rx->nparens; i++) {
4588 s = rx->startp[i] + orig;
4589 m = rx->endp[i] + orig;
4591 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4592 parens that didn't match -- they should be set to
4593 undef, not the empty string */
4594 if (m >= orig && s >= orig) {
4595 dstr = NEWSV(33, m-s);
4596 sv_setpvn(dstr, s, m-s);
4599 dstr = &PL_sv_undef; /* undef, not "" */
4603 (void)SvUTF8_on(dstr);
4607 s = rx->endp[0] + orig;
4611 LEAVE_SCOPE(oldsave);
4612 iters = (SP - PL_stack_base) - base;
4613 if (iters > maxiters)
4614 DIE(aTHX_ "Split loop");
4616 /* keep field after final delim? */
4617 if (s < strend || (iters && origlimit)) {
4618 STRLEN l = strend - s;
4619 dstr = NEWSV(34, l);
4620 sv_setpvn(dstr, s, l);
4624 (void)SvUTF8_on(dstr);
4628 else if (!origlimit) {
4629 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4630 if (TOPs && !make_mortal)
4639 SWITCHSTACK(ary, oldstack);
4640 PL_curstackinfo->si_stack = oldstack;
4641 if (SvSMAGICAL(ary)) {
4646 if (gimme == G_ARRAY) {
4648 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4656 call_method("PUSH",G_SCALAR|G_DISCARD);
4659 if (gimme == G_ARRAY) {
4660 /* EXTEND should not be needed - we just popped them */
4662 for (i=0; i < iters; i++) {
4663 SV **svp = av_fetch(ary, i, FALSE);
4664 PUSHs((svp) ? *svp : &PL_sv_undef);
4671 if (gimme == G_ARRAY)
4686 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4687 || SvTYPE(retsv) == SVt_PVCV) {
4688 retsv = refto(retsv);
4696 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");