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)) {
1763 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1767 #ifdef PERL_PRESERVE_IVUV
1770 SvIV_please(TOPm1s);
1771 if (SvIOK(TOPm1s)) {
1772 bool auvok = SvUOK(TOPm1s);
1773 bool buvok = SvUOK(TOPs);
1775 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1776 IV aiv = SvIVX(TOPm1s);
1777 IV biv = SvIVX(TOPs);
1780 SETs(boolSV(aiv != biv));
1783 if (auvok && buvok) { /* ## UV != UV ## */
1784 UV auv = SvUVX(TOPm1s);
1785 UV buv = SvUVX(TOPs);
1788 SETs(boolSV(auv != buv));
1791 { /* ## Mixed IV,UV ## */
1795 /* != is commutative so swap if needed (save code) */
1797 /* swap. top of stack (b) is the iv */
1801 /* As (a) is a UV, it's >0, so it cannot be == */
1810 /* As (b) is a UV, it's >0, so it cannot be == */
1814 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1816 SETs(boolSV((UV)iv != uv));
1824 SETs(boolSV(TOPn != value));
1831 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1832 #ifndef NV_PRESERVES_UV
1833 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1834 UV right = PTR2UV(SvRV(POPs));
1835 UV left = PTR2UV(SvRV(TOPs));
1836 SETi((left > right) - (left < right));
1840 #ifdef PERL_PRESERVE_IVUV
1841 /* Fortunately it seems NaN isn't IOK */
1844 SvIV_please(TOPm1s);
1845 if (SvIOK(TOPm1s)) {
1846 bool leftuvok = SvUOK(TOPm1s);
1847 bool rightuvok = SvUOK(TOPs);
1849 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1850 IV leftiv = SvIVX(TOPm1s);
1851 IV rightiv = SvIVX(TOPs);
1853 if (leftiv > rightiv)
1855 else if (leftiv < rightiv)
1859 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1860 UV leftuv = SvUVX(TOPm1s);
1861 UV rightuv = SvUVX(TOPs);
1863 if (leftuv > rightuv)
1865 else if (leftuv < rightuv)
1869 } else if (leftuvok) { /* ## UV <=> IV ## */
1873 rightiv = SvIVX(TOPs);
1875 /* As (a) is a UV, it's >=0, so it cannot be < */
1878 leftuv = SvUVX(TOPm1s);
1879 if (leftuv > (UV)rightiv) {
1881 } else if (leftuv < (UV)rightiv) {
1887 } else { /* ## IV <=> UV ## */
1891 leftiv = SvIVX(TOPm1s);
1893 /* As (b) is a UV, it's >=0, so it must be < */
1896 rightuv = SvUVX(TOPs);
1897 if ((UV)leftiv > rightuv) {
1899 } else if ((UV)leftiv < rightuv) {
1917 if (Perl_isnan(left) || Perl_isnan(right)) {
1921 value = (left > right) - (left < right);
1925 else if (left < right)
1927 else if (left > right)
1941 dSP; tryAMAGICbinSET(slt,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(sgt,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(sle,0);
1970 int cmp = (IN_LOCALE_RUNTIME
1971 ? sv_cmp_locale(left, right)
1972 : sv_cmp(left, right));
1973 SETs(boolSV(cmp <= 0));
1980 dSP; tryAMAGICbinSET(sge,0);
1983 int cmp = (IN_LOCALE_RUNTIME
1984 ? sv_cmp_locale(left, right)
1985 : sv_cmp(left, right));
1986 SETs(boolSV(cmp >= 0));
1993 dSP; tryAMAGICbinSET(seq,0);
1996 SETs(boolSV(sv_eq(left, right)));
2003 dSP; tryAMAGICbinSET(sne,0);
2006 SETs(boolSV(!sv_eq(left, right)));
2013 dSP; dTARGET; tryAMAGICbin(scmp,0);
2016 int cmp = (IN_LOCALE_RUNTIME
2017 ? sv_cmp_locale(left, right)
2018 : sv_cmp(left, right));
2026 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2029 if (SvNIOKp(left) || SvNIOKp(right)) {
2030 if (PL_op->op_private & HINT_INTEGER) {
2031 IV i = SvIV(left) & SvIV(right);
2035 UV u = SvUV(left) & SvUV(right);
2040 do_vop(PL_op->op_type, TARG, left, right);
2049 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2052 if (SvNIOKp(left) || SvNIOKp(right)) {
2053 if (PL_op->op_private & HINT_INTEGER) {
2054 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2058 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2063 do_vop(PL_op->op_type, TARG, left, right);
2072 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2075 if (SvNIOKp(left) || SvNIOKp(right)) {
2076 if (PL_op->op_private & HINT_INTEGER) {
2077 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2081 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2086 do_vop(PL_op->op_type, TARG, left, right);
2095 dSP; dTARGET; tryAMAGICun(neg);
2098 int flags = SvFLAGS(sv);
2101 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2102 /* It's publicly an integer, or privately an integer-not-float */
2105 if (SvIVX(sv) == IV_MIN) {
2106 /* 2s complement assumption. */
2107 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2110 else if (SvUVX(sv) <= IV_MAX) {
2115 else if (SvIVX(sv) != IV_MIN) {
2119 #ifdef PERL_PRESERVE_IVUV
2128 else if (SvPOKp(sv)) {
2130 char *s = SvPV(sv, len);
2131 if (isIDFIRST(*s)) {
2132 sv_setpvn(TARG, "-", 1);
2135 else if (*s == '+' || *s == '-') {
2137 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2139 else if (DO_UTF8(sv)) {
2142 goto oops_its_an_int;
2144 sv_setnv(TARG, -SvNV(sv));
2146 sv_setpvn(TARG, "-", 1);
2153 goto oops_its_an_int;
2154 sv_setnv(TARG, -SvNV(sv));
2166 dSP; tryAMAGICunSET(not);
2167 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2173 dSP; dTARGET; tryAMAGICun(compl);
2177 if (PL_op->op_private & HINT_INTEGER) {
2192 tmps = (U8*)SvPV_force(TARG, len);
2195 /* Calculate exact length, let's not estimate. */
2204 while (tmps < send) {
2205 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2206 tmps += UTF8SKIP(tmps);
2207 targlen += UNISKIP(~c);
2213 /* Now rewind strings and write them. */
2217 Newz(0, result, targlen + 1, U8);
2218 while (tmps < send) {
2219 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2220 tmps += UTF8SKIP(tmps);
2221 result = uvchr_to_utf8(result, ~c);
2225 sv_setpvn(TARG, (char*)result, targlen);
2229 Newz(0, result, nchar + 1, U8);
2230 while (tmps < send) {
2231 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2232 tmps += UTF8SKIP(tmps);
2237 sv_setpvn(TARG, (char*)result, nchar);
2245 register long *tmpl;
2246 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2249 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2254 for ( ; anum > 0; anum--, tmps++)
2263 /* integer versions of some of the above */
2267 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2270 SETi( left * right );
2277 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2281 DIE(aTHX_ "Illegal division by zero");
2282 value = POPi / value;
2290 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2294 DIE(aTHX_ "Illegal modulus zero");
2295 SETi( left % right );
2302 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2305 SETi( left + right );
2312 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2315 SETi( left - right );
2322 dSP; tryAMAGICbinSET(lt,0);
2325 SETs(boolSV(left < right));
2332 dSP; tryAMAGICbinSET(gt,0);
2335 SETs(boolSV(left > right));
2342 dSP; tryAMAGICbinSET(le,0);
2345 SETs(boolSV(left <= right));
2352 dSP; tryAMAGICbinSET(ge,0);
2355 SETs(boolSV(left >= right));
2362 dSP; tryAMAGICbinSET(eq,0);
2365 SETs(boolSV(left == right));
2372 dSP; tryAMAGICbinSET(ne,0);
2375 SETs(boolSV(left != right));
2382 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2389 else if (left < right)
2400 dSP; dTARGET; tryAMAGICun(neg);
2405 /* High falutin' math. */
2409 dSP; dTARGET; tryAMAGICbin(atan2,0);
2412 SETn(Perl_atan2(left, right));
2419 dSP; dTARGET; tryAMAGICun(sin);
2423 value = Perl_sin(value);
2431 dSP; dTARGET; tryAMAGICun(cos);
2435 value = Perl_cos(value);
2441 /* Support Configure command-line overrides for rand() functions.
2442 After 5.005, perhaps we should replace this by Configure support
2443 for drand48(), random(), or rand(). For 5.005, though, maintain
2444 compatibility by calling rand() but allow the user to override it.
2445 See INSTALL for details. --Andy Dougherty 15 July 1998
2447 /* Now it's after 5.005, and Configure supports drand48() and random(),
2448 in addition to rand(). So the overrides should not be needed any more.
2449 --Jarkko Hietaniemi 27 September 1998
2452 #ifndef HAS_DRAND48_PROTO
2453 extern double drand48 (void);
2466 if (!PL_srand_called) {
2467 (void)seedDrand01((Rand_seed_t)seed());
2468 PL_srand_called = TRUE;
2483 (void)seedDrand01((Rand_seed_t)anum);
2484 PL_srand_called = TRUE;
2493 * This is really just a quick hack which grabs various garbage
2494 * values. It really should be a real hash algorithm which
2495 * spreads the effect of every input bit onto every output bit,
2496 * if someone who knows about such things would bother to write it.
2497 * Might be a good idea to add that function to CORE as well.
2498 * No numbers below come from careful analysis or anything here,
2499 * except they are primes and SEED_C1 > 1E6 to get a full-width
2500 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2501 * probably be bigger too.
2504 # define SEED_C1 1000003
2505 #define SEED_C4 73819
2507 # define SEED_C1 25747
2508 #define SEED_C4 20639
2512 #define SEED_C5 26107
2514 #ifndef PERL_NO_DEV_RANDOM
2519 # include <starlet.h>
2520 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2521 * in 100-ns units, typically incremented ever 10 ms. */
2522 unsigned int when[2];
2524 # ifdef HAS_GETTIMEOFDAY
2525 struct timeval when;
2531 /* This test is an escape hatch, this symbol isn't set by Configure. */
2532 #ifndef PERL_NO_DEV_RANDOM
2533 #ifndef PERL_RANDOM_DEVICE
2534 /* /dev/random isn't used by default because reads from it will block
2535 * if there isn't enough entropy available. You can compile with
2536 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2537 * is enough real entropy to fill the seed. */
2538 # define PERL_RANDOM_DEVICE "/dev/urandom"
2540 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2542 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2551 _ckvmssts(sys$gettim(when));
2552 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2554 # ifdef HAS_GETTIMEOFDAY
2555 gettimeofday(&when,(struct timezone *) 0);
2556 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2559 u = (U32)SEED_C1 * when;
2562 u += SEED_C3 * (U32)PerlProc_getpid();
2563 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2564 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2565 u += SEED_C5 * (U32)PTR2UV(&when);
2572 dSP; dTARGET; tryAMAGICun(exp);
2576 value = Perl_exp(value);
2584 dSP; dTARGET; tryAMAGICun(log);
2589 SET_NUMERIC_STANDARD();
2590 DIE(aTHX_ "Can't take log of %g", value);
2592 value = Perl_log(value);
2600 dSP; dTARGET; tryAMAGICun(sqrt);
2605 SET_NUMERIC_STANDARD();
2606 DIE(aTHX_ "Can't take sqrt of %g", value);
2608 value = Perl_sqrt(value);
2616 dSP; dTARGET; tryAMAGICun(int);
2619 IV iv = TOPi; /* attempt to convert to IV if possible. */
2620 /* XXX it's arguable that compiler casting to IV might be subtly
2621 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2622 else preferring IV has introduced a subtle behaviour change bug. OTOH
2623 relying on floating point to be accurate is a bug. */
2634 if (value < (NV)UV_MAX + 0.5) {
2637 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2638 # ifdef HAS_MODFL_POW32_BUG
2639 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2641 NV offset = Perl_modf(value, &value);
2642 (void)Perl_modf(offset, &offset);
2646 (void)Perl_modf(value, &value);
2649 double tmp = (double)value;
2650 (void)Perl_modf(tmp, &tmp);
2657 if (value > (NV)IV_MIN - 0.5) {
2660 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2661 # ifdef HAS_MODFL_POW32_BUG
2662 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2664 NV offset = Perl_modf(-value, &value);
2665 (void)Perl_modf(offset, &offset);
2669 (void)Perl_modf(-value, &value);
2673 double tmp = (double)value;
2674 (void)Perl_modf(-tmp, &tmp);
2687 dSP; dTARGET; tryAMAGICun(abs);
2689 /* This will cache the NV value if string isn't actually integer */
2693 /* IVX is precise */
2695 SETu(TOPu); /* force it to be numeric only */
2703 /* 2s complement assumption. Also, not really needed as
2704 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2724 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2729 tmps = (SvPVx(POPs, len));
2730 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2731 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2744 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2749 tmps = (SvPVx(POPs, len));
2750 while (*tmps && len && isSPACE(*tmps))
2755 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2756 else if (*tmps == 'b')
2757 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2759 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2761 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2778 SETi(sv_len_utf8(sv));
2794 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2796 I32 arybase = PL_curcop->cop_arybase;
2800 int num_args = PL_op->op_private & 7;
2801 bool repl_need_utf8_upgrade = FALSE;
2802 bool repl_is_utf8 = FALSE;
2804 SvTAINTED_off(TARG); /* decontaminate */
2805 SvUTF8_off(TARG); /* decontaminate */
2809 repl = SvPV(repl_sv, repl_len);
2810 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2820 sv_utf8_upgrade(sv);
2822 else if (DO_UTF8(sv))
2823 repl_need_utf8_upgrade = TRUE;
2825 tmps = SvPV(sv, curlen);
2827 utf8_curlen = sv_len_utf8(sv);
2828 if (utf8_curlen == curlen)
2831 curlen = utf8_curlen;
2836 if (pos >= arybase) {
2854 else if (len >= 0) {
2856 if (rem > (I32)curlen)
2871 Perl_croak(aTHX_ "substr outside of string");
2872 if (ckWARN(WARN_SUBSTR))
2873 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2880 sv_pos_u2b(sv, &pos, &rem);
2882 sv_setpvn(TARG, tmps, rem);
2883 #ifdef USE_LOCALE_COLLATE
2884 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2889 SV* repl_sv_copy = NULL;
2891 if (repl_need_utf8_upgrade) {
2892 repl_sv_copy = newSVsv(repl_sv);
2893 sv_utf8_upgrade(repl_sv_copy);
2894 repl = SvPV(repl_sv_copy, repl_len);
2895 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2897 sv_insert(sv, pos, rem, repl, repl_len);
2901 SvREFCNT_dec(repl_sv_copy);
2903 else if (lvalue) { /* it's an lvalue! */
2904 if (!SvGMAGICAL(sv)) {
2908 if (ckWARN(WARN_SUBSTR))
2909 Perl_warner(aTHX_ WARN_SUBSTR,
2910 "Attempt to use reference as lvalue in substr");
2912 if (SvOK(sv)) /* is it defined ? */
2913 (void)SvPOK_only_UTF8(sv);
2915 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2918 if (SvTYPE(TARG) < SVt_PVLV) {
2919 sv_upgrade(TARG, SVt_PVLV);
2920 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2924 if (LvTARG(TARG) != sv) {
2926 SvREFCNT_dec(LvTARG(TARG));
2927 LvTARG(TARG) = SvREFCNT_inc(sv);
2929 LvTARGOFF(TARG) = upos;
2930 LvTARGLEN(TARG) = urem;
2934 PUSHs(TARG); /* avoid SvSETMAGIC here */
2941 register IV size = POPi;
2942 register IV offset = POPi;
2943 register SV *src = POPs;
2944 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2946 SvTAINTED_off(TARG); /* decontaminate */
2947 if (lvalue) { /* it's an lvalue! */
2948 if (SvTYPE(TARG) < SVt_PVLV) {
2949 sv_upgrade(TARG, SVt_PVLV);
2950 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2953 if (LvTARG(TARG) != src) {
2955 SvREFCNT_dec(LvTARG(TARG));
2956 LvTARG(TARG) = SvREFCNT_inc(src);
2958 LvTARGOFF(TARG) = offset;
2959 LvTARGLEN(TARG) = size;
2962 sv_setuv(TARG, do_vecget(src, offset, size));
2977 I32 arybase = PL_curcop->cop_arybase;
2982 offset = POPi - arybase;
2985 tmps = SvPV(big, biglen);
2986 if (offset > 0 && DO_UTF8(big))
2987 sv_pos_u2b(big, &offset, 0);
2990 else if (offset > biglen)
2992 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2993 (unsigned char*)tmps + biglen, little, 0)))
2996 retval = tmps2 - tmps;
2997 if (retval > 0 && DO_UTF8(big))
2998 sv_pos_b2u(big, &retval);
2999 PUSHi(retval + arybase);
3014 I32 arybase = PL_curcop->cop_arybase;
3020 tmps2 = SvPV(little, llen);
3021 tmps = SvPV(big, blen);
3025 if (offset > 0 && DO_UTF8(big))
3026 sv_pos_u2b(big, &offset, 0);
3027 offset = offset - arybase + llen;
3031 else if (offset > blen)
3033 if (!(tmps2 = rninstr(tmps, tmps + offset,
3034 tmps2, tmps2 + llen)))
3037 retval = tmps2 - tmps;
3038 if (retval > 0 && DO_UTF8(big))
3039 sv_pos_b2u(big, &retval);
3040 PUSHi(retval + arybase);
3046 dSP; dMARK; dORIGMARK; dTARGET;
3047 do_sprintf(TARG, SP-MARK, MARK+1);
3048 TAINT_IF(SvTAINTED(TARG));
3049 if (DO_UTF8(*(MARK+1)))
3061 U8 *s = (U8*)SvPVx(argsv, len);
3064 if (PL_encoding && !DO_UTF8(argsv)) {
3065 tmpsv = sv_2mortal(newSVsv(argsv));
3066 s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3070 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3081 (void)SvUPGRADE(TARG,SVt_PV);
3083 if (value > 255 && !IN_BYTES) {
3084 SvGROW(TARG, UNISKIP(value)+1);
3085 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3086 SvCUR_set(TARG, tmps - SvPVX(TARG));
3088 (void)SvPOK_only(TARG);
3099 (void)SvPOK_only(TARG);
3101 Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3108 dSP; dTARGET; dPOPTOPssrl;
3112 char *tmps = SvPV(left, len);
3114 if (DO_UTF8(left)) {
3115 /* If Unicode take the crypt() of the low 8 bits
3116 * of the characters of the string. */
3118 char *send = tmps + len;
3120 Newz(688, t, len, char);
3122 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3128 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3130 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3135 "The crypt() function is unimplemented due to excessive paranoia.");
3149 U8 tmpbuf[UTF8_MAXLEN*2+1];
3153 s = (U8*)SvPV(sv, slen);
3154 utf8_to_uvchr(s, &ulen);
3156 toTITLE_utf8(s, tmpbuf, &tculen);
3157 utf8_to_uvchr(tmpbuf, 0);
3159 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3161 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3162 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3167 s = (U8*)SvPV_force(sv, slen);
3168 Copy(tmpbuf, s, tculen, U8);
3172 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3174 SvUTF8_off(TARG); /* decontaminate */
3179 s = (U8*)SvPV_force(sv, slen);
3181 if (IN_LOCALE_RUNTIME) {
3184 *s = toUPPER_LC(*s);
3202 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3204 U8 tmpbuf[UTF8_MAXLEN*2+1];
3208 toLOWER_utf8(s, tmpbuf, &ulen);
3209 uv = utf8_to_uvchr(tmpbuf, 0);
3211 tend = uvchr_to_utf8(tmpbuf, uv);
3213 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3215 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3216 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3221 s = (U8*)SvPV_force(sv, slen);
3222 Copy(tmpbuf, s, ulen, U8);
3226 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3228 SvUTF8_off(TARG); /* decontaminate */
3233 s = (U8*)SvPV_force(sv, slen);
3235 if (IN_LOCALE_RUNTIME) {
3238 *s = toLOWER_LC(*s);
3261 U8 tmpbuf[UTF8_MAXLEN*2+1];
3263 s = (U8*)SvPV(sv,len);
3265 SvUTF8_off(TARG); /* decontaminate */
3266 sv_setpvn(TARG, "", 0);
3270 (void)SvUPGRADE(TARG, SVt_PV);
3271 SvGROW(TARG, (len * 2) + 1);
3272 (void)SvPOK_only(TARG);
3273 d = (U8*)SvPVX(TARG);
3276 toUPPER_utf8(s, tmpbuf, &ulen);
3277 Copy(tmpbuf, d, ulen, U8);
3283 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3288 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3290 SvUTF8_off(TARG); /* decontaminate */
3295 s = (U8*)SvPV_force(sv, len);
3297 register U8 *send = s + len;
3299 if (IN_LOCALE_RUNTIME) {
3302 for (; s < send; s++)
3303 *s = toUPPER_LC(*s);
3306 for (; s < send; s++)
3328 U8 tmpbuf[UTF8_MAXLEN*2+1];
3330 s = (U8*)SvPV(sv,len);
3332 SvUTF8_off(TARG); /* decontaminate */
3333 sv_setpvn(TARG, "", 0);
3337 (void)SvUPGRADE(TARG, SVt_PV);
3338 SvGROW(TARG, (len * 2) + 1);
3339 (void)SvPOK_only(TARG);
3340 d = (U8*)SvPVX(TARG);
3343 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3344 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3345 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3347 * Now if the sigma is NOT followed by
3348 * /$ignorable_sequence$cased_letter/;
3349 * and it IS preceded by
3350 * /$cased_letter$ignorable_sequence/;
3351 * where $ignorable_sequence is
3352 * [\x{2010}\x{AD}\p{Mn}]*
3353 * and $cased_letter is
3354 * [\p{Ll}\p{Lo}\p{Lt}]
3355 * then it should be mapped to 0x03C2,
3356 * (GREEK SMALL LETTER FINAL SIGMA),
3357 * instead of staying 0x03A3.
3358 * See lib/unicore/SpecCase.txt.
3361 Copy(tmpbuf, d, ulen, U8);
3367 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3372 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3374 SvUTF8_off(TARG); /* decontaminate */
3380 s = (U8*)SvPV_force(sv, len);
3382 register U8 *send = s + len;
3384 if (IN_LOCALE_RUNTIME) {
3387 for (; s < send; s++)
3388 *s = toLOWER_LC(*s);
3391 for (; s < send; s++)
3406 register char *s = SvPV(sv,len);
3409 SvUTF8_off(TARG); /* decontaminate */
3411 (void)SvUPGRADE(TARG, SVt_PV);
3412 SvGROW(TARG, (len * 2) + 1);
3416 if (UTF8_IS_CONTINUED(*s)) {
3417 STRLEN ulen = UTF8SKIP(s);
3441 SvCUR_set(TARG, d - SvPVX(TARG));
3442 (void)SvPOK_only_UTF8(TARG);
3445 sv_setpvn(TARG, s, len);
3447 if (SvSMAGICAL(TARG))
3456 dSP; dMARK; dORIGMARK;
3458 register AV* av = (AV*)POPs;
3459 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3460 I32 arybase = PL_curcop->cop_arybase;
3463 if (SvTYPE(av) == SVt_PVAV) {
3464 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3466 for (svp = MARK + 1; svp <= SP; svp++) {
3471 if (max > AvMAX(av))
3474 while (++MARK <= SP) {
3475 elem = SvIVx(*MARK);
3479 svp = av_fetch(av, elem, lval);
3481 if (!svp || *svp == &PL_sv_undef)
3482 DIE(aTHX_ PL_no_aelem, elem);
3483 if (PL_op->op_private & OPpLVAL_INTRO)
3484 save_aelem(av, elem, svp);
3486 *MARK = svp ? *svp : &PL_sv_undef;
3489 if (GIMME != G_ARRAY) {
3497 /* Associative arrays. */
3502 HV *hash = (HV*)POPs;
3504 I32 gimme = GIMME_V;
3505 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3508 /* might clobber stack_sp */
3509 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3514 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3515 if (gimme == G_ARRAY) {
3518 /* might clobber stack_sp */
3520 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3525 else if (gimme == G_SCALAR)
3544 I32 gimme = GIMME_V;
3545 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3549 if (PL_op->op_private & OPpSLICE) {
3553 hvtype = SvTYPE(hv);
3554 if (hvtype == SVt_PVHV) { /* hash element */
3555 while (++MARK <= SP) {
3556 sv = hv_delete_ent(hv, *MARK, discard, 0);
3557 *MARK = sv ? sv : &PL_sv_undef;
3560 else if (hvtype == SVt_PVAV) {
3561 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3562 while (++MARK <= SP) {
3563 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3564 *MARK = sv ? sv : &PL_sv_undef;
3567 else { /* pseudo-hash element */
3568 while (++MARK <= SP) {
3569 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3570 *MARK = sv ? sv : &PL_sv_undef;
3575 DIE(aTHX_ "Not a HASH reference");
3578 else if (gimme == G_SCALAR) {
3587 if (SvTYPE(hv) == SVt_PVHV)
3588 sv = hv_delete_ent(hv, keysv, discard, 0);
3589 else if (SvTYPE(hv) == SVt_PVAV) {
3590 if (PL_op->op_flags & OPf_SPECIAL)
3591 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3593 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3596 DIE(aTHX_ "Not a HASH reference");
3611 if (PL_op->op_private & OPpEXISTS_SUB) {
3615 cv = sv_2cv(sv, &hv, &gv, FALSE);
3618 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3624 if (SvTYPE(hv) == SVt_PVHV) {
3625 if (hv_exists_ent(hv, tmpsv, 0))
3628 else if (SvTYPE(hv) == SVt_PVAV) {
3629 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3630 if (av_exists((AV*)hv, SvIV(tmpsv)))
3633 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3637 DIE(aTHX_ "Not a HASH reference");
3644 dSP; dMARK; dORIGMARK;
3645 register HV *hv = (HV*)POPs;
3646 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3647 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3649 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3650 DIE(aTHX_ "Can't localize pseudo-hash element");
3652 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3653 while (++MARK <= SP) {
3656 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3657 realhv ? hv_exists_ent(hv, keysv, 0)
3658 : avhv_exists_ent((AV*)hv, keysv, 0);
3660 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3661 svp = he ? &HeVAL(he) : 0;
3664 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3667 if (!svp || *svp == &PL_sv_undef) {
3669 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3671 if (PL_op->op_private & OPpLVAL_INTRO) {
3673 save_helem(hv, keysv, svp);
3676 char *key = SvPV(keysv, keylen);
3677 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3681 *MARK = svp ? *svp : &PL_sv_undef;
3684 if (GIMME != G_ARRAY) {
3692 /* List operators. */
3697 if (GIMME != G_ARRAY) {
3699 *MARK = *SP; /* unwanted list, return last item */
3701 *MARK = &PL_sv_undef;
3710 SV **lastrelem = PL_stack_sp;
3711 SV **lastlelem = PL_stack_base + POPMARK;
3712 SV **firstlelem = PL_stack_base + POPMARK + 1;
3713 register SV **firstrelem = lastlelem + 1;
3714 I32 arybase = PL_curcop->cop_arybase;
3715 I32 lval = PL_op->op_flags & OPf_MOD;
3716 I32 is_something_there = lval;
3718 register I32 max = lastrelem - lastlelem;
3719 register SV **lelem;
3722 if (GIMME != G_ARRAY) {
3723 ix = SvIVx(*lastlelem);
3728 if (ix < 0 || ix >= max)
3729 *firstlelem = &PL_sv_undef;
3731 *firstlelem = firstrelem[ix];
3737 SP = firstlelem - 1;
3741 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3747 if (ix < 0 || ix >= max)
3748 *lelem = &PL_sv_undef;
3750 is_something_there = TRUE;
3751 if (!(*lelem = firstrelem[ix]))
3752 *lelem = &PL_sv_undef;
3755 if (is_something_there)
3758 SP = firstlelem - 1;
3764 dSP; dMARK; dORIGMARK;
3765 I32 items = SP - MARK;
3766 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3767 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3774 dSP; dMARK; dORIGMARK;
3775 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3779 SV *val = NEWSV(46, 0);
3781 sv_setsv(val, *++MARK);
3782 else if (ckWARN(WARN_MISC))
3783 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3784 (void)hv_store_ent(hv,key,val,0);
3793 dSP; dMARK; dORIGMARK;
3794 register AV *ary = (AV*)*++MARK;
3798 register I32 offset;
3799 register I32 length;
3806 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3807 *MARK-- = SvTIED_obj((SV*)ary, mg);
3811 call_method("SPLICE",GIMME_V);
3820 offset = i = SvIVx(*MARK);
3822 offset += AvFILLp(ary) + 1;
3824 offset -= PL_curcop->cop_arybase;
3826 DIE(aTHX_ PL_no_aelem, i);
3828 length = SvIVx(*MARK++);
3830 length += AvFILLp(ary) - offset + 1;
3836 length = AvMAX(ary) + 1; /* close enough to infinity */
3840 length = AvMAX(ary) + 1;
3842 if (offset > AvFILLp(ary) + 1)
3843 offset = AvFILLp(ary) + 1;
3844 after = AvFILLp(ary) + 1 - (offset + length);
3845 if (after < 0) { /* not that much array */
3846 length += after; /* offset+length now in array */
3852 /* At this point, MARK .. SP-1 is our new LIST */
3855 diff = newlen - length;
3856 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3859 if (diff < 0) { /* shrinking the area */
3861 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3862 Copy(MARK, tmparyval, newlen, SV*);
3865 MARK = ORIGMARK + 1;
3866 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3867 MEXTEND(MARK, length);
3868 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3870 EXTEND_MORTAL(length);
3871 for (i = length, dst = MARK; i; i--) {
3872 sv_2mortal(*dst); /* free them eventualy */
3879 *MARK = AvARRAY(ary)[offset+length-1];
3882 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3883 SvREFCNT_dec(*dst++); /* free them now */
3886 AvFILLp(ary) += diff;
3888 /* pull up or down? */
3890 if (offset < after) { /* easier to pull up */
3891 if (offset) { /* esp. if nothing to pull */
3892 src = &AvARRAY(ary)[offset-1];
3893 dst = src - diff; /* diff is negative */
3894 for (i = offset; i > 0; i--) /* can't trust Copy */
3898 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3902 if (after) { /* anything to pull down? */
3903 src = AvARRAY(ary) + offset + length;
3904 dst = src + diff; /* diff is negative */
3905 Move(src, dst, after, SV*);
3907 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3908 /* avoid later double free */
3912 dst[--i] = &PL_sv_undef;
3915 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3917 *dst = NEWSV(46, 0);
3918 sv_setsv(*dst++, *src++);
3920 Safefree(tmparyval);
3923 else { /* no, expanding (or same) */
3925 New(452, tmparyval, length, SV*); /* so remember deletion */
3926 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3929 if (diff > 0) { /* expanding */
3931 /* push up or down? */
3933 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3937 Move(src, dst, offset, SV*);
3939 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3941 AvFILLp(ary) += diff;
3944 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3945 av_extend(ary, AvFILLp(ary) + diff);
3946 AvFILLp(ary) += diff;
3949 dst = AvARRAY(ary) + AvFILLp(ary);
3951 for (i = after; i; i--) {
3958 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3959 *dst = NEWSV(46, 0);
3960 sv_setsv(*dst++, *src++);
3962 MARK = ORIGMARK + 1;
3963 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3965 Copy(tmparyval, MARK, length, SV*);
3967 EXTEND_MORTAL(length);
3968 for (i = length, dst = MARK; i; i--) {
3969 sv_2mortal(*dst); /* free them eventualy */
3973 Safefree(tmparyval);
3977 else if (length--) {
3978 *MARK = tmparyval[length];
3981 while (length-- > 0)
3982 SvREFCNT_dec(tmparyval[length]);
3984 Safefree(tmparyval);
3987 *MARK = &PL_sv_undef;
3995 dSP; dMARK; dORIGMARK; dTARGET;
3996 register AV *ary = (AV*)*++MARK;
3997 register SV *sv = &PL_sv_undef;
4000 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4001 *MARK-- = SvTIED_obj((SV*)ary, mg);
4005 call_method("PUSH",G_SCALAR|G_DISCARD);
4010 /* Why no pre-extend of ary here ? */
4011 for (++MARK; MARK <= SP; MARK++) {
4014 sv_setsv(sv, *MARK);
4019 PUSHi( AvFILL(ary) + 1 );
4027 SV *sv = av_pop(av);
4029 (void)sv_2mortal(sv);
4038 SV *sv = av_shift(av);
4043 (void)sv_2mortal(sv);
4050 dSP; dMARK; dORIGMARK; dTARGET;
4051 register AV *ary = (AV*)*++MARK;
4056 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4057 *MARK-- = SvTIED_obj((SV*)ary, mg);
4061 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4066 av_unshift(ary, SP - MARK);
4069 sv_setsv(sv, *++MARK);
4070 (void)av_store(ary, i++, sv);
4074 PUSHi( AvFILL(ary) + 1 );
4084 if (GIMME == G_ARRAY) {
4091 /* safe as long as stack cannot get extended in the above */
4096 register char *down;
4101 SvUTF8_off(TARG); /* decontaminate */
4103 do_join(TARG, &PL_sv_no, MARK, SP);
4105 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4106 up = SvPV_force(TARG, len);
4108 if (DO_UTF8(TARG)) { /* first reverse each character */
4109 U8* s = (U8*)SvPVX(TARG);
4110 U8* send = (U8*)(s + len);
4112 if (UTF8_IS_INVARIANT(*s)) {
4117 if (!utf8_to_uvchr(s, 0))
4121 down = (char*)(s - 1);
4122 /* reverse this character */
4132 down = SvPVX(TARG) + len - 1;
4138 (void)SvPOK_only_UTF8(TARG);
4150 register IV limit = POPi; /* note, negative is forever */
4153 register char *s = SvPV(sv, len);
4154 bool do_utf8 = DO_UTF8(sv);
4155 char *strend = s + len;
4157 register REGEXP *rx;
4161 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4162 I32 maxiters = slen + 10;
4165 I32 origlimit = limit;
4168 AV *oldstack = PL_curstack;
4169 I32 gimme = GIMME_V;
4170 I32 oldsave = PL_savestack_ix;
4171 I32 make_mortal = 1;
4172 MAGIC *mg = (MAGIC *) NULL;
4175 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4180 DIE(aTHX_ "panic: pp_split");
4183 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4184 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4186 PL_reg_match_utf8 = do_utf8;
4188 if (pm->op_pmreplroot) {
4190 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4192 ary = GvAVn((GV*)pm->op_pmreplroot);
4195 else if (gimme != G_ARRAY)
4196 #ifdef USE_5005THREADS
4197 ary = (AV*)PL_curpad[0];
4199 ary = GvAVn(PL_defgv);
4200 #endif /* USE_5005THREADS */
4203 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4209 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4211 XPUSHs(SvTIED_obj((SV*)ary, mg));
4217 for (i = AvFILLp(ary); i >= 0; i--)
4218 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4220 /* temporarily switch stacks */
4221 SWITCHSTACK(PL_curstack, ary);
4225 base = SP - PL_stack_base;
4227 if (pm->op_pmflags & PMf_SKIPWHITE) {
4228 if (pm->op_pmflags & PMf_LOCALE) {
4229 while (isSPACE_LC(*s))
4237 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4238 SAVEINT(PL_multiline);
4239 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4243 limit = maxiters + 2;
4244 if (pm->op_pmflags & PMf_WHITE) {
4247 while (m < strend &&
4248 !((pm->op_pmflags & PMf_LOCALE)
4249 ? isSPACE_LC(*m) : isSPACE(*m)))
4254 dstr = NEWSV(30, m-s);
4255 sv_setpvn(dstr, s, m-s);
4259 (void)SvUTF8_on(dstr);
4263 while (s < strend &&
4264 ((pm->op_pmflags & PMf_LOCALE)
4265 ? isSPACE_LC(*s) : isSPACE(*s)))
4269 else if (strEQ("^", rx->precomp)) {
4272 for (m = s; m < strend && *m != '\n'; m++) ;
4276 dstr = NEWSV(30, m-s);
4277 sv_setpvn(dstr, s, m-s);
4281 (void)SvUTF8_on(dstr);
4286 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4287 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4288 && (rx->reganch & ROPT_CHECK_ALL)
4289 && !(rx->reganch & ROPT_ANCH)) {
4290 int tail = (rx->reganch & RE_INTUIT_TAIL);
4291 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4294 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4296 char c = *SvPV(csv, n_a);
4299 for (m = s; m < strend && *m != c; m++) ;
4302 dstr = NEWSV(30, m-s);
4303 sv_setpvn(dstr, s, m-s);
4307 (void)SvUTF8_on(dstr);
4309 /* The rx->minlen is in characters but we want to step
4310 * s ahead by bytes. */
4312 s = (char*)utf8_hop((U8*)m, len);
4314 s = m + len; /* Fake \n at the end */
4319 while (s < strend && --limit &&
4320 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4321 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4324 dstr = NEWSV(31, m-s);
4325 sv_setpvn(dstr, s, m-s);
4329 (void)SvUTF8_on(dstr);
4331 /* The rx->minlen is in characters but we want to step
4332 * s ahead by bytes. */
4334 s = (char*)utf8_hop((U8*)m, len);
4336 s = m + len; /* Fake \n at the end */
4341 maxiters += slen * rx->nparens;
4342 while (s < strend && --limit
4343 /* && (!rx->check_substr
4344 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4346 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4347 1 /* minend */, sv, NULL, 0))
4349 TAINT_IF(RX_MATCH_TAINTED(rx));
4350 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4355 strend = s + (strend - m);
4357 m = rx->startp[0] + orig;
4358 dstr = NEWSV(32, m-s);
4359 sv_setpvn(dstr, s, m-s);
4363 (void)SvUTF8_on(dstr);
4366 for (i = 1; i <= rx->nparens; i++) {
4367 s = rx->startp[i] + orig;
4368 m = rx->endp[i] + orig;
4370 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4371 parens that didn't match -- they should be set to
4372 undef, not the empty string */
4373 if (m >= orig && s >= orig) {
4374 dstr = NEWSV(33, m-s);
4375 sv_setpvn(dstr, s, m-s);
4378 dstr = &PL_sv_undef; /* undef, not "" */
4382 (void)SvUTF8_on(dstr);
4386 s = rx->endp[0] + orig;
4390 LEAVE_SCOPE(oldsave);
4391 iters = (SP - PL_stack_base) - base;
4392 if (iters > maxiters)
4393 DIE(aTHX_ "Split loop");
4395 /* keep field after final delim? */
4396 if (s < strend || (iters && origlimit)) {
4397 STRLEN l = strend - s;
4398 dstr = NEWSV(34, l);
4399 sv_setpvn(dstr, s, l);
4403 (void)SvUTF8_on(dstr);
4407 else if (!origlimit) {
4408 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4414 SWITCHSTACK(ary, oldstack);
4415 if (SvSMAGICAL(ary)) {
4420 if (gimme == G_ARRAY) {
4422 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4430 call_method("PUSH",G_SCALAR|G_DISCARD);
4433 if (gimme == G_ARRAY) {
4434 /* EXTEND should not be needed - we just popped them */
4436 for (i=0; i < iters; i++) {
4437 SV **svp = av_fetch(ary, i, FALSE);
4438 PUSHs((svp) ? *svp : &PL_sv_undef);
4445 if (gimme == G_ARRAY)
4448 if (iters || !pm->op_pmreplroot) {
4456 #ifdef USE_5005THREADS
4458 Perl_unlock_condpair(pTHX_ void *svv)
4460 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4463 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4464 MUTEX_LOCK(MgMUTEXP(mg));
4465 if (MgOWNER(mg) != thr)
4466 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4468 COND_SIGNAL(MgOWNERCONDP(mg));
4469 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4470 PTR2UV(thr), PTR2UV(svv)));
4471 MUTEX_UNLOCK(MgMUTEXP(mg));
4473 #endif /* USE_5005THREADS */
4480 #ifdef USE_5005THREADS
4482 #endif /* USE_5005THREADS */
4484 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4486 Perl_sharedsv_lock(aTHX_ ssv);
4487 #endif /* USE_ITHREADS */
4488 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4489 || SvTYPE(retsv) == SVt_PVCV) {
4490 retsv = refto(retsv);
4498 #ifdef USE_5005THREADS
4501 if (PL_op->op_private & OPpLVAL_INTRO)
4502 PUSHs(*save_threadsv(PL_op->op_targ));
4504 PUSHs(THREADSV(PL_op->op_targ));
4507 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4508 #endif /* USE_5005THREADS */