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;
1389 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1391 I32 items = SP - MARK;
1393 static const char list_extend[] = "panic: list extend";
1395 max = items * count;
1396 MEM_WRAP_CHECK_1(max, SV*, list_extend);
1397 if (items > 0 && max > 0 && (max < items || max < count))
1398 Perl_croak(aTHX_ list_extend);
1403 /* This code was intended to fix 20010809.028:
1406 for (($x =~ /./g) x 2) {
1407 print chop; # "abcdabcd" expected as output.
1410 * but that change (#11635) broke this code:
1412 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1414 * I can't think of a better fix that doesn't introduce
1415 * an efficiency hit by copying the SVs. The stack isn't
1416 * refcounted, and mortalisation obviously doesn't
1417 * Do The Right Thing when the stack has more than
1418 * one pointer to the same mortal value.
1422 *SP = sv_2mortal(newSVsv(*SP));
1432 repeatcpy((char*)(MARK + items), (char*)MARK,
1433 items * sizeof(SV*), count - 1);
1436 else if (count <= 0)
1439 else { /* Note: mark already snarfed by pp_list */
1444 SvSetSV(TARG, tmpstr);
1445 SvPV_force(TARG, len);
1446 isutf = DO_UTF8(TARG);
1451 MEM_WRAP_CHECK_1(count, len, "panic: string extend");
1452 SvGROW(TARG, (count * len) + 1);
1453 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1454 SvCUR(TARG) *= count;
1456 *SvEND(TARG) = '\0';
1459 (void)SvPOK_only_UTF8(TARG);
1461 (void)SvPOK_only(TARG);
1463 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1464 /* The parser saw this as a list repeat, and there
1465 are probably several items on the stack. But we're
1466 in scalar context, and there's no pp_list to save us
1467 now. So drop the rest of the items -- robin@kitsite.com
1480 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1481 useleft = USE_LEFT(TOPm1s);
1482 #ifdef PERL_PRESERVE_IVUV
1483 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1484 "bad things" happen if you rely on signed integers wrapping. */
1487 /* Unless the left argument is integer in range we are going to have to
1488 use NV maths. Hence only attempt to coerce the right argument if
1489 we know the left is integer. */
1490 register UV auv = 0;
1496 a_valid = auvok = 1;
1497 /* left operand is undef, treat as zero. */
1499 /* Left operand is defined, so is it IV? */
1500 SvIV_please(TOPm1s);
1501 if (SvIOK(TOPm1s)) {
1502 if ((auvok = SvUOK(TOPm1s)))
1503 auv = SvUVX(TOPm1s);
1505 register IV aiv = SvIVX(TOPm1s);
1508 auvok = 1; /* Now acting as a sign flag. */
1509 } else { /* 2s complement assumption for IV_MIN */
1517 bool result_good = 0;
1520 bool buvok = SvUOK(TOPs);
1525 register IV biv = SvIVX(TOPs);
1532 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1533 else "IV" now, independent of how it came in.
1534 if a, b represents positive, A, B negative, a maps to -A etc
1539 all UV maths. negate result if A negative.
1540 subtract if signs same, add if signs differ. */
1542 if (auvok ^ buvok) {
1551 /* Must get smaller */
1556 if (result <= buv) {
1557 /* result really should be -(auv-buv). as its negation
1558 of true value, need to swap our result flag */
1570 if (result <= (UV)IV_MIN)
1571 SETi( -(IV)result );
1573 /* result valid, but out of range for IV. */
1574 SETn( -(NV)result );
1578 } /* Overflow, drop through to NVs. */
1582 useleft = USE_LEFT(TOPm1s);
1586 /* left operand is undef, treat as zero - value */
1590 SETn( TOPn - value );
1597 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1600 if (PL_op->op_private & HINT_INTEGER) {
1614 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1617 if (PL_op->op_private & HINT_INTEGER) {
1631 dSP; tryAMAGICbinSET(lt,0);
1632 #ifdef PERL_PRESERVE_IVUV
1635 SvIV_please(TOPm1s);
1636 if (SvIOK(TOPm1s)) {
1637 bool auvok = SvUOK(TOPm1s);
1638 bool buvok = SvUOK(TOPs);
1640 if (!auvok && !buvok) { /* ## IV < IV ## */
1641 IV aiv = SvIVX(TOPm1s);
1642 IV biv = SvIVX(TOPs);
1645 SETs(boolSV(aiv < biv));
1648 if (auvok && buvok) { /* ## UV < UV ## */
1649 UV auv = SvUVX(TOPm1s);
1650 UV buv = SvUVX(TOPs);
1653 SETs(boolSV(auv < buv));
1656 if (auvok) { /* ## UV < IV ## */
1663 /* As (a) is a UV, it's >=0, so it cannot be < */
1668 SETs(boolSV(auv < (UV)biv));
1671 { /* ## IV < UV ## */
1675 aiv = SvIVX(TOPm1s);
1677 /* As (b) is a UV, it's >=0, so it must be < */
1684 SETs(boolSV((UV)aiv < buv));
1690 #ifndef NV_PRESERVES_UV
1691 #ifdef PERL_PRESERVE_IVUV
1694 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1696 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1702 SETs(boolSV(TOPn < value));
1709 dSP; tryAMAGICbinSET(gt,0);
1710 #ifdef PERL_PRESERVE_IVUV
1713 SvIV_please(TOPm1s);
1714 if (SvIOK(TOPm1s)) {
1715 bool auvok = SvUOK(TOPm1s);
1716 bool buvok = SvUOK(TOPs);
1718 if (!auvok && !buvok) { /* ## IV > IV ## */
1719 IV aiv = SvIVX(TOPm1s);
1720 IV biv = SvIVX(TOPs);
1723 SETs(boolSV(aiv > biv));
1726 if (auvok && buvok) { /* ## UV > UV ## */
1727 UV auv = SvUVX(TOPm1s);
1728 UV buv = SvUVX(TOPs);
1731 SETs(boolSV(auv > buv));
1734 if (auvok) { /* ## UV > IV ## */
1741 /* As (a) is a UV, it's >=0, so it must be > */
1746 SETs(boolSV(auv > (UV)biv));
1749 { /* ## IV > UV ## */
1753 aiv = SvIVX(TOPm1s);
1755 /* As (b) is a UV, it's >=0, so it cannot be > */
1762 SETs(boolSV((UV)aiv > buv));
1768 #ifndef NV_PRESERVES_UV
1769 #ifdef PERL_PRESERVE_IVUV
1772 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1774 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1780 SETs(boolSV(TOPn > value));
1787 dSP; tryAMAGICbinSET(le,0);
1788 #ifdef PERL_PRESERVE_IVUV
1791 SvIV_please(TOPm1s);
1792 if (SvIOK(TOPm1s)) {
1793 bool auvok = SvUOK(TOPm1s);
1794 bool buvok = SvUOK(TOPs);
1796 if (!auvok && !buvok) { /* ## IV <= IV ## */
1797 IV aiv = SvIVX(TOPm1s);
1798 IV biv = SvIVX(TOPs);
1801 SETs(boolSV(aiv <= biv));
1804 if (auvok && buvok) { /* ## UV <= UV ## */
1805 UV auv = SvUVX(TOPm1s);
1806 UV buv = SvUVX(TOPs);
1809 SETs(boolSV(auv <= buv));
1812 if (auvok) { /* ## UV <= IV ## */
1819 /* As (a) is a UV, it's >=0, so a cannot be <= */
1824 SETs(boolSV(auv <= (UV)biv));
1827 { /* ## IV <= UV ## */
1831 aiv = SvIVX(TOPm1s);
1833 /* As (b) is a UV, it's >=0, so a must be <= */
1840 SETs(boolSV((UV)aiv <= buv));
1846 #ifndef NV_PRESERVES_UV
1847 #ifdef PERL_PRESERVE_IVUV
1850 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1852 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1858 SETs(boolSV(TOPn <= value));
1865 dSP; tryAMAGICbinSET(ge,0);
1866 #ifdef PERL_PRESERVE_IVUV
1869 SvIV_please(TOPm1s);
1870 if (SvIOK(TOPm1s)) {
1871 bool auvok = SvUOK(TOPm1s);
1872 bool buvok = SvUOK(TOPs);
1874 if (!auvok && !buvok) { /* ## IV >= IV ## */
1875 IV aiv = SvIVX(TOPm1s);
1876 IV biv = SvIVX(TOPs);
1879 SETs(boolSV(aiv >= biv));
1882 if (auvok && buvok) { /* ## UV >= UV ## */
1883 UV auv = SvUVX(TOPm1s);
1884 UV buv = SvUVX(TOPs);
1887 SETs(boolSV(auv >= buv));
1890 if (auvok) { /* ## UV >= IV ## */
1897 /* As (a) is a UV, it's >=0, so it must be >= */
1902 SETs(boolSV(auv >= (UV)biv));
1905 { /* ## IV >= UV ## */
1909 aiv = SvIVX(TOPm1s);
1911 /* As (b) is a UV, it's >=0, so a cannot be >= */
1918 SETs(boolSV((UV)aiv >= buv));
1924 #ifndef NV_PRESERVES_UV
1925 #ifdef PERL_PRESERVE_IVUV
1928 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1930 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1936 SETs(boolSV(TOPn >= value));
1943 dSP; tryAMAGICbinSET(ne,0);
1944 #ifndef NV_PRESERVES_UV
1945 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1947 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1951 #ifdef PERL_PRESERVE_IVUV
1954 SvIV_please(TOPm1s);
1955 if (SvIOK(TOPm1s)) {
1956 bool auvok = SvUOK(TOPm1s);
1957 bool buvok = SvUOK(TOPs);
1959 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1960 /* Casting IV to UV before comparison isn't going to matter
1961 on 2s complement. On 1s complement or sign&magnitude
1962 (if we have any of them) it could make negative zero
1963 differ from normal zero. As I understand it. (Need to
1964 check - is negative zero implementation defined behaviour
1966 UV buv = SvUVX(POPs);
1967 UV auv = SvUVX(TOPs);
1969 SETs(boolSV(auv != buv));
1972 { /* ## Mixed IV,UV ## */
1976 /* != is commutative so swap if needed (save code) */
1978 /* swap. top of stack (b) is the iv */
1982 /* As (a) is a UV, it's >0, so it cannot be == */
1991 /* As (b) is a UV, it's >0, so it cannot be == */
1995 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1997 SETs(boolSV((UV)iv != uv));
2005 SETs(boolSV(TOPn != value));
2012 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2013 #ifndef NV_PRESERVES_UV
2014 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2015 UV right = PTR2UV(SvRV(POPs));
2016 UV left = PTR2UV(SvRV(TOPs));
2017 SETi((left > right) - (left < right));
2021 #ifdef PERL_PRESERVE_IVUV
2022 /* Fortunately it seems NaN isn't IOK */
2025 SvIV_please(TOPm1s);
2026 if (SvIOK(TOPm1s)) {
2027 bool leftuvok = SvUOK(TOPm1s);
2028 bool rightuvok = SvUOK(TOPs);
2030 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2031 IV leftiv = SvIVX(TOPm1s);
2032 IV rightiv = SvIVX(TOPs);
2034 if (leftiv > rightiv)
2036 else if (leftiv < rightiv)
2040 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2041 UV leftuv = SvUVX(TOPm1s);
2042 UV rightuv = SvUVX(TOPs);
2044 if (leftuv > rightuv)
2046 else if (leftuv < rightuv)
2050 } else if (leftuvok) { /* ## UV <=> IV ## */
2054 rightiv = SvIVX(TOPs);
2056 /* As (a) is a UV, it's >=0, so it cannot be < */
2059 leftuv = SvUVX(TOPm1s);
2060 if (leftuv > (UV)rightiv) {
2062 } else if (leftuv < (UV)rightiv) {
2068 } else { /* ## IV <=> UV ## */
2072 leftiv = SvIVX(TOPm1s);
2074 /* As (b) is a UV, it's >=0, so it must be < */
2077 rightuv = SvUVX(TOPs);
2078 if ((UV)leftiv > rightuv) {
2080 } else if ((UV)leftiv < rightuv) {
2098 if (Perl_isnan(left) || Perl_isnan(right)) {
2102 value = (left > right) - (left < right);
2106 else if (left < right)
2108 else if (left > right)
2122 dSP; tryAMAGICbinSET(slt,0);
2125 int cmp = (IN_LOCALE_RUNTIME
2126 ? sv_cmp_locale(left, right)
2127 : sv_cmp(left, right));
2128 SETs(boolSV(cmp < 0));
2135 dSP; tryAMAGICbinSET(sgt,0);
2138 int cmp = (IN_LOCALE_RUNTIME
2139 ? sv_cmp_locale(left, right)
2140 : sv_cmp(left, right));
2141 SETs(boolSV(cmp > 0));
2148 dSP; tryAMAGICbinSET(sle,0);
2151 int cmp = (IN_LOCALE_RUNTIME
2152 ? sv_cmp_locale(left, right)
2153 : sv_cmp(left, right));
2154 SETs(boolSV(cmp <= 0));
2161 dSP; tryAMAGICbinSET(sge,0);
2164 int cmp = (IN_LOCALE_RUNTIME
2165 ? sv_cmp_locale(left, right)
2166 : sv_cmp(left, right));
2167 SETs(boolSV(cmp >= 0));
2174 dSP; tryAMAGICbinSET(seq,0);
2177 SETs(boolSV(sv_eq(left, right)));
2184 dSP; tryAMAGICbinSET(sne,0);
2187 SETs(boolSV(!sv_eq(left, right)));
2194 dSP; dTARGET; tryAMAGICbin(scmp,0);
2197 int cmp = (IN_LOCALE_RUNTIME
2198 ? sv_cmp_locale(left, right)
2199 : sv_cmp(left, right));
2207 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2210 if (SvGMAGICAL(left)) mg_get(left);
2211 if (SvGMAGICAL(right)) mg_get(right);
2212 if (SvNIOKp(left) || SvNIOKp(right)) {
2213 if (PL_op->op_private & HINT_INTEGER) {
2214 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2218 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2223 do_vop(PL_op->op_type, TARG, left, right);
2232 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2235 if (SvGMAGICAL(left)) mg_get(left);
2236 if (SvGMAGICAL(right)) mg_get(right);
2237 if (SvNIOKp(left) || SvNIOKp(right)) {
2238 if (PL_op->op_private & HINT_INTEGER) {
2239 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2243 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2248 do_vop(PL_op->op_type, TARG, left, right);
2257 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2260 if (SvGMAGICAL(left)) mg_get(left);
2261 if (SvGMAGICAL(right)) mg_get(right);
2262 if (SvNIOKp(left) || SvNIOKp(right)) {
2263 if (PL_op->op_private & HINT_INTEGER) {
2264 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2268 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2273 do_vop(PL_op->op_type, TARG, left, right);
2282 dSP; dTARGET; tryAMAGICun(neg);
2285 int flags = SvFLAGS(sv);
2288 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2289 /* It's publicly an integer, or privately an integer-not-float */
2292 if (SvIVX(sv) == IV_MIN) {
2293 /* 2s complement assumption. */
2294 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2297 else if (SvUVX(sv) <= IV_MAX) {
2302 else if (SvIVX(sv) != IV_MIN) {
2306 #ifdef PERL_PRESERVE_IVUV
2315 else if (SvPOKp(sv)) {
2317 char *s = SvPV(sv, len);
2318 if (isIDFIRST(*s)) {
2319 sv_setpvn(TARG, "-", 1);
2322 else if (*s == '+' || *s == '-') {
2324 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2326 else if (DO_UTF8(sv)) {
2329 goto oops_its_an_int;
2331 sv_setnv(TARG, -SvNV(sv));
2333 sv_setpvn(TARG, "-", 1);
2340 goto oops_its_an_int;
2341 sv_setnv(TARG, -SvNV(sv));
2353 dSP; tryAMAGICunSET(not);
2354 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2360 dSP; dTARGET; tryAMAGICun(compl);
2366 if (PL_op->op_private & HINT_INTEGER) {
2367 IV i = ~SvIV_nomg(sv);
2371 UV u = ~SvUV_nomg(sv);
2380 (void)SvPV_nomg(sv,len);
2381 sv_setsv_nomg(TARG, sv);
2382 tmps = (U8*)SvPV_force(TARG, len);
2385 /* Calculate exact length, let's not estimate. */
2394 while (tmps < send) {
2395 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2396 tmps += UTF8SKIP(tmps);
2397 targlen += UNISKIP(~c);
2403 /* Now rewind strings and write them. */
2407 Newz(0, result, targlen + 1, U8);
2408 while (tmps < send) {
2409 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2410 tmps += UTF8SKIP(tmps);
2411 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2415 sv_setpvn(TARG, (char*)result, targlen);
2419 Newz(0, result, nchar + 1, U8);
2420 while (tmps < send) {
2421 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2422 tmps += UTF8SKIP(tmps);
2427 sv_setpvn(TARG, (char*)result, nchar);
2436 register long *tmpl;
2437 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2440 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2445 for ( ; anum > 0; anum--, tmps++)
2454 /* integer versions of some of the above */
2458 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2461 SETi( left * right );
2468 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2472 DIE(aTHX_ "Illegal division by zero");
2473 value = POPi / value;
2482 /* This is the vanilla old i_modulo. */
2483 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2487 DIE(aTHX_ "Illegal modulus zero");
2488 SETi( left % right );
2493 #if defined(__GLIBC__) && IVSIZE == 8
2497 /* This is the i_modulo with the workaround for the _moddi3 bug
2498 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2499 * See below for pp_i_modulo. */
2500 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2504 DIE(aTHX_ "Illegal modulus zero");
2505 SETi( left % PERL_ABS(right) );
2513 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2517 DIE(aTHX_ "Illegal modulus zero");
2518 /* The assumption is to use hereafter the old vanilla version... */
2520 PL_ppaddr[OP_I_MODULO] =
2521 &Perl_pp_i_modulo_0;
2522 /* .. but if we have glibc, we might have a buggy _moddi3
2523 * (at least glicb 2.2.5 is known to have this bug), in other
2524 * words our integer modulus with negative quad as the second
2525 * argument might be broken. Test for this and re-patch the
2526 * opcode dispatch table if that is the case, remembering to
2527 * also apply the workaround so that this first round works
2528 * right, too. See [perl #9402] for more information. */
2529 #if defined(__GLIBC__) && IVSIZE == 8
2533 /* Cannot do this check with inlined IV constants since
2534 * that seems to work correctly even with the buggy glibc. */
2536 /* Yikes, we have the bug.
2537 * Patch in the workaround version. */
2539 PL_ppaddr[OP_I_MODULO] =
2540 &Perl_pp_i_modulo_1;
2541 /* Make certain we work right this time, too. */
2542 right = PERL_ABS(right);
2546 SETi( left % right );
2553 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2556 SETi( left + right );
2563 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2566 SETi( left - right );
2573 dSP; tryAMAGICbinSET(lt,0);
2576 SETs(boolSV(left < right));
2583 dSP; tryAMAGICbinSET(gt,0);
2586 SETs(boolSV(left > right));
2593 dSP; tryAMAGICbinSET(le,0);
2596 SETs(boolSV(left <= right));
2603 dSP; tryAMAGICbinSET(ge,0);
2606 SETs(boolSV(left >= right));
2613 dSP; tryAMAGICbinSET(eq,0);
2616 SETs(boolSV(left == right));
2623 dSP; tryAMAGICbinSET(ne,0);
2626 SETs(boolSV(left != right));
2633 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2640 else if (left < right)
2651 dSP; dTARGET; tryAMAGICun(neg);
2656 /* High falutin' math. */
2660 dSP; dTARGET; tryAMAGICbin(atan2,0);
2663 SETn(Perl_atan2(left, right));
2670 dSP; dTARGET; tryAMAGICun(sin);
2674 value = Perl_sin(value);
2682 dSP; dTARGET; tryAMAGICun(cos);
2686 value = Perl_cos(value);
2692 /* Support Configure command-line overrides for rand() functions.
2693 After 5.005, perhaps we should replace this by Configure support
2694 for drand48(), random(), or rand(). For 5.005, though, maintain
2695 compatibility by calling rand() but allow the user to override it.
2696 See INSTALL for details. --Andy Dougherty 15 July 1998
2698 /* Now it's after 5.005, and Configure supports drand48() and random(),
2699 in addition to rand(). So the overrides should not be needed any more.
2700 --Jarkko Hietaniemi 27 September 1998
2703 #ifndef HAS_DRAND48_PROTO
2704 extern double drand48 (void);
2717 if (!PL_srand_called) {
2718 (void)seedDrand01((Rand_seed_t)seed());
2719 PL_srand_called = TRUE;
2734 (void)seedDrand01((Rand_seed_t)anum);
2735 PL_srand_called = TRUE;
2742 dSP; dTARGET; tryAMAGICun(exp);
2746 value = Perl_exp(value);
2754 dSP; dTARGET; tryAMAGICun(log);
2759 SET_NUMERIC_STANDARD();
2760 DIE(aTHX_ "Can't take log of %"NVgf, value);
2762 value = Perl_log(value);
2770 dSP; dTARGET; tryAMAGICun(sqrt);
2775 SET_NUMERIC_STANDARD();
2776 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2778 value = Perl_sqrt(value);
2786 dSP; dTARGET; tryAMAGICun(int);
2789 IV iv = TOPi; /* attempt to convert to IV if possible. */
2790 /* XXX it's arguable that compiler casting to IV might be subtly
2791 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2792 else preferring IV has introduced a subtle behaviour change bug. OTOH
2793 relying on floating point to be accurate is a bug. */
2804 if (value < (NV)UV_MAX + 0.5) {
2807 SETn(Perl_floor(value));
2811 if (value > (NV)IV_MIN - 0.5) {
2814 SETn(Perl_ceil(value));
2824 dSP; dTARGET; tryAMAGICun(abs);
2826 /* This will cache the NV value if string isn't actually integer */
2830 /* IVX is precise */
2832 SETu(TOPu); /* force it to be numeric only */
2840 /* 2s complement assumption. Also, not really needed as
2841 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2861 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2867 tmps = (SvPVx(sv, len));
2869 /* If Unicode, try to downgrade
2870 * If not possible, croak. */
2871 SV* tsv = sv_2mortal(newSVsv(sv));
2874 sv_utf8_downgrade(tsv, FALSE);
2877 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2878 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2891 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2897 tmps = (SvPVx(sv, len));
2899 /* If Unicode, try to downgrade
2900 * If not possible, croak. */
2901 SV* tsv = sv_2mortal(newSVsv(sv));
2904 sv_utf8_downgrade(tsv, FALSE);
2907 while (*tmps && len && isSPACE(*tmps))
2912 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2913 else if (*tmps == 'b')
2914 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2916 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2918 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2935 SETi(sv_len_utf8(sv));
2951 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2953 I32 arybase = PL_curcop->cop_arybase;
2957 int num_args = PL_op->op_private & 7;
2958 bool repl_need_utf8_upgrade = FALSE;
2959 bool repl_is_utf8 = FALSE;
2961 SvTAINTED_off(TARG); /* decontaminate */
2962 SvUTF8_off(TARG); /* decontaminate */
2966 repl = SvPV(repl_sv, repl_len);
2967 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2977 sv_utf8_upgrade(sv);
2979 else if (DO_UTF8(sv))
2980 repl_need_utf8_upgrade = TRUE;
2982 tmps = SvPV(sv, curlen);
2984 utf8_curlen = sv_len_utf8(sv);
2985 if (utf8_curlen == curlen)
2988 curlen = utf8_curlen;
2993 if (pos >= arybase) {
3011 else if (len >= 0) {
3013 if (rem > (I32)curlen)
3028 Perl_croak(aTHX_ "substr outside of string");
3029 if (ckWARN(WARN_SUBSTR))
3030 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3037 sv_pos_u2b(sv, &pos, &rem);
3039 sv_setpvn(TARG, tmps, rem);
3040 #ifdef USE_LOCALE_COLLATE
3041 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3046 SV* repl_sv_copy = NULL;
3048 if (repl_need_utf8_upgrade) {
3049 repl_sv_copy = newSVsv(repl_sv);
3050 sv_utf8_upgrade(repl_sv_copy);
3051 repl = SvPV(repl_sv_copy, repl_len);
3052 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3054 sv_insert(sv, pos, rem, repl, repl_len);
3058 SvREFCNT_dec(repl_sv_copy);
3060 else if (lvalue) { /* it's an lvalue! */
3061 if (!SvGMAGICAL(sv)) {
3065 if (ckWARN(WARN_SUBSTR))
3066 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3067 "Attempt to use reference as lvalue in substr");
3069 if (SvOK(sv)) /* is it defined ? */
3070 (void)SvPOK_only_UTF8(sv);
3072 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3075 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3076 TARG = sv_newmortal();
3077 if (SvTYPE(TARG) < SVt_PVLV) {
3078 sv_upgrade(TARG, SVt_PVLV);
3079 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3082 (void)SvOK_off(TARG);
3085 if (LvTARG(TARG) != sv) {
3087 SvREFCNT_dec(LvTARG(TARG));
3088 LvTARG(TARG) = SvREFCNT_inc(sv);
3090 LvTARGOFF(TARG) = upos;
3091 LvTARGLEN(TARG) = urem;
3095 PUSHs(TARG); /* avoid SvSETMAGIC here */
3102 register IV size = POPi;
3103 register IV offset = POPi;
3104 register SV *src = POPs;
3105 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3107 SvTAINTED_off(TARG); /* decontaminate */
3108 if (lvalue) { /* it's an lvalue! */
3109 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3110 TARG = sv_newmortal();
3111 if (SvTYPE(TARG) < SVt_PVLV) {
3112 sv_upgrade(TARG, SVt_PVLV);
3113 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3116 if (LvTARG(TARG) != src) {
3118 SvREFCNT_dec(LvTARG(TARG));
3119 LvTARG(TARG) = SvREFCNT_inc(src);
3121 LvTARGOFF(TARG) = offset;
3122 LvTARGLEN(TARG) = size;
3125 sv_setuv(TARG, do_vecget(src, offset, size));
3140 I32 arybase = PL_curcop->cop_arybase;
3145 offset = POPi - arybase;
3148 tmps = SvPV(big, biglen);
3149 if (offset > 0 && DO_UTF8(big))
3150 sv_pos_u2b(big, &offset, 0);
3153 else if (offset > (I32)biglen)
3155 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3156 (unsigned char*)tmps + biglen, little, 0)))
3159 retval = tmps2 - tmps;
3160 if (retval > 0 && DO_UTF8(big))
3161 sv_pos_b2u(big, &retval);
3162 PUSHi(retval + arybase);
3177 I32 arybase = PL_curcop->cop_arybase;
3183 tmps2 = SvPV(little, llen);
3184 tmps = SvPV(big, blen);
3188 if (offset > 0 && DO_UTF8(big))
3189 sv_pos_u2b(big, &offset, 0);
3190 offset = offset - arybase + llen;
3194 else if (offset > (I32)blen)
3196 if (!(tmps2 = rninstr(tmps, tmps + offset,
3197 tmps2, tmps2 + llen)))
3200 retval = tmps2 - tmps;
3201 if (retval > 0 && DO_UTF8(big))
3202 sv_pos_b2u(big, &retval);
3203 PUSHi(retval + arybase);
3209 dSP; dMARK; dORIGMARK; dTARGET;
3210 do_sprintf(TARG, SP-MARK, MARK+1);
3211 TAINT_IF(SvTAINTED(TARG));
3212 if (DO_UTF8(*(MARK+1)))
3224 U8 *s = (U8*)SvPVx(argsv, len);
3227 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3228 tmpsv = sv_2mortal(newSVsv(argsv));
3229 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3233 XPUSHu(DO_UTF8(argsv) ?
3234 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3246 (void)SvUPGRADE(TARG,SVt_PV);
3248 if (value > 255 && !IN_BYTES) {
3249 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3250 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3251 SvCUR_set(TARG, tmps - SvPVX(TARG));
3253 (void)SvPOK_only(TARG);
3262 *tmps++ = (char)value;
3264 (void)SvPOK_only(TARG);
3265 if (PL_encoding && !IN_BYTES) {
3266 sv_recode_to_utf8(TARG, PL_encoding);
3268 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3269 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3273 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3274 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3290 char *tmps = SvPV(left, len);
3292 if (DO_UTF8(left)) {
3293 /* If Unicode, try to downgrade.
3294 * If not possible, croak.
3295 * Yes, we made this up. */
3296 SV* tsv = sv_2mortal(newSVsv(left));
3299 sv_utf8_downgrade(tsv, FALSE);
3302 # ifdef USE_ITHREADS
3304 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3305 /* This should be threadsafe because in ithreads there is only
3306 * one thread per interpreter. If this would not be true,
3307 * we would need a mutex to protect this malloc. */
3308 PL_reentrant_buffer->_crypt_struct_buffer =
3309 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3310 #if defined(__GLIBC__) || defined(__EMX__)
3311 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3312 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3313 /* work around glibc-2.2.5 bug */
3314 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3318 # endif /* HAS_CRYPT_R */
3319 # endif /* USE_ITHREADS */
3321 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3323 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3329 "The crypt() function is unimplemented due to excessive paranoia.");
3342 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3343 UTF8_IS_START(*s)) {
3344 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3348 utf8_to_uvchr(s, &ulen);
3349 toTITLE_utf8(s, tmpbuf, &tculen);
3350 utf8_to_uvchr(tmpbuf, 0);
3352 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3354 /* slen is the byte length of the whole SV.
3355 * ulen is the byte length of the original Unicode character
3356 * stored as UTF-8 at s.
3357 * tculen is the byte length of the freshly titlecased
3358 * Unicode character stored as UTF-8 at tmpbuf.
3359 * We first set the result to be the titlecased character,
3360 * and then append the rest of the SV data. */
3361 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3363 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3368 s = (U8*)SvPV_force_nomg(sv, slen);
3369 Copy(tmpbuf, s, tculen, U8);
3373 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3375 SvUTF8_off(TARG); /* decontaminate */
3376 sv_setsv_nomg(TARG, sv);
3380 s = (U8*)SvPV_force_nomg(sv, slen);
3382 if (IN_LOCALE_RUNTIME) {
3385 *s = toUPPER_LC(*s);
3404 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3405 UTF8_IS_START(*s)) {
3407 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3411 toLOWER_utf8(s, tmpbuf, &ulen);
3412 uv = utf8_to_uvchr(tmpbuf, 0);
3413 tend = uvchr_to_utf8(tmpbuf, uv);
3415 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3417 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3419 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3424 s = (U8*)SvPV_force_nomg(sv, slen);
3425 Copy(tmpbuf, s, ulen, U8);
3429 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3431 SvUTF8_off(TARG); /* decontaminate */
3432 sv_setsv_nomg(TARG, sv);
3436 s = (U8*)SvPV_force_nomg(sv, slen);
3438 if (IN_LOCALE_RUNTIME) {
3441 *s = toLOWER_LC(*s);
3464 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3466 s = (U8*)SvPV_nomg(sv,len);
3468 SvUTF8_off(TARG); /* decontaminate */
3469 sv_setpvn(TARG, "", 0);
3473 STRLEN nchar = utf8_length(s, s + len);
3475 (void)SvUPGRADE(TARG, SVt_PV);
3476 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3477 (void)SvPOK_only(TARG);
3478 d = (U8*)SvPVX(TARG);
3481 toUPPER_utf8(s, tmpbuf, &ulen);
3482 Copy(tmpbuf, d, ulen, U8);
3488 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3493 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3495 SvUTF8_off(TARG); /* decontaminate */
3496 sv_setsv_nomg(TARG, sv);
3500 s = (U8*)SvPV_force_nomg(sv, len);
3502 register U8 *send = s + len;
3504 if (IN_LOCALE_RUNTIME) {
3507 for (; s < send; s++)
3508 *s = toUPPER_LC(*s);
3511 for (; s < send; s++)
3533 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3535 s = (U8*)SvPV_nomg(sv,len);
3537 SvUTF8_off(TARG); /* decontaminate */
3538 sv_setpvn(TARG, "", 0);
3542 STRLEN nchar = utf8_length(s, s + len);
3544 (void)SvUPGRADE(TARG, SVt_PV);
3545 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3546 (void)SvPOK_only(TARG);
3547 d = (U8*)SvPVX(TARG);
3550 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3551 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3552 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3554 * Now if the sigma is NOT followed by
3555 * /$ignorable_sequence$cased_letter/;
3556 * and it IS preceded by
3557 * /$cased_letter$ignorable_sequence/;
3558 * where $ignorable_sequence is
3559 * [\x{2010}\x{AD}\p{Mn}]*
3560 * and $cased_letter is
3561 * [\p{Ll}\p{Lo}\p{Lt}]
3562 * then it should be mapped to 0x03C2,
3563 * (GREEK SMALL LETTER FINAL SIGMA),
3564 * instead of staying 0x03A3.
3565 * See lib/unicore/SpecCase.txt.
3568 Copy(tmpbuf, d, ulen, U8);
3574 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3579 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3581 SvUTF8_off(TARG); /* decontaminate */
3582 sv_setsv_nomg(TARG, sv);
3587 s = (U8*)SvPV_force_nomg(sv, len);
3589 register U8 *send = s + len;
3591 if (IN_LOCALE_RUNTIME) {
3594 for (; s < send; s++)
3595 *s = toLOWER_LC(*s);
3598 for (; s < send; s++)
3612 register char *s = SvPV(sv,len);
3615 SvUTF8_off(TARG); /* decontaminate */
3617 (void)SvUPGRADE(TARG, SVt_PV);
3618 SvGROW(TARG, (len * 2) + 1);
3622 if (UTF8_IS_CONTINUED(*s)) {
3623 STRLEN ulen = UTF8SKIP(s);
3647 SvCUR_set(TARG, d - SvPVX(TARG));
3648 (void)SvPOK_only_UTF8(TARG);
3651 sv_setpvn(TARG, s, len);
3653 if (SvSMAGICAL(TARG))
3662 dSP; dMARK; dORIGMARK;
3664 register AV* av = (AV*)POPs;
3665 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3666 I32 arybase = PL_curcop->cop_arybase;
3669 if (SvTYPE(av) == SVt_PVAV) {
3670 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3672 for (svp = MARK + 1; svp <= SP; svp++) {
3677 if (max > AvMAX(av))
3680 while (++MARK <= SP) {
3681 elem = SvIVx(*MARK);
3685 svp = av_fetch(av, elem, lval);
3687 if (!svp || *svp == &PL_sv_undef)
3688 DIE(aTHX_ PL_no_aelem, elem);
3689 if (PL_op->op_private & OPpLVAL_INTRO)
3690 save_aelem(av, elem, svp);
3692 *MARK = svp ? *svp : &PL_sv_undef;
3695 if (GIMME != G_ARRAY) {
3703 /* Associative arrays. */
3708 HV *hash = (HV*)POPs;
3710 I32 gimme = GIMME_V;
3713 /* might clobber stack_sp */
3714 entry = hv_iternext(hash);
3719 SV* sv = hv_iterkeysv(entry);
3720 PUSHs(sv); /* won't clobber stack_sp */
3721 if (gimme == G_ARRAY) {
3724 /* might clobber stack_sp */
3725 val = hv_iterval(hash, entry);
3730 else if (gimme == G_SCALAR)
3749 I32 gimme = GIMME_V;
3750 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3754 if (PL_op->op_private & OPpSLICE) {
3758 hvtype = SvTYPE(hv);
3759 if (hvtype == SVt_PVHV) { /* hash element */
3760 while (++MARK <= SP) {
3761 sv = hv_delete_ent(hv, *MARK, discard, 0);
3762 *MARK = sv ? sv : &PL_sv_undef;
3765 else if (hvtype == SVt_PVAV) { /* array element */
3766 if (PL_op->op_flags & OPf_SPECIAL) {
3767 while (++MARK <= SP) {
3768 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3769 *MARK = sv ? sv : &PL_sv_undef;
3774 DIE(aTHX_ "Not a HASH reference");
3777 else if (gimme == G_SCALAR) {
3786 if (SvTYPE(hv) == SVt_PVHV)
3787 sv = hv_delete_ent(hv, keysv, discard, 0);
3788 else if (SvTYPE(hv) == SVt_PVAV) {
3789 if (PL_op->op_flags & OPf_SPECIAL)
3790 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3792 DIE(aTHX_ "panic: avhv_delete no longer supported");
3795 DIE(aTHX_ "Not a HASH reference");
3810 if (PL_op->op_private & OPpEXISTS_SUB) {
3814 cv = sv_2cv(sv, &hv, &gv, FALSE);
3817 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3823 if (SvTYPE(hv) == SVt_PVHV) {
3824 if (hv_exists_ent(hv, tmpsv, 0))
3827 else if (SvTYPE(hv) == SVt_PVAV) {
3828 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3829 if (av_exists((AV*)hv, SvIV(tmpsv)))
3834 DIE(aTHX_ "Not a HASH reference");
3841 dSP; dMARK; dORIGMARK;
3842 register HV *hv = (HV*)POPs;
3843 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3844 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3845 bool other_magic = FALSE;
3851 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3852 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3853 /* Try to preserve the existenceness of a tied hash
3854 * element by using EXISTS and DELETE if possible.
3855 * Fallback to FETCH and STORE otherwise */
3856 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3857 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3858 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3861 while (++MARK <= SP) {
3865 bool preeminent = FALSE;
3868 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3869 hv_exists_ent(hv, keysv, 0);
3872 he = hv_fetch_ent(hv, keysv, lval, 0);
3873 svp = he ? &HeVAL(he) : 0;
3876 if (!svp || *svp == &PL_sv_undef) {
3878 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3882 save_helem(hv, keysv, svp);
3885 char *key = SvPV(keysv, keylen);
3886 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3890 *MARK = svp ? *svp : &PL_sv_undef;
3892 if (GIMME != G_ARRAY) {
3900 /* List operators. */
3905 if (GIMME != G_ARRAY) {
3907 *MARK = *SP; /* unwanted list, return last item */
3909 *MARK = &PL_sv_undef;
3918 SV **lastrelem = PL_stack_sp;
3919 SV **lastlelem = PL_stack_base + POPMARK;
3920 SV **firstlelem = PL_stack_base + POPMARK + 1;
3921 register SV **firstrelem = lastlelem + 1;
3922 I32 arybase = PL_curcop->cop_arybase;
3923 I32 lval = PL_op->op_flags & OPf_MOD;
3924 I32 is_something_there = lval;
3926 register I32 max = lastrelem - lastlelem;
3927 register SV **lelem;
3930 if (GIMME != G_ARRAY) {
3931 ix = SvIVx(*lastlelem);
3936 if (ix < 0 || ix >= max)
3937 *firstlelem = &PL_sv_undef;
3939 *firstlelem = firstrelem[ix];
3945 SP = firstlelem - 1;
3949 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3955 if (ix < 0 || ix >= max)
3956 *lelem = &PL_sv_undef;
3958 is_something_there = TRUE;
3959 if (!(*lelem = firstrelem[ix]))
3960 *lelem = &PL_sv_undef;
3963 if (is_something_there)
3966 SP = firstlelem - 1;
3972 dSP; dMARK; dORIGMARK;
3973 I32 items = SP - MARK;
3974 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3975 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3982 dSP; dMARK; dORIGMARK;
3983 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3987 SV *val = NEWSV(46, 0);
3989 sv_setsv(val, *++MARK);
3990 else if (ckWARN(WARN_MISC))
3991 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3992 (void)hv_store_ent(hv,key,val,0);
4001 dSP; dMARK; dORIGMARK;
4002 register AV *ary = (AV*)*++MARK;
4006 register I32 offset;
4007 register I32 length;
4014 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4015 *MARK-- = SvTIED_obj((SV*)ary, mg);
4019 call_method("SPLICE",GIMME_V);
4028 offset = i = SvIVx(*MARK);
4030 offset += AvFILLp(ary) + 1;
4032 offset -= PL_curcop->cop_arybase;
4034 DIE(aTHX_ PL_no_aelem, i);
4036 length = SvIVx(*MARK++);
4038 length += AvFILLp(ary) - offset + 1;
4044 length = AvMAX(ary) + 1; /* close enough to infinity */
4048 length = AvMAX(ary) + 1;
4050 if (offset > AvFILLp(ary) + 1) {
4051 if (ckWARN(WARN_MISC))
4052 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4053 offset = AvFILLp(ary) + 1;
4055 after = AvFILLp(ary) + 1 - (offset + length);
4056 if (after < 0) { /* not that much array */
4057 length += after; /* offset+length now in array */
4063 /* At this point, MARK .. SP-1 is our new LIST */
4066 diff = newlen - length;
4067 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4070 if (diff < 0) { /* shrinking the area */
4072 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4073 Copy(MARK, tmparyval, newlen, SV*);
4076 MARK = ORIGMARK + 1;
4077 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4078 MEXTEND(MARK, length);
4079 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4081 EXTEND_MORTAL(length);
4082 for (i = length, dst = MARK; i; i--) {
4083 sv_2mortal(*dst); /* free them eventualy */
4090 *MARK = AvARRAY(ary)[offset+length-1];
4093 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4094 SvREFCNT_dec(*dst++); /* free them now */
4097 AvFILLp(ary) += diff;
4099 /* pull up or down? */
4101 if (offset < after) { /* easier to pull up */
4102 if (offset) { /* esp. if nothing to pull */
4103 src = &AvARRAY(ary)[offset-1];
4104 dst = src - diff; /* diff is negative */
4105 for (i = offset; i > 0; i--) /* can't trust Copy */
4109 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4113 if (after) { /* anything to pull down? */
4114 src = AvARRAY(ary) + offset + length;
4115 dst = src + diff; /* diff is negative */
4116 Move(src, dst, after, SV*);
4118 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4119 /* avoid later double free */
4123 dst[--i] = &PL_sv_undef;
4126 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4128 *dst = NEWSV(46, 0);
4129 sv_setsv(*dst++, *src++);
4131 Safefree(tmparyval);
4134 else { /* no, expanding (or same) */
4136 New(452, tmparyval, length, SV*); /* so remember deletion */
4137 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4140 if (diff > 0) { /* expanding */
4142 /* push up or down? */
4144 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4148 Move(src, dst, offset, SV*);
4150 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4152 AvFILLp(ary) += diff;
4155 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4156 av_extend(ary, AvFILLp(ary) + diff);
4157 AvFILLp(ary) += diff;
4160 dst = AvARRAY(ary) + AvFILLp(ary);
4162 for (i = after; i; i--) {
4169 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4170 *dst = NEWSV(46, 0);
4171 sv_setsv(*dst++, *src++);
4173 MARK = ORIGMARK + 1;
4174 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4176 Copy(tmparyval, MARK, length, SV*);
4178 EXTEND_MORTAL(length);
4179 for (i = length, dst = MARK; i; i--) {
4180 sv_2mortal(*dst); /* free them eventualy */
4184 Safefree(tmparyval);
4188 else if (length--) {
4189 *MARK = tmparyval[length];
4192 while (length-- > 0)
4193 SvREFCNT_dec(tmparyval[length]);
4195 Safefree(tmparyval);
4198 *MARK = &PL_sv_undef;
4206 dSP; dMARK; dORIGMARK; dTARGET;
4207 register AV *ary = (AV*)*++MARK;
4208 register SV *sv = &PL_sv_undef;
4211 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4212 *MARK-- = SvTIED_obj((SV*)ary, mg);
4216 call_method("PUSH",G_SCALAR|G_DISCARD);
4221 /* Why no pre-extend of ary here ? */
4222 for (++MARK; MARK <= SP; MARK++) {
4225 sv_setsv(sv, *MARK);
4230 PUSHi( AvFILL(ary) + 1 );
4238 SV *sv = av_pop(av);
4240 (void)sv_2mortal(sv);
4249 SV *sv = av_shift(av);
4254 (void)sv_2mortal(sv);
4261 dSP; dMARK; dORIGMARK; dTARGET;
4262 register AV *ary = (AV*)*++MARK;
4267 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4268 *MARK-- = SvTIED_obj((SV*)ary, mg);
4272 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4277 av_unshift(ary, SP - MARK);
4280 sv_setsv(sv, *++MARK);
4281 (void)av_store(ary, i++, sv);
4285 PUSHi( AvFILL(ary) + 1 );
4295 if (GIMME == G_ARRAY) {
4302 /* safe as long as stack cannot get extended in the above */
4307 register char *down;
4312 SvUTF8_off(TARG); /* decontaminate */
4314 do_join(TARG, &PL_sv_no, MARK, SP);
4316 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4317 up = SvPV_force(TARG, len);
4319 if (DO_UTF8(TARG)) { /* first reverse each character */
4320 U8* s = (U8*)SvPVX(TARG);
4321 U8* send = (U8*)(s + len);
4323 if (UTF8_IS_INVARIANT(*s)) {
4328 if (!utf8_to_uvchr(s, 0))
4332 down = (char*)(s - 1);
4333 /* reverse this character */
4337 *down-- = (char)tmp;
4343 down = SvPVX(TARG) + len - 1;
4347 *down-- = (char)tmp;
4349 (void)SvPOK_only_UTF8(TARG);
4361 register IV limit = POPi; /* note, negative is forever */
4364 register char *s = SvPV(sv, len);
4365 bool do_utf8 = DO_UTF8(sv);
4366 char *strend = s + len;
4368 register REGEXP *rx;
4372 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4373 I32 maxiters = slen + 10;
4376 I32 origlimit = limit;
4379 AV *oldstack = PL_curstack;
4380 I32 gimme = GIMME_V;
4381 I32 oldsave = PL_savestack_ix;
4382 I32 make_mortal = 1;
4383 MAGIC *mg = (MAGIC *) NULL;
4386 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4391 DIE(aTHX_ "panic: pp_split");
4394 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4395 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4397 RX_MATCH_UTF8_set(rx, do_utf8);
4399 if (pm->op_pmreplroot) {
4401 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4403 ary = GvAVn((GV*)pm->op_pmreplroot);
4406 else if (gimme != G_ARRAY)
4407 ary = GvAVn(PL_defgv);
4410 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4416 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4418 XPUSHs(SvTIED_obj((SV*)ary, mg));
4424 for (i = AvFILLp(ary); i >= 0; i--)
4425 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4427 /* temporarily switch stacks */
4428 SWITCHSTACK(PL_curstack, ary);
4429 PL_curstackinfo->si_stack = ary;
4433 base = SP - PL_stack_base;
4435 if (pm->op_pmflags & PMf_SKIPWHITE) {
4436 if (pm->op_pmflags & PMf_LOCALE) {
4437 while (isSPACE_LC(*s))
4445 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4446 SAVEINT(PL_multiline);
4447 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4451 limit = maxiters + 2;
4452 if (pm->op_pmflags & PMf_WHITE) {
4455 while (m < strend &&
4456 !((pm->op_pmflags & PMf_LOCALE)
4457 ? isSPACE_LC(*m) : isSPACE(*m)))
4462 dstr = NEWSV(30, m-s);
4463 sv_setpvn(dstr, s, m-s);
4467 (void)SvUTF8_on(dstr);
4471 while (s < strend &&
4472 ((pm->op_pmflags & PMf_LOCALE)
4473 ? isSPACE_LC(*s) : isSPACE(*s)))
4477 else if (strEQ("^", rx->precomp)) {
4480 for (m = s; m < strend && *m != '\n'; m++) ;
4484 dstr = NEWSV(30, m-s);
4485 sv_setpvn(dstr, s, m-s);
4489 (void)SvUTF8_on(dstr);
4494 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4495 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4496 && (rx->reganch & ROPT_CHECK_ALL)
4497 && !(rx->reganch & ROPT_ANCH)) {
4498 int tail = (rx->reganch & RE_INTUIT_TAIL);
4499 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4502 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4504 char c = *SvPV(csv, n_a);
4507 for (m = s; m < strend && *m != c; m++) ;
4510 dstr = NEWSV(30, m-s);
4511 sv_setpvn(dstr, s, m-s);
4515 (void)SvUTF8_on(dstr);
4517 /* The rx->minlen is in characters but we want to step
4518 * s ahead by bytes. */
4520 s = (char*)utf8_hop((U8*)m, len);
4522 s = m + len; /* Fake \n at the end */
4527 while (s < strend && --limit &&
4528 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4529 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4532 dstr = NEWSV(31, m-s);
4533 sv_setpvn(dstr, s, m-s);
4537 (void)SvUTF8_on(dstr);
4539 /* The rx->minlen is in characters but we want to step
4540 * s ahead by bytes. */
4542 s = (char*)utf8_hop((U8*)m, len);
4544 s = m + len; /* Fake \n at the end */
4549 maxiters += slen * rx->nparens;
4550 while (s < strend && --limit)
4553 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4557 TAINT_IF(RX_MATCH_TAINTED(rx));
4558 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4563 strend = s + (strend - m);
4565 m = rx->startp[0] + orig;
4566 dstr = NEWSV(32, m-s);
4567 sv_setpvn(dstr, s, m-s);
4571 (void)SvUTF8_on(dstr);
4574 for (i = 1; i <= (I32)rx->nparens; i++) {
4575 s = rx->startp[i] + orig;
4576 m = rx->endp[i] + orig;
4578 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4579 parens that didn't match -- they should be set to
4580 undef, not the empty string */
4581 if (m >= orig && s >= orig) {
4582 dstr = NEWSV(33, m-s);
4583 sv_setpvn(dstr, s, m-s);
4586 dstr = &PL_sv_undef; /* undef, not "" */
4590 (void)SvUTF8_on(dstr);
4594 s = rx->endp[0] + orig;
4598 LEAVE_SCOPE(oldsave);
4599 iters = (SP - PL_stack_base) - base;
4600 if (iters > maxiters)
4601 DIE(aTHX_ "Split loop");
4603 /* keep field after final delim? */
4604 if (s < strend || (iters && origlimit)) {
4605 STRLEN l = strend - s;
4606 dstr = NEWSV(34, l);
4607 sv_setpvn(dstr, s, l);
4611 (void)SvUTF8_on(dstr);
4615 else if (!origlimit) {
4616 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4617 if (TOPs && !make_mortal)
4626 SWITCHSTACK(ary, oldstack);
4627 PL_curstackinfo->si_stack = oldstack;
4628 if (SvSMAGICAL(ary)) {
4633 if (gimme == G_ARRAY) {
4635 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4643 call_method("PUSH",G_SCALAR|G_DISCARD);
4646 if (gimme == G_ARRAY) {
4647 /* EXTEND should not be needed - we just popped them */
4649 for (i=0; i < iters; i++) {
4650 SV **svp = av_fetch(ary, i, FALSE);
4651 PUSHs((svp) ? *svp : &PL_sv_undef);
4658 if (gimme == G_ARRAY)
4673 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4674 || SvTYPE(retsv) == SVt_PVCV) {
4675 retsv = refto(retsv);
4683 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");