3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
23 /* XXX I can't imagine anyone who doesn't have this actually _needs_
24 it, since pid_t is an integral type.
27 #ifdef NEED_GETPID_PROTO
28 extern Pid_t getpid (void);
31 /* variations on pp_null */
36 if (GIMME_V == G_SCALAR)
52 if (PL_op->op_private & OPpLVAL_INTRO)
53 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
55 if (PL_op->op_flags & OPf_REF) {
59 if (GIMME == G_SCALAR)
60 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
65 if (gimme == G_ARRAY) {
66 I32 maxarg = AvFILL((AV*)TARG) + 1;
68 if (SvMAGICAL(TARG)) {
70 for (i=0; i < (U32)maxarg; i++) {
71 SV **svp = av_fetch((AV*)TARG, i, FALSE);
72 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
76 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
80 else if (gimme == G_SCALAR) {
81 SV* sv = sv_newmortal();
82 I32 maxarg = AvFILL((AV*)TARG) + 1;
95 if (PL_op->op_private & OPpLVAL_INTRO)
96 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
97 if (PL_op->op_flags & OPf_REF)
100 if (GIMME == G_SCALAR)
101 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
105 if (gimme == G_ARRAY) {
108 else if (gimme == G_SCALAR) {
109 SV* sv = sv_newmortal();
110 if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied))
111 Perl_croak(aTHX_ "Can't provide tied hash usage; "
112 "use keys(%%hash) to test if empty");
113 if (HvFILL((HV*)TARG))
114 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
115 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
125 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
136 tryAMAGICunDEREF(to_gv);
139 if (SvTYPE(sv) == SVt_PVIO) {
140 GV *gv = (GV*) sv_newmortal();
141 gv_init(gv, 0, "", 0, 0);
142 GvIOp(gv) = (IO *)sv;
143 (void)SvREFCNT_inc(sv);
146 else if (SvTYPE(sv) != SVt_PVGV)
147 DIE(aTHX_ "Not a GLOB reference");
150 if (SvTYPE(sv) != SVt_PVGV) {
154 if (SvGMAGICAL(sv)) {
159 if (!SvOK(sv) && sv != &PL_sv_undef) {
160 /* If this is a 'my' scalar and flag is set then vivify
163 if (PL_op->op_private & OPpDEREF) {
166 if (cUNOP->op_targ) {
168 SV *namesv = PAD_SV(cUNOP->op_targ);
169 name = SvPV(namesv, len);
170 gv = (GV*)NEWSV(0,0);
171 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
174 name = CopSTASHPV(PL_curcop);
177 if (SvTYPE(sv) < SVt_RV)
178 sv_upgrade(sv, SVt_RV);
184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
186 DIE(aTHX_ PL_no_usym, "a symbol");
187 if (ckWARN(WARN_UNINITIALIZED))
192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
195 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
197 && (!is_gv_magical(sym,len,0)
198 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
204 if (PL_op->op_private & HINT_STRICT_REFS)
205 DIE(aTHX_ PL_no_symref, sym, "a symbol");
206 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
210 if (PL_op->op_private & OPpLVAL_INTRO)
211 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
223 tryAMAGICunDEREF(to_sv);
226 switch (SvTYPE(sv)) {
230 DIE(aTHX_ "Not a SCALAR reference");
238 if (SvTYPE(gv) != SVt_PVGV) {
239 if (SvGMAGICAL(sv)) {
245 if (PL_op->op_flags & OPf_REF ||
246 PL_op->op_private & HINT_STRICT_REFS)
247 DIE(aTHX_ PL_no_usym, "a SCALAR");
248 if (ckWARN(WARN_UNINITIALIZED))
253 if ((PL_op->op_flags & OPf_SPECIAL) &&
254 !(PL_op->op_flags & OPf_MOD))
256 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
258 && (!is_gv_magical(sym,len,0)
259 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
265 if (PL_op->op_private & HINT_STRICT_REFS)
266 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
267 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
272 if (PL_op->op_flags & OPf_MOD) {
273 if (PL_op->op_private & OPpLVAL_INTRO) {
274 if (cUNOP->op_first->op_type == OP_NULL)
275 sv = save_scalar((GV*)TOPs);
277 sv = save_scalar(gv);
279 Perl_croak(aTHX_ PL_no_localize_ref);
281 else if (PL_op->op_private & OPpDEREF)
282 vivify_ref(sv, PL_op->op_private & OPpDEREF);
292 SV *sv = AvARYLEN(av);
294 AvARYLEN(av) = sv = NEWSV(0,0);
295 sv_upgrade(sv, SVt_IV);
296 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
304 dSP; dTARGET; dPOPss;
306 if (PL_op->op_flags & OPf_MOD || LVRET) {
307 if (SvTYPE(TARG) < SVt_PVLV) {
308 sv_upgrade(TARG, SVt_PVLV);
309 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
313 if (LvTARG(TARG) != sv) {
315 SvREFCNT_dec(LvTARG(TARG));
316 LvTARG(TARG) = SvREFCNT_inc(sv);
318 PUSHs(TARG); /* no SvSETMAGIC */
324 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
325 mg = mg_find(sv, PERL_MAGIC_regex_global);
326 if (mg && mg->mg_len >= 0) {
330 PUSHi(i + PL_curcop->cop_arybase);
344 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
345 /* (But not in defined().) */
346 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
349 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
350 if ((PL_op->op_private & OPpLVAL_INTRO)) {
351 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
354 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
358 cv = (CV*)&PL_sv_undef;
372 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
373 char *s = SvPVX(TOPs);
374 if (strnEQ(s, "CORE::", 6)) {
377 code = keyword(s + 6, SvCUR(TOPs) - 6);
378 if (code < 0) { /* Overridable. */
379 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
380 int i = 0, n = 0, seen_question = 0;
382 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
384 if (code == -KEY_chop || code == -KEY_chomp)
386 while (i < MAXO) { /* The slow way. */
387 if (strEQ(s + 6, PL_op_name[i])
388 || strEQ(s + 6, PL_op_desc[i]))
394 goto nonesuch; /* Should not happen... */
396 oa = PL_opargs[i] >> OASHIFT;
398 if (oa & OA_OPTIONAL && !seen_question) {
402 else if (n && str[0] == ';' && seen_question)
403 goto set; /* XXXX system, exec */
404 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
405 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
406 /* But globs are already references (kinda) */
407 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
411 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
415 ret = sv_2mortal(newSVpvn(str, n - 1));
417 else if (code) /* Non-Overridable */
419 else { /* None such */
421 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
425 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
427 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
436 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
438 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
454 if (GIMME != G_ARRAY) {
458 *MARK = &PL_sv_undef;
459 *MARK = refto(*MARK);
463 EXTEND_MORTAL(SP - MARK);
465 *MARK = refto(*MARK);
470 S_refto(pTHX_ SV *sv)
474 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
477 if (!(sv = LvTARG(sv)))
480 (void)SvREFCNT_inc(sv);
482 else if (SvTYPE(sv) == SVt_PVAV) {
483 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
486 (void)SvREFCNT_inc(sv);
488 else if (SvPADTMP(sv) && !IS_PADGV(sv))
492 (void)SvREFCNT_inc(sv);
495 sv_upgrade(rv, SVt_RV);
509 if (sv && SvGMAGICAL(sv))
512 if (!sv || !SvROK(sv))
516 pv = sv_reftype(sv,TRUE);
517 PUSHp(pv, strlen(pv));
527 stash = CopSTASH(PL_curcop);
533 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
534 Perl_croak(aTHX_ "Attempt to bless into a reference");
536 if (ckWARN(WARN_MISC) && len == 0)
537 Perl_warner(aTHX_ packWARN(WARN_MISC),
538 "Explicit blessing to '' (assuming package main)");
539 stash = gv_stashpvn(ptr, len, TRUE);
542 (void)sv_bless(TOPs, stash);
556 elem = SvPV(sv, n_a);
560 switch (elem ? *elem : '\0')
563 if (strEQ(elem, "ARRAY"))
564 tmpRef = (SV*)GvAV(gv);
567 if (strEQ(elem, "CODE"))
568 tmpRef = (SV*)GvCVu(gv);
571 if (strEQ(elem, "FILEHANDLE")) {
572 /* finally deprecated in 5.8.0 */
573 deprecate("*glob{FILEHANDLE}");
574 tmpRef = (SV*)GvIOp(gv);
577 if (strEQ(elem, "FORMAT"))
578 tmpRef = (SV*)GvFORM(gv);
581 if (strEQ(elem, "GLOB"))
585 if (strEQ(elem, "HASH"))
586 tmpRef = (SV*)GvHV(gv);
589 if (strEQ(elem, "IO"))
590 tmpRef = (SV*)GvIOp(gv);
593 if (strEQ(elem, "NAME"))
594 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
597 if (strEQ(elem, "PACKAGE"))
598 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
601 if (strEQ(elem, "SCALAR"))
615 /* Pattern matching */
620 register unsigned char *s;
623 register I32 *sfirst;
627 if (sv == PL_lastscream) {
633 SvSCREAM_off(PL_lastscream);
634 SvREFCNT_dec(PL_lastscream);
636 PL_lastscream = SvREFCNT_inc(sv);
639 s = (unsigned char*)(SvPV(sv, len));
643 if (pos > PL_maxscream) {
644 if (PL_maxscream < 0) {
645 PL_maxscream = pos + 80;
646 New(301, PL_screamfirst, 256, I32);
647 New(302, PL_screamnext, PL_maxscream, I32);
650 PL_maxscream = pos + pos / 4;
651 Renew(PL_screamnext, PL_maxscream, I32);
655 sfirst = PL_screamfirst;
656 snext = PL_screamnext;
658 if (!sfirst || !snext)
659 DIE(aTHX_ "do_study: out of memory");
661 for (ch = 256; ch; --ch)
668 snext[pos] = sfirst[ch] - pos;
675 /* piggyback on m//g magic */
676 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
685 if (PL_op->op_flags & OPf_STACKED)
691 TARG = sv_newmortal();
696 /* Lvalue operators. */
708 dSP; dMARK; dTARGET; dORIGMARK;
710 do_chop(TARG, *++MARK);
719 SETi(do_chomp(TOPs));
726 register I32 count = 0;
729 count += do_chomp(POPs);
740 if (!sv || !SvANY(sv))
742 switch (SvTYPE(sv)) {
744 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
745 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
749 if (HvARRAY(sv) || SvGMAGICAL(sv)
750 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
754 if (CvROOT(sv) || CvXSUB(sv))
771 if (!PL_op->op_private) {
780 SV_CHECK_THINKFIRST_COW_DROP(sv);
782 switch (SvTYPE(sv)) {
792 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
793 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
794 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
798 /* let user-undef'd sub keep its identity */
799 GV* gv = CvGV((CV*)sv);
806 SvSetMagicSV(sv, &PL_sv_undef);
810 Newz(602, gp, 1, GP);
811 GvGP(sv) = gp_ref(gp);
812 GvSV(sv) = NEWSV(72,0);
813 GvLINE(sv) = CopLINE(PL_curcop);
819 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
822 SvPV_set(sv, Nullch);
835 if (SvTYPE(TOPs) > SVt_PVLV)
836 DIE(aTHX_ PL_no_modify);
837 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
838 && SvIVX(TOPs) != IV_MIN)
841 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
852 if (SvTYPE(TOPs) > SVt_PVLV)
853 DIE(aTHX_ PL_no_modify);
854 sv_setsv(TARG, TOPs);
855 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
856 && SvIVX(TOPs) != IV_MAX)
859 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
864 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
874 if (SvTYPE(TOPs) > SVt_PVLV)
875 DIE(aTHX_ PL_no_modify);
876 sv_setsv(TARG, TOPs);
877 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
878 && SvIVX(TOPs) != IV_MIN)
881 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
890 /* Ordinary operators. */
895 #ifdef PERL_PRESERVE_IVUV
898 tryAMAGICbin(pow,opASSIGN);
899 #ifdef PERL_PRESERVE_IVUV
900 /* For integer to integer power, we do the calculation by hand wherever
901 we're sure it is safe; otherwise we call pow() and try to convert to
902 integer afterwards. */
906 bool baseuok = SvUOK(TOPm1s);
910 baseuv = SvUVX(TOPm1s);
912 IV iv = SvIVX(TOPm1s);
915 baseuok = TRUE; /* effectively it's a UV now */
917 baseuv = -iv; /* abs, baseuok == false records sign */
931 goto float_it; /* Can't do negative powers this way. */
934 /* now we have integer ** positive integer. */
937 /* foo & (foo - 1) is zero only for a power of 2. */
938 if (!(baseuv & (baseuv - 1))) {
939 /* We are raising power-of-2 to a positive integer.
940 The logic here will work for any base (even non-integer
941 bases) but it can be less accurate than
942 pow (base,power) or exp (power * log (base)) when the
943 intermediate values start to spill out of the mantissa.
944 With powers of 2 we know this can't happen.
945 And powers of 2 are the favourite thing for perl
946 programmers to notice ** not doing what they mean. */
948 NV base = baseuok ? baseuv : -(NV)baseuv;
951 for (; power; base *= base, n++) {
952 /* Do I look like I trust gcc with long longs here?
954 UV bit = (UV)1 << (UV)n;
957 /* Only bother to clear the bit if it is set. */
959 /* Avoid squaring base again if we're done. */
960 if (power == 0) break;
968 register unsigned int highbit = 8 * sizeof(UV);
969 register unsigned int lowbit = 0;
970 register unsigned int diff;
971 while ((diff = (highbit - lowbit) >> 1)) {
972 if (baseuv & ~((1 << (lowbit + diff)) - 1))
977 /* we now have baseuv < 2 ** highbit */
978 if (power * highbit <= 8 * sizeof(UV)) {
979 /* result will definitely fit in UV, so use UV math
980 on same algorithm as above */
981 register UV result = 1;
982 register UV base = baseuv;
984 for (; power; base *= base, n++) {
985 register UV bit = (UV)1 << (UV)n;
989 if (power == 0) break;
993 if (baseuok || !(power & 1))
994 /* answer is positive */
996 else if (result <= (UV)IV_MAX)
997 /* answer negative, fits in IV */
999 else if (result == (UV)IV_MIN)
1000 /* 2's complement assumption: special case IV_MIN */
1003 /* answer negative, doesn't fit */
1004 SETn( -(NV)result );
1015 SETn( Perl_pow( left, right) );
1016 #ifdef PERL_PRESERVE_IVUV
1026 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1027 #ifdef PERL_PRESERVE_IVUV
1030 /* Unless the left argument is integer in range we are going to have to
1031 use NV maths. Hence only attempt to coerce the right argument if
1032 we know the left is integer. */
1033 /* Left operand is defined, so is it IV? */
1034 SvIV_please(TOPm1s);
1035 if (SvIOK(TOPm1s)) {
1036 bool auvok = SvUOK(TOPm1s);
1037 bool buvok = SvUOK(TOPs);
1038 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1039 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1046 alow = SvUVX(TOPm1s);
1048 IV aiv = SvIVX(TOPm1s);
1051 auvok = TRUE; /* effectively it's a UV now */
1053 alow = -aiv; /* abs, auvok == false records sign */
1059 IV biv = SvIVX(TOPs);
1062 buvok = TRUE; /* effectively it's a UV now */
1064 blow = -biv; /* abs, buvok == false records sign */
1068 /* If this does sign extension on unsigned it's time for plan B */
1069 ahigh = alow >> (4 * sizeof (UV));
1071 bhigh = blow >> (4 * sizeof (UV));
1073 if (ahigh && bhigh) {
1074 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1075 which is overflow. Drop to NVs below. */
1076 } else if (!ahigh && !bhigh) {
1077 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1078 so the unsigned multiply cannot overflow. */
1079 UV product = alow * blow;
1080 if (auvok == buvok) {
1081 /* -ve * -ve or +ve * +ve gives a +ve result. */
1085 } else if (product <= (UV)IV_MIN) {
1086 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1087 /* -ve result, which could overflow an IV */
1089 SETi( -(IV)product );
1091 } /* else drop to NVs below. */
1093 /* One operand is large, 1 small */
1096 /* swap the operands */
1098 bhigh = blow; /* bhigh now the temp var for the swap */
1102 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1103 multiplies can't overflow. shift can, add can, -ve can. */
1104 product_middle = ahigh * blow;
1105 if (!(product_middle & topmask)) {
1106 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1108 product_middle <<= (4 * sizeof (UV));
1109 product_low = alow * blow;
1111 /* as for pp_add, UV + something mustn't get smaller.
1112 IIRC ANSI mandates this wrapping *behaviour* for
1113 unsigned whatever the actual representation*/
1114 product_low += product_middle;
1115 if (product_low >= product_middle) {
1116 /* didn't overflow */
1117 if (auvok == buvok) {
1118 /* -ve * -ve or +ve * +ve gives a +ve result. */
1120 SETu( product_low );
1122 } else if (product_low <= (UV)IV_MIN) {
1123 /* 2s complement assumption again */
1124 /* -ve result, which could overflow an IV */
1126 SETi( -(IV)product_low );
1128 } /* else drop to NVs below. */
1130 } /* product_middle too large */
1131 } /* ahigh && bhigh */
1132 } /* SvIOK(TOPm1s) */
1137 SETn( left * right );
1144 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1145 /* Only try to do UV divide first
1146 if ((SLOPPYDIVIDE is true) or
1147 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1149 The assumption is that it is better to use floating point divide
1150 whenever possible, only doing integer divide first if we can't be sure.
1151 If NV_PRESERVES_UV is true then we know at compile time that no UV
1152 can be too large to preserve, so don't need to compile the code to
1153 test the size of UVs. */
1156 # define PERL_TRY_UV_DIVIDE
1157 /* ensure that 20./5. == 4. */
1159 # ifdef PERL_PRESERVE_IVUV
1160 # ifndef NV_PRESERVES_UV
1161 # define PERL_TRY_UV_DIVIDE
1166 #ifdef PERL_TRY_UV_DIVIDE
1169 SvIV_please(TOPm1s);
1170 if (SvIOK(TOPm1s)) {
1171 bool left_non_neg = SvUOK(TOPm1s);
1172 bool right_non_neg = SvUOK(TOPs);
1176 if (right_non_neg) {
1177 right = SvUVX(TOPs);
1180 IV biv = SvIVX(TOPs);
1183 right_non_neg = TRUE; /* effectively it's a UV now */
1189 /* historically undef()/0 gives a "Use of uninitialized value"
1190 warning before dieing, hence this test goes here.
1191 If it were immediately before the second SvIV_please, then
1192 DIE() would be invoked before left was even inspected, so
1193 no inpsection would give no warning. */
1195 DIE(aTHX_ "Illegal division by zero");
1198 left = SvUVX(TOPm1s);
1201 IV aiv = SvIVX(TOPm1s);
1204 left_non_neg = TRUE; /* effectively it's a UV now */
1213 /* For sloppy divide we always attempt integer division. */
1215 /* Otherwise we only attempt it if either or both operands
1216 would not be preserved by an NV. If both fit in NVs
1217 we fall through to the NV divide code below. However,
1218 as left >= right to ensure integer result here, we know that
1219 we can skip the test on the right operand - right big
1220 enough not to be preserved can't get here unless left is
1223 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1226 /* Integer division can't overflow, but it can be imprecise. */
1227 UV result = left / right;
1228 if (result * right == left) {
1229 SP--; /* result is valid */
1230 if (left_non_neg == right_non_neg) {
1231 /* signs identical, result is positive. */
1235 /* 2s complement assumption */
1236 if (result <= (UV)IV_MIN)
1237 SETi( -(IV)result );
1239 /* It's exact but too negative for IV. */
1240 SETn( -(NV)result );
1243 } /* tried integer divide but it was not an integer result */
1244 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1245 } /* left wasn't SvIOK */
1246 } /* right wasn't SvIOK */
1247 #endif /* PERL_TRY_UV_DIVIDE */
1251 DIE(aTHX_ "Illegal division by zero");
1252 PUSHn( left / right );
1259 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1263 bool left_neg = FALSE;
1264 bool right_neg = FALSE;
1265 bool use_double = FALSE;
1266 bool dright_valid = FALSE;
1272 right_neg = !SvUOK(TOPs);
1274 right = SvUVX(POPs);
1276 IV biv = SvIVX(POPs);
1279 right_neg = FALSE; /* effectively it's a UV now */
1287 right_neg = dright < 0;
1290 if (dright < UV_MAX_P1) {
1291 right = U_V(dright);
1292 dright_valid = TRUE; /* In case we need to use double below. */
1298 /* At this point use_double is only true if right is out of range for
1299 a UV. In range NV has been rounded down to nearest UV and
1300 use_double false. */
1302 if (!use_double && SvIOK(TOPs)) {
1304 left_neg = !SvUOK(TOPs);
1308 IV aiv = SvIVX(POPs);
1311 left_neg = FALSE; /* effectively it's a UV now */
1320 left_neg = dleft < 0;
1324 /* This should be exactly the 5.6 behaviour - if left and right are
1325 both in range for UV then use U_V() rather than floor. */
1327 if (dleft < UV_MAX_P1) {
1328 /* right was in range, so is dleft, so use UVs not double.
1332 /* left is out of range for UV, right was in range, so promote
1333 right (back) to double. */
1335 /* The +0.5 is used in 5.6 even though it is not strictly
1336 consistent with the implicit +0 floor in the U_V()
1337 inside the #if 1. */
1338 dleft = Perl_floor(dleft + 0.5);
1341 dright = Perl_floor(dright + 0.5);
1351 DIE(aTHX_ "Illegal modulus zero");
1353 dans = Perl_fmod(dleft, dright);
1354 if ((left_neg != right_neg) && dans)
1355 dans = dright - dans;
1358 sv_setnv(TARG, dans);
1364 DIE(aTHX_ "Illegal modulus zero");
1367 if ((left_neg != right_neg) && ans)
1370 /* XXX may warn: unary minus operator applied to unsigned type */
1371 /* could change -foo to be (~foo)+1 instead */
1372 if (ans <= ~((UV)IV_MAX)+1)
1373 sv_setiv(TARG, ~ans+1);
1375 sv_setnv(TARG, -(NV)ans);
1378 sv_setuv(TARG, ans);
1387 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1389 register IV count = POPi;
1390 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1392 I32 items = SP - MARK;
1395 max = items * count;
1400 /* This code was intended to fix 20010809.028:
1403 for (($x =~ /./g) x 2) {
1404 print chop; # "abcdabcd" expected as output.
1407 * but that change (#11635) broke this code:
1409 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1411 * I can't think of a better fix that doesn't introduce
1412 * an efficiency hit by copying the SVs. The stack isn't
1413 * refcounted, and mortalisation obviously doesn't
1414 * Do The Right Thing when the stack has more than
1415 * one pointer to the same mortal value.
1419 *SP = sv_2mortal(newSVsv(*SP));
1429 repeatcpy((char*)(MARK + items), (char*)MARK,
1430 items * sizeof(SV*), count - 1);
1433 else if (count <= 0)
1436 else { /* Note: mark already snarfed by pp_list */
1441 SvSetSV(TARG, tmpstr);
1442 SvPV_force(TARG, len);
1443 isutf = DO_UTF8(TARG);
1448 SvGROW(TARG, (count * len) + 1);
1449 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1450 SvCUR(TARG) *= count;
1452 *SvEND(TARG) = '\0';
1455 (void)SvPOK_only_UTF8(TARG);
1457 (void)SvPOK_only(TARG);
1459 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1460 /* The parser saw this as a list repeat, and there
1461 are probably several items on the stack. But we're
1462 in scalar context, and there's no pp_list to save us
1463 now. So drop the rest of the items -- robin@kitsite.com
1476 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1477 useleft = USE_LEFT(TOPm1s);
1478 #ifdef PERL_PRESERVE_IVUV
1479 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1480 "bad things" happen if you rely on signed integers wrapping. */
1483 /* Unless the left argument is integer in range we are going to have to
1484 use NV maths. Hence only attempt to coerce the right argument if
1485 we know the left is integer. */
1486 register UV auv = 0;
1492 a_valid = auvok = 1;
1493 /* left operand is undef, treat as zero. */
1495 /* Left operand is defined, so is it IV? */
1496 SvIV_please(TOPm1s);
1497 if (SvIOK(TOPm1s)) {
1498 if ((auvok = SvUOK(TOPm1s)))
1499 auv = SvUVX(TOPm1s);
1501 register IV aiv = SvIVX(TOPm1s);
1504 auvok = 1; /* Now acting as a sign flag. */
1505 } else { /* 2s complement assumption for IV_MIN */
1513 bool result_good = 0;
1516 bool buvok = SvUOK(TOPs);
1521 register IV biv = SvIVX(TOPs);
1528 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1529 else "IV" now, independent of how it came in.
1530 if a, b represents positive, A, B negative, a maps to -A etc
1535 all UV maths. negate result if A negative.
1536 subtract if signs same, add if signs differ. */
1538 if (auvok ^ buvok) {
1547 /* Must get smaller */
1552 if (result <= buv) {
1553 /* result really should be -(auv-buv). as its negation
1554 of true value, need to swap our result flag */
1566 if (result <= (UV)IV_MIN)
1567 SETi( -(IV)result );
1569 /* result valid, but out of range for IV. */
1570 SETn( -(NV)result );
1574 } /* Overflow, drop through to NVs. */
1578 useleft = USE_LEFT(TOPm1s);
1582 /* left operand is undef, treat as zero - value */
1586 SETn( TOPn - value );
1593 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1596 if (PL_op->op_private & HINT_INTEGER) {
1610 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1613 if (PL_op->op_private & HINT_INTEGER) {
1627 dSP; tryAMAGICbinSET(lt,0);
1628 #ifdef PERL_PRESERVE_IVUV
1631 SvIV_please(TOPm1s);
1632 if (SvIOK(TOPm1s)) {
1633 bool auvok = SvUOK(TOPm1s);
1634 bool buvok = SvUOK(TOPs);
1636 if (!auvok && !buvok) { /* ## IV < IV ## */
1637 IV aiv = SvIVX(TOPm1s);
1638 IV biv = SvIVX(TOPs);
1641 SETs(boolSV(aiv < biv));
1644 if (auvok && buvok) { /* ## UV < UV ## */
1645 UV auv = SvUVX(TOPm1s);
1646 UV buv = SvUVX(TOPs);
1649 SETs(boolSV(auv < buv));
1652 if (auvok) { /* ## UV < IV ## */
1659 /* As (a) is a UV, it's >=0, so it cannot be < */
1664 SETs(boolSV(auv < (UV)biv));
1667 { /* ## IV < UV ## */
1671 aiv = SvIVX(TOPm1s);
1673 /* As (b) is a UV, it's >=0, so it must be < */
1680 SETs(boolSV((UV)aiv < buv));
1686 #ifndef NV_PRESERVES_UV
1687 #ifdef PERL_PRESERVE_IVUV
1690 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1692 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1698 SETs(boolSV(TOPn < value));
1705 dSP; tryAMAGICbinSET(gt,0);
1706 #ifdef PERL_PRESERVE_IVUV
1709 SvIV_please(TOPm1s);
1710 if (SvIOK(TOPm1s)) {
1711 bool auvok = SvUOK(TOPm1s);
1712 bool buvok = SvUOK(TOPs);
1714 if (!auvok && !buvok) { /* ## IV > IV ## */
1715 IV aiv = SvIVX(TOPm1s);
1716 IV biv = SvIVX(TOPs);
1719 SETs(boolSV(aiv > biv));
1722 if (auvok && buvok) { /* ## UV > UV ## */
1723 UV auv = SvUVX(TOPm1s);
1724 UV buv = SvUVX(TOPs);
1727 SETs(boolSV(auv > buv));
1730 if (auvok) { /* ## UV > IV ## */
1737 /* As (a) is a UV, it's >=0, so it must be > */
1742 SETs(boolSV(auv > (UV)biv));
1745 { /* ## IV > UV ## */
1749 aiv = SvIVX(TOPm1s);
1751 /* As (b) is a UV, it's >=0, so it cannot be > */
1758 SETs(boolSV((UV)aiv > buv));
1764 #ifndef NV_PRESERVES_UV
1765 #ifdef PERL_PRESERVE_IVUV
1768 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1770 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1776 SETs(boolSV(TOPn > value));
1783 dSP; tryAMAGICbinSET(le,0);
1784 #ifdef PERL_PRESERVE_IVUV
1787 SvIV_please(TOPm1s);
1788 if (SvIOK(TOPm1s)) {
1789 bool auvok = SvUOK(TOPm1s);
1790 bool buvok = SvUOK(TOPs);
1792 if (!auvok && !buvok) { /* ## IV <= IV ## */
1793 IV aiv = SvIVX(TOPm1s);
1794 IV biv = SvIVX(TOPs);
1797 SETs(boolSV(aiv <= biv));
1800 if (auvok && buvok) { /* ## UV <= UV ## */
1801 UV auv = SvUVX(TOPm1s);
1802 UV buv = SvUVX(TOPs);
1805 SETs(boolSV(auv <= buv));
1808 if (auvok) { /* ## UV <= IV ## */
1815 /* As (a) is a UV, it's >=0, so a cannot be <= */
1820 SETs(boolSV(auv <= (UV)biv));
1823 { /* ## IV <= UV ## */
1827 aiv = SvIVX(TOPm1s);
1829 /* As (b) is a UV, it's >=0, so a must be <= */
1836 SETs(boolSV((UV)aiv <= buv));
1842 #ifndef NV_PRESERVES_UV
1843 #ifdef PERL_PRESERVE_IVUV
1846 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1848 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1854 SETs(boolSV(TOPn <= value));
1861 dSP; tryAMAGICbinSET(ge,0);
1862 #ifdef PERL_PRESERVE_IVUV
1865 SvIV_please(TOPm1s);
1866 if (SvIOK(TOPm1s)) {
1867 bool auvok = SvUOK(TOPm1s);
1868 bool buvok = SvUOK(TOPs);
1870 if (!auvok && !buvok) { /* ## IV >= IV ## */
1871 IV aiv = SvIVX(TOPm1s);
1872 IV biv = SvIVX(TOPs);
1875 SETs(boolSV(aiv >= biv));
1878 if (auvok && buvok) { /* ## UV >= UV ## */
1879 UV auv = SvUVX(TOPm1s);
1880 UV buv = SvUVX(TOPs);
1883 SETs(boolSV(auv >= buv));
1886 if (auvok) { /* ## UV >= IV ## */
1893 /* As (a) is a UV, it's >=0, so it must be >= */
1898 SETs(boolSV(auv >= (UV)biv));
1901 { /* ## IV >= UV ## */
1905 aiv = SvIVX(TOPm1s);
1907 /* As (b) is a UV, it's >=0, so a cannot be >= */
1914 SETs(boolSV((UV)aiv >= buv));
1920 #ifndef NV_PRESERVES_UV
1921 #ifdef PERL_PRESERVE_IVUV
1924 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1926 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1932 SETs(boolSV(TOPn >= value));
1939 dSP; tryAMAGICbinSET(ne,0);
1940 #ifndef NV_PRESERVES_UV
1941 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1943 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1947 #ifdef PERL_PRESERVE_IVUV
1950 SvIV_please(TOPm1s);
1951 if (SvIOK(TOPm1s)) {
1952 bool auvok = SvUOK(TOPm1s);
1953 bool buvok = SvUOK(TOPs);
1955 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1956 /* Casting IV to UV before comparison isn't going to matter
1957 on 2s complement. On 1s complement or sign&magnitude
1958 (if we have any of them) it could make negative zero
1959 differ from normal zero. As I understand it. (Need to
1960 check - is negative zero implementation defined behaviour
1962 UV buv = SvUVX(POPs);
1963 UV auv = SvUVX(TOPs);
1965 SETs(boolSV(auv != buv));
1968 { /* ## Mixed IV,UV ## */
1972 /* != is commutative so swap if needed (save code) */
1974 /* swap. top of stack (b) is the iv */
1978 /* As (a) is a UV, it's >0, so it cannot be == */
1987 /* As (b) is a UV, it's >0, so it cannot be == */
1991 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1993 SETs(boolSV((UV)iv != uv));
2001 SETs(boolSV(TOPn != value));
2008 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2009 #ifndef NV_PRESERVES_UV
2010 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2011 UV right = PTR2UV(SvRV(POPs));
2012 UV left = PTR2UV(SvRV(TOPs));
2013 SETi((left > right) - (left < right));
2017 #ifdef PERL_PRESERVE_IVUV
2018 /* Fortunately it seems NaN isn't IOK */
2021 SvIV_please(TOPm1s);
2022 if (SvIOK(TOPm1s)) {
2023 bool leftuvok = SvUOK(TOPm1s);
2024 bool rightuvok = SvUOK(TOPs);
2026 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2027 IV leftiv = SvIVX(TOPm1s);
2028 IV rightiv = SvIVX(TOPs);
2030 if (leftiv > rightiv)
2032 else if (leftiv < rightiv)
2036 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2037 UV leftuv = SvUVX(TOPm1s);
2038 UV rightuv = SvUVX(TOPs);
2040 if (leftuv > rightuv)
2042 else if (leftuv < rightuv)
2046 } else if (leftuvok) { /* ## UV <=> IV ## */
2050 rightiv = SvIVX(TOPs);
2052 /* As (a) is a UV, it's >=0, so it cannot be < */
2055 leftuv = SvUVX(TOPm1s);
2056 if (leftuv > (UV)rightiv) {
2058 } else if (leftuv < (UV)rightiv) {
2064 } else { /* ## IV <=> UV ## */
2068 leftiv = SvIVX(TOPm1s);
2070 /* As (b) is a UV, it's >=0, so it must be < */
2073 rightuv = SvUVX(TOPs);
2074 if ((UV)leftiv > rightuv) {
2076 } else if ((UV)leftiv < rightuv) {
2094 if (Perl_isnan(left) || Perl_isnan(right)) {
2098 value = (left > right) - (left < right);
2102 else if (left < right)
2104 else if (left > right)
2118 dSP; tryAMAGICbinSET(slt,0);
2121 int cmp = (IN_LOCALE_RUNTIME
2122 ? sv_cmp_locale(left, right)
2123 : sv_cmp(left, right));
2124 SETs(boolSV(cmp < 0));
2131 dSP; tryAMAGICbinSET(sgt,0);
2134 int cmp = (IN_LOCALE_RUNTIME
2135 ? sv_cmp_locale(left, right)
2136 : sv_cmp(left, right));
2137 SETs(boolSV(cmp > 0));
2144 dSP; tryAMAGICbinSET(sle,0);
2147 int cmp = (IN_LOCALE_RUNTIME
2148 ? sv_cmp_locale(left, right)
2149 : sv_cmp(left, right));
2150 SETs(boolSV(cmp <= 0));
2157 dSP; tryAMAGICbinSET(sge,0);
2160 int cmp = (IN_LOCALE_RUNTIME
2161 ? sv_cmp_locale(left, right)
2162 : sv_cmp(left, right));
2163 SETs(boolSV(cmp >= 0));
2170 dSP; tryAMAGICbinSET(seq,0);
2173 SETs(boolSV(sv_eq(left, right)));
2180 dSP; tryAMAGICbinSET(sne,0);
2183 SETs(boolSV(!sv_eq(left, right)));
2190 dSP; dTARGET; tryAMAGICbin(scmp,0);
2193 int cmp = (IN_LOCALE_RUNTIME
2194 ? sv_cmp_locale(left, right)
2195 : sv_cmp(left, right));
2203 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2206 if (SvNIOKp(left) || SvNIOKp(right)) {
2207 if (PL_op->op_private & HINT_INTEGER) {
2208 IV i = SvIV(left) & SvIV(right);
2212 UV u = SvUV(left) & SvUV(right);
2217 do_vop(PL_op->op_type, TARG, left, right);
2226 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2229 if (SvNIOKp(left) || SvNIOKp(right)) {
2230 if (PL_op->op_private & HINT_INTEGER) {
2231 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2235 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2240 do_vop(PL_op->op_type, TARG, left, right);
2249 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2252 if (SvNIOKp(left) || SvNIOKp(right)) {
2253 if (PL_op->op_private & HINT_INTEGER) {
2254 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2258 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2263 do_vop(PL_op->op_type, TARG, left, right);
2272 dSP; dTARGET; tryAMAGICun(neg);
2275 int flags = SvFLAGS(sv);
2278 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2279 /* It's publicly an integer, or privately an integer-not-float */
2282 if (SvIVX(sv) == IV_MIN) {
2283 /* 2s complement assumption. */
2284 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2287 else if (SvUVX(sv) <= IV_MAX) {
2292 else if (SvIVX(sv) != IV_MIN) {
2296 #ifdef PERL_PRESERVE_IVUV
2305 else if (SvPOKp(sv)) {
2307 char *s = SvPV(sv, len);
2308 if (isIDFIRST(*s)) {
2309 sv_setpvn(TARG, "-", 1);
2312 else if (*s == '+' || *s == '-') {
2314 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2316 else if (DO_UTF8(sv)) {
2319 goto oops_its_an_int;
2321 sv_setnv(TARG, -SvNV(sv));
2323 sv_setpvn(TARG, "-", 1);
2330 goto oops_its_an_int;
2331 sv_setnv(TARG, -SvNV(sv));
2343 dSP; tryAMAGICunSET(not);
2344 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2350 dSP; dTARGET; tryAMAGICun(compl);
2354 if (PL_op->op_private & HINT_INTEGER) {
2369 tmps = (U8*)SvPV_force(TARG, len);
2372 /* Calculate exact length, let's not estimate. */
2381 while (tmps < send) {
2382 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2383 tmps += UTF8SKIP(tmps);
2384 targlen += UNISKIP(~c);
2390 /* Now rewind strings and write them. */
2394 Newz(0, result, targlen + 1, U8);
2395 while (tmps < send) {
2396 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2397 tmps += UTF8SKIP(tmps);
2398 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2402 sv_setpvn(TARG, (char*)result, targlen);
2406 Newz(0, result, nchar + 1, U8);
2407 while (tmps < send) {
2408 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2409 tmps += UTF8SKIP(tmps);
2414 sv_setpvn(TARG, (char*)result, nchar);
2422 register long *tmpl;
2423 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2426 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2431 for ( ; anum > 0; anum--, tmps++)
2440 /* integer versions of some of the above */
2444 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2447 SETi( left * right );
2454 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2458 DIE(aTHX_ "Illegal division by zero");
2459 value = POPi / value;
2468 /* This is the vanilla old i_modulo. */
2469 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2473 DIE(aTHX_ "Illegal modulus zero");
2474 SETi( left % right );
2479 #if defined(__GLIBC__) && IVSIZE == 8
2483 /* This is the i_modulo with the workaround for the _moddi3 bug
2484 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2485 * See below for pp_i_modulo. */
2486 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2490 DIE(aTHX_ "Illegal modulus zero");
2491 SETi( left % PERL_ABS(right) );
2499 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2503 DIE(aTHX_ "Illegal modulus zero");
2504 /* The assumption is to use hereafter the old vanilla version... */
2506 PL_ppaddr[OP_I_MODULO] =
2507 &Perl_pp_i_modulo_0;
2508 /* .. but if we have glibc, we might have a buggy _moddi3
2509 * (at least glicb 2.2.5 is known to have this bug), in other
2510 * words our integer modulus with negative quad as the second
2511 * argument might be broken. Test for this and re-patch the
2512 * opcode dispatch table if that is the case, remembering to
2513 * also apply the workaround so that this first round works
2514 * right, too. See [perl #9402] for more information. */
2515 #if defined(__GLIBC__) && IVSIZE == 8
2519 /* Cannot do this check with inlined IV constants since
2520 * that seems to work correctly even with the buggy glibc. */
2522 /* Yikes, we have the bug.
2523 * Patch in the workaround version. */
2525 PL_ppaddr[OP_I_MODULO] =
2526 &Perl_pp_i_modulo_1;
2527 /* Make certain we work right this time, too. */
2528 right = PERL_ABS(right);
2532 SETi( left % right );
2539 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2542 SETi( left + right );
2549 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2552 SETi( left - right );
2559 dSP; tryAMAGICbinSET(lt,0);
2562 SETs(boolSV(left < right));
2569 dSP; tryAMAGICbinSET(gt,0);
2572 SETs(boolSV(left > right));
2579 dSP; tryAMAGICbinSET(le,0);
2582 SETs(boolSV(left <= right));
2589 dSP; tryAMAGICbinSET(ge,0);
2592 SETs(boolSV(left >= right));
2599 dSP; tryAMAGICbinSET(eq,0);
2602 SETs(boolSV(left == right));
2609 dSP; tryAMAGICbinSET(ne,0);
2612 SETs(boolSV(left != right));
2619 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2626 else if (left < right)
2637 dSP; dTARGET; tryAMAGICun(neg);
2642 /* High falutin' math. */
2646 dSP; dTARGET; tryAMAGICbin(atan2,0);
2649 SETn(Perl_atan2(left, right));
2656 dSP; dTARGET; tryAMAGICun(sin);
2660 value = Perl_sin(value);
2668 dSP; dTARGET; tryAMAGICun(cos);
2672 value = Perl_cos(value);
2678 /* Support Configure command-line overrides for rand() functions.
2679 After 5.005, perhaps we should replace this by Configure support
2680 for drand48(), random(), or rand(). For 5.005, though, maintain
2681 compatibility by calling rand() but allow the user to override it.
2682 See INSTALL for details. --Andy Dougherty 15 July 1998
2684 /* Now it's after 5.005, and Configure supports drand48() and random(),
2685 in addition to rand(). So the overrides should not be needed any more.
2686 --Jarkko Hietaniemi 27 September 1998
2689 #ifndef HAS_DRAND48_PROTO
2690 extern double drand48 (void);
2703 if (!PL_srand_called) {
2704 (void)seedDrand01((Rand_seed_t)seed());
2705 PL_srand_called = TRUE;
2720 (void)seedDrand01((Rand_seed_t)anum);
2721 PL_srand_called = TRUE;
2730 * This is really just a quick hack which grabs various garbage
2731 * values. It really should be a real hash algorithm which
2732 * spreads the effect of every input bit onto every output bit,
2733 * if someone who knows about such things would bother to write it.
2734 * Might be a good idea to add that function to CORE as well.
2735 * No numbers below come from careful analysis or anything here,
2736 * except they are primes and SEED_C1 > 1E6 to get a full-width
2737 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2738 * probably be bigger too.
2741 # define SEED_C1 1000003
2742 #define SEED_C4 73819
2744 # define SEED_C1 25747
2745 #define SEED_C4 20639
2749 #define SEED_C5 26107
2751 #ifndef PERL_NO_DEV_RANDOM
2756 # include <starlet.h>
2757 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2758 * in 100-ns units, typically incremented ever 10 ms. */
2759 unsigned int when[2];
2761 # ifdef HAS_GETTIMEOFDAY
2762 struct timeval when;
2768 /* This test is an escape hatch, this symbol isn't set by Configure. */
2769 #ifndef PERL_NO_DEV_RANDOM
2770 #ifndef PERL_RANDOM_DEVICE
2771 /* /dev/random isn't used by default because reads from it will block
2772 * if there isn't enough entropy available. You can compile with
2773 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2774 * is enough real entropy to fill the seed. */
2775 # define PERL_RANDOM_DEVICE "/dev/urandom"
2777 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2779 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2788 _ckvmssts(sys$gettim(when));
2789 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2791 # ifdef HAS_GETTIMEOFDAY
2792 PerlProc_gettimeofday(&when,NULL);
2793 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2796 u = (U32)SEED_C1 * when;
2799 u += SEED_C3 * (U32)PerlProc_getpid();
2800 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2801 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2802 u += SEED_C5 * (U32)PTR2UV(&when);
2809 dSP; dTARGET; tryAMAGICun(exp);
2813 value = Perl_exp(value);
2821 dSP; dTARGET; tryAMAGICun(log);
2826 SET_NUMERIC_STANDARD();
2827 DIE(aTHX_ "Can't take log of %"NVgf, value);
2829 value = Perl_log(value);
2837 dSP; dTARGET; tryAMAGICun(sqrt);
2842 SET_NUMERIC_STANDARD();
2843 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2845 value = Perl_sqrt(value);
2852 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2853 * These need to be revisited when a newer toolchain becomes available.
2855 #if defined(__sparc64__) && defined(__GNUC__)
2856 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2857 # undef SPARC64_MODF_WORKAROUND
2858 # define SPARC64_MODF_WORKAROUND 1
2862 #if defined(SPARC64_MODF_WORKAROUND)
2864 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2867 ret = Perl_modf(theVal, &res);
2875 dSP; dTARGET; tryAMAGICun(int);
2878 IV iv = TOPi; /* attempt to convert to IV if possible. */
2879 /* XXX it's arguable that compiler casting to IV might be subtly
2880 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2881 else preferring IV has introduced a subtle behaviour change bug. OTOH
2882 relying on floating point to be accurate is a bug. */
2893 if (value < (NV)UV_MAX + 0.5) {
2896 #if defined(SPARC64_MODF_WORKAROUND)
2897 (void)sparc64_workaround_modf(value, &value);
2898 #elif defined(HAS_MODFL_POW32_BUG)
2899 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2900 NV offset = Perl_modf(value, &value);
2901 (void)Perl_modf(offset, &offset);
2904 (void)Perl_modf(value, &value);
2910 if (value > (NV)IV_MIN - 0.5) {
2913 #if defined(SPARC64_MODF_WORKAROUND)
2914 (void)sparc64_workaround_modf(-value, &value);
2915 #elif defined(HAS_MODFL_POW32_BUG)
2916 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2917 NV offset = Perl_modf(-value, &value);
2918 (void)Perl_modf(offset, &offset);
2921 (void)Perl_modf(-value, &value);
2933 dSP; dTARGET; tryAMAGICun(abs);
2935 /* This will cache the NV value if string isn't actually integer */
2939 /* IVX is precise */
2941 SETu(TOPu); /* force it to be numeric only */
2949 /* 2s complement assumption. Also, not really needed as
2950 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2970 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2976 tmps = (SvPVx(sv, len));
2978 /* If Unicode, try to downgrade
2979 * If not possible, croak. */
2980 SV* tsv = sv_2mortal(newSVsv(sv));
2983 sv_utf8_downgrade(tsv, FALSE);
2986 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2987 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3000 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3006 tmps = (SvPVx(sv, len));
3008 /* If Unicode, try to downgrade
3009 * If not possible, croak. */
3010 SV* tsv = sv_2mortal(newSVsv(sv));
3013 sv_utf8_downgrade(tsv, FALSE);
3016 while (*tmps && len && isSPACE(*tmps))
3021 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3022 else if (*tmps == 'b')
3023 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3025 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3027 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3044 SETi(sv_len_utf8(sv));
3060 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3062 I32 arybase = PL_curcop->cop_arybase;
3066 int num_args = PL_op->op_private & 7;
3067 bool repl_need_utf8_upgrade = FALSE;
3068 bool repl_is_utf8 = FALSE;
3070 SvTAINTED_off(TARG); /* decontaminate */
3071 SvUTF8_off(TARG); /* decontaminate */
3075 repl = SvPV(repl_sv, repl_len);
3076 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3086 sv_utf8_upgrade(sv);
3088 else if (DO_UTF8(sv))
3089 repl_need_utf8_upgrade = TRUE;
3091 tmps = SvPV(sv, curlen);
3093 utf8_curlen = sv_len_utf8(sv);
3094 if (utf8_curlen == curlen)
3097 curlen = utf8_curlen;
3102 if (pos >= arybase) {
3120 else if (len >= 0) {
3122 if (rem > (I32)curlen)
3137 Perl_croak(aTHX_ "substr outside of string");
3138 if (ckWARN(WARN_SUBSTR))
3139 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3146 sv_pos_u2b(sv, &pos, &rem);
3148 sv_setpvn(TARG, tmps, rem);
3149 #ifdef USE_LOCALE_COLLATE
3150 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3155 SV* repl_sv_copy = NULL;
3157 if (repl_need_utf8_upgrade) {
3158 repl_sv_copy = newSVsv(repl_sv);
3159 sv_utf8_upgrade(repl_sv_copy);
3160 repl = SvPV(repl_sv_copy, repl_len);
3161 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3163 sv_insert(sv, pos, rem, repl, repl_len);
3167 SvREFCNT_dec(repl_sv_copy);
3169 else if (lvalue) { /* it's an lvalue! */
3170 if (!SvGMAGICAL(sv)) {
3174 if (ckWARN(WARN_SUBSTR))
3175 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3176 "Attempt to use reference as lvalue in substr");
3178 if (SvOK(sv)) /* is it defined ? */
3179 (void)SvPOK_only_UTF8(sv);
3181 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3184 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3185 TARG = sv_newmortal();
3186 if (SvTYPE(TARG) < SVt_PVLV) {
3187 sv_upgrade(TARG, SVt_PVLV);
3188 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3192 if (LvTARG(TARG) != sv) {
3194 SvREFCNT_dec(LvTARG(TARG));
3195 LvTARG(TARG) = SvREFCNT_inc(sv);
3197 LvTARGOFF(TARG) = upos;
3198 LvTARGLEN(TARG) = urem;
3202 PUSHs(TARG); /* avoid SvSETMAGIC here */
3209 register IV size = POPi;
3210 register IV offset = POPi;
3211 register SV *src = POPs;
3212 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3214 SvTAINTED_off(TARG); /* decontaminate */
3215 if (lvalue) { /* it's an lvalue! */
3216 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3217 TARG = sv_newmortal();
3218 if (SvTYPE(TARG) < SVt_PVLV) {
3219 sv_upgrade(TARG, SVt_PVLV);
3220 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3223 if (LvTARG(TARG) != src) {
3225 SvREFCNT_dec(LvTARG(TARG));
3226 LvTARG(TARG) = SvREFCNT_inc(src);
3228 LvTARGOFF(TARG) = offset;
3229 LvTARGLEN(TARG) = size;
3232 sv_setuv(TARG, do_vecget(src, offset, size));
3247 I32 arybase = PL_curcop->cop_arybase;
3252 offset = POPi - arybase;
3255 tmps = SvPV(big, biglen);
3256 if (offset > 0 && DO_UTF8(big))
3257 sv_pos_u2b(big, &offset, 0);
3260 else if (offset > (I32)biglen)
3262 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3263 (unsigned char*)tmps + biglen, little, 0)))
3266 retval = tmps2 - tmps;
3267 if (retval > 0 && DO_UTF8(big))
3268 sv_pos_b2u(big, &retval);
3269 PUSHi(retval + arybase);
3284 I32 arybase = PL_curcop->cop_arybase;
3290 tmps2 = SvPV(little, llen);
3291 tmps = SvPV(big, blen);
3295 if (offset > 0 && DO_UTF8(big))
3296 sv_pos_u2b(big, &offset, 0);
3297 offset = offset - arybase + llen;
3301 else if (offset > (I32)blen)
3303 if (!(tmps2 = rninstr(tmps, tmps + offset,
3304 tmps2, tmps2 + llen)))
3307 retval = tmps2 - tmps;
3308 if (retval > 0 && DO_UTF8(big))
3309 sv_pos_b2u(big, &retval);
3310 PUSHi(retval + arybase);
3316 dSP; dMARK; dORIGMARK; dTARGET;
3317 do_sprintf(TARG, SP-MARK, MARK+1);
3318 TAINT_IF(SvTAINTED(TARG));
3319 if (DO_UTF8(*(MARK+1)))
3331 U8 *s = (U8*)SvPVx(argsv, len);
3334 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3335 tmpsv = sv_2mortal(newSVsv(argsv));
3336 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3340 XPUSHu(DO_UTF8(argsv) ?
3341 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3353 (void)SvUPGRADE(TARG,SVt_PV);
3355 if (value > 255 && !IN_BYTES) {
3356 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3357 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3358 SvCUR_set(TARG, tmps - SvPVX(TARG));
3360 (void)SvPOK_only(TARG);
3369 *tmps++ = (char)value;
3371 (void)SvPOK_only(TARG);
3372 if (PL_encoding && !IN_BYTES) {
3373 sv_recode_to_utf8(TARG, PL_encoding);
3375 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3376 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3380 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3381 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3397 char *tmps = SvPV(left, len);
3399 if (DO_UTF8(left)) {
3400 /* If Unicode, try to downgrade.
3401 * If not possible, croak.
3402 * Yes, we made this up. */
3403 SV* tsv = sv_2mortal(newSVsv(left));
3406 sv_utf8_downgrade(tsv, FALSE);
3409 # ifdef USE_ITHREADS
3411 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3412 /* This should be threadsafe because in ithreads there is only
3413 * one thread per interpreter. If this would not be true,
3414 * we would need a mutex to protect this malloc. */
3415 PL_reentrant_buffer->_crypt_struct_buffer =
3416 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3417 #if defined(__GLIBC__) || defined(__EMX__)
3418 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3419 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3420 /* work around glibc-2.2.5 bug */
3421 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3425 # endif /* HAS_CRYPT_R */
3426 # endif /* USE_ITHREADS */
3428 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3430 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3436 "The crypt() function is unimplemented due to excessive paranoia.");
3449 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3450 UTF8_IS_START(*s)) {
3451 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3455 utf8_to_uvchr(s, &ulen);
3456 toTITLE_utf8(s, tmpbuf, &tculen);
3457 utf8_to_uvchr(tmpbuf, 0);
3459 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3461 /* slen is the byte length of the whole SV.
3462 * ulen is the byte length of the original Unicode character
3463 * stored as UTF-8 at s.
3464 * tculen is the byte length of the freshly titlecased
3465 * Unicode character stored as UTF-8 at tmpbuf.
3466 * We first set the result to be the titlecased character,
3467 * and then append the rest of the SV data. */
3468 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3470 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3475 s = (U8*)SvPV_force_nomg(sv, slen);
3476 Copy(tmpbuf, s, tculen, U8);
3480 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3482 SvUTF8_off(TARG); /* decontaminate */
3483 sv_setsv_nomg(TARG, sv);
3487 s = (U8*)SvPV_force_nomg(sv, slen);
3489 if (IN_LOCALE_RUNTIME) {
3492 *s = toUPPER_LC(*s);
3511 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3512 UTF8_IS_START(*s)) {
3514 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3518 toLOWER_utf8(s, tmpbuf, &ulen);
3519 uv = utf8_to_uvchr(tmpbuf, 0);
3520 tend = uvchr_to_utf8(tmpbuf, uv);
3522 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3524 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3526 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3531 s = (U8*)SvPV_force_nomg(sv, slen);
3532 Copy(tmpbuf, s, ulen, U8);
3536 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3538 SvUTF8_off(TARG); /* decontaminate */
3539 sv_setsv_nomg(TARG, sv);
3543 s = (U8*)SvPV_force_nomg(sv, slen);
3545 if (IN_LOCALE_RUNTIME) {
3548 *s = toLOWER_LC(*s);
3571 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3573 s = (U8*)SvPV_nomg(sv,len);
3575 SvUTF8_off(TARG); /* decontaminate */
3576 sv_setpvn(TARG, "", 0);
3580 STRLEN nchar = utf8_length(s, s + len);
3582 (void)SvUPGRADE(TARG, SVt_PV);
3583 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3584 (void)SvPOK_only(TARG);
3585 d = (U8*)SvPVX(TARG);
3588 toUPPER_utf8(s, tmpbuf, &ulen);
3589 Copy(tmpbuf, d, ulen, U8);
3595 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3600 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3602 SvUTF8_off(TARG); /* decontaminate */
3603 sv_setsv_nomg(TARG, sv);
3607 s = (U8*)SvPV_force_nomg(sv, len);
3609 register U8 *send = s + len;
3611 if (IN_LOCALE_RUNTIME) {
3614 for (; s < send; s++)
3615 *s = toUPPER_LC(*s);
3618 for (; s < send; s++)
3640 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3642 s = (U8*)SvPV_nomg(sv,len);
3644 SvUTF8_off(TARG); /* decontaminate */
3645 sv_setpvn(TARG, "", 0);
3649 STRLEN nchar = utf8_length(s, s + len);
3651 (void)SvUPGRADE(TARG, SVt_PV);
3652 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3653 (void)SvPOK_only(TARG);
3654 d = (U8*)SvPVX(TARG);
3657 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3658 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3659 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3661 * Now if the sigma is NOT followed by
3662 * /$ignorable_sequence$cased_letter/;
3663 * and it IS preceded by
3664 * /$cased_letter$ignorable_sequence/;
3665 * where $ignorable_sequence is
3666 * [\x{2010}\x{AD}\p{Mn}]*
3667 * and $cased_letter is
3668 * [\p{Ll}\p{Lo}\p{Lt}]
3669 * then it should be mapped to 0x03C2,
3670 * (GREEK SMALL LETTER FINAL SIGMA),
3671 * instead of staying 0x03A3.
3672 * See lib/unicore/SpecCase.txt.
3675 Copy(tmpbuf, d, ulen, U8);
3681 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3686 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3688 SvUTF8_off(TARG); /* decontaminate */
3689 sv_setsv_nomg(TARG, sv);
3694 s = (U8*)SvPV_force_nomg(sv, len);
3696 register U8 *send = s + len;
3698 if (IN_LOCALE_RUNTIME) {
3701 for (; s < send; s++)
3702 *s = toLOWER_LC(*s);
3705 for (; s < send; s++)
3719 register char *s = SvPV(sv,len);
3722 SvUTF8_off(TARG); /* decontaminate */
3724 (void)SvUPGRADE(TARG, SVt_PV);
3725 SvGROW(TARG, (len * 2) + 1);
3729 if (UTF8_IS_CONTINUED(*s)) {
3730 STRLEN ulen = UTF8SKIP(s);
3754 SvCUR_set(TARG, d - SvPVX(TARG));
3755 (void)SvPOK_only_UTF8(TARG);
3758 sv_setpvn(TARG, s, len);
3760 if (SvSMAGICAL(TARG))
3769 dSP; dMARK; dORIGMARK;
3771 register AV* av = (AV*)POPs;
3772 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3773 I32 arybase = PL_curcop->cop_arybase;
3776 if (SvTYPE(av) == SVt_PVAV) {
3777 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3779 for (svp = MARK + 1; svp <= SP; svp++) {
3784 if (max > AvMAX(av))
3787 while (++MARK <= SP) {
3788 elem = SvIVx(*MARK);
3792 svp = av_fetch(av, elem, lval);
3794 if (!svp || *svp == &PL_sv_undef)
3795 DIE(aTHX_ PL_no_aelem, elem);
3796 if (PL_op->op_private & OPpLVAL_INTRO)
3797 save_aelem(av, elem, svp);
3799 *MARK = svp ? *svp : &PL_sv_undef;
3802 if (GIMME != G_ARRAY) {
3810 /* Associative arrays. */
3815 HV *hash = (HV*)POPs;
3817 I32 gimme = GIMME_V;
3820 /* might clobber stack_sp */
3821 entry = hv_iternext(hash);
3826 SV* sv = hv_iterkeysv(entry);
3827 PUSHs(sv); /* won't clobber stack_sp */
3828 if (gimme == G_ARRAY) {
3831 /* might clobber stack_sp */
3832 val = hv_iterval(hash, entry);
3837 else if (gimme == G_SCALAR)
3856 I32 gimme = GIMME_V;
3857 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3861 if (PL_op->op_private & OPpSLICE) {
3865 hvtype = SvTYPE(hv);
3866 if (hvtype == SVt_PVHV) { /* hash element */
3867 while (++MARK <= SP) {
3868 sv = hv_delete_ent(hv, *MARK, discard, 0);
3869 *MARK = sv ? sv : &PL_sv_undef;
3872 else if (hvtype == SVt_PVAV) { /* array element */
3873 if (PL_op->op_flags & OPf_SPECIAL) {
3874 while (++MARK <= SP) {
3875 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3876 *MARK = sv ? sv : &PL_sv_undef;
3881 DIE(aTHX_ "Not a HASH reference");
3884 else if (gimme == G_SCALAR) {
3893 if (SvTYPE(hv) == SVt_PVHV)
3894 sv = hv_delete_ent(hv, keysv, discard, 0);
3895 else if (SvTYPE(hv) == SVt_PVAV) {
3896 if (PL_op->op_flags & OPf_SPECIAL)
3897 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3899 DIE(aTHX_ "panic: avhv_delete no longer supported");
3902 DIE(aTHX_ "Not a HASH reference");
3917 if (PL_op->op_private & OPpEXISTS_SUB) {
3921 cv = sv_2cv(sv, &hv, &gv, FALSE);
3924 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3930 if (SvTYPE(hv) == SVt_PVHV) {
3931 if (hv_exists_ent(hv, tmpsv, 0))
3934 else if (SvTYPE(hv) == SVt_PVAV) {
3935 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3936 if (av_exists((AV*)hv, SvIV(tmpsv)))
3941 DIE(aTHX_ "Not a HASH reference");
3948 dSP; dMARK; dORIGMARK;
3949 register HV *hv = (HV*)POPs;
3950 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3951 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3952 bool other_magic = FALSE;
3958 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3959 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3960 /* Try to preserve the existenceness of a tied hash
3961 * element by using EXISTS and DELETE if possible.
3962 * Fallback to FETCH and STORE otherwise */
3963 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3964 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3965 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3968 while (++MARK <= SP) {
3972 bool preeminent = FALSE;
3975 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3976 hv_exists_ent(hv, keysv, 0);
3979 he = hv_fetch_ent(hv, keysv, lval, 0);
3980 svp = he ? &HeVAL(he) : 0;
3983 if (!svp || *svp == &PL_sv_undef) {
3985 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3989 save_helem(hv, keysv, svp);
3992 char *key = SvPV(keysv, keylen);
3993 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3997 *MARK = svp ? *svp : &PL_sv_undef;
3999 if (GIMME != G_ARRAY) {
4007 /* List operators. */
4012 if (GIMME != G_ARRAY) {
4014 *MARK = *SP; /* unwanted list, return last item */
4016 *MARK = &PL_sv_undef;
4025 SV **lastrelem = PL_stack_sp;
4026 SV **lastlelem = PL_stack_base + POPMARK;
4027 SV **firstlelem = PL_stack_base + POPMARK + 1;
4028 register SV **firstrelem = lastlelem + 1;
4029 I32 arybase = PL_curcop->cop_arybase;
4030 I32 lval = PL_op->op_flags & OPf_MOD;
4031 I32 is_something_there = lval;
4033 register I32 max = lastrelem - lastlelem;
4034 register SV **lelem;
4037 if (GIMME != G_ARRAY) {
4038 ix = SvIVx(*lastlelem);
4043 if (ix < 0 || ix >= max)
4044 *firstlelem = &PL_sv_undef;
4046 *firstlelem = firstrelem[ix];
4052 SP = firstlelem - 1;
4056 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4062 if (ix < 0 || ix >= max)
4063 *lelem = &PL_sv_undef;
4065 is_something_there = TRUE;
4066 if (!(*lelem = firstrelem[ix]))
4067 *lelem = &PL_sv_undef;
4070 if (is_something_there)
4073 SP = firstlelem - 1;
4079 dSP; dMARK; dORIGMARK;
4080 I32 items = SP - MARK;
4081 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4082 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4089 dSP; dMARK; dORIGMARK;
4090 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4094 SV *val = NEWSV(46, 0);
4096 sv_setsv(val, *++MARK);
4097 else if (ckWARN(WARN_MISC))
4098 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4099 (void)hv_store_ent(hv,key,val,0);
4108 dSP; dMARK; dORIGMARK;
4109 register AV *ary = (AV*)*++MARK;
4113 register I32 offset;
4114 register I32 length;
4121 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4122 *MARK-- = SvTIED_obj((SV*)ary, mg);
4126 call_method("SPLICE",GIMME_V);
4135 offset = i = SvIVx(*MARK);
4137 offset += AvFILLp(ary) + 1;
4139 offset -= PL_curcop->cop_arybase;
4141 DIE(aTHX_ PL_no_aelem, i);
4143 length = SvIVx(*MARK++);
4145 length += AvFILLp(ary) - offset + 1;
4151 length = AvMAX(ary) + 1; /* close enough to infinity */
4155 length = AvMAX(ary) + 1;
4157 if (offset > AvFILLp(ary) + 1) {
4158 if (ckWARN(WARN_MISC))
4159 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4160 offset = AvFILLp(ary) + 1;
4162 after = AvFILLp(ary) + 1 - (offset + length);
4163 if (after < 0) { /* not that much array */
4164 length += after; /* offset+length now in array */
4170 /* At this point, MARK .. SP-1 is our new LIST */
4173 diff = newlen - length;
4174 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4177 if (diff < 0) { /* shrinking the area */
4179 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4180 Copy(MARK, tmparyval, newlen, SV*);
4183 MARK = ORIGMARK + 1;
4184 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4185 MEXTEND(MARK, length);
4186 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4188 EXTEND_MORTAL(length);
4189 for (i = length, dst = MARK; i; i--) {
4190 sv_2mortal(*dst); /* free them eventualy */
4197 *MARK = AvARRAY(ary)[offset+length-1];
4200 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4201 SvREFCNT_dec(*dst++); /* free them now */
4204 AvFILLp(ary) += diff;
4206 /* pull up or down? */
4208 if (offset < after) { /* easier to pull up */
4209 if (offset) { /* esp. if nothing to pull */
4210 src = &AvARRAY(ary)[offset-1];
4211 dst = src - diff; /* diff is negative */
4212 for (i = offset; i > 0; i--) /* can't trust Copy */
4216 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4220 if (after) { /* anything to pull down? */
4221 src = AvARRAY(ary) + offset + length;
4222 dst = src + diff; /* diff is negative */
4223 Move(src, dst, after, SV*);
4225 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4226 /* avoid later double free */
4230 dst[--i] = &PL_sv_undef;
4233 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4235 *dst = NEWSV(46, 0);
4236 sv_setsv(*dst++, *src++);
4238 Safefree(tmparyval);
4241 else { /* no, expanding (or same) */
4243 New(452, tmparyval, length, SV*); /* so remember deletion */
4244 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4247 if (diff > 0) { /* expanding */
4249 /* push up or down? */
4251 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4255 Move(src, dst, offset, SV*);
4257 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4259 AvFILLp(ary) += diff;
4262 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4263 av_extend(ary, AvFILLp(ary) + diff);
4264 AvFILLp(ary) += diff;
4267 dst = AvARRAY(ary) + AvFILLp(ary);
4269 for (i = after; i; i--) {
4276 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4277 *dst = NEWSV(46, 0);
4278 sv_setsv(*dst++, *src++);
4280 MARK = ORIGMARK + 1;
4281 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4283 Copy(tmparyval, MARK, length, SV*);
4285 EXTEND_MORTAL(length);
4286 for (i = length, dst = MARK; i; i--) {
4287 sv_2mortal(*dst); /* free them eventualy */
4291 Safefree(tmparyval);
4295 else if (length--) {
4296 *MARK = tmparyval[length];
4299 while (length-- > 0)
4300 SvREFCNT_dec(tmparyval[length]);
4302 Safefree(tmparyval);
4305 *MARK = &PL_sv_undef;
4313 dSP; dMARK; dORIGMARK; dTARGET;
4314 register AV *ary = (AV*)*++MARK;
4315 register SV *sv = &PL_sv_undef;
4318 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4319 *MARK-- = SvTIED_obj((SV*)ary, mg);
4323 call_method("PUSH",G_SCALAR|G_DISCARD);
4328 /* Why no pre-extend of ary here ? */
4329 for (++MARK; MARK <= SP; MARK++) {
4332 sv_setsv(sv, *MARK);
4337 PUSHi( AvFILL(ary) + 1 );
4345 SV *sv = av_pop(av);
4347 (void)sv_2mortal(sv);
4356 SV *sv = av_shift(av);
4361 (void)sv_2mortal(sv);
4368 dSP; dMARK; dORIGMARK; dTARGET;
4369 register AV *ary = (AV*)*++MARK;
4374 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4375 *MARK-- = SvTIED_obj((SV*)ary, mg);
4379 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4384 av_unshift(ary, SP - MARK);
4387 sv_setsv(sv, *++MARK);
4388 (void)av_store(ary, i++, sv);
4392 PUSHi( AvFILL(ary) + 1 );
4402 if (GIMME == G_ARRAY) {
4409 /* safe as long as stack cannot get extended in the above */
4414 register char *down;
4419 SvUTF8_off(TARG); /* decontaminate */
4421 do_join(TARG, &PL_sv_no, MARK, SP);
4423 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4424 up = SvPV_force(TARG, len);
4426 if (DO_UTF8(TARG)) { /* first reverse each character */
4427 U8* s = (U8*)SvPVX(TARG);
4428 U8* send = (U8*)(s + len);
4430 if (UTF8_IS_INVARIANT(*s)) {
4435 if (!utf8_to_uvchr(s, 0))
4439 down = (char*)(s - 1);
4440 /* reverse this character */
4444 *down-- = (char)tmp;
4450 down = SvPVX(TARG) + len - 1;
4454 *down-- = (char)tmp;
4456 (void)SvPOK_only_UTF8(TARG);
4468 register IV limit = POPi; /* note, negative is forever */
4471 register char *s = SvPV(sv, len);
4472 bool do_utf8 = DO_UTF8(sv);
4473 char *strend = s + len;
4475 register REGEXP *rx;
4479 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4480 I32 maxiters = slen + 10;
4483 I32 origlimit = limit;
4486 AV *oldstack = PL_curstack;
4487 I32 gimme = GIMME_V;
4488 I32 oldsave = PL_savestack_ix;
4489 I32 make_mortal = 1;
4490 MAGIC *mg = (MAGIC *) NULL;
4493 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4498 DIE(aTHX_ "panic: pp_split");
4501 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4502 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4504 RX_MATCH_UTF8_set(rx, do_utf8);
4506 if (pm->op_pmreplroot) {
4508 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4510 ary = GvAVn((GV*)pm->op_pmreplroot);
4513 else if (gimme != G_ARRAY)
4514 ary = GvAVn(PL_defgv);
4517 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4523 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4525 XPUSHs(SvTIED_obj((SV*)ary, mg));
4531 for (i = AvFILLp(ary); i >= 0; i--)
4532 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4534 /* temporarily switch stacks */
4535 SWITCHSTACK(PL_curstack, ary);
4536 PL_curstackinfo->si_stack = ary;
4540 base = SP - PL_stack_base;
4542 if (pm->op_pmflags & PMf_SKIPWHITE) {
4543 if (pm->op_pmflags & PMf_LOCALE) {
4544 while (isSPACE_LC(*s))
4552 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4553 SAVEINT(PL_multiline);
4554 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4558 limit = maxiters + 2;
4559 if (pm->op_pmflags & PMf_WHITE) {
4562 while (m < strend &&
4563 !((pm->op_pmflags & PMf_LOCALE)
4564 ? isSPACE_LC(*m) : isSPACE(*m)))
4569 dstr = NEWSV(30, m-s);
4570 sv_setpvn(dstr, s, m-s);
4574 (void)SvUTF8_on(dstr);
4578 while (s < strend &&
4579 ((pm->op_pmflags & PMf_LOCALE)
4580 ? isSPACE_LC(*s) : isSPACE(*s)))
4584 else if (strEQ("^", rx->precomp)) {
4587 for (m = s; m < strend && *m != '\n'; m++) ;
4591 dstr = NEWSV(30, m-s);
4592 sv_setpvn(dstr, s, m-s);
4596 (void)SvUTF8_on(dstr);
4601 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4602 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4603 && (rx->reganch & ROPT_CHECK_ALL)
4604 && !(rx->reganch & ROPT_ANCH)) {
4605 int tail = (rx->reganch & RE_INTUIT_TAIL);
4606 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4609 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4611 char c = *SvPV(csv, n_a);
4614 for (m = s; m < strend && *m != c; m++) ;
4617 dstr = NEWSV(30, m-s);
4618 sv_setpvn(dstr, s, m-s);
4622 (void)SvUTF8_on(dstr);
4624 /* The rx->minlen is in characters but we want to step
4625 * s ahead by bytes. */
4627 s = (char*)utf8_hop((U8*)m, len);
4629 s = m + len; /* Fake \n at the end */
4634 while (s < strend && --limit &&
4635 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4636 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4639 dstr = NEWSV(31, m-s);
4640 sv_setpvn(dstr, s, m-s);
4644 (void)SvUTF8_on(dstr);
4646 /* The rx->minlen is in characters but we want to step
4647 * s ahead by bytes. */
4649 s = (char*)utf8_hop((U8*)m, len);
4651 s = m + len; /* Fake \n at the end */
4656 maxiters += slen * rx->nparens;
4657 while (s < strend && --limit
4658 /* && (!rx->check_substr
4659 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4661 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4662 1 /* minend */, sv, NULL, 0))
4664 TAINT_IF(RX_MATCH_TAINTED(rx));
4665 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4670 strend = s + (strend - m);
4672 m = rx->startp[0] + orig;
4673 dstr = NEWSV(32, m-s);
4674 sv_setpvn(dstr, s, m-s);
4678 (void)SvUTF8_on(dstr);
4681 for (i = 1; i <= (I32)rx->nparens; i++) {
4682 s = rx->startp[i] + orig;
4683 m = rx->endp[i] + orig;
4685 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4686 parens that didn't match -- they should be set to
4687 undef, not the empty string */
4688 if (m >= orig && s >= orig) {
4689 dstr = NEWSV(33, m-s);
4690 sv_setpvn(dstr, s, m-s);
4693 dstr = &PL_sv_undef; /* undef, not "" */
4697 (void)SvUTF8_on(dstr);
4701 s = rx->endp[0] + orig;
4706 LEAVE_SCOPE(oldsave);
4707 iters = (SP - PL_stack_base) - base;
4708 if (iters > maxiters)
4709 DIE(aTHX_ "Split loop");
4711 /* keep field after final delim? */
4712 if (s < strend || (iters && origlimit)) {
4713 STRLEN l = strend - s;
4714 dstr = NEWSV(34, l);
4715 sv_setpvn(dstr, s, l);
4719 (void)SvUTF8_on(dstr);
4723 else if (!origlimit) {
4724 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4725 if (TOPs && !make_mortal)
4734 SWITCHSTACK(ary, oldstack);
4735 PL_curstackinfo->si_stack = oldstack;
4736 if (SvSMAGICAL(ary)) {
4741 if (gimme == G_ARRAY) {
4743 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4751 call_method("PUSH",G_SCALAR|G_DISCARD);
4754 if (gimme == G_ARRAY) {
4755 /* EXTEND should not be needed - we just popped them */
4757 for (i=0; i < iters; i++) {
4758 SV **svp = av_fetch(ary, i, FALSE);
4759 PUSHs((svp) ? *svp : &PL_sv_undef);
4766 if (gimme == G_ARRAY)
4781 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4782 || SvTYPE(retsv) == SVt_PVCV) {
4783 retsv = refto(retsv);
4791 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");