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 /* This code was intended to fix 20010809.028:
1263 for (($x =~ /./g) x 2) {
1264 print chop; # "abcdabcd" expected as output.
1267 * but that change (#11635) broke this code:
1269 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1271 * I can't think of a better fix that doesn't introduce
1272 * an efficiency hit by copying the SVs. The stack isn't
1273 * refcounted, and mortalisation obviously doesn't
1274 * Do The Right Thing when the stack has more than
1275 * one pointer to the same mortal value.
1279 *SP = sv_2mortal(newSVsv(*SP));
1289 repeatcpy((char*)(MARK + items), (char*)MARK,
1290 items * sizeof(SV*), count - 1);
1293 else if (count <= 0)
1296 else { /* Note: mark already snarfed by pp_list */
1301 SvSetSV(TARG, tmpstr);
1302 SvPV_force(TARG, len);
1303 isutf = DO_UTF8(TARG);
1308 SvGROW(TARG, (count * len) + 1);
1309 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1310 SvCUR(TARG) *= count;
1312 *SvEND(TARG) = '\0';
1315 (void)SvPOK_only_UTF8(TARG);
1317 (void)SvPOK_only(TARG);
1319 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1320 /* The parser saw this as a list repeat, and there
1321 are probably several items on the stack. But we're
1322 in scalar context, and there's no pp_list to save us
1323 now. So drop the rest of the items -- robin@kitsite.com
1336 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1337 useleft = USE_LEFT(TOPm1s);
1338 #ifdef PERL_PRESERVE_IVUV
1339 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1340 "bad things" happen if you rely on signed integers wrapping. */
1343 /* Unless the left argument is integer in range we are going to have to
1344 use NV maths. Hence only attempt to coerce the right argument if
1345 we know the left is integer. */
1346 register UV auv = 0;
1352 a_valid = auvok = 1;
1353 /* left operand is undef, treat as zero. */
1355 /* Left operand is defined, so is it IV? */
1356 SvIV_please(TOPm1s);
1357 if (SvIOK(TOPm1s)) {
1358 if ((auvok = SvUOK(TOPm1s)))
1359 auv = SvUVX(TOPm1s);
1361 register IV aiv = SvIVX(TOPm1s);
1364 auvok = 1; /* Now acting as a sign flag. */
1365 } else { /* 2s complement assumption for IV_MIN */
1373 bool result_good = 0;
1376 bool buvok = SvUOK(TOPs);
1381 register IV biv = SvIVX(TOPs);
1388 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1389 else "IV" now, independant of how it came in.
1390 if a, b represents positive, A, B negative, a maps to -A etc
1395 all UV maths. negate result if A negative.
1396 subtract if signs same, add if signs differ. */
1398 if (auvok ^ buvok) {
1407 /* Must get smaller */
1412 if (result <= buv) {
1413 /* result really should be -(auv-buv). as its negation
1414 of true value, need to swap our result flag */
1426 if (result <= (UV)IV_MIN)
1427 SETi( -(IV)result );
1429 /* result valid, but out of range for IV. */
1430 SETn( -(NV)result );
1434 } /* Overflow, drop through to NVs. */
1438 useleft = USE_LEFT(TOPm1s);
1442 /* left operand is undef, treat as zero - value */
1446 SETn( TOPn - value );
1453 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1456 if (PL_op->op_private & HINT_INTEGER) {
1470 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1473 if (PL_op->op_private & HINT_INTEGER) {
1487 dSP; tryAMAGICbinSET(lt,0);
1488 #ifdef PERL_PRESERVE_IVUV
1491 SvIV_please(TOPm1s);
1492 if (SvIOK(TOPm1s)) {
1493 bool auvok = SvUOK(TOPm1s);
1494 bool buvok = SvUOK(TOPs);
1496 if (!auvok && !buvok) { /* ## IV < IV ## */
1497 IV aiv = SvIVX(TOPm1s);
1498 IV biv = SvIVX(TOPs);
1501 SETs(boolSV(aiv < biv));
1504 if (auvok && buvok) { /* ## UV < UV ## */
1505 UV auv = SvUVX(TOPm1s);
1506 UV buv = SvUVX(TOPs);
1509 SETs(boolSV(auv < buv));
1512 if (auvok) { /* ## UV < IV ## */
1519 /* As (a) is a UV, it's >=0, so it cannot be < */
1524 SETs(boolSV(auv < (UV)biv));
1527 { /* ## IV < UV ## */
1531 aiv = SvIVX(TOPm1s);
1533 /* As (b) is a UV, it's >=0, so it must be < */
1540 SETs(boolSV((UV)aiv < buv));
1548 SETs(boolSV(TOPn < value));
1555 dSP; tryAMAGICbinSET(gt,0);
1556 #ifdef PERL_PRESERVE_IVUV
1559 SvIV_please(TOPm1s);
1560 if (SvIOK(TOPm1s)) {
1561 bool auvok = SvUOK(TOPm1s);
1562 bool buvok = SvUOK(TOPs);
1564 if (!auvok && !buvok) { /* ## IV > IV ## */
1565 IV aiv = SvIVX(TOPm1s);
1566 IV biv = SvIVX(TOPs);
1569 SETs(boolSV(aiv > biv));
1572 if (auvok && buvok) { /* ## UV > UV ## */
1573 UV auv = SvUVX(TOPm1s);
1574 UV buv = SvUVX(TOPs);
1577 SETs(boolSV(auv > buv));
1580 if (auvok) { /* ## UV > IV ## */
1587 /* As (a) is a UV, it's >=0, so it must be > */
1592 SETs(boolSV(auv > (UV)biv));
1595 { /* ## IV > UV ## */
1599 aiv = SvIVX(TOPm1s);
1601 /* As (b) is a UV, it's >=0, so it cannot be > */
1608 SETs(boolSV((UV)aiv > buv));
1616 SETs(boolSV(TOPn > value));
1623 dSP; tryAMAGICbinSET(le,0);
1624 #ifdef PERL_PRESERVE_IVUV
1627 SvIV_please(TOPm1s);
1628 if (SvIOK(TOPm1s)) {
1629 bool auvok = SvUOK(TOPm1s);
1630 bool buvok = SvUOK(TOPs);
1632 if (!auvok && !buvok) { /* ## IV <= IV ## */
1633 IV aiv = SvIVX(TOPm1s);
1634 IV biv = SvIVX(TOPs);
1637 SETs(boolSV(aiv <= biv));
1640 if (auvok && buvok) { /* ## UV <= UV ## */
1641 UV auv = SvUVX(TOPm1s);
1642 UV buv = SvUVX(TOPs);
1645 SETs(boolSV(auv <= buv));
1648 if (auvok) { /* ## UV <= IV ## */
1655 /* As (a) is a UV, it's >=0, so a cannot be <= */
1660 SETs(boolSV(auv <= (UV)biv));
1663 { /* ## IV <= UV ## */
1667 aiv = SvIVX(TOPm1s);
1669 /* As (b) is a UV, it's >=0, so a must be <= */
1676 SETs(boolSV((UV)aiv <= buv));
1684 SETs(boolSV(TOPn <= value));
1691 dSP; tryAMAGICbinSET(ge,0);
1692 #ifdef PERL_PRESERVE_IVUV
1695 SvIV_please(TOPm1s);
1696 if (SvIOK(TOPm1s)) {
1697 bool auvok = SvUOK(TOPm1s);
1698 bool buvok = SvUOK(TOPs);
1700 if (!auvok && !buvok) { /* ## IV >= IV ## */
1701 IV aiv = SvIVX(TOPm1s);
1702 IV biv = SvIVX(TOPs);
1705 SETs(boolSV(aiv >= biv));
1708 if (auvok && buvok) { /* ## UV >= UV ## */
1709 UV auv = SvUVX(TOPm1s);
1710 UV buv = SvUVX(TOPs);
1713 SETs(boolSV(auv >= buv));
1716 if (auvok) { /* ## UV >= IV ## */
1723 /* As (a) is a UV, it's >=0, so it must be >= */
1728 SETs(boolSV(auv >= (UV)biv));
1731 { /* ## IV >= UV ## */
1735 aiv = SvIVX(TOPm1s);
1737 /* As (b) is a UV, it's >=0, so a cannot be >= */
1744 SETs(boolSV((UV)aiv >= buv));
1752 SETs(boolSV(TOPn >= value));
1759 dSP; tryAMAGICbinSET(ne,0);
1760 #ifndef NV_PRESERVES_UV
1761 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1762 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1766 #ifdef PERL_PRESERVE_IVUV
1769 SvIV_please(TOPm1s);
1770 if (SvIOK(TOPm1s)) {
1771 bool auvok = SvUOK(TOPm1s);
1772 bool buvok = SvUOK(TOPs);
1774 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1775 IV aiv = SvIVX(TOPm1s);
1776 IV biv = SvIVX(TOPs);
1779 SETs(boolSV(aiv != biv));
1782 if (auvok && buvok) { /* ## UV != UV ## */
1783 UV auv = SvUVX(TOPm1s);
1784 UV buv = SvUVX(TOPs);
1787 SETs(boolSV(auv != buv));
1790 { /* ## Mixed IV,UV ## */
1794 /* != is commutative so swap if needed (save code) */
1796 /* swap. top of stack (b) is the iv */
1800 /* As (a) is a UV, it's >0, so it cannot be == */
1809 /* As (b) is a UV, it's >0, so it cannot be == */
1813 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1815 SETs(boolSV((UV)iv != uv));
1823 SETs(boolSV(TOPn != value));
1830 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1831 #ifndef NV_PRESERVES_UV
1832 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1833 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1837 #ifdef PERL_PRESERVE_IVUV
1838 /* Fortunately it seems NaN isn't IOK */
1841 SvIV_please(TOPm1s);
1842 if (SvIOK(TOPm1s)) {
1843 bool leftuvok = SvUOK(TOPm1s);
1844 bool rightuvok = SvUOK(TOPs);
1846 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1847 IV leftiv = SvIVX(TOPm1s);
1848 IV rightiv = SvIVX(TOPs);
1850 if (leftiv > rightiv)
1852 else if (leftiv < rightiv)
1856 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1857 UV leftuv = SvUVX(TOPm1s);
1858 UV rightuv = SvUVX(TOPs);
1860 if (leftuv > rightuv)
1862 else if (leftuv < rightuv)
1866 } else if (leftuvok) { /* ## UV <=> IV ## */
1870 rightiv = SvIVX(TOPs);
1872 /* As (a) is a UV, it's >=0, so it cannot be < */
1875 leftuv = SvUVX(TOPm1s);
1876 if (leftuv > (UV)rightiv) {
1878 } else if (leftuv < (UV)rightiv) {
1884 } else { /* ## IV <=> UV ## */
1888 leftiv = SvIVX(TOPm1s);
1890 /* As (b) is a UV, it's >=0, so it must be < */
1893 rightuv = SvUVX(TOPs);
1894 if ((UV)leftiv > rightuv) {
1896 } else if ((UV)leftiv < rightuv) {
1914 if (Perl_isnan(left) || Perl_isnan(right)) {
1918 value = (left > right) - (left < right);
1922 else if (left < right)
1924 else if (left > right)
1938 dSP; tryAMAGICbinSET(slt,0);
1941 int cmp = (IN_LOCALE_RUNTIME
1942 ? sv_cmp_locale(left, right)
1943 : sv_cmp(left, right));
1944 SETs(boolSV(cmp < 0));
1951 dSP; tryAMAGICbinSET(sgt,0);
1954 int cmp = (IN_LOCALE_RUNTIME
1955 ? sv_cmp_locale(left, right)
1956 : sv_cmp(left, right));
1957 SETs(boolSV(cmp > 0));
1964 dSP; tryAMAGICbinSET(sle,0);
1967 int cmp = (IN_LOCALE_RUNTIME
1968 ? sv_cmp_locale(left, right)
1969 : sv_cmp(left, right));
1970 SETs(boolSV(cmp <= 0));
1977 dSP; tryAMAGICbinSET(sge,0);
1980 int cmp = (IN_LOCALE_RUNTIME
1981 ? sv_cmp_locale(left, right)
1982 : sv_cmp(left, right));
1983 SETs(boolSV(cmp >= 0));
1990 dSP; tryAMAGICbinSET(seq,0);
1993 SETs(boolSV(sv_eq(left, right)));
2000 dSP; tryAMAGICbinSET(sne,0);
2003 SETs(boolSV(!sv_eq(left, right)));
2010 dSP; dTARGET; tryAMAGICbin(scmp,0);
2013 int cmp = (IN_LOCALE_RUNTIME
2014 ? sv_cmp_locale(left, right)
2015 : sv_cmp(left, right));
2023 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2026 if (SvNIOKp(left) || SvNIOKp(right)) {
2027 if (PL_op->op_private & HINT_INTEGER) {
2028 IV i = SvIV(left) & SvIV(right);
2032 UV u = SvUV(left) & SvUV(right);
2037 do_vop(PL_op->op_type, TARG, left, right);
2046 dSP; dATARGET; tryAMAGICbin(bxor,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; dATARGET; tryAMAGICbin(bor,opASSIGN);
2072 if (SvNIOKp(left) || SvNIOKp(right)) {
2073 if (PL_op->op_private & HINT_INTEGER) {
2074 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2078 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2083 do_vop(PL_op->op_type, TARG, left, right);
2092 dSP; dTARGET; tryAMAGICun(neg);
2095 int flags = SvFLAGS(sv);
2098 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2099 /* It's publicly an integer, or privately an integer-not-float */
2102 if (SvIVX(sv) == IV_MIN) {
2103 /* 2s complement assumption. */
2104 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2107 else if (SvUVX(sv) <= IV_MAX) {
2112 else if (SvIVX(sv) != IV_MIN) {
2116 #ifdef PERL_PRESERVE_IVUV
2125 else if (SvPOKp(sv)) {
2127 char *s = SvPV(sv, len);
2128 if (isIDFIRST(*s)) {
2129 sv_setpvn(TARG, "-", 1);
2132 else if (*s == '+' || *s == '-') {
2134 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2136 else if (DO_UTF8(sv)) {
2139 goto oops_its_an_int;
2141 sv_setnv(TARG, -SvNV(sv));
2143 sv_setpvn(TARG, "-", 1);
2150 goto oops_its_an_int;
2151 sv_setnv(TARG, -SvNV(sv));
2163 dSP; tryAMAGICunSET(not);
2164 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2170 dSP; dTARGET; tryAMAGICun(compl);
2174 if (PL_op->op_private & HINT_INTEGER) {
2189 tmps = (U8*)SvPV_force(TARG, len);
2192 /* Calculate exact length, let's not estimate. */
2201 while (tmps < send) {
2202 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2203 tmps += UTF8SKIP(tmps);
2204 targlen += UNISKIP(~c);
2210 /* Now rewind strings and write them. */
2214 Newz(0, result, targlen + 1, U8);
2215 while (tmps < send) {
2216 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2217 tmps += UTF8SKIP(tmps);
2218 result = uvchr_to_utf8(result, ~c);
2222 sv_setpvn(TARG, (char*)result, targlen);
2226 Newz(0, result, nchar + 1, U8);
2227 while (tmps < send) {
2228 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2229 tmps += UTF8SKIP(tmps);
2234 sv_setpvn(TARG, (char*)result, nchar);
2242 register long *tmpl;
2243 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2246 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2251 for ( ; anum > 0; anum--, tmps++)
2260 /* integer versions of some of the above */
2264 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2267 SETi( left * right );
2274 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2278 DIE(aTHX_ "Illegal division by zero");
2279 value = POPi / value;
2287 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2291 DIE(aTHX_ "Illegal modulus zero");
2292 SETi( left % right );
2299 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2302 SETi( left + right );
2309 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2312 SETi( left - right );
2319 dSP; tryAMAGICbinSET(lt,0);
2322 SETs(boolSV(left < right));
2329 dSP; tryAMAGICbinSET(gt,0);
2332 SETs(boolSV(left > right));
2339 dSP; tryAMAGICbinSET(le,0);
2342 SETs(boolSV(left <= right));
2349 dSP; tryAMAGICbinSET(ge,0);
2352 SETs(boolSV(left >= right));
2359 dSP; tryAMAGICbinSET(eq,0);
2362 SETs(boolSV(left == right));
2369 dSP; tryAMAGICbinSET(ne,0);
2372 SETs(boolSV(left != right));
2379 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2386 else if (left < right)
2397 dSP; dTARGET; tryAMAGICun(neg);
2402 /* High falutin' math. */
2406 dSP; dTARGET; tryAMAGICbin(atan2,0);
2409 SETn(Perl_atan2(left, right));
2416 dSP; dTARGET; tryAMAGICun(sin);
2420 value = Perl_sin(value);
2428 dSP; dTARGET; tryAMAGICun(cos);
2432 value = Perl_cos(value);
2438 /* Support Configure command-line overrides for rand() functions.
2439 After 5.005, perhaps we should replace this by Configure support
2440 for drand48(), random(), or rand(). For 5.005, though, maintain
2441 compatibility by calling rand() but allow the user to override it.
2442 See INSTALL for details. --Andy Dougherty 15 July 1998
2444 /* Now it's after 5.005, and Configure supports drand48() and random(),
2445 in addition to rand(). So the overrides should not be needed any more.
2446 --Jarkko Hietaniemi 27 September 1998
2449 #ifndef HAS_DRAND48_PROTO
2450 extern double drand48 (void);
2463 if (!PL_srand_called) {
2464 (void)seedDrand01((Rand_seed_t)seed());
2465 PL_srand_called = TRUE;
2480 (void)seedDrand01((Rand_seed_t)anum);
2481 PL_srand_called = TRUE;
2490 * This is really just a quick hack which grabs various garbage
2491 * values. It really should be a real hash algorithm which
2492 * spreads the effect of every input bit onto every output bit,
2493 * if someone who knows about such things would bother to write it.
2494 * Might be a good idea to add that function to CORE as well.
2495 * No numbers below come from careful analysis or anything here,
2496 * except they are primes and SEED_C1 > 1E6 to get a full-width
2497 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2498 * probably be bigger too.
2501 # define SEED_C1 1000003
2502 #define SEED_C4 73819
2504 # define SEED_C1 25747
2505 #define SEED_C4 20639
2509 #define SEED_C5 26107
2511 #ifndef PERL_NO_DEV_RANDOM
2516 # include <starlet.h>
2517 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2518 * in 100-ns units, typically incremented ever 10 ms. */
2519 unsigned int when[2];
2521 # ifdef HAS_GETTIMEOFDAY
2522 struct timeval when;
2528 /* This test is an escape hatch, this symbol isn't set by Configure. */
2529 #ifndef PERL_NO_DEV_RANDOM
2530 #ifndef PERL_RANDOM_DEVICE
2531 /* /dev/random isn't used by default because reads from it will block
2532 * if there isn't enough entropy available. You can compile with
2533 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2534 * is enough real entropy to fill the seed. */
2535 # define PERL_RANDOM_DEVICE "/dev/urandom"
2537 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2539 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2548 _ckvmssts(sys$gettim(when));
2549 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2551 # ifdef HAS_GETTIMEOFDAY
2552 gettimeofday(&when,(struct timezone *) 0);
2553 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2556 u = (U32)SEED_C1 * when;
2559 u += SEED_C3 * (U32)PerlProc_getpid();
2560 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2561 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2562 u += SEED_C5 * (U32)PTR2UV(&when);
2569 dSP; dTARGET; tryAMAGICun(exp);
2573 value = Perl_exp(value);
2581 dSP; dTARGET; tryAMAGICun(log);
2586 SET_NUMERIC_STANDARD();
2587 DIE(aTHX_ "Can't take log of %g", value);
2589 value = Perl_log(value);
2597 dSP; dTARGET; tryAMAGICun(sqrt);
2602 SET_NUMERIC_STANDARD();
2603 DIE(aTHX_ "Can't take sqrt of %g", value);
2605 value = Perl_sqrt(value);
2613 dSP; dTARGET; tryAMAGICun(int);
2616 IV iv = TOPi; /* attempt to convert to IV if possible. */
2617 /* XXX it's arguable that compiler casting to IV might be subtly
2618 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2619 else preferring IV has introduced a subtle behaviour change bug. OTOH
2620 relying on floating point to be accurate is a bug. */
2631 if (value < (NV)UV_MAX + 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);
2646 double tmp = (double)value;
2647 (void)Perl_modf(tmp, &tmp);
2654 if (value > (NV)IV_MIN - 0.5) {
2657 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2658 # ifdef HAS_MODFL_POW32_BUG
2659 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2661 NV offset = Perl_modf(-value, &value);
2662 (void)Perl_modf(offset, &offset);
2666 (void)Perl_modf(-value, &value);
2670 double tmp = (double)value;
2671 (void)Perl_modf(-tmp, &tmp);
2684 dSP; dTARGET; tryAMAGICun(abs);
2686 /* This will cache the NV value if string isn't actually integer */
2690 /* IVX is precise */
2692 SETu(TOPu); /* force it to be numeric only */
2700 /* 2s complement assumption. Also, not really needed as
2701 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2721 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2726 tmps = (SvPVx(POPs, len));
2727 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2728 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2741 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2746 tmps = (SvPVx(POPs, len));
2747 while (*tmps && len && isSPACE(*tmps))
2752 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2753 else if (*tmps == 'b')
2754 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2756 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2758 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2775 SETi(sv_len_utf8(sv));
2791 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2793 I32 arybase = PL_curcop->cop_arybase;
2797 int num_args = PL_op->op_private & 7;
2798 bool repl_need_utf8_upgrade = FALSE;
2799 bool repl_is_utf8 = FALSE;
2801 SvTAINTED_off(TARG); /* decontaminate */
2802 SvUTF8_off(TARG); /* decontaminate */
2806 repl = SvPV(repl_sv, repl_len);
2807 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2817 sv_utf8_upgrade(sv);
2819 else if (DO_UTF8(sv))
2820 repl_need_utf8_upgrade = TRUE;
2822 tmps = SvPV(sv, curlen);
2824 utf8_curlen = sv_len_utf8(sv);
2825 if (utf8_curlen == curlen)
2828 curlen = utf8_curlen;
2833 if (pos >= arybase) {
2851 else if (len >= 0) {
2853 if (rem > (I32)curlen)
2868 Perl_croak(aTHX_ "substr outside of string");
2869 if (ckWARN(WARN_SUBSTR))
2870 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2877 sv_pos_u2b(sv, &pos, &rem);
2879 sv_setpvn(TARG, tmps, rem);
2880 #ifdef USE_LOCALE_COLLATE
2881 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2886 SV* repl_sv_copy = NULL;
2888 if (repl_need_utf8_upgrade) {
2889 repl_sv_copy = newSVsv(repl_sv);
2890 sv_utf8_upgrade(repl_sv_copy);
2891 repl = SvPV(repl_sv_copy, repl_len);
2892 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2894 sv_insert(sv, pos, rem, repl, repl_len);
2898 SvREFCNT_dec(repl_sv_copy);
2900 else if (lvalue) { /* it's an lvalue! */
2901 if (!SvGMAGICAL(sv)) {
2905 if (ckWARN(WARN_SUBSTR))
2906 Perl_warner(aTHX_ WARN_SUBSTR,
2907 "Attempt to use reference as lvalue in substr");
2909 if (SvOK(sv)) /* is it defined ? */
2910 (void)SvPOK_only_UTF8(sv);
2912 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2915 if (SvTYPE(TARG) < SVt_PVLV) {
2916 sv_upgrade(TARG, SVt_PVLV);
2917 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2921 if (LvTARG(TARG) != sv) {
2923 SvREFCNT_dec(LvTARG(TARG));
2924 LvTARG(TARG) = SvREFCNT_inc(sv);
2926 LvTARGOFF(TARG) = upos;
2927 LvTARGLEN(TARG) = urem;
2931 PUSHs(TARG); /* avoid SvSETMAGIC here */
2938 register IV size = POPi;
2939 register IV offset = POPi;
2940 register SV *src = POPs;
2941 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2943 SvTAINTED_off(TARG); /* decontaminate */
2944 if (lvalue) { /* it's an lvalue! */
2945 if (SvTYPE(TARG) < SVt_PVLV) {
2946 sv_upgrade(TARG, SVt_PVLV);
2947 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2950 if (LvTARG(TARG) != src) {
2952 SvREFCNT_dec(LvTARG(TARG));
2953 LvTARG(TARG) = SvREFCNT_inc(src);
2955 LvTARGOFF(TARG) = offset;
2956 LvTARGLEN(TARG) = size;
2959 sv_setuv(TARG, do_vecget(src, offset, size));
2974 I32 arybase = PL_curcop->cop_arybase;
2979 offset = POPi - arybase;
2982 tmps = SvPV(big, biglen);
2983 if (offset > 0 && DO_UTF8(big))
2984 sv_pos_u2b(big, &offset, 0);
2987 else if (offset > biglen)
2989 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2990 (unsigned char*)tmps + biglen, little, 0)))
2993 retval = tmps2 - tmps;
2994 if (retval > 0 && DO_UTF8(big))
2995 sv_pos_b2u(big, &retval);
2996 PUSHi(retval + arybase);
3011 I32 arybase = PL_curcop->cop_arybase;
3017 tmps2 = SvPV(little, llen);
3018 tmps = SvPV(big, blen);
3022 if (offset > 0 && DO_UTF8(big))
3023 sv_pos_u2b(big, &offset, 0);
3024 offset = offset - arybase + llen;
3028 else if (offset > blen)
3030 if (!(tmps2 = rninstr(tmps, tmps + offset,
3031 tmps2, tmps2 + llen)))
3034 retval = tmps2 - tmps;
3035 if (retval > 0 && DO_UTF8(big))
3036 sv_pos_b2u(big, &retval);
3037 PUSHi(retval + arybase);
3043 dSP; dMARK; dORIGMARK; dTARGET;
3044 do_sprintf(TARG, SP-MARK, MARK+1);
3045 TAINT_IF(SvTAINTED(TARG));
3046 if (DO_UTF8(*(MARK+1)))
3058 U8 *s = (U8*)SvPVx(argsv, len);
3061 if (PL_encoding && !DO_UTF8(argsv)) {
3062 tmpsv = sv_2mortal(newSVsv(argsv));
3063 s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3067 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3078 (void)SvUPGRADE(TARG,SVt_PV);
3080 if (value > 255 && !IN_BYTES) {
3081 SvGROW(TARG, UNISKIP(value)+1);
3082 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3083 SvCUR_set(TARG, tmps - SvPVX(TARG));
3085 (void)SvPOK_only(TARG);
3096 (void)SvPOK_only(TARG);
3098 Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3105 dSP; dTARGET; dPOPTOPssrl;
3109 char *tmps = SvPV(left, len);
3111 if (DO_UTF8(left)) {
3112 /* If Unicode take the crypt() of the low 8 bits
3113 * of the characters of the string. */
3115 char *send = tmps + len;
3117 Newz(688, t, len, char);
3119 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3125 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3127 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3132 "The crypt() function is unimplemented due to excessive paranoia.");
3146 U8 tmpbuf[UTF8_MAXLEN*2+1];
3150 s = (U8*)SvPV(sv, slen);
3151 utf8_to_uvchr(s, &ulen);
3153 toTITLE_utf8(s, tmpbuf, &tculen);
3154 utf8_to_uvchr(tmpbuf, 0);
3156 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3158 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3159 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3164 s = (U8*)SvPV_force(sv, slen);
3165 Copy(tmpbuf, s, tculen, U8);
3169 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3171 SvUTF8_off(TARG); /* decontaminate */
3176 s = (U8*)SvPV_force(sv, slen);
3178 if (IN_LOCALE_RUNTIME) {
3181 *s = toUPPER_LC(*s);
3199 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3201 U8 tmpbuf[UTF8_MAXLEN*2+1];
3205 toLOWER_utf8(s, tmpbuf, &ulen);
3206 uv = utf8_to_uvchr(tmpbuf, 0);
3208 tend = uvchr_to_utf8(tmpbuf, uv);
3210 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3212 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3213 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3218 s = (U8*)SvPV_force(sv, slen);
3219 Copy(tmpbuf, s, ulen, U8);
3223 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3225 SvUTF8_off(TARG); /* decontaminate */
3230 s = (U8*)SvPV_force(sv, slen);
3232 if (IN_LOCALE_RUNTIME) {
3235 *s = toLOWER_LC(*s);
3258 U8 tmpbuf[UTF8_MAXLEN*2+1];
3260 s = (U8*)SvPV(sv,len);
3262 SvUTF8_off(TARG); /* decontaminate */
3263 sv_setpvn(TARG, "", 0);
3267 (void)SvUPGRADE(TARG, SVt_PV);
3268 SvGROW(TARG, (len * 2) + 1);
3269 (void)SvPOK_only(TARG);
3270 d = (U8*)SvPVX(TARG);
3273 toUPPER_utf8(s, tmpbuf, &ulen);
3274 Copy(tmpbuf, d, ulen, U8);
3280 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3285 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3287 SvUTF8_off(TARG); /* decontaminate */
3292 s = (U8*)SvPV_force(sv, len);
3294 register U8 *send = s + len;
3296 if (IN_LOCALE_RUNTIME) {
3299 for (; s < send; s++)
3300 *s = toUPPER_LC(*s);
3303 for (; s < send; s++)
3325 U8 tmpbuf[UTF8_MAXLEN*2+1];
3327 s = (U8*)SvPV(sv,len);
3329 SvUTF8_off(TARG); /* decontaminate */
3330 sv_setpvn(TARG, "", 0);
3334 (void)SvUPGRADE(TARG, SVt_PV);
3335 SvGROW(TARG, (len * 2) + 1);
3336 (void)SvPOK_only(TARG);
3337 d = (U8*)SvPVX(TARG);
3340 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3341 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3342 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3344 * Now if the sigma is NOT followed by
3345 * /$ignorable_sequence$cased_letter/;
3346 * and it IS preceded by
3347 * /$cased_letter$ignorable_sequence/;
3348 * where $ignorable_sequence is
3349 * [\x{2010}\x{AD}\p{Mn}]*
3350 * and $cased_letter is
3351 * [\p{Ll}\p{Lo}\p{Lt}]
3352 * then it should be mapped to 0x03C2,
3353 * (GREEK SMALL LETTER FINAL SIGMA),
3354 * instead of staying 0x03A3.
3355 * See lib/unicore/SpecCase.txt.
3358 Copy(tmpbuf, d, ulen, U8);
3364 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3369 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3371 SvUTF8_off(TARG); /* decontaminate */
3377 s = (U8*)SvPV_force(sv, len);
3379 register U8 *send = s + len;
3381 if (IN_LOCALE_RUNTIME) {
3384 for (; s < send; s++)
3385 *s = toLOWER_LC(*s);
3388 for (; s < send; s++)
3403 register char *s = SvPV(sv,len);
3406 SvUTF8_off(TARG); /* decontaminate */
3408 (void)SvUPGRADE(TARG, SVt_PV);
3409 SvGROW(TARG, (len * 2) + 1);
3413 if (UTF8_IS_CONTINUED(*s)) {
3414 STRLEN ulen = UTF8SKIP(s);
3438 SvCUR_set(TARG, d - SvPVX(TARG));
3439 (void)SvPOK_only_UTF8(TARG);
3442 sv_setpvn(TARG, s, len);
3444 if (SvSMAGICAL(TARG))
3453 dSP; dMARK; dORIGMARK;
3455 register AV* av = (AV*)POPs;
3456 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3457 I32 arybase = PL_curcop->cop_arybase;
3460 if (SvTYPE(av) == SVt_PVAV) {
3461 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3463 for (svp = MARK + 1; svp <= SP; svp++) {
3468 if (max > AvMAX(av))
3471 while (++MARK <= SP) {
3472 elem = SvIVx(*MARK);
3476 svp = av_fetch(av, elem, lval);
3478 if (!svp || *svp == &PL_sv_undef)
3479 DIE(aTHX_ PL_no_aelem, elem);
3480 if (PL_op->op_private & OPpLVAL_INTRO)
3481 save_aelem(av, elem, svp);
3483 *MARK = svp ? *svp : &PL_sv_undef;
3486 if (GIMME != G_ARRAY) {
3494 /* Associative arrays. */
3499 HV *hash = (HV*)POPs;
3501 I32 gimme = GIMME_V;
3502 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3505 /* might clobber stack_sp */
3506 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3511 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3512 if (gimme == G_ARRAY) {
3515 /* might clobber stack_sp */
3517 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3522 else if (gimme == G_SCALAR)
3541 I32 gimme = GIMME_V;
3542 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3546 if (PL_op->op_private & OPpSLICE) {
3550 hvtype = SvTYPE(hv);
3551 if (hvtype == SVt_PVHV) { /* hash element */
3552 while (++MARK <= SP) {
3553 sv = hv_delete_ent(hv, *MARK, discard, 0);
3554 *MARK = sv ? sv : &PL_sv_undef;
3557 else if (hvtype == SVt_PVAV) {
3558 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3559 while (++MARK <= SP) {
3560 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3561 *MARK = sv ? sv : &PL_sv_undef;
3564 else { /* pseudo-hash element */
3565 while (++MARK <= SP) {
3566 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3567 *MARK = sv ? sv : &PL_sv_undef;
3572 DIE(aTHX_ "Not a HASH reference");
3575 else if (gimme == G_SCALAR) {
3584 if (SvTYPE(hv) == SVt_PVHV)
3585 sv = hv_delete_ent(hv, keysv, discard, 0);
3586 else if (SvTYPE(hv) == SVt_PVAV) {
3587 if (PL_op->op_flags & OPf_SPECIAL)
3588 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3590 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3593 DIE(aTHX_ "Not a HASH reference");
3608 if (PL_op->op_private & OPpEXISTS_SUB) {
3612 cv = sv_2cv(sv, &hv, &gv, FALSE);
3615 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3621 if (SvTYPE(hv) == SVt_PVHV) {
3622 if (hv_exists_ent(hv, tmpsv, 0))
3625 else if (SvTYPE(hv) == SVt_PVAV) {
3626 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3627 if (av_exists((AV*)hv, SvIV(tmpsv)))
3630 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3634 DIE(aTHX_ "Not a HASH reference");
3641 dSP; dMARK; dORIGMARK;
3642 register HV *hv = (HV*)POPs;
3643 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3644 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3646 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3647 DIE(aTHX_ "Can't localize pseudo-hash element");
3649 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3650 while (++MARK <= SP) {
3653 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3654 realhv ? hv_exists_ent(hv, keysv, 0)
3655 : avhv_exists_ent((AV*)hv, keysv, 0);
3657 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3658 svp = he ? &HeVAL(he) : 0;
3661 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3664 if (!svp || *svp == &PL_sv_undef) {
3666 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3668 if (PL_op->op_private & OPpLVAL_INTRO) {
3670 save_helem(hv, keysv, svp);
3673 char *key = SvPV(keysv, keylen);
3674 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3678 *MARK = svp ? *svp : &PL_sv_undef;
3681 if (GIMME != G_ARRAY) {
3689 /* List operators. */
3694 if (GIMME != G_ARRAY) {
3696 *MARK = *SP; /* unwanted list, return last item */
3698 *MARK = &PL_sv_undef;
3707 SV **lastrelem = PL_stack_sp;
3708 SV **lastlelem = PL_stack_base + POPMARK;
3709 SV **firstlelem = PL_stack_base + POPMARK + 1;
3710 register SV **firstrelem = lastlelem + 1;
3711 I32 arybase = PL_curcop->cop_arybase;
3712 I32 lval = PL_op->op_flags & OPf_MOD;
3713 I32 is_something_there = lval;
3715 register I32 max = lastrelem - lastlelem;
3716 register SV **lelem;
3719 if (GIMME != G_ARRAY) {
3720 ix = SvIVx(*lastlelem);
3725 if (ix < 0 || ix >= max)
3726 *firstlelem = &PL_sv_undef;
3728 *firstlelem = firstrelem[ix];
3734 SP = firstlelem - 1;
3738 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3744 if (ix < 0 || ix >= max)
3745 *lelem = &PL_sv_undef;
3747 is_something_there = TRUE;
3748 if (!(*lelem = firstrelem[ix]))
3749 *lelem = &PL_sv_undef;
3752 if (is_something_there)
3755 SP = firstlelem - 1;
3761 dSP; dMARK; dORIGMARK;
3762 I32 items = SP - MARK;
3763 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3764 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3771 dSP; dMARK; dORIGMARK;
3772 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3776 SV *val = NEWSV(46, 0);
3778 sv_setsv(val, *++MARK);
3779 else if (ckWARN(WARN_MISC))
3780 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3781 (void)hv_store_ent(hv,key,val,0);
3790 dSP; dMARK; dORIGMARK;
3791 register AV *ary = (AV*)*++MARK;
3795 register I32 offset;
3796 register I32 length;
3803 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3804 *MARK-- = SvTIED_obj((SV*)ary, mg);
3808 call_method("SPLICE",GIMME_V);
3817 offset = i = SvIVx(*MARK);
3819 offset += AvFILLp(ary) + 1;
3821 offset -= PL_curcop->cop_arybase;
3823 DIE(aTHX_ PL_no_aelem, i);
3825 length = SvIVx(*MARK++);
3827 length += AvFILLp(ary) - offset + 1;
3833 length = AvMAX(ary) + 1; /* close enough to infinity */
3837 length = AvMAX(ary) + 1;
3839 if (offset > AvFILLp(ary) + 1)
3840 offset = AvFILLp(ary) + 1;
3841 after = AvFILLp(ary) + 1 - (offset + length);
3842 if (after < 0) { /* not that much array */
3843 length += after; /* offset+length now in array */
3849 /* At this point, MARK .. SP-1 is our new LIST */
3852 diff = newlen - length;
3853 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3856 if (diff < 0) { /* shrinking the area */
3858 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3859 Copy(MARK, tmparyval, newlen, SV*);
3862 MARK = ORIGMARK + 1;
3863 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3864 MEXTEND(MARK, length);
3865 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3867 EXTEND_MORTAL(length);
3868 for (i = length, dst = MARK; i; i--) {
3869 sv_2mortal(*dst); /* free them eventualy */
3876 *MARK = AvARRAY(ary)[offset+length-1];
3879 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3880 SvREFCNT_dec(*dst++); /* free them now */
3883 AvFILLp(ary) += diff;
3885 /* pull up or down? */
3887 if (offset < after) { /* easier to pull up */
3888 if (offset) { /* esp. if nothing to pull */
3889 src = &AvARRAY(ary)[offset-1];
3890 dst = src - diff; /* diff is negative */
3891 for (i = offset; i > 0; i--) /* can't trust Copy */
3895 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3899 if (after) { /* anything to pull down? */
3900 src = AvARRAY(ary) + offset + length;
3901 dst = src + diff; /* diff is negative */
3902 Move(src, dst, after, SV*);
3904 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3905 /* avoid later double free */
3909 dst[--i] = &PL_sv_undef;
3912 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3914 *dst = NEWSV(46, 0);
3915 sv_setsv(*dst++, *src++);
3917 Safefree(tmparyval);
3920 else { /* no, expanding (or same) */
3922 New(452, tmparyval, length, SV*); /* so remember deletion */
3923 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3926 if (diff > 0) { /* expanding */
3928 /* push up or down? */
3930 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3934 Move(src, dst, offset, SV*);
3936 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3938 AvFILLp(ary) += diff;
3941 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3942 av_extend(ary, AvFILLp(ary) + diff);
3943 AvFILLp(ary) += diff;
3946 dst = AvARRAY(ary) + AvFILLp(ary);
3948 for (i = after; i; i--) {
3955 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3956 *dst = NEWSV(46, 0);
3957 sv_setsv(*dst++, *src++);
3959 MARK = ORIGMARK + 1;
3960 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3962 Copy(tmparyval, MARK, length, SV*);
3964 EXTEND_MORTAL(length);
3965 for (i = length, dst = MARK; i; i--) {
3966 sv_2mortal(*dst); /* free them eventualy */
3970 Safefree(tmparyval);
3974 else if (length--) {
3975 *MARK = tmparyval[length];
3978 while (length-- > 0)
3979 SvREFCNT_dec(tmparyval[length]);
3981 Safefree(tmparyval);
3984 *MARK = &PL_sv_undef;
3992 dSP; dMARK; dORIGMARK; dTARGET;
3993 register AV *ary = (AV*)*++MARK;
3994 register SV *sv = &PL_sv_undef;
3997 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3998 *MARK-- = SvTIED_obj((SV*)ary, mg);
4002 call_method("PUSH",G_SCALAR|G_DISCARD);
4007 /* Why no pre-extend of ary here ? */
4008 for (++MARK; MARK <= SP; MARK++) {
4011 sv_setsv(sv, *MARK);
4016 PUSHi( AvFILL(ary) + 1 );
4024 SV *sv = av_pop(av);
4026 (void)sv_2mortal(sv);
4035 SV *sv = av_shift(av);
4040 (void)sv_2mortal(sv);
4047 dSP; dMARK; dORIGMARK; dTARGET;
4048 register AV *ary = (AV*)*++MARK;
4053 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4054 *MARK-- = SvTIED_obj((SV*)ary, mg);
4058 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4063 av_unshift(ary, SP - MARK);
4066 sv_setsv(sv, *++MARK);
4067 (void)av_store(ary, i++, sv);
4071 PUSHi( AvFILL(ary) + 1 );
4081 if (GIMME == G_ARRAY) {
4088 /* safe as long as stack cannot get extended in the above */
4093 register char *down;
4098 SvUTF8_off(TARG); /* decontaminate */
4100 do_join(TARG, &PL_sv_no, MARK, SP);
4102 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4103 up = SvPV_force(TARG, len);
4105 if (DO_UTF8(TARG)) { /* first reverse each character */
4106 U8* s = (U8*)SvPVX(TARG);
4107 U8* send = (U8*)(s + len);
4109 if (UTF8_IS_INVARIANT(*s)) {
4114 if (!utf8_to_uvchr(s, 0))
4118 down = (char*)(s - 1);
4119 /* reverse this character */
4129 down = SvPVX(TARG) + len - 1;
4135 (void)SvPOK_only_UTF8(TARG);
4147 register IV limit = POPi; /* note, negative is forever */
4150 register char *s = SvPV(sv, len);
4151 bool do_utf8 = DO_UTF8(sv);
4152 char *strend = s + len;
4154 register REGEXP *rx;
4158 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4159 I32 maxiters = slen + 10;
4162 I32 origlimit = limit;
4165 AV *oldstack = PL_curstack;
4166 I32 gimme = GIMME_V;
4167 I32 oldsave = PL_savestack_ix;
4168 I32 make_mortal = 1;
4169 MAGIC *mg = (MAGIC *) NULL;
4172 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4177 DIE(aTHX_ "panic: pp_split");
4180 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4181 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4183 PL_reg_match_utf8 = do_utf8;
4185 if (pm->op_pmreplroot) {
4187 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4189 ary = GvAVn((GV*)pm->op_pmreplroot);
4192 else if (gimme != G_ARRAY)
4193 #ifdef USE_5005THREADS
4194 ary = (AV*)PL_curpad[0];
4196 ary = GvAVn(PL_defgv);
4197 #endif /* USE_5005THREADS */
4200 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4206 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4208 XPUSHs(SvTIED_obj((SV*)ary, mg));
4214 for (i = AvFILLp(ary); i >= 0; i--)
4215 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4217 /* temporarily switch stacks */
4218 SWITCHSTACK(PL_curstack, ary);
4222 base = SP - PL_stack_base;
4224 if (pm->op_pmflags & PMf_SKIPWHITE) {
4225 if (pm->op_pmflags & PMf_LOCALE) {
4226 while (isSPACE_LC(*s))
4234 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4235 SAVEINT(PL_multiline);
4236 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4240 limit = maxiters + 2;
4241 if (pm->op_pmflags & PMf_WHITE) {
4244 while (m < strend &&
4245 !((pm->op_pmflags & PMf_LOCALE)
4246 ? isSPACE_LC(*m) : isSPACE(*m)))
4251 dstr = NEWSV(30, m-s);
4252 sv_setpvn(dstr, s, m-s);
4256 (void)SvUTF8_on(dstr);
4260 while (s < strend &&
4261 ((pm->op_pmflags & PMf_LOCALE)
4262 ? isSPACE_LC(*s) : isSPACE(*s)))
4266 else if (strEQ("^", rx->precomp)) {
4269 for (m = s; m < strend && *m != '\n'; m++) ;
4273 dstr = NEWSV(30, m-s);
4274 sv_setpvn(dstr, s, m-s);
4278 (void)SvUTF8_on(dstr);
4283 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4284 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4285 && (rx->reganch & ROPT_CHECK_ALL)
4286 && !(rx->reganch & ROPT_ANCH)) {
4287 int tail = (rx->reganch & RE_INTUIT_TAIL);
4288 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4291 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4293 char c = *SvPV(csv, n_a);
4296 for (m = s; m < strend && *m != c; m++) ;
4299 dstr = NEWSV(30, m-s);
4300 sv_setpvn(dstr, s, m-s);
4304 (void)SvUTF8_on(dstr);
4306 /* The rx->minlen is in characters but we want to step
4307 * s ahead by bytes. */
4309 s = (char*)utf8_hop((U8*)m, len);
4311 s = m + len; /* Fake \n at the end */
4316 while (s < strend && --limit &&
4317 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4318 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4321 dstr = NEWSV(31, m-s);
4322 sv_setpvn(dstr, s, m-s);
4326 (void)SvUTF8_on(dstr);
4328 /* The rx->minlen is in characters but we want to step
4329 * s ahead by bytes. */
4331 s = (char*)utf8_hop((U8*)m, len);
4333 s = m + len; /* Fake \n at the end */
4338 maxiters += slen * rx->nparens;
4339 while (s < strend && --limit
4340 /* && (!rx->check_substr
4341 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4343 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4344 1 /* minend */, sv, NULL, 0))
4346 TAINT_IF(RX_MATCH_TAINTED(rx));
4347 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4352 strend = s + (strend - m);
4354 m = rx->startp[0] + orig;
4355 dstr = NEWSV(32, m-s);
4356 sv_setpvn(dstr, s, m-s);
4360 (void)SvUTF8_on(dstr);
4363 for (i = 1; i <= rx->nparens; i++) {
4364 s = rx->startp[i] + orig;
4365 m = rx->endp[i] + orig;
4367 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4368 parens that didn't match -- they should be set to
4369 undef, not the empty string */
4370 if (m >= orig && s >= orig) {
4371 dstr = NEWSV(33, m-s);
4372 sv_setpvn(dstr, s, m-s);
4375 dstr = &PL_sv_undef; /* undef, not "" */
4379 (void)SvUTF8_on(dstr);
4383 s = rx->endp[0] + orig;
4387 LEAVE_SCOPE(oldsave);
4388 iters = (SP - PL_stack_base) - base;
4389 if (iters > maxiters)
4390 DIE(aTHX_ "Split loop");
4392 /* keep field after final delim? */
4393 if (s < strend || (iters && origlimit)) {
4394 STRLEN l = strend - s;
4395 dstr = NEWSV(34, l);
4396 sv_setpvn(dstr, s, l);
4400 (void)SvUTF8_on(dstr);
4404 else if (!origlimit) {
4405 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4411 SWITCHSTACK(ary, oldstack);
4412 if (SvSMAGICAL(ary)) {
4417 if (gimme == G_ARRAY) {
4419 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4427 call_method("PUSH",G_SCALAR|G_DISCARD);
4430 if (gimme == G_ARRAY) {
4431 /* EXTEND should not be needed - we just popped them */
4433 for (i=0; i < iters; i++) {
4434 SV **svp = av_fetch(ary, i, FALSE);
4435 PUSHs((svp) ? *svp : &PL_sv_undef);
4442 if (gimme == G_ARRAY)
4445 if (iters || !pm->op_pmreplroot) {
4453 #ifdef USE_5005THREADS
4455 Perl_unlock_condpair(pTHX_ void *svv)
4457 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4460 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4461 MUTEX_LOCK(MgMUTEXP(mg));
4462 if (MgOWNER(mg) != thr)
4463 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4465 COND_SIGNAL(MgOWNERCONDP(mg));
4466 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4467 PTR2UV(thr), PTR2UV(svv)));
4468 MUTEX_UNLOCK(MgMUTEXP(mg));
4470 #endif /* USE_5005THREADS */
4477 #ifdef USE_5005THREADS
4479 #endif /* USE_5005THREADS */
4481 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4483 Perl_sharedsv_lock(aTHX_ ssv);
4484 #endif /* USE_ITHREADS */
4485 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4486 || SvTYPE(retsv) == SVt_PVCV) {
4487 retsv = refto(retsv);
4495 #ifdef USE_5005THREADS
4498 if (PL_op->op_private & OPpLVAL_INTRO)
4499 PUSHs(*save_threadsv(PL_op->op_targ));
4501 PUSHs(THREADSV(PL_op->op_targ));
4504 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4505 #endif /* USE_5005THREADS */