3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
19 /* variations on pp_null */
21 /* XXX I can't imagine anyone who doesn't have this actually _needs_
22 it, since pid_t is an integral type.
25 #ifdef NEED_GETPID_PROTO
26 extern Pid_t getpid (void);
32 if (GIMME_V == G_SCALAR)
47 if (PL_op->op_private & OPpLVAL_INTRO)
48 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
50 if (PL_op->op_flags & OPf_REF) {
54 if (GIMME == G_SCALAR)
55 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
59 if (GIMME == G_ARRAY) {
60 I32 maxarg = AvFILL((AV*)TARG) + 1;
62 if (SvMAGICAL(TARG)) {
64 for (i=0; i < maxarg; i++) {
65 SV **svp = av_fetch((AV*)TARG, i, FALSE);
66 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
70 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
75 SV* sv = sv_newmortal();
76 I32 maxarg = AvFILL((AV*)TARG) + 1;
89 if (PL_op->op_private & OPpLVAL_INTRO)
90 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
91 if (PL_op->op_flags & OPf_REF)
94 if (GIMME == G_SCALAR)
95 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
99 if (gimme == G_ARRAY) {
102 else if (gimme == G_SCALAR) {
103 SV* sv = sv_newmortal();
104 if (HvFILL((HV*)TARG))
105 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
106 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
116 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
127 tryAMAGICunDEREF(to_gv);
130 if (SvTYPE(sv) == SVt_PVIO) {
131 GV *gv = (GV*) sv_newmortal();
132 gv_init(gv, 0, "", 0, 0);
133 GvIOp(gv) = (IO *)sv;
134 (void)SvREFCNT_inc(sv);
137 else if (SvTYPE(sv) != SVt_PVGV)
138 DIE(aTHX_ "Not a GLOB reference");
141 if (SvTYPE(sv) != SVt_PVGV) {
145 if (SvGMAGICAL(sv)) {
150 if (!SvOK(sv) && sv != &PL_sv_undef) {
151 /* If this is a 'my' scalar and flag is set then vivify
154 if (PL_op->op_private & OPpDEREF) {
157 if (cUNOP->op_targ) {
159 SV *namesv = PL_curpad[cUNOP->op_targ];
160 name = SvPV(namesv, len);
161 gv = (GV*)NEWSV(0,0);
162 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
165 name = CopSTASHPV(PL_curcop);
168 if (SvTYPE(sv) < SVt_RV)
169 sv_upgrade(sv, SVt_RV);
175 if (PL_op->op_flags & OPf_REF ||
176 PL_op->op_private & HINT_STRICT_REFS)
177 DIE(aTHX_ PL_no_usym, "a symbol");
178 if (ckWARN(WARN_UNINITIALIZED))
183 if ((PL_op->op_flags & OPf_SPECIAL) &&
184 !(PL_op->op_flags & OPf_MOD))
186 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
188 && (!is_gv_magical(sym,len,0)
189 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
195 if (PL_op->op_private & HINT_STRICT_REFS)
196 DIE(aTHX_ PL_no_symref, sym, "a symbol");
197 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
213 tryAMAGICunDEREF(to_sv);
216 switch (SvTYPE(sv)) {
220 DIE(aTHX_ "Not a SCALAR reference");
228 if (SvTYPE(gv) != SVt_PVGV) {
229 if (SvGMAGICAL(sv)) {
235 if (PL_op->op_flags & OPf_REF ||
236 PL_op->op_private & HINT_STRICT_REFS)
237 DIE(aTHX_ PL_no_usym, "a SCALAR");
238 if (ckWARN(WARN_UNINITIALIZED))
243 if ((PL_op->op_flags & OPf_SPECIAL) &&
244 !(PL_op->op_flags & OPf_MOD))
246 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
248 && (!is_gv_magical(sym,len,0)
249 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
255 if (PL_op->op_private & HINT_STRICT_REFS)
256 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
257 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
262 if (PL_op->op_flags & OPf_MOD) {
263 if (PL_op->op_private & OPpLVAL_INTRO)
264 sv = save_scalar((GV*)TOPs);
265 else if (PL_op->op_private & OPpDEREF)
266 vivify_ref(sv, PL_op->op_private & OPpDEREF);
276 SV *sv = AvARYLEN(av);
278 AvARYLEN(av) = sv = NEWSV(0,0);
279 sv_upgrade(sv, SVt_IV);
280 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
288 dSP; dTARGET; dPOPss;
290 if (PL_op->op_flags & OPf_MOD || LVRET) {
291 if (SvTYPE(TARG) < SVt_PVLV) {
292 sv_upgrade(TARG, SVt_PVLV);
293 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
297 if (LvTARG(TARG) != sv) {
299 SvREFCNT_dec(LvTARG(TARG));
300 LvTARG(TARG) = SvREFCNT_inc(sv);
302 PUSHs(TARG); /* no SvSETMAGIC */
308 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
309 mg = mg_find(sv, PERL_MAGIC_regex_global);
310 if (mg && mg->mg_len >= 0) {
314 PUSHi(i + PL_curcop->cop_arybase);
328 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
329 /* (But not in defined().) */
330 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
333 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
334 if ((PL_op->op_private & OPpLVAL_INTRO)) {
335 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
338 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
342 cv = (CV*)&PL_sv_undef;
356 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
357 char *s = SvPVX(TOPs);
358 if (strnEQ(s, "CORE::", 6)) {
361 code = keyword(s + 6, SvCUR(TOPs) - 6);
362 if (code < 0) { /* Overridable. */
363 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
364 int i = 0, n = 0, seen_question = 0;
366 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
368 while (i < MAXO) { /* The slow way. */
369 if (strEQ(s + 6, PL_op_name[i])
370 || strEQ(s + 6, PL_op_desc[i]))
376 goto nonesuch; /* Should not happen... */
378 oa = PL_opargs[i] >> OASHIFT;
380 if (oa & OA_OPTIONAL && !seen_question) {
384 else if (n && str[0] == ';' && seen_question)
385 goto set; /* XXXX system, exec */
386 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
387 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
388 /* But globs are already references (kinda) */
389 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
393 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
397 ret = sv_2mortal(newSVpvn(str, n - 1));
399 else if (code) /* Non-Overridable */
401 else { /* None such */
403 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
407 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
409 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
418 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
420 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
436 if (GIMME != G_ARRAY) {
440 *MARK = &PL_sv_undef;
441 *MARK = refto(*MARK);
445 EXTEND_MORTAL(SP - MARK);
447 *MARK = refto(*MARK);
452 S_refto(pTHX_ SV *sv)
456 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
459 if (!(sv = LvTARG(sv)))
462 (void)SvREFCNT_inc(sv);
464 else if (SvTYPE(sv) == SVt_PVAV) {
465 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
468 (void)SvREFCNT_inc(sv);
470 else if (SvPADTMP(sv) && !IS_PADGV(sv))
474 (void)SvREFCNT_inc(sv);
477 sv_upgrade(rv, SVt_RV);
491 if (sv && SvGMAGICAL(sv))
494 if (!sv || !SvROK(sv))
498 pv = sv_reftype(sv,TRUE);
499 PUSHp(pv, strlen(pv));
509 stash = CopSTASH(PL_curcop);
515 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
516 Perl_croak(aTHX_ "Attempt to bless into a reference");
518 if (ckWARN(WARN_MISC) && len == 0)
519 Perl_warner(aTHX_ WARN_MISC,
520 "Explicit blessing to '' (assuming package main)");
521 stash = gv_stashpvn(ptr, len, TRUE);
524 (void)sv_bless(TOPs, stash);
538 elem = SvPV(sv, n_a);
542 switch (elem ? *elem : '\0')
545 if (strEQ(elem, "ARRAY"))
546 tmpRef = (SV*)GvAV(gv);
549 if (strEQ(elem, "CODE"))
550 tmpRef = (SV*)GvCVu(gv);
553 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
554 tmpRef = (SV*)GvIOp(gv);
556 if (strEQ(elem, "FORMAT"))
557 tmpRef = (SV*)GvFORM(gv);
560 if (strEQ(elem, "GLOB"))
564 if (strEQ(elem, "HASH"))
565 tmpRef = (SV*)GvHV(gv);
568 if (strEQ(elem, "IO"))
569 tmpRef = (SV*)GvIOp(gv);
572 if (strEQ(elem, "NAME"))
573 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
576 if (strEQ(elem, "PACKAGE"))
577 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
580 if (strEQ(elem, "SCALAR"))
594 /* Pattern matching */
599 register unsigned char *s;
602 register I32 *sfirst;
606 if (sv == PL_lastscream) {
612 SvSCREAM_off(PL_lastscream);
613 SvREFCNT_dec(PL_lastscream);
615 PL_lastscream = SvREFCNT_inc(sv);
618 s = (unsigned char*)(SvPV(sv, len));
622 if (pos > PL_maxscream) {
623 if (PL_maxscream < 0) {
624 PL_maxscream = pos + 80;
625 New(301, PL_screamfirst, 256, I32);
626 New(302, PL_screamnext, PL_maxscream, I32);
629 PL_maxscream = pos + pos / 4;
630 Renew(PL_screamnext, PL_maxscream, I32);
634 sfirst = PL_screamfirst;
635 snext = PL_screamnext;
637 if (!sfirst || !snext)
638 DIE(aTHX_ "do_study: out of memory");
640 for (ch = 256; ch; --ch)
647 snext[pos] = sfirst[ch] - pos;
654 /* piggyback on m//g magic */
655 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
664 if (PL_op->op_flags & OPf_STACKED)
670 TARG = sv_newmortal();
675 /* Lvalue operators. */
687 dSP; dMARK; dTARGET; dORIGMARK;
689 do_chop(TARG, *++MARK);
698 SETi(do_chomp(TOPs));
705 register I32 count = 0;
708 count += do_chomp(POPs);
719 if (!sv || !SvANY(sv))
721 switch (SvTYPE(sv)) {
723 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
724 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
728 if (HvARRAY(sv) || SvGMAGICAL(sv)
729 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
733 if (CvROOT(sv) || CvXSUB(sv))
750 if (!PL_op->op_private) {
759 if (SvTHINKFIRST(sv))
762 switch (SvTYPE(sv)) {
772 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
773 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
774 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
778 /* let user-undef'd sub keep its identity */
779 GV* gv = CvGV((CV*)sv);
786 SvSetMagicSV(sv, &PL_sv_undef);
790 Newz(602, gp, 1, GP);
791 GvGP(sv) = gp_ref(gp);
792 GvSV(sv) = NEWSV(72,0);
793 GvLINE(sv) = CopLINE(PL_curcop);
799 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
802 SvPV_set(sv, Nullch);
815 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
816 DIE(aTHX_ PL_no_modify);
817 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
818 SvIVX(TOPs) != IV_MIN)
821 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
832 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
833 DIE(aTHX_ PL_no_modify);
834 sv_setsv(TARG, TOPs);
835 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
836 SvIVX(TOPs) != IV_MAX)
839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
853 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
854 DIE(aTHX_ PL_no_modify);
855 sv_setsv(TARG, TOPs);
856 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
857 SvIVX(TOPs) != IV_MIN)
860 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
869 /* Ordinary operators. */
873 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
876 SETn( Perl_pow( left, right) );
883 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
884 #ifdef PERL_PRESERVE_IVUV
887 /* Unless the left argument is integer in range we are going to have to
888 use NV maths. Hence only attempt to coerce the right argument if
889 we know the left is integer. */
890 /* Left operand is defined, so is it IV? */
893 bool auvok = SvUOK(TOPm1s);
894 bool buvok = SvUOK(TOPs);
895 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
896 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
903 alow = SvUVX(TOPm1s);
905 IV aiv = SvIVX(TOPm1s);
908 auvok = TRUE; /* effectively it's a UV now */
910 alow = -aiv; /* abs, auvok == false records sign */
916 IV biv = SvIVX(TOPs);
919 buvok = TRUE; /* effectively it's a UV now */
921 blow = -biv; /* abs, buvok == false records sign */
925 /* If this does sign extension on unsigned it's time for plan B */
926 ahigh = alow >> (4 * sizeof (UV));
928 bhigh = blow >> (4 * sizeof (UV));
930 if (ahigh && bhigh) {
931 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
932 which is overflow. Drop to NVs below. */
933 } else if (!ahigh && !bhigh) {
934 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
935 so the unsigned multiply cannot overflow. */
936 UV product = alow * blow;
937 if (auvok == buvok) {
938 /* -ve * -ve or +ve * +ve gives a +ve result. */
942 } else if (product <= (UV)IV_MIN) {
943 /* 2s complement assumption that (UV)-IV_MIN is correct. */
944 /* -ve result, which could overflow an IV */
946 SETi( -(IV)product );
948 } /* else drop to NVs below. */
950 /* One operand is large, 1 small */
953 /* swap the operands */
955 bhigh = blow; /* bhigh now the temp var for the swap */
959 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
960 multiplies can't overflow. shift can, add can, -ve can. */
961 product_middle = ahigh * blow;
962 if (!(product_middle & topmask)) {
963 /* OK, (ahigh * blow) won't lose bits when we shift it. */
965 product_middle <<= (4 * sizeof (UV));
966 product_low = alow * blow;
968 /* as for pp_add, UV + something mustn't get smaller.
969 IIRC ANSI mandates this wrapping *behaviour* for
970 unsigned whatever the actual representation*/
971 product_low += product_middle;
972 if (product_low >= product_middle) {
973 /* didn't overflow */
974 if (auvok == buvok) {
975 /* -ve * -ve or +ve * +ve gives a +ve result. */
979 } else if (product_low <= (UV)IV_MIN) {
980 /* 2s complement assumption again */
981 /* -ve result, which could overflow an IV */
983 SETi( -(IV)product_low );
985 } /* else drop to NVs below. */
987 } /* product_middle too large */
988 } /* ahigh && bhigh */
989 } /* SvIOK(TOPm1s) */
994 SETn( left * right );
1001 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1002 /* Only try to do UV divide first
1003 if ((SLOPPYDIVIDE is true) or
1004 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1006 The assumption is that it is better to use floating point divide
1007 whenever possible, only doing integer divide first if we can't be sure.
1008 If NV_PRESERVES_UV is true then we know at compile time that no UV
1009 can be too large to preserve, so don't need to compile the code to
1010 test the size of UVs. */
1013 # define PERL_TRY_UV_DIVIDE
1014 /* ensure that 20./5. == 4. */
1016 # ifdef PERL_PRESERVE_IVUV
1017 # ifndef NV_PRESERVES_UV
1018 # define PERL_TRY_UV_DIVIDE
1023 #ifdef PERL_TRY_UV_DIVIDE
1026 SvIV_please(TOPm1s);
1027 if (SvIOK(TOPm1s)) {
1028 bool left_non_neg = SvUOK(TOPm1s);
1029 bool right_non_neg = SvUOK(TOPs);
1033 if (right_non_neg) {
1034 right = SvUVX(TOPs);
1037 IV biv = SvIVX(TOPs);
1040 right_non_neg = TRUE; /* effectively it's a UV now */
1046 /* historically undef()/0 gives a "Use of uninitialized value"
1047 warning before dieing, hence this test goes here.
1048 If it were immediately before the second SvIV_please, then
1049 DIE() would be invoked before left was even inspected, so
1050 no inpsection would give no warning. */
1052 DIE(aTHX_ "Illegal division by zero");
1055 left = SvUVX(TOPm1s);
1058 IV aiv = SvIVX(TOPm1s);
1061 left_non_neg = TRUE; /* effectively it's a UV now */
1070 /* For sloppy divide we always attempt integer division. */
1072 /* Otherwise we only attempt it if either or both operands
1073 would not be preserved by an NV. If both fit in NVs
1074 we fall through to the NV divide code below. */
1075 && ((left > ((UV)1 << NV_PRESERVES_UV_BITS))
1076 || (right > ((UV)1 << NV_PRESERVES_UV_BITS)))
1079 /* Integer division can't overflow, but it can be imprecise. */
1080 UV result = left / right;
1081 if (result * right == left) {
1082 SP--; /* result is valid */
1083 if (left_non_neg == right_non_neg) {
1084 /* signs identical, result is positive. */
1088 /* 2s complement assumption */
1089 if (result <= (UV)IV_MIN)
1092 /* It's exact but too negative for IV. */
1093 SETn( -(NV)result );
1096 } /* tried integer divide but it was not an integer result */
1097 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1098 } /* left wasn't SvIOK */
1099 } /* right wasn't SvIOK */
1100 #endif /* PERL_TRY_UV_DIVIDE */
1104 DIE(aTHX_ "Illegal division by zero");
1105 PUSHn( left / right );
1112 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1118 bool use_double = 0;
1122 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1124 right = (right_neg = (i < 0)) ? -i : i;
1129 right_neg = dright < 0;
1134 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1136 left = (left_neg = (i < 0)) ? -i : i;
1144 left_neg = dleft < 0;
1153 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1155 # define CAST_D2UV(d) U_V(d)
1157 # define CAST_D2UV(d) ((UV)(d))
1159 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1160 * or, in other words, precision of UV more than of NV.
1161 * But in fact the approach below turned out to be an
1162 * optimization - floor() may be slow */
1163 if (dright <= UV_MAX && dleft <= UV_MAX) {
1164 right = CAST_D2UV(dright);
1165 left = CAST_D2UV(dleft);
1170 /* Backward-compatibility clause: */
1171 dright = Perl_floor(dright + 0.5);
1172 dleft = Perl_floor(dleft + 0.5);
1175 DIE(aTHX_ "Illegal modulus zero");
1177 dans = Perl_fmod(dleft, dright);
1178 if ((left_neg != right_neg) && dans)
1179 dans = dright - dans;
1182 sv_setnv(TARG, dans);
1189 DIE(aTHX_ "Illegal modulus zero");
1192 if ((left_neg != right_neg) && ans)
1195 /* XXX may warn: unary minus operator applied to unsigned type */
1196 /* could change -foo to be (~foo)+1 instead */
1197 if (ans <= ~((UV)IV_MAX)+1)
1198 sv_setiv(TARG, ~ans+1);
1200 sv_setnv(TARG, -(NV)ans);
1203 sv_setuv(TARG, ans);
1212 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1214 register IV count = POPi;
1215 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1217 I32 items = SP - MARK;
1220 max = items * count;
1225 *SP = sv_2mortal(newSVsv(*SP));
1231 repeatcpy((char*)(MARK + items), (char*)MARK,
1232 items * sizeof(SV*), count - 1);
1235 else if (count <= 0)
1238 else { /* Note: mark already snarfed by pp_list */
1243 SvSetSV(TARG, tmpstr);
1244 SvPV_force(TARG, len);
1245 isutf = DO_UTF8(TARG);
1250 SvGROW(TARG, (count * len) + 1);
1251 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1252 SvCUR(TARG) *= count;
1254 *SvEND(TARG) = '\0';
1257 (void)SvPOK_only_UTF8(TARG);
1259 (void)SvPOK_only(TARG);
1261 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1262 /* The parser saw this as a list repeat, and there
1263 are probably several items on the stack. But we're
1264 in scalar context, and there's no pp_list to save us
1265 now. So drop the rest of the items -- robin@kitsite.com
1278 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1279 useleft = USE_LEFT(TOPm1s);
1280 #ifdef PERL_PRESERVE_IVUV
1281 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1282 "bad things" happen if you rely on signed integers wrapping. */
1285 /* Unless the left argument is integer in range we are going to have to
1286 use NV maths. Hence only attempt to coerce the right argument if
1287 we know the left is integer. */
1288 register UV auv = 0;
1294 a_valid = auvok = 1;
1295 /* left operand is undef, treat as zero. */
1297 /* Left operand is defined, so is it IV? */
1298 SvIV_please(TOPm1s);
1299 if (SvIOK(TOPm1s)) {
1300 if ((auvok = SvUOK(TOPm1s)))
1301 auv = SvUVX(TOPm1s);
1303 register IV aiv = SvIVX(TOPm1s);
1306 auvok = 1; /* Now acting as a sign flag. */
1307 } else { /* 2s complement assumption for IV_MIN */
1315 bool result_good = 0;
1318 bool buvok = SvUOK(TOPs);
1323 register IV biv = SvIVX(TOPs);
1330 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1331 else "IV" now, independant of how it came in.
1332 if a, b represents positive, A, B negative, a maps to -A etc
1337 all UV maths. negate result if A negative.
1338 subtract if signs same, add if signs differ. */
1340 if (auvok ^ buvok) {
1349 /* Must get smaller */
1354 if (result <= buv) {
1355 /* result really should be -(auv-buv). as its negation
1356 of true value, need to swap our result flag */
1368 if (result <= (UV)IV_MIN)
1369 SETi( -(IV)result );
1371 /* result valid, but out of range for IV. */
1372 SETn( -(NV)result );
1376 } /* Overflow, drop through to NVs. */
1380 useleft = USE_LEFT(TOPm1s);
1384 /* left operand is undef, treat as zero - value */
1388 SETn( TOPn - value );
1395 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1398 if (PL_op->op_private & HINT_INTEGER) {
1412 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1415 if (PL_op->op_private & HINT_INTEGER) {
1429 dSP; tryAMAGICbinSET(lt,0);
1430 #ifdef PERL_PRESERVE_IVUV
1433 SvIV_please(TOPm1s);
1434 if (SvIOK(TOPm1s)) {
1435 bool auvok = SvUOK(TOPm1s);
1436 bool buvok = SvUOK(TOPs);
1438 if (!auvok && !buvok) { /* ## IV < IV ## */
1439 IV aiv = SvIVX(TOPm1s);
1440 IV biv = SvIVX(TOPs);
1443 SETs(boolSV(aiv < biv));
1446 if (auvok && buvok) { /* ## UV < UV ## */
1447 UV auv = SvUVX(TOPm1s);
1448 UV buv = SvUVX(TOPs);
1451 SETs(boolSV(auv < buv));
1454 if (auvok) { /* ## UV < IV ## */
1461 /* As (a) is a UV, it's >=0, so it cannot be < */
1466 if (auv >= (UV) IV_MAX) {
1467 /* As (b) is an IV, it cannot be > IV_MAX */
1471 SETs(boolSV(auv < (UV)biv));
1474 { /* ## IV < UV ## */
1478 aiv = SvIVX(TOPm1s);
1480 /* As (b) is a UV, it's >=0, so it must be < */
1487 if (buv > (UV) IV_MAX) {
1488 /* As (a) is an IV, it cannot be > IV_MAX */
1492 SETs(boolSV((UV)aiv < buv));
1500 SETs(boolSV(TOPn < value));
1507 dSP; tryAMAGICbinSET(gt,0);
1508 #ifdef PERL_PRESERVE_IVUV
1511 SvIV_please(TOPm1s);
1512 if (SvIOK(TOPm1s)) {
1513 bool auvok = SvUOK(TOPm1s);
1514 bool buvok = SvUOK(TOPs);
1516 if (!auvok && !buvok) { /* ## IV > IV ## */
1517 IV aiv = SvIVX(TOPm1s);
1518 IV biv = SvIVX(TOPs);
1521 SETs(boolSV(aiv > biv));
1524 if (auvok && buvok) { /* ## UV > UV ## */
1525 UV auv = SvUVX(TOPm1s);
1526 UV buv = SvUVX(TOPs);
1529 SETs(boolSV(auv > buv));
1532 if (auvok) { /* ## UV > IV ## */
1539 /* As (a) is a UV, it's >=0, so it must be > */
1544 if (auv > (UV) IV_MAX) {
1545 /* As (b) is an IV, it cannot be > IV_MAX */
1549 SETs(boolSV(auv > (UV)biv));
1552 { /* ## IV > UV ## */
1556 aiv = SvIVX(TOPm1s);
1558 /* As (b) is a UV, it's >=0, so it cannot be > */
1565 if (buv >= (UV) IV_MAX) {
1566 /* As (a) is an IV, it cannot be > IV_MAX */
1570 SETs(boolSV((UV)aiv > buv));
1578 SETs(boolSV(TOPn > value));
1585 dSP; tryAMAGICbinSET(le,0);
1586 #ifdef PERL_PRESERVE_IVUV
1589 SvIV_please(TOPm1s);
1590 if (SvIOK(TOPm1s)) {
1591 bool auvok = SvUOK(TOPm1s);
1592 bool buvok = SvUOK(TOPs);
1594 if (!auvok && !buvok) { /* ## IV <= IV ## */
1595 IV aiv = SvIVX(TOPm1s);
1596 IV biv = SvIVX(TOPs);
1599 SETs(boolSV(aiv <= biv));
1602 if (auvok && buvok) { /* ## UV <= UV ## */
1603 UV auv = SvUVX(TOPm1s);
1604 UV buv = SvUVX(TOPs);
1607 SETs(boolSV(auv <= buv));
1610 if (auvok) { /* ## UV <= IV ## */
1617 /* As (a) is a UV, it's >=0, so a cannot be <= */
1622 if (auv > (UV) IV_MAX) {
1623 /* As (b) is an IV, it cannot be > IV_MAX */
1627 SETs(boolSV(auv <= (UV)biv));
1630 { /* ## IV <= UV ## */
1634 aiv = SvIVX(TOPm1s);
1636 /* As (b) is a UV, it's >=0, so a must be <= */
1643 if (buv >= (UV) IV_MAX) {
1644 /* As (a) is an IV, it cannot be > IV_MAX */
1648 SETs(boolSV((UV)aiv <= buv));
1656 SETs(boolSV(TOPn <= value));
1663 dSP; tryAMAGICbinSET(ge,0);
1664 #ifdef PERL_PRESERVE_IVUV
1667 SvIV_please(TOPm1s);
1668 if (SvIOK(TOPm1s)) {
1669 bool auvok = SvUOK(TOPm1s);
1670 bool buvok = SvUOK(TOPs);
1672 if (!auvok && !buvok) { /* ## IV >= IV ## */
1673 IV aiv = SvIVX(TOPm1s);
1674 IV biv = SvIVX(TOPs);
1677 SETs(boolSV(aiv >= biv));
1680 if (auvok && buvok) { /* ## UV >= UV ## */
1681 UV auv = SvUVX(TOPm1s);
1682 UV buv = SvUVX(TOPs);
1685 SETs(boolSV(auv >= buv));
1688 if (auvok) { /* ## UV >= IV ## */
1695 /* As (a) is a UV, it's >=0, so it must be >= */
1700 if (auv >= (UV) IV_MAX) {
1701 /* As (b) is an IV, it cannot be > IV_MAX */
1705 SETs(boolSV(auv >= (UV)biv));
1708 { /* ## IV >= UV ## */
1712 aiv = SvIVX(TOPm1s);
1714 /* As (b) is a UV, it's >=0, so a cannot be >= */
1721 if (buv > (UV) IV_MAX) {
1722 /* As (a) is an IV, it cannot be > IV_MAX */
1726 SETs(boolSV((UV)aiv >= buv));
1734 SETs(boolSV(TOPn >= value));
1741 dSP; tryAMAGICbinSET(ne,0);
1742 #ifndef NV_PRESERVES_UV
1743 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1744 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1748 #ifdef PERL_PRESERVE_IVUV
1751 SvIV_please(TOPm1s);
1752 if (SvIOK(TOPm1s)) {
1753 bool auvok = SvUOK(TOPm1s);
1754 bool buvok = SvUOK(TOPs);
1756 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1757 IV aiv = SvIVX(TOPm1s);
1758 IV biv = SvIVX(TOPs);
1761 SETs(boolSV(aiv != biv));
1764 if (auvok && buvok) { /* ## UV != UV ## */
1765 UV auv = SvUVX(TOPm1s);
1766 UV buv = SvUVX(TOPs);
1769 SETs(boolSV(auv != buv));
1772 { /* ## Mixed IV,UV ## */
1776 /* != is commutative so swap if needed (save code) */
1778 /* swap. top of stack (b) is the iv */
1782 /* As (a) is a UV, it's >0, so it cannot be == */
1791 /* As (b) is a UV, it's >0, so it cannot be == */
1795 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1797 /* we know iv is >= 0 */
1798 if (uv > (UV) IV_MAX) {
1802 SETs(boolSV((UV)iv != uv));
1810 SETs(boolSV(TOPn != value));
1817 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1818 #ifndef NV_PRESERVES_UV
1819 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1820 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1824 #ifdef PERL_PRESERVE_IVUV
1825 /* Fortunately it seems NaN isn't IOK */
1828 SvIV_please(TOPm1s);
1829 if (SvIOK(TOPm1s)) {
1830 bool leftuvok = SvUOK(TOPm1s);
1831 bool rightuvok = SvUOK(TOPs);
1833 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1834 IV leftiv = SvIVX(TOPm1s);
1835 IV rightiv = SvIVX(TOPs);
1837 if (leftiv > rightiv)
1839 else if (leftiv < rightiv)
1843 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1844 UV leftuv = SvUVX(TOPm1s);
1845 UV rightuv = SvUVX(TOPs);
1847 if (leftuv > rightuv)
1849 else if (leftuv < rightuv)
1853 } else if (leftuvok) { /* ## UV <=> IV ## */
1857 rightiv = SvIVX(TOPs);
1859 /* As (a) is a UV, it's >=0, so it cannot be < */
1862 leftuv = SvUVX(TOPm1s);
1863 if (leftuv > (UV) IV_MAX) {
1864 /* As (b) is an IV, it cannot be > IV_MAX */
1866 } else if (leftuv > (UV)rightiv) {
1868 } else if (leftuv < (UV)rightiv) {
1874 } else { /* ## IV <=> UV ## */
1878 leftiv = SvIVX(TOPm1s);
1880 /* As (b) is a UV, it's >=0, so it must be < */
1883 rightuv = SvUVX(TOPs);
1884 if (rightuv > (UV) IV_MAX) {
1885 /* As (a) is an IV, it cannot be > IV_MAX */
1887 } else if (leftiv > (UV)rightuv) {
1889 } else if (leftiv < (UV)rightuv) {
1907 if (Perl_isnan(left) || Perl_isnan(right)) {
1911 value = (left > right) - (left < right);
1915 else if (left < right)
1917 else if (left > right)
1931 dSP; tryAMAGICbinSET(slt,0);
1934 int cmp = (IN_LOCALE_RUNTIME
1935 ? sv_cmp_locale(left, right)
1936 : sv_cmp(left, right));
1937 SETs(boolSV(cmp < 0));
1944 dSP; tryAMAGICbinSET(sgt,0);
1947 int cmp = (IN_LOCALE_RUNTIME
1948 ? sv_cmp_locale(left, right)
1949 : sv_cmp(left, right));
1950 SETs(boolSV(cmp > 0));
1957 dSP; tryAMAGICbinSET(sle,0);
1960 int cmp = (IN_LOCALE_RUNTIME
1961 ? sv_cmp_locale(left, right)
1962 : sv_cmp(left, right));
1963 SETs(boolSV(cmp <= 0));
1970 dSP; tryAMAGICbinSET(sge,0);
1973 int cmp = (IN_LOCALE_RUNTIME
1974 ? sv_cmp_locale(left, right)
1975 : sv_cmp(left, right));
1976 SETs(boolSV(cmp >= 0));
1983 dSP; tryAMAGICbinSET(seq,0);
1986 SETs(boolSV(sv_eq(left, right)));
1993 dSP; tryAMAGICbinSET(sne,0);
1996 SETs(boolSV(!sv_eq(left, right)));
2003 dSP; dTARGET; tryAMAGICbin(scmp,0);
2006 int cmp = (IN_LOCALE_RUNTIME
2007 ? sv_cmp_locale(left, right)
2008 : sv_cmp(left, right));
2016 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2019 if (SvNIOKp(left) || SvNIOKp(right)) {
2020 if (PL_op->op_private & HINT_INTEGER) {
2021 IV i = SvIV(left) & SvIV(right);
2025 UV u = SvUV(left) & SvUV(right);
2030 do_vop(PL_op->op_type, TARG, left, right);
2039 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2042 if (SvNIOKp(left) || SvNIOKp(right)) {
2043 if (PL_op->op_private & HINT_INTEGER) {
2044 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2048 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2053 do_vop(PL_op->op_type, TARG, left, right);
2062 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2065 if (SvNIOKp(left) || SvNIOKp(right)) {
2066 if (PL_op->op_private & HINT_INTEGER) {
2067 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2071 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2076 do_vop(PL_op->op_type, TARG, left, right);
2085 dSP; dTARGET; tryAMAGICun(neg);
2088 int flags = SvFLAGS(sv);
2091 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2092 /* It's publicly an integer, or privately an integer-not-float */
2095 if (SvIVX(sv) == IV_MIN) {
2096 /* 2s complement assumption. */
2097 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2100 else if (SvUVX(sv) <= IV_MAX) {
2105 else if (SvIVX(sv) != IV_MIN) {
2109 #ifdef PERL_PRESERVE_IVUV
2118 else if (SvPOKp(sv)) {
2120 char *s = SvPV(sv, len);
2121 if (isIDFIRST(*s)) {
2122 sv_setpvn(TARG, "-", 1);
2125 else if (*s == '+' || *s == '-') {
2127 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2129 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2130 sv_setpvn(TARG, "-", 1);
2136 goto oops_its_an_int;
2137 sv_setnv(TARG, -SvNV(sv));
2149 dSP; tryAMAGICunSET(not);
2150 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2156 dSP; dTARGET; tryAMAGICun(compl);
2160 if (PL_op->op_private & HINT_INTEGER) {
2175 tmps = (U8*)SvPV_force(TARG, len);
2178 /* Calculate exact length, let's not estimate. */
2187 while (tmps < send) {
2188 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2189 tmps += UTF8SKIP(tmps);
2190 targlen += UNISKIP(~c);
2196 /* Now rewind strings and write them. */
2200 Newz(0, result, targlen + 1, U8);
2201 while (tmps < send) {
2202 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2203 tmps += UTF8SKIP(tmps);
2204 result = uvchr_to_utf8(result, ~c);
2208 sv_setpvn(TARG, (char*)result, targlen);
2212 Newz(0, result, nchar + 1, U8);
2213 while (tmps < send) {
2214 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2215 tmps += UTF8SKIP(tmps);
2220 sv_setpvn(TARG, (char*)result, nchar);
2228 register long *tmpl;
2229 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2232 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2237 for ( ; anum > 0; anum--, tmps++)
2246 /* integer versions of some of the above */
2250 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2253 SETi( left * right );
2260 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2264 DIE(aTHX_ "Illegal division by zero");
2265 value = POPi / value;
2273 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2277 DIE(aTHX_ "Illegal modulus zero");
2278 SETi( left % right );
2285 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2288 SETi( left + right );
2295 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2298 SETi( left - right );
2305 dSP; tryAMAGICbinSET(lt,0);
2308 SETs(boolSV(left < right));
2315 dSP; tryAMAGICbinSET(gt,0);
2318 SETs(boolSV(left > right));
2325 dSP; tryAMAGICbinSET(le,0);
2328 SETs(boolSV(left <= right));
2335 dSP; tryAMAGICbinSET(ge,0);
2338 SETs(boolSV(left >= right));
2345 dSP; tryAMAGICbinSET(eq,0);
2348 SETs(boolSV(left == right));
2355 dSP; tryAMAGICbinSET(ne,0);
2358 SETs(boolSV(left != right));
2365 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2372 else if (left < right)
2383 dSP; dTARGET; tryAMAGICun(neg);
2388 /* High falutin' math. */
2392 dSP; dTARGET; tryAMAGICbin(atan2,0);
2395 SETn(Perl_atan2(left, right));
2402 dSP; dTARGET; tryAMAGICun(sin);
2406 value = Perl_sin(value);
2414 dSP; dTARGET; tryAMAGICun(cos);
2418 value = Perl_cos(value);
2424 /* Support Configure command-line overrides for rand() functions.
2425 After 5.005, perhaps we should replace this by Configure support
2426 for drand48(), random(), or rand(). For 5.005, though, maintain
2427 compatibility by calling rand() but allow the user to override it.
2428 See INSTALL for details. --Andy Dougherty 15 July 1998
2430 /* Now it's after 5.005, and Configure supports drand48() and random(),
2431 in addition to rand(). So the overrides should not be needed any more.
2432 --Jarkko Hietaniemi 27 September 1998
2435 #ifndef HAS_DRAND48_PROTO
2436 extern double drand48 (void);
2449 if (!PL_srand_called) {
2450 (void)seedDrand01((Rand_seed_t)seed());
2451 PL_srand_called = TRUE;
2466 (void)seedDrand01((Rand_seed_t)anum);
2467 PL_srand_called = TRUE;
2476 * This is really just a quick hack which grabs various garbage
2477 * values. It really should be a real hash algorithm which
2478 * spreads the effect of every input bit onto every output bit,
2479 * if someone who knows about such things would bother to write it.
2480 * Might be a good idea to add that function to CORE as well.
2481 * No numbers below come from careful analysis or anything here,
2482 * except they are primes and SEED_C1 > 1E6 to get a full-width
2483 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2484 * probably be bigger too.
2487 # define SEED_C1 1000003
2488 #define SEED_C4 73819
2490 # define SEED_C1 25747
2491 #define SEED_C4 20639
2495 #define SEED_C5 26107
2497 #ifndef PERL_NO_DEV_RANDOM
2502 # include <starlet.h>
2503 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2504 * in 100-ns units, typically incremented ever 10 ms. */
2505 unsigned int when[2];
2507 # ifdef HAS_GETTIMEOFDAY
2508 struct timeval when;
2514 /* This test is an escape hatch, this symbol isn't set by Configure. */
2515 #ifndef PERL_NO_DEV_RANDOM
2516 #ifndef PERL_RANDOM_DEVICE
2517 /* /dev/random isn't used by default because reads from it will block
2518 * if there isn't enough entropy available. You can compile with
2519 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2520 * is enough real entropy to fill the seed. */
2521 # define PERL_RANDOM_DEVICE "/dev/urandom"
2523 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2525 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2534 _ckvmssts(sys$gettim(when));
2535 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2537 # ifdef HAS_GETTIMEOFDAY
2538 gettimeofday(&when,(struct timezone *) 0);
2539 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2542 u = (U32)SEED_C1 * when;
2545 u += SEED_C3 * (U32)PerlProc_getpid();
2546 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2547 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2548 u += SEED_C5 * (U32)PTR2UV(&when);
2555 dSP; dTARGET; tryAMAGICun(exp);
2559 value = Perl_exp(value);
2567 dSP; dTARGET; tryAMAGICun(log);
2572 SET_NUMERIC_STANDARD();
2573 DIE(aTHX_ "Can't take log of %g", value);
2575 value = Perl_log(value);
2583 dSP; dTARGET; tryAMAGICun(sqrt);
2588 SET_NUMERIC_STANDARD();
2589 DIE(aTHX_ "Can't take sqrt of %g", value);
2591 value = Perl_sqrt(value);
2599 dSP; dTARGET; tryAMAGICun(int);
2602 IV iv = TOPi; /* attempt to convert to IV if possible. */
2603 /* XXX it's arguable that compiler casting to IV might be subtly
2604 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2605 else preferring IV has introduced a subtle behaviour change bug. OTOH
2606 relying on floating point to be accurate is a bug. */
2617 if (value < (NV)UV_MAX + 0.5) {
2620 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2621 # ifdef HAS_MODFL_POW32_BUG
2622 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2624 NV offset = Perl_modf(value, &value);
2625 (void)Perl_modf(offset, &offset);
2629 (void)Perl_modf(value, &value);
2632 double tmp = (double)value;
2633 (void)Perl_modf(tmp, &tmp);
2640 if (value > (NV)IV_MIN - 0.5) {
2643 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2644 # ifdef HAS_MODFL_POW32_BUG
2645 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2647 NV offset = Perl_modf(-value, &value);
2648 (void)Perl_modf(offset, &offset);
2652 (void)Perl_modf(-value, &value);
2656 double tmp = (double)value;
2657 (void)Perl_modf(-tmp, &tmp);
2670 dSP; dTARGET; tryAMAGICun(abs);
2672 /* This will cache the NV value if string isn't actually integer */
2676 /* IVX is precise */
2678 SETu(TOPu); /* force it to be numeric only */
2686 /* 2s complement assumption. Also, not really needed as
2687 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2709 tmps = (SvPVx(POPs, len));
2710 argtype = 1; /* allow underscores */
2711 XPUSHn(scan_hex(tmps, len, &argtype));
2723 tmps = (SvPVx(POPs, len));
2724 while (*tmps && len && isSPACE(*tmps))
2728 argtype = 1; /* allow underscores */
2730 value = scan_hex(++tmps, --len, &argtype);
2731 else if (*tmps == 'b')
2732 value = scan_bin(++tmps, --len, &argtype);
2734 value = scan_oct(tmps, len, &argtype);
2747 SETi(sv_len_utf8(sv));
2763 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2765 I32 arybase = PL_curcop->cop_arybase;
2769 int num_args = PL_op->op_private & 7;
2770 bool repl_need_utf8_upgrade = FALSE;
2771 bool repl_is_utf8 = FALSE;
2773 SvTAINTED_off(TARG); /* decontaminate */
2774 SvUTF8_off(TARG); /* decontaminate */
2778 repl = SvPV(repl_sv, repl_len);
2779 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2789 sv_utf8_upgrade(sv);
2791 else if (DO_UTF8(sv))
2792 repl_need_utf8_upgrade = TRUE;
2794 tmps = SvPV(sv, curlen);
2796 utf8_curlen = sv_len_utf8(sv);
2797 if (utf8_curlen == curlen)
2800 curlen = utf8_curlen;
2805 if (pos >= arybase) {
2823 else if (len >= 0) {
2825 if (rem > (I32)curlen)
2840 Perl_croak(aTHX_ "substr outside of string");
2841 if (ckWARN(WARN_SUBSTR))
2842 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2849 sv_pos_u2b(sv, &pos, &rem);
2851 sv_setpvn(TARG, tmps, rem);
2852 #ifdef USE_LOCALE_COLLATE
2853 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2858 SV* repl_sv_copy = NULL;
2860 if (repl_need_utf8_upgrade) {
2861 repl_sv_copy = newSVsv(repl_sv);
2862 sv_utf8_upgrade(repl_sv_copy);
2863 repl = SvPV(repl_sv_copy, repl_len);
2864 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2866 sv_insert(sv, pos, rem, repl, repl_len);
2870 SvREFCNT_dec(repl_sv_copy);
2872 else if (lvalue) { /* it's an lvalue! */
2873 if (!SvGMAGICAL(sv)) {
2877 if (ckWARN(WARN_SUBSTR))
2878 Perl_warner(aTHX_ WARN_SUBSTR,
2879 "Attempt to use reference as lvalue in substr");
2881 if (SvOK(sv)) /* is it defined ? */
2882 (void)SvPOK_only_UTF8(sv);
2884 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2887 if (SvTYPE(TARG) < SVt_PVLV) {
2888 sv_upgrade(TARG, SVt_PVLV);
2889 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2893 if (LvTARG(TARG) != sv) {
2895 SvREFCNT_dec(LvTARG(TARG));
2896 LvTARG(TARG) = SvREFCNT_inc(sv);
2898 LvTARGOFF(TARG) = upos;
2899 LvTARGLEN(TARG) = urem;
2903 PUSHs(TARG); /* avoid SvSETMAGIC here */
2910 register IV size = POPi;
2911 register IV offset = POPi;
2912 register SV *src = POPs;
2913 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2915 SvTAINTED_off(TARG); /* decontaminate */
2916 if (lvalue) { /* it's an lvalue! */
2917 if (SvTYPE(TARG) < SVt_PVLV) {
2918 sv_upgrade(TARG, SVt_PVLV);
2919 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2922 if (LvTARG(TARG) != src) {
2924 SvREFCNT_dec(LvTARG(TARG));
2925 LvTARG(TARG) = SvREFCNT_inc(src);
2927 LvTARGOFF(TARG) = offset;
2928 LvTARGLEN(TARG) = size;
2931 sv_setuv(TARG, do_vecget(src, offset, size));
2946 I32 arybase = PL_curcop->cop_arybase;
2951 offset = POPi - arybase;
2954 tmps = SvPV(big, biglen);
2955 if (offset > 0 && DO_UTF8(big))
2956 sv_pos_u2b(big, &offset, 0);
2959 else if (offset > biglen)
2961 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2962 (unsigned char*)tmps + biglen, little, 0)))
2965 retval = tmps2 - tmps;
2966 if (retval > 0 && DO_UTF8(big))
2967 sv_pos_b2u(big, &retval);
2968 PUSHi(retval + arybase);
2983 I32 arybase = PL_curcop->cop_arybase;
2989 tmps2 = SvPV(little, llen);
2990 tmps = SvPV(big, blen);
2994 if (offset > 0 && DO_UTF8(big))
2995 sv_pos_u2b(big, &offset, 0);
2996 offset = offset - arybase + llen;
3000 else if (offset > blen)
3002 if (!(tmps2 = rninstr(tmps, tmps + offset,
3003 tmps2, tmps2 + llen)))
3006 retval = tmps2 - tmps;
3007 if (retval > 0 && DO_UTF8(big))
3008 sv_pos_b2u(big, &retval);
3009 PUSHi(retval + arybase);
3015 dSP; dMARK; dORIGMARK; dTARGET;
3016 do_sprintf(TARG, SP-MARK, MARK+1);
3017 TAINT_IF(SvTAINTED(TARG));
3018 if (DO_UTF8(*(MARK+1)))
3030 U8 *s = (U8*)SvPVx(argsv, len);
3032 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3042 (void)SvUPGRADE(TARG,SVt_PV);
3044 if (value > 255 && !IN_BYTES) {
3045 SvGROW(TARG, UNISKIP(value)+1);
3046 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3047 SvCUR_set(TARG, tmps - SvPVX(TARG));
3049 (void)SvPOK_only(TARG);
3060 (void)SvPOK_only(TARG);
3067 dSP; dTARGET; dPOPTOPssrl;
3070 char *tmps = SvPV(left, n_a);
3072 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3074 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3078 "The crypt() function is unimplemented due to excessive paranoia.");
3091 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3093 U8 tmpbuf[UTF8_MAXLEN+1];
3097 if (IN_LOCALE_RUNTIME) {
3100 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3103 uv = toTITLE_utf8(s);
3107 tend = uvchr_to_utf8(tmpbuf, uv);
3109 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3111 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3112 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3117 s = (U8*)SvPV_force(sv, slen);
3118 Copy(tmpbuf, s, ulen, U8);
3122 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3124 SvUTF8_off(TARG); /* decontaminate */
3129 s = (U8*)SvPV_force(sv, slen);
3131 if (IN_LOCALE_RUNTIME) {
3134 *s = toUPPER_LC(*s);
3152 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3154 U8 tmpbuf[UTF8_MAXLEN+1];
3158 if (IN_LOCALE_RUNTIME) {
3161 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3164 uv = toLOWER_utf8(s);
3168 tend = uvchr_to_utf8(tmpbuf, uv);
3170 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3172 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3173 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3178 s = (U8*)SvPV_force(sv, slen);
3179 Copy(tmpbuf, s, ulen, U8);
3183 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3185 SvUTF8_off(TARG); /* decontaminate */
3190 s = (U8*)SvPV_force(sv, slen);
3192 if (IN_LOCALE_RUNTIME) {
3195 *s = toLOWER_LC(*s);
3219 s = (U8*)SvPV(sv,len);
3221 SvUTF8_off(TARG); /* decontaminate */
3222 sv_setpvn(TARG, "", 0);
3226 (void)SvUPGRADE(TARG, SVt_PV);
3227 SvGROW(TARG, (len * 2) + 1);
3228 (void)SvPOK_only(TARG);
3229 d = (U8*)SvPVX(TARG);
3231 if (IN_LOCALE_RUNTIME) {
3235 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3241 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3247 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3252 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3254 SvUTF8_off(TARG); /* decontaminate */
3259 s = (U8*)SvPV_force(sv, len);
3261 register U8 *send = s + len;
3263 if (IN_LOCALE_RUNTIME) {
3266 for (; s < send; s++)
3267 *s = toUPPER_LC(*s);
3270 for (; s < send; s++)
3293 s = (U8*)SvPV(sv,len);
3295 SvUTF8_off(TARG); /* decontaminate */
3296 sv_setpvn(TARG, "", 0);
3300 (void)SvUPGRADE(TARG, SVt_PV);
3301 SvGROW(TARG, (len * 2) + 1);
3302 (void)SvPOK_only(TARG);
3303 d = (U8*)SvPVX(TARG);
3305 if (IN_LOCALE_RUNTIME) {
3309 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3315 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3321 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3326 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3328 SvUTF8_off(TARG); /* decontaminate */
3334 s = (U8*)SvPV_force(sv, len);
3336 register U8 *send = s + len;
3338 if (IN_LOCALE_RUNTIME) {
3341 for (; s < send; s++)
3342 *s = toLOWER_LC(*s);
3345 for (; s < send; s++)
3360 register char *s = SvPV(sv,len);
3363 SvUTF8_off(TARG); /* decontaminate */
3365 (void)SvUPGRADE(TARG, SVt_PV);
3366 SvGROW(TARG, (len * 2) + 1);
3370 if (UTF8_IS_CONTINUED(*s)) {
3371 STRLEN ulen = UTF8SKIP(s);
3395 SvCUR_set(TARG, d - SvPVX(TARG));
3396 (void)SvPOK_only_UTF8(TARG);
3399 sv_setpvn(TARG, s, len);
3401 if (SvSMAGICAL(TARG))
3410 dSP; dMARK; dORIGMARK;
3412 register AV* av = (AV*)POPs;
3413 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3414 I32 arybase = PL_curcop->cop_arybase;
3417 if (SvTYPE(av) == SVt_PVAV) {
3418 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3420 for (svp = MARK + 1; svp <= SP; svp++) {
3425 if (max > AvMAX(av))
3428 while (++MARK <= SP) {
3429 elem = SvIVx(*MARK);
3433 svp = av_fetch(av, elem, lval);
3435 if (!svp || *svp == &PL_sv_undef)
3436 DIE(aTHX_ PL_no_aelem, elem);
3437 if (PL_op->op_private & OPpLVAL_INTRO)
3438 save_aelem(av, elem, svp);
3440 *MARK = svp ? *svp : &PL_sv_undef;
3443 if (GIMME != G_ARRAY) {
3451 /* Associative arrays. */
3456 HV *hash = (HV*)POPs;
3458 I32 gimme = GIMME_V;
3459 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3462 /* might clobber stack_sp */
3463 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3468 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3469 if (gimme == G_ARRAY) {
3472 /* might clobber stack_sp */
3474 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3479 else if (gimme == G_SCALAR)
3498 I32 gimme = GIMME_V;
3499 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3503 if (PL_op->op_private & OPpSLICE) {
3507 hvtype = SvTYPE(hv);
3508 if (hvtype == SVt_PVHV) { /* hash element */
3509 while (++MARK <= SP) {
3510 sv = hv_delete_ent(hv, *MARK, discard, 0);
3511 *MARK = sv ? sv : &PL_sv_undef;
3514 else if (hvtype == SVt_PVAV) {
3515 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3516 while (++MARK <= SP) {
3517 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3518 *MARK = sv ? sv : &PL_sv_undef;
3521 else { /* pseudo-hash element */
3522 while (++MARK <= SP) {
3523 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3524 *MARK = sv ? sv : &PL_sv_undef;
3529 DIE(aTHX_ "Not a HASH reference");
3532 else if (gimme == G_SCALAR) {
3541 if (SvTYPE(hv) == SVt_PVHV)
3542 sv = hv_delete_ent(hv, keysv, discard, 0);
3543 else if (SvTYPE(hv) == SVt_PVAV) {
3544 if (PL_op->op_flags & OPf_SPECIAL)
3545 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3547 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3550 DIE(aTHX_ "Not a HASH reference");
3565 if (PL_op->op_private & OPpEXISTS_SUB) {
3569 cv = sv_2cv(sv, &hv, &gv, FALSE);
3572 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3578 if (SvTYPE(hv) == SVt_PVHV) {
3579 if (hv_exists_ent(hv, tmpsv, 0))
3582 else if (SvTYPE(hv) == SVt_PVAV) {
3583 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3584 if (av_exists((AV*)hv, SvIV(tmpsv)))
3587 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3591 DIE(aTHX_ "Not a HASH reference");
3598 dSP; dMARK; dORIGMARK;
3599 register HV *hv = (HV*)POPs;
3600 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3601 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3603 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3604 DIE(aTHX_ "Can't localize pseudo-hash element");
3606 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3607 while (++MARK <= SP) {
3610 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3611 realhv ? hv_exists_ent(hv, keysv, 0)
3612 : avhv_exists_ent((AV*)hv, keysv, 0);
3614 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3615 svp = he ? &HeVAL(he) : 0;
3618 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3621 if (!svp || *svp == &PL_sv_undef) {
3623 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3625 if (PL_op->op_private & OPpLVAL_INTRO) {
3627 save_helem(hv, keysv, svp);
3630 char *key = SvPV(keysv, keylen);
3631 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3635 *MARK = svp ? *svp : &PL_sv_undef;
3638 if (GIMME != G_ARRAY) {
3646 /* List operators. */
3651 if (GIMME != G_ARRAY) {
3653 *MARK = *SP; /* unwanted list, return last item */
3655 *MARK = &PL_sv_undef;
3664 SV **lastrelem = PL_stack_sp;
3665 SV **lastlelem = PL_stack_base + POPMARK;
3666 SV **firstlelem = PL_stack_base + POPMARK + 1;
3667 register SV **firstrelem = lastlelem + 1;
3668 I32 arybase = PL_curcop->cop_arybase;
3669 I32 lval = PL_op->op_flags & OPf_MOD;
3670 I32 is_something_there = lval;
3672 register I32 max = lastrelem - lastlelem;
3673 register SV **lelem;
3676 if (GIMME != G_ARRAY) {
3677 ix = SvIVx(*lastlelem);
3682 if (ix < 0 || ix >= max)
3683 *firstlelem = &PL_sv_undef;
3685 *firstlelem = firstrelem[ix];
3691 SP = firstlelem - 1;
3695 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3701 if (ix < 0 || ix >= max)
3702 *lelem = &PL_sv_undef;
3704 is_something_there = TRUE;
3705 if (!(*lelem = firstrelem[ix]))
3706 *lelem = &PL_sv_undef;
3709 if (is_something_there)
3712 SP = firstlelem - 1;
3718 dSP; dMARK; dORIGMARK;
3719 I32 items = SP - MARK;
3720 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3721 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3728 dSP; dMARK; dORIGMARK;
3729 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3733 SV *val = NEWSV(46, 0);
3735 sv_setsv(val, *++MARK);
3736 else if (ckWARN(WARN_MISC))
3737 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3738 (void)hv_store_ent(hv,key,val,0);
3747 dSP; dMARK; dORIGMARK;
3748 register AV *ary = (AV*)*++MARK;
3752 register I32 offset;
3753 register I32 length;
3760 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3761 *MARK-- = SvTIED_obj((SV*)ary, mg);
3765 call_method("SPLICE",GIMME_V);
3774 offset = i = SvIVx(*MARK);
3776 offset += AvFILLp(ary) + 1;
3778 offset -= PL_curcop->cop_arybase;
3780 DIE(aTHX_ PL_no_aelem, i);
3782 length = SvIVx(*MARK++);
3784 length += AvFILLp(ary) - offset + 1;
3790 length = AvMAX(ary) + 1; /* close enough to infinity */
3794 length = AvMAX(ary) + 1;
3796 if (offset > AvFILLp(ary) + 1)
3797 offset = AvFILLp(ary) + 1;
3798 after = AvFILLp(ary) + 1 - (offset + length);
3799 if (after < 0) { /* not that much array */
3800 length += after; /* offset+length now in array */
3806 /* At this point, MARK .. SP-1 is our new LIST */
3809 diff = newlen - length;
3810 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3813 if (diff < 0) { /* shrinking the area */
3815 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3816 Copy(MARK, tmparyval, newlen, SV*);
3819 MARK = ORIGMARK + 1;
3820 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3821 MEXTEND(MARK, length);
3822 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3824 EXTEND_MORTAL(length);
3825 for (i = length, dst = MARK; i; i--) {
3826 sv_2mortal(*dst); /* free them eventualy */
3833 *MARK = AvARRAY(ary)[offset+length-1];
3836 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3837 SvREFCNT_dec(*dst++); /* free them now */
3840 AvFILLp(ary) += diff;
3842 /* pull up or down? */
3844 if (offset < after) { /* easier to pull up */
3845 if (offset) { /* esp. if nothing to pull */
3846 src = &AvARRAY(ary)[offset-1];
3847 dst = src - diff; /* diff is negative */
3848 for (i = offset; i > 0; i--) /* can't trust Copy */
3852 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3856 if (after) { /* anything to pull down? */
3857 src = AvARRAY(ary) + offset + length;
3858 dst = src + diff; /* diff is negative */
3859 Move(src, dst, after, SV*);
3861 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3862 /* avoid later double free */
3866 dst[--i] = &PL_sv_undef;
3869 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3871 *dst = NEWSV(46, 0);
3872 sv_setsv(*dst++, *src++);
3874 Safefree(tmparyval);
3877 else { /* no, expanding (or same) */
3879 New(452, tmparyval, length, SV*); /* so remember deletion */
3880 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3883 if (diff > 0) { /* expanding */
3885 /* push up or down? */
3887 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3891 Move(src, dst, offset, SV*);
3893 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3895 AvFILLp(ary) += diff;
3898 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3899 av_extend(ary, AvFILLp(ary) + diff);
3900 AvFILLp(ary) += diff;
3903 dst = AvARRAY(ary) + AvFILLp(ary);
3905 for (i = after; i; i--) {
3912 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3913 *dst = NEWSV(46, 0);
3914 sv_setsv(*dst++, *src++);
3916 MARK = ORIGMARK + 1;
3917 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3919 Copy(tmparyval, MARK, length, SV*);
3921 EXTEND_MORTAL(length);
3922 for (i = length, dst = MARK; i; i--) {
3923 sv_2mortal(*dst); /* free them eventualy */
3927 Safefree(tmparyval);
3931 else if (length--) {
3932 *MARK = tmparyval[length];
3935 while (length-- > 0)
3936 SvREFCNT_dec(tmparyval[length]);
3938 Safefree(tmparyval);
3941 *MARK = &PL_sv_undef;
3949 dSP; dMARK; dORIGMARK; dTARGET;
3950 register AV *ary = (AV*)*++MARK;
3951 register SV *sv = &PL_sv_undef;
3954 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3955 *MARK-- = SvTIED_obj((SV*)ary, mg);
3959 call_method("PUSH",G_SCALAR|G_DISCARD);
3964 /* Why no pre-extend of ary here ? */
3965 for (++MARK; MARK <= SP; MARK++) {
3968 sv_setsv(sv, *MARK);
3973 PUSHi( AvFILL(ary) + 1 );
3981 SV *sv = av_pop(av);
3983 (void)sv_2mortal(sv);
3992 SV *sv = av_shift(av);
3997 (void)sv_2mortal(sv);
4004 dSP; dMARK; dORIGMARK; dTARGET;
4005 register AV *ary = (AV*)*++MARK;
4010 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4011 *MARK-- = SvTIED_obj((SV*)ary, mg);
4015 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4020 av_unshift(ary, SP - MARK);
4023 sv_setsv(sv, *++MARK);
4024 (void)av_store(ary, i++, sv);
4028 PUSHi( AvFILL(ary) + 1 );
4038 if (GIMME == G_ARRAY) {
4045 /* safe as long as stack cannot get extended in the above */
4050 register char *down;
4055 SvUTF8_off(TARG); /* decontaminate */
4057 do_join(TARG, &PL_sv_no, MARK, SP);
4059 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4060 up = SvPV_force(TARG, len);
4062 if (DO_UTF8(TARG)) { /* first reverse each character */
4063 U8* s = (U8*)SvPVX(TARG);
4064 U8* send = (U8*)(s + len);
4066 if (UTF8_IS_INVARIANT(*s)) {
4071 if (!utf8_to_uvchr(s, 0))
4075 down = (char*)(s - 1);
4076 /* reverse this character */
4086 down = SvPVX(TARG) + len - 1;
4092 (void)SvPOK_only_UTF8(TARG);
4104 register IV limit = POPi; /* note, negative is forever */
4107 register char *s = SvPV(sv, len);
4108 bool do_utf8 = DO_UTF8(sv);
4109 char *strend = s + len;
4111 register REGEXP *rx;
4115 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4116 I32 maxiters = slen + 10;
4119 I32 origlimit = limit;
4122 AV *oldstack = PL_curstack;
4123 I32 gimme = GIMME_V;
4124 I32 oldsave = PL_savestack_ix;
4125 I32 make_mortal = 1;
4126 MAGIC *mg = (MAGIC *) NULL;
4129 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4134 DIE(aTHX_ "panic: pp_split");
4137 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4138 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4140 PL_reg_sv_utf8 = do_utf8;
4142 if (pm->op_pmreplroot) {
4144 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4146 ary = GvAVn((GV*)pm->op_pmreplroot);
4149 else if (gimme != G_ARRAY)
4150 #ifdef USE_5005THREADS
4151 ary = (AV*)PL_curpad[0];
4153 ary = GvAVn(PL_defgv);
4154 #endif /* USE_5005THREADS */
4157 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4163 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4165 XPUSHs(SvTIED_obj((SV*)ary, mg));
4171 for (i = AvFILLp(ary); i >= 0; i--)
4172 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4174 /* temporarily switch stacks */
4175 SWITCHSTACK(PL_curstack, ary);
4179 base = SP - PL_stack_base;
4181 if (pm->op_pmflags & PMf_SKIPWHITE) {
4182 if (pm->op_pmflags & PMf_LOCALE) {
4183 while (isSPACE_LC(*s))
4191 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4192 SAVEINT(PL_multiline);
4193 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4197 limit = maxiters + 2;
4198 if (pm->op_pmflags & PMf_WHITE) {
4201 while (m < strend &&
4202 !((pm->op_pmflags & PMf_LOCALE)
4203 ? isSPACE_LC(*m) : isSPACE(*m)))
4208 dstr = NEWSV(30, m-s);
4209 sv_setpvn(dstr, s, m-s);
4213 (void)SvUTF8_on(dstr);
4217 while (s < strend &&
4218 ((pm->op_pmflags & PMf_LOCALE)
4219 ? isSPACE_LC(*s) : isSPACE(*s)))
4223 else if (strEQ("^", rx->precomp)) {
4226 for (m = s; m < strend && *m != '\n'; m++) ;
4230 dstr = NEWSV(30, m-s);
4231 sv_setpvn(dstr, s, m-s);
4235 (void)SvUTF8_on(dstr);
4240 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4241 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4242 && (rx->reganch & ROPT_CHECK_ALL)
4243 && !(rx->reganch & ROPT_ANCH)) {
4244 int tail = (rx->reganch & RE_INTUIT_TAIL);
4245 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4248 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4250 char c = *SvPV(csv, n_a);
4253 for (m = s; m < strend && *m != c; m++) ;
4256 dstr = NEWSV(30, m-s);
4257 sv_setpvn(dstr, s, m-s);
4261 (void)SvUTF8_on(dstr);
4263 /* The rx->minlen is in characters but we want to step
4264 * s ahead by bytes. */
4266 s = (char*)utf8_hop((U8*)m, len);
4268 s = m + len; /* Fake \n at the end */
4273 while (s < strend && --limit &&
4274 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4275 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4278 dstr = NEWSV(31, m-s);
4279 sv_setpvn(dstr, s, m-s);
4283 (void)SvUTF8_on(dstr);
4285 /* The rx->minlen is in characters but we want to step
4286 * s ahead by bytes. */
4288 s = (char*)utf8_hop((U8*)m, len);
4290 s = m + len; /* Fake \n at the end */
4295 maxiters += slen * rx->nparens;
4296 while (s < strend && --limit
4297 /* && (!rx->check_substr
4298 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4300 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4301 1 /* minend */, sv, NULL, 0))
4303 TAINT_IF(RX_MATCH_TAINTED(rx));
4304 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4309 strend = s + (strend - m);
4311 m = rx->startp[0] + orig;
4312 dstr = NEWSV(32, m-s);
4313 sv_setpvn(dstr, s, m-s);
4317 (void)SvUTF8_on(dstr);
4320 for (i = 1; i <= rx->nparens; i++) {
4321 s = rx->startp[i] + orig;
4322 m = rx->endp[i] + orig;
4324 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4325 parens that didn't match -- they should be set to
4326 undef, not the empty string */
4327 if (m >= orig && s >= orig) {
4328 dstr = NEWSV(33, m-s);
4329 sv_setpvn(dstr, s, m-s);
4332 dstr = &PL_sv_undef; /* undef, not "" */
4336 (void)SvUTF8_on(dstr);
4340 s = rx->endp[0] + orig;
4344 LEAVE_SCOPE(oldsave);
4345 iters = (SP - PL_stack_base) - base;
4346 if (iters > maxiters)
4347 DIE(aTHX_ "Split loop");
4349 /* keep field after final delim? */
4350 if (s < strend || (iters && origlimit)) {
4351 STRLEN l = strend - s;
4352 dstr = NEWSV(34, l);
4353 sv_setpvn(dstr, s, l);
4357 (void)SvUTF8_on(dstr);
4361 else if (!origlimit) {
4362 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4368 SWITCHSTACK(ary, oldstack);
4369 if (SvSMAGICAL(ary)) {
4374 if (gimme == G_ARRAY) {
4376 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4384 call_method("PUSH",G_SCALAR|G_DISCARD);
4387 if (gimme == G_ARRAY) {
4388 /* EXTEND should not be needed - we just popped them */
4390 for (i=0; i < iters; i++) {
4391 SV **svp = av_fetch(ary, i, FALSE);
4392 PUSHs((svp) ? *svp : &PL_sv_undef);
4399 if (gimme == G_ARRAY)
4402 if (iters || !pm->op_pmreplroot) {
4410 #ifdef USE_5005THREADS
4412 Perl_unlock_condpair(pTHX_ void *svv)
4414 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4417 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4418 MUTEX_LOCK(MgMUTEXP(mg));
4419 if (MgOWNER(mg) != thr)
4420 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4422 COND_SIGNAL(MgOWNERCONDP(mg));
4423 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4424 PTR2UV(thr), PTR2UV(svv)));
4425 MUTEX_UNLOCK(MgMUTEXP(mg));
4427 #endif /* USE_5005THREADS */
4434 #ifdef USE_5005THREADS
4436 #endif /* USE_5005THREADS */
4438 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4440 Perl_sharedsv_lock(aTHX_ ssv);
4441 #endif /* USE_ITHREADS */
4442 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4443 || SvTYPE(retsv) == SVt_PVCV) {
4444 retsv = refto(retsv);
4452 #ifdef USE_5005THREADS
4455 if (PL_op->op_private & OPpLVAL_INTRO)
4456 PUSHs(*save_threadsv(PL_op->op_targ));
4458 PUSHs(THREADSV(PL_op->op_targ));
4461 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4462 #endif /* USE_5005THREADS */