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 sv_setsv_nomg(TARG, sv);
2381 tmps = (U8*)SvPV_force(TARG, len);
2384 /* Calculate exact length, let's not estimate. */
2393 while (tmps < send) {
2394 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2395 tmps += UTF8SKIP(tmps);
2396 targlen += UNISKIP(~c);
2402 /* Now rewind strings and write them. */
2406 Newz(0, result, targlen + 1, U8);
2407 while (tmps < send) {
2408 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2409 tmps += UTF8SKIP(tmps);
2410 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2414 sv_setpvn(TARG, (char*)result, targlen);
2418 Newz(0, result, nchar + 1, U8);
2419 while (tmps < send) {
2420 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2421 tmps += UTF8SKIP(tmps);
2426 sv_setpvn(TARG, (char*)result, nchar);
2435 register long *tmpl;
2436 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2439 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2444 for ( ; anum > 0; anum--, tmps++)
2453 /* integer versions of some of the above */
2457 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2460 SETi( left * right );
2467 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2471 DIE(aTHX_ "Illegal division by zero");
2472 value = POPi / value;
2481 /* This is the vanilla old i_modulo. */
2482 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2486 DIE(aTHX_ "Illegal modulus zero");
2487 SETi( left % right );
2492 #if defined(__GLIBC__) && IVSIZE == 8
2496 /* This is the i_modulo with the workaround for the _moddi3 bug
2497 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2498 * See below for pp_i_modulo. */
2499 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2503 DIE(aTHX_ "Illegal modulus zero");
2504 SETi( left % PERL_ABS(right) );
2512 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2516 DIE(aTHX_ "Illegal modulus zero");
2517 /* The assumption is to use hereafter the old vanilla version... */
2519 PL_ppaddr[OP_I_MODULO] =
2520 &Perl_pp_i_modulo_0;
2521 /* .. but if we have glibc, we might have a buggy _moddi3
2522 * (at least glicb 2.2.5 is known to have this bug), in other
2523 * words our integer modulus with negative quad as the second
2524 * argument might be broken. Test for this and re-patch the
2525 * opcode dispatch table if that is the case, remembering to
2526 * also apply the workaround so that this first round works
2527 * right, too. See [perl #9402] for more information. */
2528 #if defined(__GLIBC__) && IVSIZE == 8
2532 /* Cannot do this check with inlined IV constants since
2533 * that seems to work correctly even with the buggy glibc. */
2535 /* Yikes, we have the bug.
2536 * Patch in the workaround version. */
2538 PL_ppaddr[OP_I_MODULO] =
2539 &Perl_pp_i_modulo_1;
2540 /* Make certain we work right this time, too. */
2541 right = PERL_ABS(right);
2545 SETi( left % right );
2552 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2555 SETi( left + right );
2562 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2565 SETi( left - right );
2572 dSP; tryAMAGICbinSET(lt,0);
2575 SETs(boolSV(left < right));
2582 dSP; tryAMAGICbinSET(gt,0);
2585 SETs(boolSV(left > right));
2592 dSP; tryAMAGICbinSET(le,0);
2595 SETs(boolSV(left <= right));
2602 dSP; tryAMAGICbinSET(ge,0);
2605 SETs(boolSV(left >= right));
2612 dSP; tryAMAGICbinSET(eq,0);
2615 SETs(boolSV(left == right));
2622 dSP; tryAMAGICbinSET(ne,0);
2625 SETs(boolSV(left != right));
2632 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2639 else if (left < right)
2650 dSP; dTARGET; tryAMAGICun(neg);
2655 /* High falutin' math. */
2659 dSP; dTARGET; tryAMAGICbin(atan2,0);
2662 SETn(Perl_atan2(left, right));
2669 dSP; dTARGET; tryAMAGICun(sin);
2673 value = Perl_sin(value);
2681 dSP; dTARGET; tryAMAGICun(cos);
2685 value = Perl_cos(value);
2691 /* Support Configure command-line overrides for rand() functions.
2692 After 5.005, perhaps we should replace this by Configure support
2693 for drand48(), random(), or rand(). For 5.005, though, maintain
2694 compatibility by calling rand() but allow the user to override it.
2695 See INSTALL for details. --Andy Dougherty 15 July 1998
2697 /* Now it's after 5.005, and Configure supports drand48() and random(),
2698 in addition to rand(). So the overrides should not be needed any more.
2699 --Jarkko Hietaniemi 27 September 1998
2702 #ifndef HAS_DRAND48_PROTO
2703 extern double drand48 (void);
2716 if (!PL_srand_called) {
2717 (void)seedDrand01((Rand_seed_t)seed());
2718 PL_srand_called = TRUE;
2733 (void)seedDrand01((Rand_seed_t)anum);
2734 PL_srand_called = TRUE;
2741 dSP; dTARGET; tryAMAGICun(exp);
2745 value = Perl_exp(value);
2753 dSP; dTARGET; tryAMAGICun(log);
2758 SET_NUMERIC_STANDARD();
2759 DIE(aTHX_ "Can't take log of %"NVgf, value);
2761 value = Perl_log(value);
2769 dSP; dTARGET; tryAMAGICun(sqrt);
2774 SET_NUMERIC_STANDARD();
2775 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2777 value = Perl_sqrt(value);
2785 dSP; dTARGET; tryAMAGICun(int);
2788 IV iv = TOPi; /* attempt to convert to IV if possible. */
2789 /* XXX it's arguable that compiler casting to IV might be subtly
2790 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2791 else preferring IV has introduced a subtle behaviour change bug. OTOH
2792 relying on floating point to be accurate is a bug. */
2803 if (value < (NV)UV_MAX + 0.5) {
2806 SETn(Perl_floor(value));
2810 if (value > (NV)IV_MIN - 0.5) {
2813 SETn(Perl_ceil(value));
2823 dSP; dTARGET; tryAMAGICun(abs);
2825 /* This will cache the NV value if string isn't actually integer */
2829 /* IVX is precise */
2831 SETu(TOPu); /* force it to be numeric only */
2839 /* 2s complement assumption. Also, not really needed as
2840 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2860 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2866 tmps = (SvPVx(sv, len));
2868 /* If Unicode, try to downgrade
2869 * If not possible, croak. */
2870 SV* tsv = sv_2mortal(newSVsv(sv));
2873 sv_utf8_downgrade(tsv, FALSE);
2876 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2877 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2890 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2896 tmps = (SvPVx(sv, len));
2898 /* If Unicode, try to downgrade
2899 * If not possible, croak. */
2900 SV* tsv = sv_2mortal(newSVsv(sv));
2903 sv_utf8_downgrade(tsv, FALSE);
2906 while (*tmps && len && isSPACE(*tmps))
2911 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2912 else if (*tmps == 'b')
2913 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2915 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2917 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2934 SETi(sv_len_utf8(sv));
2950 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2952 I32 arybase = PL_curcop->cop_arybase;
2956 int num_args = PL_op->op_private & 7;
2957 bool repl_need_utf8_upgrade = FALSE;
2958 bool repl_is_utf8 = FALSE;
2960 SvTAINTED_off(TARG); /* decontaminate */
2961 SvUTF8_off(TARG); /* decontaminate */
2965 repl = SvPV(repl_sv, repl_len);
2966 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2976 sv_utf8_upgrade(sv);
2978 else if (DO_UTF8(sv))
2979 repl_need_utf8_upgrade = TRUE;
2981 tmps = SvPV(sv, curlen);
2983 utf8_curlen = sv_len_utf8(sv);
2984 if (utf8_curlen == curlen)
2987 curlen = utf8_curlen;
2992 if (pos >= arybase) {
3010 else if (len >= 0) {
3012 if (rem > (I32)curlen)
3027 Perl_croak(aTHX_ "substr outside of string");
3028 if (ckWARN(WARN_SUBSTR))
3029 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3036 sv_pos_u2b(sv, &pos, &rem);
3038 sv_setpvn(TARG, tmps, rem);
3039 #ifdef USE_LOCALE_COLLATE
3040 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3045 SV* repl_sv_copy = NULL;
3047 if (repl_need_utf8_upgrade) {
3048 repl_sv_copy = newSVsv(repl_sv);
3049 sv_utf8_upgrade(repl_sv_copy);
3050 repl = SvPV(repl_sv_copy, repl_len);
3051 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3053 sv_insert(sv, pos, rem, repl, repl_len);
3057 SvREFCNT_dec(repl_sv_copy);
3059 else if (lvalue) { /* it's an lvalue! */
3060 if (!SvGMAGICAL(sv)) {
3064 if (ckWARN(WARN_SUBSTR))
3065 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3066 "Attempt to use reference as lvalue in substr");
3068 if (SvOK(sv)) /* is it defined ? */
3069 (void)SvPOK_only_UTF8(sv);
3071 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3074 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3075 TARG = sv_newmortal();
3076 if (SvTYPE(TARG) < SVt_PVLV) {
3077 sv_upgrade(TARG, SVt_PVLV);
3078 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3081 (void)SvOK_off(TARG);
3084 if (LvTARG(TARG) != sv) {
3086 SvREFCNT_dec(LvTARG(TARG));
3087 LvTARG(TARG) = SvREFCNT_inc(sv);
3089 LvTARGOFF(TARG) = upos;
3090 LvTARGLEN(TARG) = urem;
3094 PUSHs(TARG); /* avoid SvSETMAGIC here */
3101 register IV size = POPi;
3102 register IV offset = POPi;
3103 register SV *src = POPs;
3104 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3106 SvTAINTED_off(TARG); /* decontaminate */
3107 if (lvalue) { /* it's an lvalue! */
3108 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3109 TARG = sv_newmortal();
3110 if (SvTYPE(TARG) < SVt_PVLV) {
3111 sv_upgrade(TARG, SVt_PVLV);
3112 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3115 if (LvTARG(TARG) != src) {
3117 SvREFCNT_dec(LvTARG(TARG));
3118 LvTARG(TARG) = SvREFCNT_inc(src);
3120 LvTARGOFF(TARG) = offset;
3121 LvTARGLEN(TARG) = size;
3124 sv_setuv(TARG, do_vecget(src, offset, size));
3139 I32 arybase = PL_curcop->cop_arybase;
3144 offset = POPi - arybase;
3147 tmps = SvPV(big, biglen);
3148 if (offset > 0 && DO_UTF8(big))
3149 sv_pos_u2b(big, &offset, 0);
3152 else if (offset > (I32)biglen)
3154 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3155 (unsigned char*)tmps + biglen, little, 0)))
3158 retval = tmps2 - tmps;
3159 if (retval > 0 && DO_UTF8(big))
3160 sv_pos_b2u(big, &retval);
3161 PUSHi(retval + arybase);
3176 I32 arybase = PL_curcop->cop_arybase;
3182 tmps2 = SvPV(little, llen);
3183 tmps = SvPV(big, blen);
3187 if (offset > 0 && DO_UTF8(big))
3188 sv_pos_u2b(big, &offset, 0);
3189 offset = offset - arybase + llen;
3193 else if (offset > (I32)blen)
3195 if (!(tmps2 = rninstr(tmps, tmps + offset,
3196 tmps2, tmps2 + llen)))
3199 retval = tmps2 - tmps;
3200 if (retval > 0 && DO_UTF8(big))
3201 sv_pos_b2u(big, &retval);
3202 PUSHi(retval + arybase);
3208 dSP; dMARK; dORIGMARK; dTARGET;
3209 do_sprintf(TARG, SP-MARK, MARK+1);
3210 TAINT_IF(SvTAINTED(TARG));
3211 if (DO_UTF8(*(MARK+1)))
3223 U8 *s = (U8*)SvPVx(argsv, len);
3226 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3227 tmpsv = sv_2mortal(newSVsv(argsv));
3228 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3232 XPUSHu(DO_UTF8(argsv) ?
3233 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3245 (void)SvUPGRADE(TARG,SVt_PV);
3247 if (value > 255 && !IN_BYTES) {
3248 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3249 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3250 SvCUR_set(TARG, tmps - SvPVX(TARG));
3252 (void)SvPOK_only(TARG);
3261 *tmps++ = (char)value;
3263 (void)SvPOK_only(TARG);
3264 if (PL_encoding && !IN_BYTES) {
3265 sv_recode_to_utf8(TARG, PL_encoding);
3267 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3268 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3272 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3273 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3289 char *tmps = SvPV(left, len);
3291 if (DO_UTF8(left)) {
3292 /* If Unicode, try to downgrade.
3293 * If not possible, croak.
3294 * Yes, we made this up. */
3295 SV* tsv = sv_2mortal(newSVsv(left));
3298 sv_utf8_downgrade(tsv, FALSE);
3301 # ifdef USE_ITHREADS
3303 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3304 /* This should be threadsafe because in ithreads there is only
3305 * one thread per interpreter. If this would not be true,
3306 * we would need a mutex to protect this malloc. */
3307 PL_reentrant_buffer->_crypt_struct_buffer =
3308 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3309 #if defined(__GLIBC__) || defined(__EMX__)
3310 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3311 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3312 /* work around glibc-2.2.5 bug */
3313 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3317 # endif /* HAS_CRYPT_R */
3318 # endif /* USE_ITHREADS */
3320 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3322 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3328 "The crypt() function is unimplemented due to excessive paranoia.");
3341 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3342 UTF8_IS_START(*s)) {
3343 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3347 utf8_to_uvchr(s, &ulen);
3348 toTITLE_utf8(s, tmpbuf, &tculen);
3349 utf8_to_uvchr(tmpbuf, 0);
3351 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3353 /* slen is the byte length of the whole SV.
3354 * ulen is the byte length of the original Unicode character
3355 * stored as UTF-8 at s.
3356 * tculen is the byte length of the freshly titlecased
3357 * Unicode character stored as UTF-8 at tmpbuf.
3358 * We first set the result to be the titlecased character,
3359 * and then append the rest of the SV data. */
3360 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3362 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3367 s = (U8*)SvPV_force_nomg(sv, slen);
3368 Copy(tmpbuf, s, tculen, U8);
3372 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3374 SvUTF8_off(TARG); /* decontaminate */
3375 sv_setsv_nomg(TARG, sv);
3379 s = (U8*)SvPV_force_nomg(sv, slen);
3381 if (IN_LOCALE_RUNTIME) {
3384 *s = toUPPER_LC(*s);
3403 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3404 UTF8_IS_START(*s)) {
3406 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3410 toLOWER_utf8(s, tmpbuf, &ulen);
3411 uv = utf8_to_uvchr(tmpbuf, 0);
3412 tend = uvchr_to_utf8(tmpbuf, uv);
3414 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3416 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3418 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3423 s = (U8*)SvPV_force_nomg(sv, slen);
3424 Copy(tmpbuf, s, ulen, U8);
3428 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3430 SvUTF8_off(TARG); /* decontaminate */
3431 sv_setsv_nomg(TARG, sv);
3435 s = (U8*)SvPV_force_nomg(sv, slen);
3437 if (IN_LOCALE_RUNTIME) {
3440 *s = toLOWER_LC(*s);
3463 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3465 s = (U8*)SvPV_nomg(sv,len);
3467 SvUTF8_off(TARG); /* decontaminate */
3468 sv_setpvn(TARG, "", 0);
3472 STRLEN nchar = utf8_length(s, s + len);
3474 (void)SvUPGRADE(TARG, SVt_PV);
3475 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3476 (void)SvPOK_only(TARG);
3477 d = (U8*)SvPVX(TARG);
3480 toUPPER_utf8(s, tmpbuf, &ulen);
3481 Copy(tmpbuf, d, ulen, U8);
3487 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3492 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3494 SvUTF8_off(TARG); /* decontaminate */
3495 sv_setsv_nomg(TARG, sv);
3499 s = (U8*)SvPV_force_nomg(sv, len);
3501 register U8 *send = s + len;
3503 if (IN_LOCALE_RUNTIME) {
3506 for (; s < send; s++)
3507 *s = toUPPER_LC(*s);
3510 for (; s < send; s++)
3532 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3534 s = (U8*)SvPV_nomg(sv,len);
3536 SvUTF8_off(TARG); /* decontaminate */
3537 sv_setpvn(TARG, "", 0);
3541 STRLEN nchar = utf8_length(s, s + len);
3543 (void)SvUPGRADE(TARG, SVt_PV);
3544 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3545 (void)SvPOK_only(TARG);
3546 d = (U8*)SvPVX(TARG);
3549 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3550 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3551 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3553 * Now if the sigma is NOT followed by
3554 * /$ignorable_sequence$cased_letter/;
3555 * and it IS preceded by
3556 * /$cased_letter$ignorable_sequence/;
3557 * where $ignorable_sequence is
3558 * [\x{2010}\x{AD}\p{Mn}]*
3559 * and $cased_letter is
3560 * [\p{Ll}\p{Lo}\p{Lt}]
3561 * then it should be mapped to 0x03C2,
3562 * (GREEK SMALL LETTER FINAL SIGMA),
3563 * instead of staying 0x03A3.
3564 * See lib/unicore/SpecCase.txt.
3567 Copy(tmpbuf, d, ulen, U8);
3573 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3578 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3580 SvUTF8_off(TARG); /* decontaminate */
3581 sv_setsv_nomg(TARG, sv);
3586 s = (U8*)SvPV_force_nomg(sv, len);
3588 register U8 *send = s + len;
3590 if (IN_LOCALE_RUNTIME) {
3593 for (; s < send; s++)
3594 *s = toLOWER_LC(*s);
3597 for (; s < send; s++)
3611 register char *s = SvPV(sv,len);
3614 SvUTF8_off(TARG); /* decontaminate */
3616 (void)SvUPGRADE(TARG, SVt_PV);
3617 SvGROW(TARG, (len * 2) + 1);
3621 if (UTF8_IS_CONTINUED(*s)) {
3622 STRLEN ulen = UTF8SKIP(s);
3646 SvCUR_set(TARG, d - SvPVX(TARG));
3647 (void)SvPOK_only_UTF8(TARG);
3650 sv_setpvn(TARG, s, len);
3652 if (SvSMAGICAL(TARG))
3661 dSP; dMARK; dORIGMARK;
3663 register AV* av = (AV*)POPs;
3664 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3665 I32 arybase = PL_curcop->cop_arybase;
3668 if (SvTYPE(av) == SVt_PVAV) {
3669 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3671 for (svp = MARK + 1; svp <= SP; svp++) {
3676 if (max > AvMAX(av))
3679 while (++MARK <= SP) {
3680 elem = SvIVx(*MARK);
3684 svp = av_fetch(av, elem, lval);
3686 if (!svp || *svp == &PL_sv_undef)
3687 DIE(aTHX_ PL_no_aelem, elem);
3688 if (PL_op->op_private & OPpLVAL_INTRO)
3689 save_aelem(av, elem, svp);
3691 *MARK = svp ? *svp : &PL_sv_undef;
3694 if (GIMME != G_ARRAY) {
3702 /* Associative arrays. */
3707 HV *hash = (HV*)POPs;
3709 I32 gimme = GIMME_V;
3712 /* might clobber stack_sp */
3713 entry = hv_iternext(hash);
3718 SV* sv = hv_iterkeysv(entry);
3719 PUSHs(sv); /* won't clobber stack_sp */
3720 if (gimme == G_ARRAY) {
3723 /* might clobber stack_sp */
3724 val = hv_iterval(hash, entry);
3729 else if (gimme == G_SCALAR)
3748 I32 gimme = GIMME_V;
3749 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3753 if (PL_op->op_private & OPpSLICE) {
3757 hvtype = SvTYPE(hv);
3758 if (hvtype == SVt_PVHV) { /* hash element */
3759 while (++MARK <= SP) {
3760 sv = hv_delete_ent(hv, *MARK, discard, 0);
3761 *MARK = sv ? sv : &PL_sv_undef;
3764 else if (hvtype == SVt_PVAV) { /* array element */
3765 if (PL_op->op_flags & OPf_SPECIAL) {
3766 while (++MARK <= SP) {
3767 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3768 *MARK = sv ? sv : &PL_sv_undef;
3773 DIE(aTHX_ "Not a HASH reference");
3776 else if (gimme == G_SCALAR) {
3785 if (SvTYPE(hv) == SVt_PVHV)
3786 sv = hv_delete_ent(hv, keysv, discard, 0);
3787 else if (SvTYPE(hv) == SVt_PVAV) {
3788 if (PL_op->op_flags & OPf_SPECIAL)
3789 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3791 DIE(aTHX_ "panic: avhv_delete no longer supported");
3794 DIE(aTHX_ "Not a HASH reference");
3809 if (PL_op->op_private & OPpEXISTS_SUB) {
3813 cv = sv_2cv(sv, &hv, &gv, FALSE);
3816 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3822 if (SvTYPE(hv) == SVt_PVHV) {
3823 if (hv_exists_ent(hv, tmpsv, 0))
3826 else if (SvTYPE(hv) == SVt_PVAV) {
3827 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3828 if (av_exists((AV*)hv, SvIV(tmpsv)))
3833 DIE(aTHX_ "Not a HASH reference");
3840 dSP; dMARK; dORIGMARK;
3841 register HV *hv = (HV*)POPs;
3842 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3843 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3844 bool other_magic = FALSE;
3850 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3851 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3852 /* Try to preserve the existenceness of a tied hash
3853 * element by using EXISTS and DELETE if possible.
3854 * Fallback to FETCH and STORE otherwise */
3855 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3856 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3857 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3860 while (++MARK <= SP) {
3864 bool preeminent = FALSE;
3867 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3868 hv_exists_ent(hv, keysv, 0);
3871 he = hv_fetch_ent(hv, keysv, lval, 0);
3872 svp = he ? &HeVAL(he) : 0;
3875 if (!svp || *svp == &PL_sv_undef) {
3877 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3881 save_helem(hv, keysv, svp);
3884 char *key = SvPV(keysv, keylen);
3885 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3889 *MARK = svp ? *svp : &PL_sv_undef;
3891 if (GIMME != G_ARRAY) {
3899 /* List operators. */
3904 if (GIMME != G_ARRAY) {
3906 *MARK = *SP; /* unwanted list, return last item */
3908 *MARK = &PL_sv_undef;
3917 SV **lastrelem = PL_stack_sp;
3918 SV **lastlelem = PL_stack_base + POPMARK;
3919 SV **firstlelem = PL_stack_base + POPMARK + 1;
3920 register SV **firstrelem = lastlelem + 1;
3921 I32 arybase = PL_curcop->cop_arybase;
3922 I32 lval = PL_op->op_flags & OPf_MOD;
3923 I32 is_something_there = lval;
3925 register I32 max = lastrelem - lastlelem;
3926 register SV **lelem;
3929 if (GIMME != G_ARRAY) {
3930 ix = SvIVx(*lastlelem);
3935 if (ix < 0 || ix >= max)
3936 *firstlelem = &PL_sv_undef;
3938 *firstlelem = firstrelem[ix];
3944 SP = firstlelem - 1;
3948 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3954 if (ix < 0 || ix >= max)
3955 *lelem = &PL_sv_undef;
3957 is_something_there = TRUE;
3958 if (!(*lelem = firstrelem[ix]))
3959 *lelem = &PL_sv_undef;
3962 if (is_something_there)
3965 SP = firstlelem - 1;
3971 dSP; dMARK; dORIGMARK;
3972 I32 items = SP - MARK;
3973 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3974 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3981 dSP; dMARK; dORIGMARK;
3982 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3986 SV *val = NEWSV(46, 0);
3988 sv_setsv(val, *++MARK);
3989 else if (ckWARN(WARN_MISC))
3990 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3991 (void)hv_store_ent(hv,key,val,0);
4000 dSP; dMARK; dORIGMARK;
4001 register AV *ary = (AV*)*++MARK;
4005 register I32 offset;
4006 register I32 length;
4013 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4014 *MARK-- = SvTIED_obj((SV*)ary, mg);
4018 call_method("SPLICE",GIMME_V);
4027 offset = i = SvIVx(*MARK);
4029 offset += AvFILLp(ary) + 1;
4031 offset -= PL_curcop->cop_arybase;
4033 DIE(aTHX_ PL_no_aelem, i);
4035 length = SvIVx(*MARK++);
4037 length += AvFILLp(ary) - offset + 1;
4043 length = AvMAX(ary) + 1; /* close enough to infinity */
4047 length = AvMAX(ary) + 1;
4049 if (offset > AvFILLp(ary) + 1) {
4050 if (ckWARN(WARN_MISC))
4051 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4052 offset = AvFILLp(ary) + 1;
4054 after = AvFILLp(ary) + 1 - (offset + length);
4055 if (after < 0) { /* not that much array */
4056 length += after; /* offset+length now in array */
4062 /* At this point, MARK .. SP-1 is our new LIST */
4065 diff = newlen - length;
4066 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4069 if (diff < 0) { /* shrinking the area */
4071 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4072 Copy(MARK, tmparyval, newlen, SV*);
4075 MARK = ORIGMARK + 1;
4076 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4077 MEXTEND(MARK, length);
4078 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4080 EXTEND_MORTAL(length);
4081 for (i = length, dst = MARK; i; i--) {
4082 sv_2mortal(*dst); /* free them eventualy */
4089 *MARK = AvARRAY(ary)[offset+length-1];
4092 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4093 SvREFCNT_dec(*dst++); /* free them now */
4096 AvFILLp(ary) += diff;
4098 /* pull up or down? */
4100 if (offset < after) { /* easier to pull up */
4101 if (offset) { /* esp. if nothing to pull */
4102 src = &AvARRAY(ary)[offset-1];
4103 dst = src - diff; /* diff is negative */
4104 for (i = offset; i > 0; i--) /* can't trust Copy */
4108 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4112 if (after) { /* anything to pull down? */
4113 src = AvARRAY(ary) + offset + length;
4114 dst = src + diff; /* diff is negative */
4115 Move(src, dst, after, SV*);
4117 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4118 /* avoid later double free */
4122 dst[--i] = &PL_sv_undef;
4125 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4127 *dst = NEWSV(46, 0);
4128 sv_setsv(*dst++, *src++);
4130 Safefree(tmparyval);
4133 else { /* no, expanding (or same) */
4135 New(452, tmparyval, length, SV*); /* so remember deletion */
4136 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4139 if (diff > 0) { /* expanding */
4141 /* push up or down? */
4143 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4147 Move(src, dst, offset, SV*);
4149 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4151 AvFILLp(ary) += diff;
4154 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4155 av_extend(ary, AvFILLp(ary) + diff);
4156 AvFILLp(ary) += diff;
4159 dst = AvARRAY(ary) + AvFILLp(ary);
4161 for (i = after; i; i--) {
4168 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4169 *dst = NEWSV(46, 0);
4170 sv_setsv(*dst++, *src++);
4172 MARK = ORIGMARK + 1;
4173 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4175 Copy(tmparyval, MARK, length, SV*);
4177 EXTEND_MORTAL(length);
4178 for (i = length, dst = MARK; i; i--) {
4179 sv_2mortal(*dst); /* free them eventualy */
4183 Safefree(tmparyval);
4187 else if (length--) {
4188 *MARK = tmparyval[length];
4191 while (length-- > 0)
4192 SvREFCNT_dec(tmparyval[length]);
4194 Safefree(tmparyval);
4197 *MARK = &PL_sv_undef;
4205 dSP; dMARK; dORIGMARK; dTARGET;
4206 register AV *ary = (AV*)*++MARK;
4207 register SV *sv = &PL_sv_undef;
4210 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4211 *MARK-- = SvTIED_obj((SV*)ary, mg);
4215 call_method("PUSH",G_SCALAR|G_DISCARD);
4220 /* Why no pre-extend of ary here ? */
4221 for (++MARK; MARK <= SP; MARK++) {
4224 sv_setsv(sv, *MARK);
4229 PUSHi( AvFILL(ary) + 1 );
4237 SV *sv = av_pop(av);
4239 (void)sv_2mortal(sv);
4248 SV *sv = av_shift(av);
4253 (void)sv_2mortal(sv);
4260 dSP; dMARK; dORIGMARK; dTARGET;
4261 register AV *ary = (AV*)*++MARK;
4266 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4267 *MARK-- = SvTIED_obj((SV*)ary, mg);
4271 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4276 av_unshift(ary, SP - MARK);
4279 sv_setsv(sv, *++MARK);
4280 (void)av_store(ary, i++, sv);
4284 PUSHi( AvFILL(ary) + 1 );
4294 if (GIMME == G_ARRAY) {
4301 /* safe as long as stack cannot get extended in the above */
4306 register char *down;
4311 SvUTF8_off(TARG); /* decontaminate */
4313 do_join(TARG, &PL_sv_no, MARK, SP);
4315 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4316 up = SvPV_force(TARG, len);
4318 if (DO_UTF8(TARG)) { /* first reverse each character */
4319 U8* s = (U8*)SvPVX(TARG);
4320 U8* send = (U8*)(s + len);
4322 if (UTF8_IS_INVARIANT(*s)) {
4327 if (!utf8_to_uvchr(s, 0))
4331 down = (char*)(s - 1);
4332 /* reverse this character */
4336 *down-- = (char)tmp;
4342 down = SvPVX(TARG) + len - 1;
4346 *down-- = (char)tmp;
4348 (void)SvPOK_only_UTF8(TARG);
4360 register IV limit = POPi; /* note, negative is forever */
4363 register char *s = SvPV(sv, len);
4364 bool do_utf8 = DO_UTF8(sv);
4365 char *strend = s + len;
4367 register REGEXP *rx;
4371 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4372 I32 maxiters = slen + 10;
4375 I32 origlimit = limit;
4378 AV *oldstack = PL_curstack;
4379 I32 gimme = GIMME_V;
4380 I32 oldsave = PL_savestack_ix;
4381 I32 make_mortal = 1;
4382 MAGIC *mg = (MAGIC *) NULL;
4385 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4390 DIE(aTHX_ "panic: pp_split");
4393 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4394 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4396 RX_MATCH_UTF8_set(rx, do_utf8);
4398 if (pm->op_pmreplroot) {
4400 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4402 ary = GvAVn((GV*)pm->op_pmreplroot);
4405 else if (gimme != G_ARRAY)
4406 ary = GvAVn(PL_defgv);
4409 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4415 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4417 XPUSHs(SvTIED_obj((SV*)ary, mg));
4423 for (i = AvFILLp(ary); i >= 0; i--)
4424 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4426 /* temporarily switch stacks */
4427 SWITCHSTACK(PL_curstack, ary);
4428 PL_curstackinfo->si_stack = ary;
4432 base = SP - PL_stack_base;
4434 if (pm->op_pmflags & PMf_SKIPWHITE) {
4435 if (pm->op_pmflags & PMf_LOCALE) {
4436 while (isSPACE_LC(*s))
4444 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4445 SAVEINT(PL_multiline);
4446 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4450 limit = maxiters + 2;
4451 if (pm->op_pmflags & PMf_WHITE) {
4454 while (m < strend &&
4455 !((pm->op_pmflags & PMf_LOCALE)
4456 ? isSPACE_LC(*m) : isSPACE(*m)))
4461 dstr = NEWSV(30, m-s);
4462 sv_setpvn(dstr, s, m-s);
4466 (void)SvUTF8_on(dstr);
4470 while (s < strend &&
4471 ((pm->op_pmflags & PMf_LOCALE)
4472 ? isSPACE_LC(*s) : isSPACE(*s)))
4476 else if (strEQ("^", rx->precomp)) {
4479 for (m = s; m < strend && *m != '\n'; m++) ;
4483 dstr = NEWSV(30, m-s);
4484 sv_setpvn(dstr, s, m-s);
4488 (void)SvUTF8_on(dstr);
4493 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4494 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4495 && (rx->reganch & ROPT_CHECK_ALL)
4496 && !(rx->reganch & ROPT_ANCH)) {
4497 int tail = (rx->reganch & RE_INTUIT_TAIL);
4498 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4501 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4503 char c = *SvPV(csv, n_a);
4506 for (m = s; m < strend && *m != c; m++) ;
4509 dstr = NEWSV(30, m-s);
4510 sv_setpvn(dstr, s, m-s);
4514 (void)SvUTF8_on(dstr);
4516 /* The rx->minlen is in characters but we want to step
4517 * s ahead by bytes. */
4519 s = (char*)utf8_hop((U8*)m, len);
4521 s = m + len; /* Fake \n at the end */
4526 while (s < strend && --limit &&
4527 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4528 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4531 dstr = NEWSV(31, m-s);
4532 sv_setpvn(dstr, s, m-s);
4536 (void)SvUTF8_on(dstr);
4538 /* The rx->minlen is in characters but we want to step
4539 * s ahead by bytes. */
4541 s = (char*)utf8_hop((U8*)m, len);
4543 s = m + len; /* Fake \n at the end */
4548 maxiters += slen * rx->nparens;
4549 while (s < strend && --limit)
4552 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4556 TAINT_IF(RX_MATCH_TAINTED(rx));
4557 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4562 strend = s + (strend - m);
4564 m = rx->startp[0] + orig;
4565 dstr = NEWSV(32, m-s);
4566 sv_setpvn(dstr, s, m-s);
4570 (void)SvUTF8_on(dstr);
4573 for (i = 1; i <= (I32)rx->nparens; i++) {
4574 s = rx->startp[i] + orig;
4575 m = rx->endp[i] + orig;
4577 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4578 parens that didn't match -- they should be set to
4579 undef, not the empty string */
4580 if (m >= orig && s >= orig) {
4581 dstr = NEWSV(33, m-s);
4582 sv_setpvn(dstr, s, m-s);
4585 dstr = &PL_sv_undef; /* undef, not "" */
4589 (void)SvUTF8_on(dstr);
4593 s = rx->endp[0] + orig;
4597 LEAVE_SCOPE(oldsave);
4598 iters = (SP - PL_stack_base) - base;
4599 if (iters > maxiters)
4600 DIE(aTHX_ "Split loop");
4602 /* keep field after final delim? */
4603 if (s < strend || (iters && origlimit)) {
4604 STRLEN l = strend - s;
4605 dstr = NEWSV(34, l);
4606 sv_setpvn(dstr, s, l);
4610 (void)SvUTF8_on(dstr);
4614 else if (!origlimit) {
4615 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4616 if (TOPs && !make_mortal)
4625 SWITCHSTACK(ary, oldstack);
4626 PL_curstackinfo->si_stack = oldstack;
4627 if (SvSMAGICAL(ary)) {
4632 if (gimme == G_ARRAY) {
4634 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4642 call_method("PUSH",G_SCALAR|G_DISCARD);
4645 if (gimme == G_ARRAY) {
4646 /* EXTEND should not be needed - we just popped them */
4648 for (i=0; i < iters; i++) {
4649 SV **svp = av_fetch(ary, i, FALSE);
4650 PUSHs((svp) ? *svp : &PL_sv_undef);
4657 if (gimme == G_ARRAY)
4672 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4673 || SvTYPE(retsv) == SVt_PVCV) {
4674 retsv = refto(retsv);
4682 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");