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")) {
554 /* finally deprecated in 5.8.0 */
555 deprecate("*glob{FILEHANDLE}");
556 tmpRef = (SV*)GvIOp(gv);
559 if (strEQ(elem, "FORMAT"))
560 tmpRef = (SV*)GvFORM(gv);
563 if (strEQ(elem, "GLOB"))
567 if (strEQ(elem, "HASH"))
568 tmpRef = (SV*)GvHV(gv);
571 if (strEQ(elem, "IO"))
572 tmpRef = (SV*)GvIOp(gv);
575 if (strEQ(elem, "NAME"))
576 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
579 if (strEQ(elem, "PACKAGE"))
580 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
583 if (strEQ(elem, "SCALAR"))
597 /* Pattern matching */
602 register unsigned char *s;
605 register I32 *sfirst;
609 if (sv == PL_lastscream) {
615 SvSCREAM_off(PL_lastscream);
616 SvREFCNT_dec(PL_lastscream);
618 PL_lastscream = SvREFCNT_inc(sv);
621 s = (unsigned char*)(SvPV(sv, len));
625 if (pos > PL_maxscream) {
626 if (PL_maxscream < 0) {
627 PL_maxscream = pos + 80;
628 New(301, PL_screamfirst, 256, I32);
629 New(302, PL_screamnext, PL_maxscream, I32);
632 PL_maxscream = pos + pos / 4;
633 Renew(PL_screamnext, PL_maxscream, I32);
637 sfirst = PL_screamfirst;
638 snext = PL_screamnext;
640 if (!sfirst || !snext)
641 DIE(aTHX_ "do_study: out of memory");
643 for (ch = 256; ch; --ch)
650 snext[pos] = sfirst[ch] - pos;
657 /* piggyback on m//g magic */
658 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
667 if (PL_op->op_flags & OPf_STACKED)
673 TARG = sv_newmortal();
678 /* Lvalue operators. */
690 dSP; dMARK; dTARGET; dORIGMARK;
692 do_chop(TARG, *++MARK);
701 SETi(do_chomp(TOPs));
708 register I32 count = 0;
711 count += do_chomp(POPs);
722 if (!sv || !SvANY(sv))
724 switch (SvTYPE(sv)) {
726 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
727 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
731 if (HvARRAY(sv) || SvGMAGICAL(sv)
732 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
736 if (CvROOT(sv) || CvXSUB(sv))
753 if (!PL_op->op_private) {
762 if (SvTHINKFIRST(sv))
765 switch (SvTYPE(sv)) {
775 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
776 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
777 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
781 /* let user-undef'd sub keep its identity */
782 GV* gv = CvGV((CV*)sv);
789 SvSetMagicSV(sv, &PL_sv_undef);
793 Newz(602, gp, 1, GP);
794 GvGP(sv) = gp_ref(gp);
795 GvSV(sv) = NEWSV(72,0);
796 GvLINE(sv) = CopLINE(PL_curcop);
802 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
805 SvPV_set(sv, Nullch);
818 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
819 DIE(aTHX_ PL_no_modify);
820 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
821 SvIVX(TOPs) != IV_MIN)
824 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
835 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
836 DIE(aTHX_ PL_no_modify);
837 sv_setsv(TARG, TOPs);
838 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
839 SvIVX(TOPs) != IV_MAX)
842 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
856 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
857 DIE(aTHX_ PL_no_modify);
858 sv_setsv(TARG, TOPs);
859 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
860 SvIVX(TOPs) != IV_MIN)
863 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 /* Ordinary operators. */
876 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
879 SETn( Perl_pow( left, right) );
886 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
887 #ifdef PERL_PRESERVE_IVUV
890 /* Unless the left argument is integer in range we are going to have to
891 use NV maths. Hence only attempt to coerce the right argument if
892 we know the left is integer. */
893 /* Left operand is defined, so is it IV? */
896 bool auvok = SvUOK(TOPm1s);
897 bool buvok = SvUOK(TOPs);
898 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
899 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
906 alow = SvUVX(TOPm1s);
908 IV aiv = SvIVX(TOPm1s);
911 auvok = TRUE; /* effectively it's a UV now */
913 alow = -aiv; /* abs, auvok == false records sign */
919 IV biv = SvIVX(TOPs);
922 buvok = TRUE; /* effectively it's a UV now */
924 blow = -biv; /* abs, buvok == false records sign */
928 /* If this does sign extension on unsigned it's time for plan B */
929 ahigh = alow >> (4 * sizeof (UV));
931 bhigh = blow >> (4 * sizeof (UV));
933 if (ahigh && bhigh) {
934 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
935 which is overflow. Drop to NVs below. */
936 } else if (!ahigh && !bhigh) {
937 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
938 so the unsigned multiply cannot overflow. */
939 UV product = alow * blow;
940 if (auvok == buvok) {
941 /* -ve * -ve or +ve * +ve gives a +ve result. */
945 } else if (product <= (UV)IV_MIN) {
946 /* 2s complement assumption that (UV)-IV_MIN is correct. */
947 /* -ve result, which could overflow an IV */
949 SETi( -(IV)product );
951 } /* else drop to NVs below. */
953 /* One operand is large, 1 small */
956 /* swap the operands */
958 bhigh = blow; /* bhigh now the temp var for the swap */
962 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
963 multiplies can't overflow. shift can, add can, -ve can. */
964 product_middle = ahigh * blow;
965 if (!(product_middle & topmask)) {
966 /* OK, (ahigh * blow) won't lose bits when we shift it. */
968 product_middle <<= (4 * sizeof (UV));
969 product_low = alow * blow;
971 /* as for pp_add, UV + something mustn't get smaller.
972 IIRC ANSI mandates this wrapping *behaviour* for
973 unsigned whatever the actual representation*/
974 product_low += product_middle;
975 if (product_low >= product_middle) {
976 /* didn't overflow */
977 if (auvok == buvok) {
978 /* -ve * -ve or +ve * +ve gives a +ve result. */
982 } else if (product_low <= (UV)IV_MIN) {
983 /* 2s complement assumption again */
984 /* -ve result, which could overflow an IV */
986 SETi( -(IV)product_low );
988 } /* else drop to NVs below. */
990 } /* product_middle too large */
991 } /* ahigh && bhigh */
992 } /* SvIOK(TOPm1s) */
997 SETn( left * right );
1004 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1005 /* Only try to do UV divide first
1006 if ((SLOPPYDIVIDE is true) or
1007 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1009 The assumption is that it is better to use floating point divide
1010 whenever possible, only doing integer divide first if we can't be sure.
1011 If NV_PRESERVES_UV is true then we know at compile time that no UV
1012 can be too large to preserve, so don't need to compile the code to
1013 test the size of UVs. */
1016 # define PERL_TRY_UV_DIVIDE
1017 /* ensure that 20./5. == 4. */
1019 # ifdef PERL_PRESERVE_IVUV
1020 # ifndef NV_PRESERVES_UV
1021 # define PERL_TRY_UV_DIVIDE
1026 #ifdef PERL_TRY_UV_DIVIDE
1029 SvIV_please(TOPm1s);
1030 if (SvIOK(TOPm1s)) {
1031 bool left_non_neg = SvUOK(TOPm1s);
1032 bool right_non_neg = SvUOK(TOPs);
1036 if (right_non_neg) {
1037 right = SvUVX(TOPs);
1040 IV biv = SvIVX(TOPs);
1043 right_non_neg = TRUE; /* effectively it's a UV now */
1049 /* historically undef()/0 gives a "Use of uninitialized value"
1050 warning before dieing, hence this test goes here.
1051 If it were immediately before the second SvIV_please, then
1052 DIE() would be invoked before left was even inspected, so
1053 no inpsection would give no warning. */
1055 DIE(aTHX_ "Illegal division by zero");
1058 left = SvUVX(TOPm1s);
1061 IV aiv = SvIVX(TOPm1s);
1064 left_non_neg = TRUE; /* effectively it's a UV now */
1073 /* For sloppy divide we always attempt integer division. */
1075 /* Otherwise we only attempt it if either or both operands
1076 would not be preserved by an NV. If both fit in NVs
1077 we fall through to the NV divide code below. However,
1078 as left >= right to ensure integer result here, we know that
1079 we can skip the test on the right operand - right big
1080 enough not to be preserved can't get here unless left is
1083 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1086 /* Integer division can't overflow, but it can be imprecise. */
1087 UV result = left / right;
1088 if (result * right == left) {
1089 SP--; /* result is valid */
1090 if (left_non_neg == right_non_neg) {
1091 /* signs identical, result is positive. */
1095 /* 2s complement assumption */
1096 if (result <= (UV)IV_MIN)
1099 /* It's exact but too negative for IV. */
1100 SETn( -(NV)result );
1103 } /* tried integer divide but it was not an integer result */
1104 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1105 } /* left wasn't SvIOK */
1106 } /* right wasn't SvIOK */
1107 #endif /* PERL_TRY_UV_DIVIDE */
1111 DIE(aTHX_ "Illegal division by zero");
1112 PUSHn( left / right );
1119 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1125 bool use_double = FALSE;
1126 bool dright_valid = FALSE;
1132 right_neg = !SvUOK(TOPs);
1134 right = SvUVX(POPs);
1136 IV biv = SvIVX(POPs);
1139 right_neg = FALSE; /* effectively it's a UV now */
1147 right_neg = dright < 0;
1150 if (dright < UV_MAX_P1) {
1151 right = U_V(dright);
1152 dright_valid = TRUE; /* In case we need to use double below. */
1158 /* At this point use_double is only true if right is out of range for
1159 a UV. In range NV has been rounded down to nearest UV and
1160 use_double false. */
1162 if (!use_double && SvIOK(TOPs)) {
1164 left_neg = !SvUOK(TOPs);
1168 IV aiv = SvIVX(POPs);
1171 left_neg = FALSE; /* effectively it's a UV now */
1180 left_neg = dleft < 0;
1184 /* This should be exactly the 5.6 behaviour - if left and right are
1185 both in range for UV then use U_V() rather than floor. */
1187 if (dleft < UV_MAX_P1) {
1188 /* right was in range, so is dleft, so use UVs not double.
1192 /* left is out of range for UV, right was in range, so promote
1193 right (back) to double. */
1195 /* The +0.5 is used in 5.6 even though it is not strictly
1196 consistent with the implicit +0 floor in the U_V()
1197 inside the #if 1. */
1198 dleft = Perl_floor(dleft + 0.5);
1201 dright = Perl_floor(dright + 0.5);
1211 DIE(aTHX_ "Illegal modulus zero");
1213 dans = Perl_fmod(dleft, dright);
1214 if ((left_neg != right_neg) && dans)
1215 dans = dright - dans;
1218 sv_setnv(TARG, dans);
1224 DIE(aTHX_ "Illegal modulus zero");
1227 if ((left_neg != right_neg) && ans)
1230 /* XXX may warn: unary minus operator applied to unsigned type */
1231 /* could change -foo to be (~foo)+1 instead */
1232 if (ans <= ~((UV)IV_MAX)+1)
1233 sv_setiv(TARG, ~ans+1);
1235 sv_setnv(TARG, -(NV)ans);
1238 sv_setuv(TARG, ans);
1247 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1249 register IV count = POPi;
1250 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1252 I32 items = SP - MARK;
1255 max = items * count;
1260 *SP = sv_2mortal(newSVsv(*SP));
1266 repeatcpy((char*)(MARK + items), (char*)MARK,
1267 items * sizeof(SV*), count - 1);
1270 else if (count <= 0)
1273 else { /* Note: mark already snarfed by pp_list */
1278 SvSetSV(TARG, tmpstr);
1279 SvPV_force(TARG, len);
1280 isutf = DO_UTF8(TARG);
1285 SvGROW(TARG, (count * len) + 1);
1286 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1287 SvCUR(TARG) *= count;
1289 *SvEND(TARG) = '\0';
1292 (void)SvPOK_only_UTF8(TARG);
1294 (void)SvPOK_only(TARG);
1296 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1297 /* The parser saw this as a list repeat, and there
1298 are probably several items on the stack. But we're
1299 in scalar context, and there's no pp_list to save us
1300 now. So drop the rest of the items -- robin@kitsite.com
1313 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1314 useleft = USE_LEFT(TOPm1s);
1315 #ifdef PERL_PRESERVE_IVUV
1316 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1317 "bad things" happen if you rely on signed integers wrapping. */
1320 /* Unless the left argument is integer in range we are going to have to
1321 use NV maths. Hence only attempt to coerce the right argument if
1322 we know the left is integer. */
1323 register UV auv = 0;
1329 a_valid = auvok = 1;
1330 /* left operand is undef, treat as zero. */
1332 /* Left operand is defined, so is it IV? */
1333 SvIV_please(TOPm1s);
1334 if (SvIOK(TOPm1s)) {
1335 if ((auvok = SvUOK(TOPm1s)))
1336 auv = SvUVX(TOPm1s);
1338 register IV aiv = SvIVX(TOPm1s);
1341 auvok = 1; /* Now acting as a sign flag. */
1342 } else { /* 2s complement assumption for IV_MIN */
1350 bool result_good = 0;
1353 bool buvok = SvUOK(TOPs);
1358 register IV biv = SvIVX(TOPs);
1365 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1366 else "IV" now, independant of how it came in.
1367 if a, b represents positive, A, B negative, a maps to -A etc
1372 all UV maths. negate result if A negative.
1373 subtract if signs same, add if signs differ. */
1375 if (auvok ^ buvok) {
1384 /* Must get smaller */
1389 if (result <= buv) {
1390 /* result really should be -(auv-buv). as its negation
1391 of true value, need to swap our result flag */
1403 if (result <= (UV)IV_MIN)
1404 SETi( -(IV)result );
1406 /* result valid, but out of range for IV. */
1407 SETn( -(NV)result );
1411 } /* Overflow, drop through to NVs. */
1415 useleft = USE_LEFT(TOPm1s);
1419 /* left operand is undef, treat as zero - value */
1423 SETn( TOPn - value );
1430 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1433 if (PL_op->op_private & HINT_INTEGER) {
1447 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1450 if (PL_op->op_private & HINT_INTEGER) {
1464 dSP; tryAMAGICbinSET(lt,0);
1465 #ifdef PERL_PRESERVE_IVUV
1468 SvIV_please(TOPm1s);
1469 if (SvIOK(TOPm1s)) {
1470 bool auvok = SvUOK(TOPm1s);
1471 bool buvok = SvUOK(TOPs);
1473 if (!auvok && !buvok) { /* ## IV < IV ## */
1474 IV aiv = SvIVX(TOPm1s);
1475 IV biv = SvIVX(TOPs);
1478 SETs(boolSV(aiv < biv));
1481 if (auvok && buvok) { /* ## UV < UV ## */
1482 UV auv = SvUVX(TOPm1s);
1483 UV buv = SvUVX(TOPs);
1486 SETs(boolSV(auv < buv));
1489 if (auvok) { /* ## UV < IV ## */
1496 /* As (a) is a UV, it's >=0, so it cannot be < */
1501 SETs(boolSV(auv < (UV)biv));
1504 { /* ## IV < UV ## */
1508 aiv = SvIVX(TOPm1s);
1510 /* As (b) is a UV, it's >=0, so it must be < */
1517 SETs(boolSV((UV)aiv < buv));
1525 SETs(boolSV(TOPn < value));
1532 dSP; tryAMAGICbinSET(gt,0);
1533 #ifdef PERL_PRESERVE_IVUV
1536 SvIV_please(TOPm1s);
1537 if (SvIOK(TOPm1s)) {
1538 bool auvok = SvUOK(TOPm1s);
1539 bool buvok = SvUOK(TOPs);
1541 if (!auvok && !buvok) { /* ## IV > IV ## */
1542 IV aiv = SvIVX(TOPm1s);
1543 IV biv = SvIVX(TOPs);
1546 SETs(boolSV(aiv > biv));
1549 if (auvok && buvok) { /* ## UV > UV ## */
1550 UV auv = SvUVX(TOPm1s);
1551 UV buv = SvUVX(TOPs);
1554 SETs(boolSV(auv > buv));
1557 if (auvok) { /* ## UV > IV ## */
1564 /* As (a) is a UV, it's >=0, so it must be > */
1569 SETs(boolSV(auv > (UV)biv));
1572 { /* ## IV > UV ## */
1576 aiv = SvIVX(TOPm1s);
1578 /* As (b) is a UV, it's >=0, so it cannot be > */
1585 SETs(boolSV((UV)aiv > buv));
1593 SETs(boolSV(TOPn > value));
1600 dSP; tryAMAGICbinSET(le,0);
1601 #ifdef PERL_PRESERVE_IVUV
1604 SvIV_please(TOPm1s);
1605 if (SvIOK(TOPm1s)) {
1606 bool auvok = SvUOK(TOPm1s);
1607 bool buvok = SvUOK(TOPs);
1609 if (!auvok && !buvok) { /* ## IV <= IV ## */
1610 IV aiv = SvIVX(TOPm1s);
1611 IV biv = SvIVX(TOPs);
1614 SETs(boolSV(aiv <= biv));
1617 if (auvok && buvok) { /* ## UV <= UV ## */
1618 UV auv = SvUVX(TOPm1s);
1619 UV buv = SvUVX(TOPs);
1622 SETs(boolSV(auv <= buv));
1625 if (auvok) { /* ## UV <= IV ## */
1632 /* As (a) is a UV, it's >=0, so a cannot be <= */
1637 SETs(boolSV(auv <= (UV)biv));
1640 { /* ## IV <= UV ## */
1644 aiv = SvIVX(TOPm1s);
1646 /* As (b) is a UV, it's >=0, so a must be <= */
1653 SETs(boolSV((UV)aiv <= buv));
1661 SETs(boolSV(TOPn <= value));
1668 dSP; tryAMAGICbinSET(ge,0);
1669 #ifdef PERL_PRESERVE_IVUV
1672 SvIV_please(TOPm1s);
1673 if (SvIOK(TOPm1s)) {
1674 bool auvok = SvUOK(TOPm1s);
1675 bool buvok = SvUOK(TOPs);
1677 if (!auvok && !buvok) { /* ## IV >= IV ## */
1678 IV aiv = SvIVX(TOPm1s);
1679 IV biv = SvIVX(TOPs);
1682 SETs(boolSV(aiv >= biv));
1685 if (auvok && buvok) { /* ## UV >= UV ## */
1686 UV auv = SvUVX(TOPm1s);
1687 UV buv = SvUVX(TOPs);
1690 SETs(boolSV(auv >= buv));
1693 if (auvok) { /* ## UV >= IV ## */
1700 /* As (a) is a UV, it's >=0, so it must be >= */
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 SETs(boolSV((UV)aiv >= buv));
1729 SETs(boolSV(TOPn >= value));
1736 dSP; tryAMAGICbinSET(ne,0);
1737 #ifndef NV_PRESERVES_UV
1738 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1739 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1743 #ifdef PERL_PRESERVE_IVUV
1746 SvIV_please(TOPm1s);
1747 if (SvIOK(TOPm1s)) {
1748 bool auvok = SvUOK(TOPm1s);
1749 bool buvok = SvUOK(TOPs);
1751 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1752 IV aiv = SvIVX(TOPm1s);
1753 IV biv = SvIVX(TOPs);
1756 SETs(boolSV(aiv != biv));
1759 if (auvok && buvok) { /* ## UV != UV ## */
1760 UV auv = SvUVX(TOPm1s);
1761 UV buv = SvUVX(TOPs);
1764 SETs(boolSV(auv != buv));
1767 { /* ## Mixed IV,UV ## */
1771 /* != is commutative so swap if needed (save code) */
1773 /* swap. top of stack (b) is the iv */
1777 /* As (a) is a UV, it's >0, so it cannot be == */
1786 /* As (b) is a UV, it's >0, so it cannot be == */
1790 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1792 SETs(boolSV((UV)iv != uv));
1800 SETs(boolSV(TOPn != value));
1807 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1808 #ifndef NV_PRESERVES_UV
1809 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1810 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1814 #ifdef PERL_PRESERVE_IVUV
1815 /* Fortunately it seems NaN isn't IOK */
1818 SvIV_please(TOPm1s);
1819 if (SvIOK(TOPm1s)) {
1820 bool leftuvok = SvUOK(TOPm1s);
1821 bool rightuvok = SvUOK(TOPs);
1823 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1824 IV leftiv = SvIVX(TOPm1s);
1825 IV rightiv = SvIVX(TOPs);
1827 if (leftiv > rightiv)
1829 else if (leftiv < rightiv)
1833 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1834 UV leftuv = SvUVX(TOPm1s);
1835 UV rightuv = SvUVX(TOPs);
1837 if (leftuv > rightuv)
1839 else if (leftuv < rightuv)
1843 } else if (leftuvok) { /* ## UV <=> IV ## */
1847 rightiv = SvIVX(TOPs);
1849 /* As (a) is a UV, it's >=0, so it cannot be < */
1852 leftuv = SvUVX(TOPm1s);
1853 if (leftuv > (UV)rightiv) {
1855 } else if (leftuv < (UV)rightiv) {
1861 } else { /* ## IV <=> UV ## */
1865 leftiv = SvIVX(TOPm1s);
1867 /* As (b) is a UV, it's >=0, so it must be < */
1870 rightuv = SvUVX(TOPs);
1871 if ((UV)leftiv > rightuv) {
1873 } else if ((UV)leftiv < rightuv) {
1891 if (Perl_isnan(left) || Perl_isnan(right)) {
1895 value = (left > right) - (left < right);
1899 else if (left < right)
1901 else if (left > right)
1915 dSP; tryAMAGICbinSET(slt,0);
1918 int cmp = (IN_LOCALE_RUNTIME
1919 ? sv_cmp_locale(left, right)
1920 : sv_cmp(left, right));
1921 SETs(boolSV(cmp < 0));
1928 dSP; tryAMAGICbinSET(sgt,0);
1931 int cmp = (IN_LOCALE_RUNTIME
1932 ? sv_cmp_locale(left, right)
1933 : sv_cmp(left, right));
1934 SETs(boolSV(cmp > 0));
1941 dSP; tryAMAGICbinSET(sle,0);
1944 int cmp = (IN_LOCALE_RUNTIME
1945 ? sv_cmp_locale(left, right)
1946 : sv_cmp(left, right));
1947 SETs(boolSV(cmp <= 0));
1954 dSP; tryAMAGICbinSET(sge,0);
1957 int cmp = (IN_LOCALE_RUNTIME
1958 ? sv_cmp_locale(left, right)
1959 : sv_cmp(left, right));
1960 SETs(boolSV(cmp >= 0));
1967 dSP; tryAMAGICbinSET(seq,0);
1970 SETs(boolSV(sv_eq(left, right)));
1977 dSP; tryAMAGICbinSET(sne,0);
1980 SETs(boolSV(!sv_eq(left, right)));
1987 dSP; dTARGET; tryAMAGICbin(scmp,0);
1990 int cmp = (IN_LOCALE_RUNTIME
1991 ? sv_cmp_locale(left, right)
1992 : sv_cmp(left, right));
2000 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2003 if (SvNIOKp(left) || SvNIOKp(right)) {
2004 if (PL_op->op_private & HINT_INTEGER) {
2005 IV i = SvIV(left) & SvIV(right);
2009 UV u = SvUV(left) & SvUV(right);
2014 do_vop(PL_op->op_type, TARG, left, right);
2023 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2026 if (SvNIOKp(left) || SvNIOKp(right)) {
2027 if (PL_op->op_private & HINT_INTEGER) {
2028 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2032 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2037 do_vop(PL_op->op_type, TARG, left, right);
2046 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2049 if (SvNIOKp(left) || SvNIOKp(right)) {
2050 if (PL_op->op_private & HINT_INTEGER) {
2051 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2055 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2060 do_vop(PL_op->op_type, TARG, left, right);
2069 dSP; dTARGET; tryAMAGICun(neg);
2072 int flags = SvFLAGS(sv);
2075 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2076 /* It's publicly an integer, or privately an integer-not-float */
2079 if (SvIVX(sv) == IV_MIN) {
2080 /* 2s complement assumption. */
2081 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2084 else if (SvUVX(sv) <= IV_MAX) {
2089 else if (SvIVX(sv) != IV_MIN) {
2093 #ifdef PERL_PRESERVE_IVUV
2102 else if (SvPOKp(sv)) {
2104 char *s = SvPV(sv, len);
2105 if (isIDFIRST(*s)) {
2106 sv_setpvn(TARG, "-", 1);
2109 else if (*s == '+' || *s == '-') {
2111 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2113 else if (DO_UTF8(sv)) {
2116 goto oops_its_an_int;
2118 sv_setnv(TARG, -SvNV(sv));
2120 sv_setpvn(TARG, "-", 1);
2127 goto oops_its_an_int;
2128 sv_setnv(TARG, -SvNV(sv));
2140 dSP; tryAMAGICunSET(not);
2141 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2147 dSP; dTARGET; tryAMAGICun(compl);
2151 if (PL_op->op_private & HINT_INTEGER) {
2166 tmps = (U8*)SvPV_force(TARG, len);
2169 /* Calculate exact length, let's not estimate. */
2178 while (tmps < send) {
2179 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2180 tmps += UTF8SKIP(tmps);
2181 targlen += UNISKIP(~c);
2187 /* Now rewind strings and write them. */
2191 Newz(0, result, targlen + 1, U8);
2192 while (tmps < send) {
2193 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2194 tmps += UTF8SKIP(tmps);
2195 result = uvchr_to_utf8(result, ~c);
2199 sv_setpvn(TARG, (char*)result, targlen);
2203 Newz(0, result, nchar + 1, U8);
2204 while (tmps < send) {
2205 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2206 tmps += UTF8SKIP(tmps);
2211 sv_setpvn(TARG, (char*)result, nchar);
2219 register long *tmpl;
2220 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2223 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2228 for ( ; anum > 0; anum--, tmps++)
2237 /* integer versions of some of the above */
2241 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2244 SETi( left * right );
2251 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2255 DIE(aTHX_ "Illegal division by zero");
2256 value = POPi / value;
2264 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2268 DIE(aTHX_ "Illegal modulus zero");
2269 SETi( left % right );
2276 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2279 SETi( left + right );
2286 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2289 SETi( left - right );
2296 dSP; tryAMAGICbinSET(lt,0);
2299 SETs(boolSV(left < right));
2306 dSP; tryAMAGICbinSET(gt,0);
2309 SETs(boolSV(left > right));
2316 dSP; tryAMAGICbinSET(le,0);
2319 SETs(boolSV(left <= right));
2326 dSP; tryAMAGICbinSET(ge,0);
2329 SETs(boolSV(left >= right));
2336 dSP; tryAMAGICbinSET(eq,0);
2339 SETs(boolSV(left == right));
2346 dSP; tryAMAGICbinSET(ne,0);
2349 SETs(boolSV(left != right));
2356 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2363 else if (left < right)
2374 dSP; dTARGET; tryAMAGICun(neg);
2379 /* High falutin' math. */
2383 dSP; dTARGET; tryAMAGICbin(atan2,0);
2386 SETn(Perl_atan2(left, right));
2393 dSP; dTARGET; tryAMAGICun(sin);
2397 value = Perl_sin(value);
2405 dSP; dTARGET; tryAMAGICun(cos);
2409 value = Perl_cos(value);
2415 /* Support Configure command-line overrides for rand() functions.
2416 After 5.005, perhaps we should replace this by Configure support
2417 for drand48(), random(), or rand(). For 5.005, though, maintain
2418 compatibility by calling rand() but allow the user to override it.
2419 See INSTALL for details. --Andy Dougherty 15 July 1998
2421 /* Now it's after 5.005, and Configure supports drand48() and random(),
2422 in addition to rand(). So the overrides should not be needed any more.
2423 --Jarkko Hietaniemi 27 September 1998
2426 #ifndef HAS_DRAND48_PROTO
2427 extern double drand48 (void);
2440 if (!PL_srand_called) {
2441 (void)seedDrand01((Rand_seed_t)seed());
2442 PL_srand_called = TRUE;
2457 (void)seedDrand01((Rand_seed_t)anum);
2458 PL_srand_called = TRUE;
2467 * This is really just a quick hack which grabs various garbage
2468 * values. It really should be a real hash algorithm which
2469 * spreads the effect of every input bit onto every output bit,
2470 * if someone who knows about such things would bother to write it.
2471 * Might be a good idea to add that function to CORE as well.
2472 * No numbers below come from careful analysis or anything here,
2473 * except they are primes and SEED_C1 > 1E6 to get a full-width
2474 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2475 * probably be bigger too.
2478 # define SEED_C1 1000003
2479 #define SEED_C4 73819
2481 # define SEED_C1 25747
2482 #define SEED_C4 20639
2486 #define SEED_C5 26107
2488 #ifndef PERL_NO_DEV_RANDOM
2493 # include <starlet.h>
2494 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2495 * in 100-ns units, typically incremented ever 10 ms. */
2496 unsigned int when[2];
2498 # ifdef HAS_GETTIMEOFDAY
2499 struct timeval when;
2505 /* This test is an escape hatch, this symbol isn't set by Configure. */
2506 #ifndef PERL_NO_DEV_RANDOM
2507 #ifndef PERL_RANDOM_DEVICE
2508 /* /dev/random isn't used by default because reads from it will block
2509 * if there isn't enough entropy available. You can compile with
2510 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2511 * is enough real entropy to fill the seed. */
2512 # define PERL_RANDOM_DEVICE "/dev/urandom"
2514 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2516 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2525 _ckvmssts(sys$gettim(when));
2526 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2528 # ifdef HAS_GETTIMEOFDAY
2529 gettimeofday(&when,(struct timezone *) 0);
2530 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2533 u = (U32)SEED_C1 * when;
2536 u += SEED_C3 * (U32)PerlProc_getpid();
2537 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2538 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2539 u += SEED_C5 * (U32)PTR2UV(&when);
2546 dSP; dTARGET; tryAMAGICun(exp);
2550 value = Perl_exp(value);
2558 dSP; dTARGET; tryAMAGICun(log);
2563 SET_NUMERIC_STANDARD();
2564 DIE(aTHX_ "Can't take log of %g", value);
2566 value = Perl_log(value);
2574 dSP; dTARGET; tryAMAGICun(sqrt);
2579 SET_NUMERIC_STANDARD();
2580 DIE(aTHX_ "Can't take sqrt of %g", value);
2582 value = Perl_sqrt(value);
2590 dSP; dTARGET; tryAMAGICun(int);
2593 IV iv = TOPi; /* attempt to convert to IV if possible. */
2594 /* XXX it's arguable that compiler casting to IV might be subtly
2595 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2596 else preferring IV has introduced a subtle behaviour change bug. OTOH
2597 relying on floating point to be accurate is a bug. */
2608 if (value < (NV)UV_MAX + 0.5) {
2611 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2612 # ifdef HAS_MODFL_POW32_BUG
2613 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2615 NV offset = Perl_modf(value, &value);
2616 (void)Perl_modf(offset, &offset);
2620 (void)Perl_modf(value, &value);
2623 double tmp = (double)value;
2624 (void)Perl_modf(tmp, &tmp);
2631 if (value > (NV)IV_MIN - 0.5) {
2634 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2635 # ifdef HAS_MODFL_POW32_BUG
2636 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2638 NV offset = Perl_modf(-value, &value);
2639 (void)Perl_modf(offset, &offset);
2643 (void)Perl_modf(-value, &value);
2647 double tmp = (double)value;
2648 (void)Perl_modf(-tmp, &tmp);
2661 dSP; dTARGET; tryAMAGICun(abs);
2663 /* This will cache the NV value if string isn't actually integer */
2667 /* IVX is precise */
2669 SETu(TOPu); /* force it to be numeric only */
2677 /* 2s complement assumption. Also, not really needed as
2678 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2698 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2703 tmps = (SvPVx(POPs, len));
2704 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2705 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2718 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2723 tmps = (SvPVx(POPs, len));
2724 while (*tmps && len && isSPACE(*tmps))
2729 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2730 else if (*tmps == 'b')
2731 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2733 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2735 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2752 SETi(sv_len_utf8(sv));
2768 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2770 I32 arybase = PL_curcop->cop_arybase;
2774 int num_args = PL_op->op_private & 7;
2775 bool repl_need_utf8_upgrade = FALSE;
2776 bool repl_is_utf8 = FALSE;
2778 SvTAINTED_off(TARG); /* decontaminate */
2779 SvUTF8_off(TARG); /* decontaminate */
2783 repl = SvPV(repl_sv, repl_len);
2784 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2794 sv_utf8_upgrade(sv);
2796 else if (DO_UTF8(sv))
2797 repl_need_utf8_upgrade = TRUE;
2799 tmps = SvPV(sv, curlen);
2801 utf8_curlen = sv_len_utf8(sv);
2802 if (utf8_curlen == curlen)
2805 curlen = utf8_curlen;
2810 if (pos >= arybase) {
2828 else if (len >= 0) {
2830 if (rem > (I32)curlen)
2845 Perl_croak(aTHX_ "substr outside of string");
2846 if (ckWARN(WARN_SUBSTR))
2847 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2854 sv_pos_u2b(sv, &pos, &rem);
2856 sv_setpvn(TARG, tmps, rem);
2857 #ifdef USE_LOCALE_COLLATE
2858 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2863 SV* repl_sv_copy = NULL;
2865 if (repl_need_utf8_upgrade) {
2866 repl_sv_copy = newSVsv(repl_sv);
2867 sv_utf8_upgrade(repl_sv_copy);
2868 repl = SvPV(repl_sv_copy, repl_len);
2869 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2871 sv_insert(sv, pos, rem, repl, repl_len);
2875 SvREFCNT_dec(repl_sv_copy);
2877 else if (lvalue) { /* it's an lvalue! */
2878 if (!SvGMAGICAL(sv)) {
2882 if (ckWARN(WARN_SUBSTR))
2883 Perl_warner(aTHX_ WARN_SUBSTR,
2884 "Attempt to use reference as lvalue in substr");
2886 if (SvOK(sv)) /* is it defined ? */
2887 (void)SvPOK_only_UTF8(sv);
2889 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2892 if (SvTYPE(TARG) < SVt_PVLV) {
2893 sv_upgrade(TARG, SVt_PVLV);
2894 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2898 if (LvTARG(TARG) != sv) {
2900 SvREFCNT_dec(LvTARG(TARG));
2901 LvTARG(TARG) = SvREFCNT_inc(sv);
2903 LvTARGOFF(TARG) = upos;
2904 LvTARGLEN(TARG) = urem;
2908 PUSHs(TARG); /* avoid SvSETMAGIC here */
2915 register IV size = POPi;
2916 register IV offset = POPi;
2917 register SV *src = POPs;
2918 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2920 SvTAINTED_off(TARG); /* decontaminate */
2921 if (lvalue) { /* it's an lvalue! */
2922 if (SvTYPE(TARG) < SVt_PVLV) {
2923 sv_upgrade(TARG, SVt_PVLV);
2924 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2927 if (LvTARG(TARG) != src) {
2929 SvREFCNT_dec(LvTARG(TARG));
2930 LvTARG(TARG) = SvREFCNT_inc(src);
2932 LvTARGOFF(TARG) = offset;
2933 LvTARGLEN(TARG) = size;
2936 sv_setuv(TARG, do_vecget(src, offset, size));
2951 I32 arybase = PL_curcop->cop_arybase;
2956 offset = POPi - arybase;
2959 tmps = SvPV(big, biglen);
2960 if (offset > 0 && DO_UTF8(big))
2961 sv_pos_u2b(big, &offset, 0);
2964 else if (offset > biglen)
2966 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2967 (unsigned char*)tmps + biglen, little, 0)))
2970 retval = tmps2 - tmps;
2971 if (retval > 0 && DO_UTF8(big))
2972 sv_pos_b2u(big, &retval);
2973 PUSHi(retval + arybase);
2988 I32 arybase = PL_curcop->cop_arybase;
2994 tmps2 = SvPV(little, llen);
2995 tmps = SvPV(big, blen);
2999 if (offset > 0 && DO_UTF8(big))
3000 sv_pos_u2b(big, &offset, 0);
3001 offset = offset - arybase + llen;
3005 else if (offset > blen)
3007 if (!(tmps2 = rninstr(tmps, tmps + offset,
3008 tmps2, tmps2 + llen)))
3011 retval = tmps2 - tmps;
3012 if (retval > 0 && DO_UTF8(big))
3013 sv_pos_b2u(big, &retval);
3014 PUSHi(retval + arybase);
3020 dSP; dMARK; dORIGMARK; dTARGET;
3021 do_sprintf(TARG, SP-MARK, MARK+1);
3022 TAINT_IF(SvTAINTED(TARG));
3023 if (DO_UTF8(*(MARK+1)))
3035 U8 *s = (U8*)SvPVx(argsv, len);
3037 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3047 (void)SvUPGRADE(TARG,SVt_PV);
3049 if (value > 255 && !IN_BYTES) {
3050 SvGROW(TARG, UNISKIP(value)+1);
3051 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3052 SvCUR_set(TARG, tmps - SvPVX(TARG));
3054 (void)SvPOK_only(TARG);
3065 (void)SvPOK_only(TARG);
3072 dSP; dTARGET; dPOPTOPssrl;
3076 char *tmps = SvPV(left, len);
3078 if (DO_UTF8(left)) {
3079 /* If Unicode take the crypt() of the low 8 bits
3080 * of the characters of the string. */
3082 char *send = tmps + len;
3084 Newz(688, t, len, char);
3086 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3092 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3094 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3099 "The crypt() function is unimplemented due to excessive paranoia.");
3113 U8 tmpbuf[UTF8_MAXLEN*2+1];
3117 s = (U8*)SvPV(sv, slen);
3118 utf8_to_uvchr(s, &ulen);
3120 toTITLE_utf8(s, tmpbuf, &tculen);
3121 utf8_to_uvchr(tmpbuf, 0);
3123 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3125 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3126 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3131 s = (U8*)SvPV_force(sv, slen);
3132 Copy(tmpbuf, s, tculen, U8);
3136 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3138 SvUTF8_off(TARG); /* decontaminate */
3143 s = (U8*)SvPV_force(sv, slen);
3145 if (IN_LOCALE_RUNTIME) {
3148 *s = toUPPER_LC(*s);
3166 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3168 U8 tmpbuf[UTF8_MAXLEN*2+1];
3172 toLOWER_utf8(s, tmpbuf, &ulen);
3173 uv = utf8_to_uvchr(tmpbuf, 0);
3175 tend = uvchr_to_utf8(tmpbuf, uv);
3177 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3179 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3180 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3185 s = (U8*)SvPV_force(sv, slen);
3186 Copy(tmpbuf, s, ulen, U8);
3190 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3192 SvUTF8_off(TARG); /* decontaminate */
3197 s = (U8*)SvPV_force(sv, slen);
3199 if (IN_LOCALE_RUNTIME) {
3202 *s = toLOWER_LC(*s);
3225 U8 tmpbuf[UTF8_MAXLEN*2+1];
3227 s = (U8*)SvPV(sv,len);
3229 SvUTF8_off(TARG); /* decontaminate */
3230 sv_setpvn(TARG, "", 0);
3234 (void)SvUPGRADE(TARG, SVt_PV);
3235 SvGROW(TARG, (len * 2) + 1);
3236 (void)SvPOK_only(TARG);
3237 d = (U8*)SvPVX(TARG);
3240 toUPPER_utf8(s, tmpbuf, &ulen);
3241 Copy(tmpbuf, d, ulen, U8);
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++)
3292 U8 tmpbuf[UTF8_MAXLEN*2+1];
3294 s = (U8*)SvPV(sv,len);
3296 SvUTF8_off(TARG); /* decontaminate */
3297 sv_setpvn(TARG, "", 0);
3301 (void)SvUPGRADE(TARG, SVt_PV);
3302 SvGROW(TARG, (len * 2) + 1);
3303 (void)SvPOK_only(TARG);
3304 d = (U8*)SvPVX(TARG);
3307 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3308 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3309 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3311 * Now if the sigma is NOT followed by
3312 * /$ignorable_sequence$cased_letter/;
3313 * and it IS preceded by
3314 * /$cased_letter$ignorable_sequence/;
3315 * where $ignorable_sequence is
3316 * [\x{2010}\x{AD}\p{Mn}]*
3317 * and $cased_letter is
3318 * [\p{Ll}\p{Lo}\p{Lt}]
3319 * then it should be mapped to 0x03C2,
3320 * (GREEK SMALL LETTER FINAL SIGMA),
3321 * instead of staying 0x03A3.
3322 * See lib/unicore/SpecCase.txt.
3325 Copy(tmpbuf, d, ulen, U8);
3331 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3336 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3338 SvUTF8_off(TARG); /* decontaminate */
3344 s = (U8*)SvPV_force(sv, len);
3346 register U8 *send = s + len;
3348 if (IN_LOCALE_RUNTIME) {
3351 for (; s < send; s++)
3352 *s = toLOWER_LC(*s);
3355 for (; s < send; s++)
3370 register char *s = SvPV(sv,len);
3373 SvUTF8_off(TARG); /* decontaminate */
3375 (void)SvUPGRADE(TARG, SVt_PV);
3376 SvGROW(TARG, (len * 2) + 1);
3380 if (UTF8_IS_CONTINUED(*s)) {
3381 STRLEN ulen = UTF8SKIP(s);
3405 SvCUR_set(TARG, d - SvPVX(TARG));
3406 (void)SvPOK_only_UTF8(TARG);
3409 sv_setpvn(TARG, s, len);
3411 if (SvSMAGICAL(TARG))
3420 dSP; dMARK; dORIGMARK;
3422 register AV* av = (AV*)POPs;
3423 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3424 I32 arybase = PL_curcop->cop_arybase;
3427 if (SvTYPE(av) == SVt_PVAV) {
3428 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3430 for (svp = MARK + 1; svp <= SP; svp++) {
3435 if (max > AvMAX(av))
3438 while (++MARK <= SP) {
3439 elem = SvIVx(*MARK);
3443 svp = av_fetch(av, elem, lval);
3445 if (!svp || *svp == &PL_sv_undef)
3446 DIE(aTHX_ PL_no_aelem, elem);
3447 if (PL_op->op_private & OPpLVAL_INTRO)
3448 save_aelem(av, elem, svp);
3450 *MARK = svp ? *svp : &PL_sv_undef;
3453 if (GIMME != G_ARRAY) {
3461 /* Associative arrays. */
3466 HV *hash = (HV*)POPs;
3468 I32 gimme = GIMME_V;
3469 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3472 /* might clobber stack_sp */
3473 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3478 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3479 if (gimme == G_ARRAY) {
3482 /* might clobber stack_sp */
3484 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3489 else if (gimme == G_SCALAR)
3508 I32 gimme = GIMME_V;
3509 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3513 if (PL_op->op_private & OPpSLICE) {
3517 hvtype = SvTYPE(hv);
3518 if (hvtype == SVt_PVHV) { /* hash element */
3519 while (++MARK <= SP) {
3520 sv = hv_delete_ent(hv, *MARK, discard, 0);
3521 *MARK = sv ? sv : &PL_sv_undef;
3524 else if (hvtype == SVt_PVAV) {
3525 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3526 while (++MARK <= SP) {
3527 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3528 *MARK = sv ? sv : &PL_sv_undef;
3531 else { /* pseudo-hash element */
3532 while (++MARK <= SP) {
3533 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3534 *MARK = sv ? sv : &PL_sv_undef;
3539 DIE(aTHX_ "Not a HASH reference");
3542 else if (gimme == G_SCALAR) {
3551 if (SvTYPE(hv) == SVt_PVHV)
3552 sv = hv_delete_ent(hv, keysv, discard, 0);
3553 else if (SvTYPE(hv) == SVt_PVAV) {
3554 if (PL_op->op_flags & OPf_SPECIAL)
3555 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3557 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3560 DIE(aTHX_ "Not a HASH reference");
3575 if (PL_op->op_private & OPpEXISTS_SUB) {
3579 cv = sv_2cv(sv, &hv, &gv, FALSE);
3582 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3588 if (SvTYPE(hv) == SVt_PVHV) {
3589 if (hv_exists_ent(hv, tmpsv, 0))
3592 else if (SvTYPE(hv) == SVt_PVAV) {
3593 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3594 if (av_exists((AV*)hv, SvIV(tmpsv)))
3597 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3601 DIE(aTHX_ "Not a HASH reference");
3608 dSP; dMARK; dORIGMARK;
3609 register HV *hv = (HV*)POPs;
3610 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3611 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3613 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3614 DIE(aTHX_ "Can't localize pseudo-hash element");
3616 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3617 while (++MARK <= SP) {
3620 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3621 realhv ? hv_exists_ent(hv, keysv, 0)
3622 : avhv_exists_ent((AV*)hv, keysv, 0);
3624 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3625 svp = he ? &HeVAL(he) : 0;
3628 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3631 if (!svp || *svp == &PL_sv_undef) {
3633 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3635 if (PL_op->op_private & OPpLVAL_INTRO) {
3637 save_helem(hv, keysv, svp);
3640 char *key = SvPV(keysv, keylen);
3641 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3645 *MARK = svp ? *svp : &PL_sv_undef;
3648 if (GIMME != G_ARRAY) {
3656 /* List operators. */
3661 if (GIMME != G_ARRAY) {
3663 *MARK = *SP; /* unwanted list, return last item */
3665 *MARK = &PL_sv_undef;
3674 SV **lastrelem = PL_stack_sp;
3675 SV **lastlelem = PL_stack_base + POPMARK;
3676 SV **firstlelem = PL_stack_base + POPMARK + 1;
3677 register SV **firstrelem = lastlelem + 1;
3678 I32 arybase = PL_curcop->cop_arybase;
3679 I32 lval = PL_op->op_flags & OPf_MOD;
3680 I32 is_something_there = lval;
3682 register I32 max = lastrelem - lastlelem;
3683 register SV **lelem;
3686 if (GIMME != G_ARRAY) {
3687 ix = SvIVx(*lastlelem);
3692 if (ix < 0 || ix >= max)
3693 *firstlelem = &PL_sv_undef;
3695 *firstlelem = firstrelem[ix];
3701 SP = firstlelem - 1;
3705 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3711 if (ix < 0 || ix >= max)
3712 *lelem = &PL_sv_undef;
3714 is_something_there = TRUE;
3715 if (!(*lelem = firstrelem[ix]))
3716 *lelem = &PL_sv_undef;
3719 if (is_something_there)
3722 SP = firstlelem - 1;
3728 dSP; dMARK; dORIGMARK;
3729 I32 items = SP - MARK;
3730 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3731 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3738 dSP; dMARK; dORIGMARK;
3739 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3743 SV *val = NEWSV(46, 0);
3745 sv_setsv(val, *++MARK);
3746 else if (ckWARN(WARN_MISC))
3747 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3748 (void)hv_store_ent(hv,key,val,0);
3757 dSP; dMARK; dORIGMARK;
3758 register AV *ary = (AV*)*++MARK;
3762 register I32 offset;
3763 register I32 length;
3770 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3771 *MARK-- = SvTIED_obj((SV*)ary, mg);
3775 call_method("SPLICE",GIMME_V);
3784 offset = i = SvIVx(*MARK);
3786 offset += AvFILLp(ary) + 1;
3788 offset -= PL_curcop->cop_arybase;
3790 DIE(aTHX_ PL_no_aelem, i);
3792 length = SvIVx(*MARK++);
3794 length += AvFILLp(ary) - offset + 1;
3800 length = AvMAX(ary) + 1; /* close enough to infinity */
3804 length = AvMAX(ary) + 1;
3806 if (offset > AvFILLp(ary) + 1)
3807 offset = AvFILLp(ary) + 1;
3808 after = AvFILLp(ary) + 1 - (offset + length);
3809 if (after < 0) { /* not that much array */
3810 length += after; /* offset+length now in array */
3816 /* At this point, MARK .. SP-1 is our new LIST */
3819 diff = newlen - length;
3820 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3823 if (diff < 0) { /* shrinking the area */
3825 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3826 Copy(MARK, tmparyval, newlen, SV*);
3829 MARK = ORIGMARK + 1;
3830 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3831 MEXTEND(MARK, length);
3832 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3834 EXTEND_MORTAL(length);
3835 for (i = length, dst = MARK; i; i--) {
3836 sv_2mortal(*dst); /* free them eventualy */
3843 *MARK = AvARRAY(ary)[offset+length-1];
3846 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3847 SvREFCNT_dec(*dst++); /* free them now */
3850 AvFILLp(ary) += diff;
3852 /* pull up or down? */
3854 if (offset < after) { /* easier to pull up */
3855 if (offset) { /* esp. if nothing to pull */
3856 src = &AvARRAY(ary)[offset-1];
3857 dst = src - diff; /* diff is negative */
3858 for (i = offset; i > 0; i--) /* can't trust Copy */
3862 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3866 if (after) { /* anything to pull down? */
3867 src = AvARRAY(ary) + offset + length;
3868 dst = src + diff; /* diff is negative */
3869 Move(src, dst, after, SV*);
3871 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3872 /* avoid later double free */
3876 dst[--i] = &PL_sv_undef;
3879 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3881 *dst = NEWSV(46, 0);
3882 sv_setsv(*dst++, *src++);
3884 Safefree(tmparyval);
3887 else { /* no, expanding (or same) */
3889 New(452, tmparyval, length, SV*); /* so remember deletion */
3890 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3893 if (diff > 0) { /* expanding */
3895 /* push up or down? */
3897 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3901 Move(src, dst, offset, SV*);
3903 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3905 AvFILLp(ary) += diff;
3908 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3909 av_extend(ary, AvFILLp(ary) + diff);
3910 AvFILLp(ary) += diff;
3913 dst = AvARRAY(ary) + AvFILLp(ary);
3915 for (i = after; i; i--) {
3922 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3923 *dst = NEWSV(46, 0);
3924 sv_setsv(*dst++, *src++);
3926 MARK = ORIGMARK + 1;
3927 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3929 Copy(tmparyval, MARK, length, SV*);
3931 EXTEND_MORTAL(length);
3932 for (i = length, dst = MARK; i; i--) {
3933 sv_2mortal(*dst); /* free them eventualy */
3937 Safefree(tmparyval);
3941 else if (length--) {
3942 *MARK = tmparyval[length];
3945 while (length-- > 0)
3946 SvREFCNT_dec(tmparyval[length]);
3948 Safefree(tmparyval);
3951 *MARK = &PL_sv_undef;
3959 dSP; dMARK; dORIGMARK; dTARGET;
3960 register AV *ary = (AV*)*++MARK;
3961 register SV *sv = &PL_sv_undef;
3964 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3965 *MARK-- = SvTIED_obj((SV*)ary, mg);
3969 call_method("PUSH",G_SCALAR|G_DISCARD);
3974 /* Why no pre-extend of ary here ? */
3975 for (++MARK; MARK <= SP; MARK++) {
3978 sv_setsv(sv, *MARK);
3983 PUSHi( AvFILL(ary) + 1 );
3991 SV *sv = av_pop(av);
3993 (void)sv_2mortal(sv);
4002 SV *sv = av_shift(av);
4007 (void)sv_2mortal(sv);
4014 dSP; dMARK; dORIGMARK; dTARGET;
4015 register AV *ary = (AV*)*++MARK;
4020 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4021 *MARK-- = SvTIED_obj((SV*)ary, mg);
4025 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4030 av_unshift(ary, SP - MARK);
4033 sv_setsv(sv, *++MARK);
4034 (void)av_store(ary, i++, sv);
4038 PUSHi( AvFILL(ary) + 1 );
4048 if (GIMME == G_ARRAY) {
4055 /* safe as long as stack cannot get extended in the above */
4060 register char *down;
4065 SvUTF8_off(TARG); /* decontaminate */
4067 do_join(TARG, &PL_sv_no, MARK, SP);
4069 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4070 up = SvPV_force(TARG, len);
4072 if (DO_UTF8(TARG)) { /* first reverse each character */
4073 U8* s = (U8*)SvPVX(TARG);
4074 U8* send = (U8*)(s + len);
4076 if (UTF8_IS_INVARIANT(*s)) {
4081 if (!utf8_to_uvchr(s, 0))
4085 down = (char*)(s - 1);
4086 /* reverse this character */
4096 down = SvPVX(TARG) + len - 1;
4102 (void)SvPOK_only_UTF8(TARG);
4114 register IV limit = POPi; /* note, negative is forever */
4117 register char *s = SvPV(sv, len);
4118 bool do_utf8 = DO_UTF8(sv);
4119 char *strend = s + len;
4121 register REGEXP *rx;
4125 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4126 I32 maxiters = slen + 10;
4129 I32 origlimit = limit;
4132 AV *oldstack = PL_curstack;
4133 I32 gimme = GIMME_V;
4134 I32 oldsave = PL_savestack_ix;
4135 I32 make_mortal = 1;
4136 MAGIC *mg = (MAGIC *) NULL;
4139 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4144 DIE(aTHX_ "panic: pp_split");
4147 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4148 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4150 PL_reg_match_utf8 = do_utf8;
4152 if (pm->op_pmreplroot) {
4154 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4156 ary = GvAVn((GV*)pm->op_pmreplroot);
4159 else if (gimme != G_ARRAY)
4160 #ifdef USE_5005THREADS
4161 ary = (AV*)PL_curpad[0];
4163 ary = GvAVn(PL_defgv);
4164 #endif /* USE_5005THREADS */
4167 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4173 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4175 XPUSHs(SvTIED_obj((SV*)ary, mg));
4181 for (i = AvFILLp(ary); i >= 0; i--)
4182 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4184 /* temporarily switch stacks */
4185 SWITCHSTACK(PL_curstack, ary);
4189 base = SP - PL_stack_base;
4191 if (pm->op_pmflags & PMf_SKIPWHITE) {
4192 if (pm->op_pmflags & PMf_LOCALE) {
4193 while (isSPACE_LC(*s))
4201 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4202 SAVEINT(PL_multiline);
4203 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4207 limit = maxiters + 2;
4208 if (pm->op_pmflags & PMf_WHITE) {
4211 while (m < strend &&
4212 !((pm->op_pmflags & PMf_LOCALE)
4213 ? isSPACE_LC(*m) : isSPACE(*m)))
4218 dstr = NEWSV(30, m-s);
4219 sv_setpvn(dstr, s, m-s);
4223 (void)SvUTF8_on(dstr);
4227 while (s < strend &&
4228 ((pm->op_pmflags & PMf_LOCALE)
4229 ? isSPACE_LC(*s) : isSPACE(*s)))
4233 else if (strEQ("^", rx->precomp)) {
4236 for (m = s; m < strend && *m != '\n'; m++) ;
4240 dstr = NEWSV(30, m-s);
4241 sv_setpvn(dstr, s, m-s);
4245 (void)SvUTF8_on(dstr);
4250 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4251 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4252 && (rx->reganch & ROPT_CHECK_ALL)
4253 && !(rx->reganch & ROPT_ANCH)) {
4254 int tail = (rx->reganch & RE_INTUIT_TAIL);
4255 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4258 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4260 char c = *SvPV(csv, n_a);
4263 for (m = s; m < strend && *m != c; m++) ;
4266 dstr = NEWSV(30, m-s);
4267 sv_setpvn(dstr, s, m-s);
4271 (void)SvUTF8_on(dstr);
4273 /* The rx->minlen is in characters but we want to step
4274 * s ahead by bytes. */
4276 s = (char*)utf8_hop((U8*)m, len);
4278 s = m + len; /* Fake \n at the end */
4283 while (s < strend && --limit &&
4284 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4285 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4288 dstr = NEWSV(31, m-s);
4289 sv_setpvn(dstr, s, m-s);
4293 (void)SvUTF8_on(dstr);
4295 /* The rx->minlen is in characters but we want to step
4296 * s ahead by bytes. */
4298 s = (char*)utf8_hop((U8*)m, len);
4300 s = m + len; /* Fake \n at the end */
4305 maxiters += slen * rx->nparens;
4306 while (s < strend && --limit
4307 /* && (!rx->check_substr
4308 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4310 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4311 1 /* minend */, sv, NULL, 0))
4313 TAINT_IF(RX_MATCH_TAINTED(rx));
4314 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4319 strend = s + (strend - m);
4321 m = rx->startp[0] + orig;
4322 dstr = NEWSV(32, m-s);
4323 sv_setpvn(dstr, s, m-s);
4327 (void)SvUTF8_on(dstr);
4330 for (i = 1; i <= rx->nparens; i++) {
4331 s = rx->startp[i] + orig;
4332 m = rx->endp[i] + orig;
4334 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4335 parens that didn't match -- they should be set to
4336 undef, not the empty string */
4337 if (m >= orig && s >= orig) {
4338 dstr = NEWSV(33, m-s);
4339 sv_setpvn(dstr, s, m-s);
4342 dstr = &PL_sv_undef; /* undef, not "" */
4346 (void)SvUTF8_on(dstr);
4350 s = rx->endp[0] + orig;
4354 LEAVE_SCOPE(oldsave);
4355 iters = (SP - PL_stack_base) - base;
4356 if (iters > maxiters)
4357 DIE(aTHX_ "Split loop");
4359 /* keep field after final delim? */
4360 if (s < strend || (iters && origlimit)) {
4361 STRLEN l = strend - s;
4362 dstr = NEWSV(34, l);
4363 sv_setpvn(dstr, s, l);
4367 (void)SvUTF8_on(dstr);
4371 else if (!origlimit) {
4372 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4378 SWITCHSTACK(ary, oldstack);
4379 if (SvSMAGICAL(ary)) {
4384 if (gimme == G_ARRAY) {
4386 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4394 call_method("PUSH",G_SCALAR|G_DISCARD);
4397 if (gimme == G_ARRAY) {
4398 /* EXTEND should not be needed - we just popped them */
4400 for (i=0; i < iters; i++) {
4401 SV **svp = av_fetch(ary, i, FALSE);
4402 PUSHs((svp) ? *svp : &PL_sv_undef);
4409 if (gimme == G_ARRAY)
4412 if (iters || !pm->op_pmreplroot) {
4420 #ifdef USE_5005THREADS
4422 Perl_unlock_condpair(pTHX_ void *svv)
4424 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4427 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4428 MUTEX_LOCK(MgMUTEXP(mg));
4429 if (MgOWNER(mg) != thr)
4430 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4432 COND_SIGNAL(MgOWNERCONDP(mg));
4433 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4434 PTR2UV(thr), PTR2UV(svv)));
4435 MUTEX_UNLOCK(MgMUTEXP(mg));
4437 #endif /* USE_5005THREADS */
4444 #ifdef USE_5005THREADS
4446 #endif /* USE_5005THREADS */
4448 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4450 Perl_sharedsv_lock(aTHX_ ssv);
4451 #endif /* USE_ITHREADS */
4452 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4453 || SvTYPE(retsv) == SVt_PVCV) {
4454 retsv = refto(retsv);
4462 #ifdef USE_5005THREADS
4465 if (PL_op->op_private & OPpLVAL_INTRO)
4466 PUSHs(*save_threadsv(PL_op->op_targ));
4468 PUSHs(THREADSV(PL_op->op_targ));
4471 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4472 #endif /* USE_5005THREADS */