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 (SvTYPE(TOPs) > SVt_PVLV)
819 DIE(aTHX_ PL_no_modify);
820 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
821 && SvIVX(TOPs) != IV_MIN)
824 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
835 if (SvTYPE(TOPs) > SVt_PVLV)
836 DIE(aTHX_ PL_no_modify);
837 sv_setsv(TARG, TOPs);
838 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
839 && SvIVX(TOPs) != IV_MAX)
842 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
856 if (SvTYPE(TOPs) > SVt_PVLV)
857 DIE(aTHX_ PL_no_modify);
858 sv_setsv(TARG, TOPs);
859 if (!SvREADONLY(TOPs) && 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));
1546 #ifndef NV_PRESERVES_UV
1547 #ifdef PERL_PRESERVE_IVUV
1550 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1552 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1558 SETs(boolSV(TOPn < value));
1565 dSP; tryAMAGICbinSET(gt,0);
1566 #ifdef PERL_PRESERVE_IVUV
1569 SvIV_please(TOPm1s);
1570 if (SvIOK(TOPm1s)) {
1571 bool auvok = SvUOK(TOPm1s);
1572 bool buvok = SvUOK(TOPs);
1574 if (!auvok && !buvok) { /* ## IV > IV ## */
1575 IV aiv = SvIVX(TOPm1s);
1576 IV biv = SvIVX(TOPs);
1579 SETs(boolSV(aiv > biv));
1582 if (auvok && buvok) { /* ## UV > UV ## */
1583 UV auv = SvUVX(TOPm1s);
1584 UV buv = SvUVX(TOPs);
1587 SETs(boolSV(auv > buv));
1590 if (auvok) { /* ## UV > IV ## */
1597 /* As (a) is a UV, it's >=0, so it must be > */
1602 SETs(boolSV(auv > (UV)biv));
1605 { /* ## IV > UV ## */
1609 aiv = SvIVX(TOPm1s);
1611 /* As (b) is a UV, it's >=0, so it cannot be > */
1618 SETs(boolSV((UV)aiv > buv));
1624 #ifndef NV_PRESERVES_UV
1625 #ifdef PERL_PRESERVE_IVUV
1628 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1630 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1636 SETs(boolSV(TOPn > value));
1643 dSP; tryAMAGICbinSET(le,0);
1644 #ifdef PERL_PRESERVE_IVUV
1647 SvIV_please(TOPm1s);
1648 if (SvIOK(TOPm1s)) {
1649 bool auvok = SvUOK(TOPm1s);
1650 bool buvok = SvUOK(TOPs);
1652 if (!auvok && !buvok) { /* ## IV <= IV ## */
1653 IV aiv = SvIVX(TOPm1s);
1654 IV biv = SvIVX(TOPs);
1657 SETs(boolSV(aiv <= biv));
1660 if (auvok && buvok) { /* ## UV <= UV ## */
1661 UV auv = SvUVX(TOPm1s);
1662 UV buv = SvUVX(TOPs);
1665 SETs(boolSV(auv <= buv));
1668 if (auvok) { /* ## UV <= IV ## */
1675 /* As (a) is a UV, it's >=0, so a cannot be <= */
1680 SETs(boolSV(auv <= (UV)biv));
1683 { /* ## IV <= UV ## */
1687 aiv = SvIVX(TOPm1s);
1689 /* As (b) is a UV, it's >=0, so a must be <= */
1696 SETs(boolSV((UV)aiv <= buv));
1702 #ifndef NV_PRESERVES_UV
1703 #ifdef PERL_PRESERVE_IVUV
1706 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1708 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1714 SETs(boolSV(TOPn <= value));
1721 dSP; tryAMAGICbinSET(ge,0);
1722 #ifdef PERL_PRESERVE_IVUV
1725 SvIV_please(TOPm1s);
1726 if (SvIOK(TOPm1s)) {
1727 bool auvok = SvUOK(TOPm1s);
1728 bool buvok = SvUOK(TOPs);
1730 if (!auvok && !buvok) { /* ## IV >= IV ## */
1731 IV aiv = SvIVX(TOPm1s);
1732 IV biv = SvIVX(TOPs);
1735 SETs(boolSV(aiv >= biv));
1738 if (auvok && buvok) { /* ## UV >= UV ## */
1739 UV auv = SvUVX(TOPm1s);
1740 UV buv = SvUVX(TOPs);
1743 SETs(boolSV(auv >= buv));
1746 if (auvok) { /* ## UV >= IV ## */
1753 /* As (a) is a UV, it's >=0, so it must be >= */
1758 SETs(boolSV(auv >= (UV)biv));
1761 { /* ## IV >= UV ## */
1765 aiv = SvIVX(TOPm1s);
1767 /* As (b) is a UV, it's >=0, so a cannot be >= */
1774 SETs(boolSV((UV)aiv >= buv));
1780 #ifndef NV_PRESERVES_UV
1781 #ifdef PERL_PRESERVE_IVUV
1784 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1786 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1792 SETs(boolSV(TOPn >= value));
1799 dSP; tryAMAGICbinSET(ne,0);
1800 #ifndef NV_PRESERVES_UV
1801 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1803 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1807 #ifdef PERL_PRESERVE_IVUV
1810 SvIV_please(TOPm1s);
1811 if (SvIOK(TOPm1s)) {
1812 bool auvok = SvUOK(TOPm1s);
1813 bool buvok = SvUOK(TOPs);
1815 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1816 /* Casting IV to UV before comparison isn't going to matter
1817 on 2s complement. On 1s complement or sign&magnitude
1818 (if we have any of them) it could make negative zero
1819 differ from normal zero. As I understand it. (Need to
1820 check - is negative zero implementation defined behaviour
1822 UV buv = SvUVX(POPs);
1823 UV auv = SvUVX(TOPs);
1825 SETs(boolSV(auv != buv));
1828 { /* ## Mixed IV,UV ## */
1832 /* != is commutative so swap if needed (save code) */
1834 /* swap. top of stack (b) is the iv */
1838 /* As (a) is a UV, it's >0, so it cannot be == */
1847 /* As (b) is a UV, it's >0, so it cannot be == */
1851 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1853 SETs(boolSV((UV)iv != uv));
1861 SETs(boolSV(TOPn != value));
1868 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1869 #ifndef NV_PRESERVES_UV
1870 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1871 UV right = PTR2UV(SvRV(POPs));
1872 UV left = PTR2UV(SvRV(TOPs));
1873 SETi((left > right) - (left < right));
1877 #ifdef PERL_PRESERVE_IVUV
1878 /* Fortunately it seems NaN isn't IOK */
1881 SvIV_please(TOPm1s);
1882 if (SvIOK(TOPm1s)) {
1883 bool leftuvok = SvUOK(TOPm1s);
1884 bool rightuvok = SvUOK(TOPs);
1886 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1887 IV leftiv = SvIVX(TOPm1s);
1888 IV rightiv = SvIVX(TOPs);
1890 if (leftiv > rightiv)
1892 else if (leftiv < rightiv)
1896 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1897 UV leftuv = SvUVX(TOPm1s);
1898 UV rightuv = SvUVX(TOPs);
1900 if (leftuv > rightuv)
1902 else if (leftuv < rightuv)
1906 } else if (leftuvok) { /* ## UV <=> IV ## */
1910 rightiv = SvIVX(TOPs);
1912 /* As (a) is a UV, it's >=0, so it cannot be < */
1915 leftuv = SvUVX(TOPm1s);
1916 if (leftuv > (UV)rightiv) {
1918 } else if (leftuv < (UV)rightiv) {
1924 } else { /* ## IV <=> UV ## */
1928 leftiv = SvIVX(TOPm1s);
1930 /* As (b) is a UV, it's >=0, so it must be < */
1933 rightuv = SvUVX(TOPs);
1934 if ((UV)leftiv > rightuv) {
1936 } else if ((UV)leftiv < rightuv) {
1954 if (Perl_isnan(left) || Perl_isnan(right)) {
1958 value = (left > right) - (left < right);
1962 else if (left < right)
1964 else if (left > right)
1978 dSP; tryAMAGICbinSET(slt,0);
1981 int cmp = (IN_LOCALE_RUNTIME
1982 ? sv_cmp_locale(left, right)
1983 : sv_cmp(left, right));
1984 SETs(boolSV(cmp < 0));
1991 dSP; tryAMAGICbinSET(sgt,0);
1994 int cmp = (IN_LOCALE_RUNTIME
1995 ? sv_cmp_locale(left, right)
1996 : sv_cmp(left, right));
1997 SETs(boolSV(cmp > 0));
2004 dSP; tryAMAGICbinSET(sle,0);
2007 int cmp = (IN_LOCALE_RUNTIME
2008 ? sv_cmp_locale(left, right)
2009 : sv_cmp(left, right));
2010 SETs(boolSV(cmp <= 0));
2017 dSP; tryAMAGICbinSET(sge,0);
2020 int cmp = (IN_LOCALE_RUNTIME
2021 ? sv_cmp_locale(left, right)
2022 : sv_cmp(left, right));
2023 SETs(boolSV(cmp >= 0));
2030 dSP; tryAMAGICbinSET(seq,0);
2033 SETs(boolSV(sv_eq(left, right)));
2040 dSP; tryAMAGICbinSET(sne,0);
2043 SETs(boolSV(!sv_eq(left, right)));
2050 dSP; dTARGET; tryAMAGICbin(scmp,0);
2053 int cmp = (IN_LOCALE_RUNTIME
2054 ? sv_cmp_locale(left, right)
2055 : sv_cmp(left, right));
2063 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2066 if (SvNIOKp(left) || SvNIOKp(right)) {
2067 if (PL_op->op_private & HINT_INTEGER) {
2068 IV i = SvIV(left) & SvIV(right);
2072 UV u = SvUV(left) & SvUV(right);
2077 do_vop(PL_op->op_type, TARG, left, right);
2086 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2089 if (SvNIOKp(left) || SvNIOKp(right)) {
2090 if (PL_op->op_private & HINT_INTEGER) {
2091 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2095 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2100 do_vop(PL_op->op_type, TARG, left, right);
2109 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2112 if (SvNIOKp(left) || SvNIOKp(right)) {
2113 if (PL_op->op_private & HINT_INTEGER) {
2114 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2118 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2123 do_vop(PL_op->op_type, TARG, left, right);
2132 dSP; dTARGET; tryAMAGICun(neg);
2135 int flags = SvFLAGS(sv);
2138 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2139 /* It's publicly an integer, or privately an integer-not-float */
2142 if (SvIVX(sv) == IV_MIN) {
2143 /* 2s complement assumption. */
2144 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2147 else if (SvUVX(sv) <= IV_MAX) {
2152 else if (SvIVX(sv) != IV_MIN) {
2156 #ifdef PERL_PRESERVE_IVUV
2165 else if (SvPOKp(sv)) {
2167 char *s = SvPV(sv, len);
2168 if (isIDFIRST(*s)) {
2169 sv_setpvn(TARG, "-", 1);
2172 else if (*s == '+' || *s == '-') {
2174 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2176 else if (DO_UTF8(sv)) {
2179 goto oops_its_an_int;
2181 sv_setnv(TARG, -SvNV(sv));
2183 sv_setpvn(TARG, "-", 1);
2190 goto oops_its_an_int;
2191 sv_setnv(TARG, -SvNV(sv));
2203 dSP; tryAMAGICunSET(not);
2204 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2210 dSP; dTARGET; tryAMAGICun(compl);
2214 if (PL_op->op_private & HINT_INTEGER) {
2229 tmps = (U8*)SvPV_force(TARG, len);
2232 /* Calculate exact length, let's not estimate. */
2241 while (tmps < send) {
2242 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2243 tmps += UTF8SKIP(tmps);
2244 targlen += UNISKIP(~c);
2250 /* Now rewind strings and write them. */
2254 Newz(0, result, targlen + 1, U8);
2255 while (tmps < send) {
2256 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2257 tmps += UTF8SKIP(tmps);
2258 result = uvchr_to_utf8(result, ~c);
2262 sv_setpvn(TARG, (char*)result, targlen);
2266 Newz(0, result, nchar + 1, U8);
2267 while (tmps < send) {
2268 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2269 tmps += UTF8SKIP(tmps);
2274 sv_setpvn(TARG, (char*)result, nchar);
2282 register long *tmpl;
2283 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2286 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2291 for ( ; anum > 0; anum--, tmps++)
2300 /* integer versions of some of the above */
2304 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2307 SETi( left * right );
2314 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2318 DIE(aTHX_ "Illegal division by zero");
2319 value = POPi / value;
2327 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2331 DIE(aTHX_ "Illegal modulus zero");
2332 SETi( left % right );
2339 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2342 SETi( left + right );
2349 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2352 SETi( left - right );
2359 dSP; tryAMAGICbinSET(lt,0);
2362 SETs(boolSV(left < right));
2369 dSP; tryAMAGICbinSET(gt,0);
2372 SETs(boolSV(left > right));
2379 dSP; tryAMAGICbinSET(le,0);
2382 SETs(boolSV(left <= right));
2389 dSP; tryAMAGICbinSET(ge,0);
2392 SETs(boolSV(left >= right));
2399 dSP; tryAMAGICbinSET(eq,0);
2402 SETs(boolSV(left == right));
2409 dSP; tryAMAGICbinSET(ne,0);
2412 SETs(boolSV(left != right));
2419 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2426 else if (left < right)
2437 dSP; dTARGET; tryAMAGICun(neg);
2442 /* High falutin' math. */
2446 dSP; dTARGET; tryAMAGICbin(atan2,0);
2449 SETn(Perl_atan2(left, right));
2456 dSP; dTARGET; tryAMAGICun(sin);
2460 value = Perl_sin(value);
2468 dSP; dTARGET; tryAMAGICun(cos);
2472 value = Perl_cos(value);
2478 /* Support Configure command-line overrides for rand() functions.
2479 After 5.005, perhaps we should replace this by Configure support
2480 for drand48(), random(), or rand(). For 5.005, though, maintain
2481 compatibility by calling rand() but allow the user to override it.
2482 See INSTALL for details. --Andy Dougherty 15 July 1998
2484 /* Now it's after 5.005, and Configure supports drand48() and random(),
2485 in addition to rand(). So the overrides should not be needed any more.
2486 --Jarkko Hietaniemi 27 September 1998
2489 #ifndef HAS_DRAND48_PROTO
2490 extern double drand48 (void);
2503 if (!PL_srand_called) {
2504 (void)seedDrand01((Rand_seed_t)seed());
2505 PL_srand_called = TRUE;
2520 (void)seedDrand01((Rand_seed_t)anum);
2521 PL_srand_called = TRUE;
2530 * This is really just a quick hack which grabs various garbage
2531 * values. It really should be a real hash algorithm which
2532 * spreads the effect of every input bit onto every output bit,
2533 * if someone who knows about such things would bother to write it.
2534 * Might be a good idea to add that function to CORE as well.
2535 * No numbers below come from careful analysis or anything here,
2536 * except they are primes and SEED_C1 > 1E6 to get a full-width
2537 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2538 * probably be bigger too.
2541 # define SEED_C1 1000003
2542 #define SEED_C4 73819
2544 # define SEED_C1 25747
2545 #define SEED_C4 20639
2549 #define SEED_C5 26107
2551 #ifndef PERL_NO_DEV_RANDOM
2556 # include <starlet.h>
2557 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2558 * in 100-ns units, typically incremented ever 10 ms. */
2559 unsigned int when[2];
2561 # ifdef HAS_GETTIMEOFDAY
2562 struct timeval when;
2568 /* This test is an escape hatch, this symbol isn't set by Configure. */
2569 #ifndef PERL_NO_DEV_RANDOM
2570 #ifndef PERL_RANDOM_DEVICE
2571 /* /dev/random isn't used by default because reads from it will block
2572 * if there isn't enough entropy available. You can compile with
2573 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2574 * is enough real entropy to fill the seed. */
2575 # define PERL_RANDOM_DEVICE "/dev/urandom"
2577 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2579 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2588 _ckvmssts(sys$gettim(when));
2589 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2591 # ifdef HAS_GETTIMEOFDAY
2592 gettimeofday(&when,(struct timezone *) 0);
2593 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2596 u = (U32)SEED_C1 * when;
2599 u += SEED_C3 * (U32)PerlProc_getpid();
2600 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2601 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2602 u += SEED_C5 * (U32)PTR2UV(&when);
2609 dSP; dTARGET; tryAMAGICun(exp);
2613 value = Perl_exp(value);
2621 dSP; dTARGET; tryAMAGICun(log);
2626 SET_NUMERIC_STANDARD();
2627 DIE(aTHX_ "Can't take log of %g", value);
2629 value = Perl_log(value);
2637 dSP; dTARGET; tryAMAGICun(sqrt);
2642 SET_NUMERIC_STANDARD();
2643 DIE(aTHX_ "Can't take sqrt of %g", value);
2645 value = Perl_sqrt(value);
2652 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2653 * These need to be revisited when a newer toolchain becomes available.
2655 #if defined(__sparc64__) && defined(__GNUC__)
2656 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2657 # undef SPARC64_MODF_WORKAROUND
2658 # define SPARC64_MODF_WORKAROUND 1
2662 #if defined(SPARC64_MODF_WORKAROUND)
2664 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2667 ret = Perl_modf(theVal, &res);
2675 dSP; dTARGET; tryAMAGICun(int);
2678 IV iv = TOPi; /* attempt to convert to IV if possible. */
2679 /* XXX it's arguable that compiler casting to IV might be subtly
2680 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2681 else preferring IV has introduced a subtle behaviour change bug. OTOH
2682 relying on floating point to be accurate is a bug. */
2693 if (value < (NV)UV_MAX + 0.5) {
2696 #if defined(SPARC64_MODF_WORKAROUND)
2697 (void)sparc64_workaround_modf(value, &value);
2699 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2700 # ifdef HAS_MODFL_POW32_BUG
2701 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2703 NV offset = Perl_modf(value, &value);
2704 (void)Perl_modf(offset, &offset);
2708 (void)Perl_modf(value, &value);
2711 double tmp = (double)value;
2712 (void)Perl_modf(tmp, &tmp);
2720 if (value > (NV)IV_MIN - 0.5) {
2723 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2724 # ifdef HAS_MODFL_POW32_BUG
2725 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2727 NV offset = Perl_modf(-value, &value);
2728 (void)Perl_modf(offset, &offset);
2732 (void)Perl_modf(-value, &value);
2736 double tmp = (double)value;
2737 (void)Perl_modf(-tmp, &tmp);
2750 dSP; dTARGET; tryAMAGICun(abs);
2752 /* This will cache the NV value if string isn't actually integer */
2756 /* IVX is precise */
2758 SETu(TOPu); /* force it to be numeric only */
2766 /* 2s complement assumption. Also, not really needed as
2767 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2787 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2792 tmps = (SvPVx(POPs, len));
2793 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2794 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2807 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2812 tmps = (SvPVx(POPs, len));
2813 while (*tmps && len && isSPACE(*tmps))
2818 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2819 else if (*tmps == 'b')
2820 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2822 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2824 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2841 SETi(sv_len_utf8(sv));
2857 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2859 I32 arybase = PL_curcop->cop_arybase;
2863 int num_args = PL_op->op_private & 7;
2864 bool repl_need_utf8_upgrade = FALSE;
2865 bool repl_is_utf8 = FALSE;
2867 SvTAINTED_off(TARG); /* decontaminate */
2868 SvUTF8_off(TARG); /* decontaminate */
2872 repl = SvPV(repl_sv, repl_len);
2873 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2883 sv_utf8_upgrade(sv);
2885 else if (DO_UTF8(sv))
2886 repl_need_utf8_upgrade = TRUE;
2888 tmps = SvPV(sv, curlen);
2890 utf8_curlen = sv_len_utf8(sv);
2891 if (utf8_curlen == curlen)
2894 curlen = utf8_curlen;
2899 if (pos >= arybase) {
2917 else if (len >= 0) {
2919 if (rem > (I32)curlen)
2934 Perl_croak(aTHX_ "substr outside of string");
2935 if (ckWARN(WARN_SUBSTR))
2936 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2943 sv_pos_u2b(sv, &pos, &rem);
2945 sv_setpvn(TARG, tmps, rem);
2946 #ifdef USE_LOCALE_COLLATE
2947 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2952 SV* repl_sv_copy = NULL;
2954 if (repl_need_utf8_upgrade) {
2955 repl_sv_copy = newSVsv(repl_sv);
2956 sv_utf8_upgrade(repl_sv_copy);
2957 repl = SvPV(repl_sv_copy, repl_len);
2958 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2960 sv_insert(sv, pos, rem, repl, repl_len);
2964 SvREFCNT_dec(repl_sv_copy);
2966 else if (lvalue) { /* it's an lvalue! */
2967 if (!SvGMAGICAL(sv)) {
2971 if (ckWARN(WARN_SUBSTR))
2972 Perl_warner(aTHX_ WARN_SUBSTR,
2973 "Attempt to use reference as lvalue in substr");
2975 if (SvOK(sv)) /* is it defined ? */
2976 (void)SvPOK_only_UTF8(sv);
2978 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2981 if (SvTYPE(TARG) < SVt_PVLV) {
2982 sv_upgrade(TARG, SVt_PVLV);
2983 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2987 if (LvTARG(TARG) != sv) {
2989 SvREFCNT_dec(LvTARG(TARG));
2990 LvTARG(TARG) = SvREFCNT_inc(sv);
2992 LvTARGOFF(TARG) = upos;
2993 LvTARGLEN(TARG) = urem;
2997 PUSHs(TARG); /* avoid SvSETMAGIC here */
3004 register IV size = POPi;
3005 register IV offset = POPi;
3006 register SV *src = POPs;
3007 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3009 SvTAINTED_off(TARG); /* decontaminate */
3010 if (lvalue) { /* it's an lvalue! */
3011 if (SvTYPE(TARG) < SVt_PVLV) {
3012 sv_upgrade(TARG, SVt_PVLV);
3013 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3016 if (LvTARG(TARG) != src) {
3018 SvREFCNT_dec(LvTARG(TARG));
3019 LvTARG(TARG) = SvREFCNT_inc(src);
3021 LvTARGOFF(TARG) = offset;
3022 LvTARGLEN(TARG) = size;
3025 sv_setuv(TARG, do_vecget(src, offset, size));
3040 I32 arybase = PL_curcop->cop_arybase;
3045 offset = POPi - arybase;
3048 tmps = SvPV(big, biglen);
3049 if (offset > 0 && DO_UTF8(big))
3050 sv_pos_u2b(big, &offset, 0);
3053 else if (offset > biglen)
3055 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3056 (unsigned char*)tmps + biglen, little, 0)))
3059 retval = tmps2 - tmps;
3060 if (retval > 0 && DO_UTF8(big))
3061 sv_pos_b2u(big, &retval);
3062 PUSHi(retval + arybase);
3077 I32 arybase = PL_curcop->cop_arybase;
3083 tmps2 = SvPV(little, llen);
3084 tmps = SvPV(big, blen);
3088 if (offset > 0 && DO_UTF8(big))
3089 sv_pos_u2b(big, &offset, 0);
3090 offset = offset - arybase + llen;
3094 else if (offset > blen)
3096 if (!(tmps2 = rninstr(tmps, tmps + offset,
3097 tmps2, tmps2 + llen)))
3100 retval = tmps2 - tmps;
3101 if (retval > 0 && DO_UTF8(big))
3102 sv_pos_b2u(big, &retval);
3103 PUSHi(retval + arybase);
3109 dSP; dMARK; dORIGMARK; dTARGET;
3110 do_sprintf(TARG, SP-MARK, MARK+1);
3111 TAINT_IF(SvTAINTED(TARG));
3112 if (DO_UTF8(*(MARK+1)))
3124 U8 *s = (U8*)SvPVx(argsv, len);
3127 if (PL_encoding && !DO_UTF8(argsv)) {
3128 tmpsv = sv_2mortal(newSVsv(argsv));
3129 s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3133 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3144 (void)SvUPGRADE(TARG,SVt_PV);
3146 if (value > 255 && !IN_BYTES) {
3147 SvGROW(TARG, UNISKIP(value)+1);
3148 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3149 SvCUR_set(TARG, tmps - SvPVX(TARG));
3151 (void)SvPOK_only(TARG);
3162 (void)SvPOK_only(TARG);
3164 Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3176 char *tmps = SvPV(left, len);
3178 if (DO_UTF8(left)) {
3179 /* If Unicode take the crypt() of the low 8 bits
3180 * of the characters of the string. */
3182 char *send = tmps + len;
3184 Newz(688, t, len, char);
3186 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3192 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3194 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3199 "The crypt() function is unimplemented due to excessive paranoia.");
3213 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3217 s = (U8*)SvPV(sv, slen);
3218 utf8_to_uvchr(s, &ulen);
3220 toTITLE_utf8(s, tmpbuf, &tculen);
3221 utf8_to_uvchr(tmpbuf, 0);
3223 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3225 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3226 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3231 s = (U8*)SvPV_force(sv, slen);
3232 Copy(tmpbuf, s, tculen, U8);
3236 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3238 SvUTF8_off(TARG); /* decontaminate */
3243 s = (U8*)SvPV_force(sv, slen);
3245 if (IN_LOCALE_RUNTIME) {
3248 *s = toUPPER_LC(*s);
3266 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3268 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3272 toLOWER_utf8(s, tmpbuf, &ulen);
3273 uv = utf8_to_uvchr(tmpbuf, 0);
3275 tend = uvchr_to_utf8(tmpbuf, uv);
3277 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3279 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3280 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3285 s = (U8*)SvPV_force(sv, slen);
3286 Copy(tmpbuf, s, ulen, U8);
3290 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3292 SvUTF8_off(TARG); /* decontaminate */
3297 s = (U8*)SvPV_force(sv, slen);
3299 if (IN_LOCALE_RUNTIME) {
3302 *s = toLOWER_LC(*s);
3325 U8 tmpbuf[UTF8_MAXLEN_UCLC+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 toUPPER_utf8(s, tmpbuf, &ulen);
3341 Copy(tmpbuf, d, ulen, U8);
3347 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3352 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3354 SvUTF8_off(TARG); /* decontaminate */
3359 s = (U8*)SvPV_force(sv, len);
3361 register U8 *send = s + len;
3363 if (IN_LOCALE_RUNTIME) {
3366 for (; s < send; s++)
3367 *s = toUPPER_LC(*s);
3370 for (; s < send; s++)
3392 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3394 s = (U8*)SvPV(sv,len);
3396 SvUTF8_off(TARG); /* decontaminate */
3397 sv_setpvn(TARG, "", 0);
3401 (void)SvUPGRADE(TARG, SVt_PV);
3402 SvGROW(TARG, (len * 2) + 1);
3403 (void)SvPOK_only(TARG);
3404 d = (U8*)SvPVX(TARG);
3407 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3408 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3409 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3411 * Now if the sigma is NOT followed by
3412 * /$ignorable_sequence$cased_letter/;
3413 * and it IS preceded by
3414 * /$cased_letter$ignorable_sequence/;
3415 * where $ignorable_sequence is
3416 * [\x{2010}\x{AD}\p{Mn}]*
3417 * and $cased_letter is
3418 * [\p{Ll}\p{Lo}\p{Lt}]
3419 * then it should be mapped to 0x03C2,
3420 * (GREEK SMALL LETTER FINAL SIGMA),
3421 * instead of staying 0x03A3.
3422 * See lib/unicore/SpecCase.txt.
3425 Copy(tmpbuf, d, ulen, U8);
3431 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3436 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3438 SvUTF8_off(TARG); /* decontaminate */
3444 s = (U8*)SvPV_force(sv, len);
3446 register U8 *send = s + len;
3448 if (IN_LOCALE_RUNTIME) {
3451 for (; s < send; s++)
3452 *s = toLOWER_LC(*s);
3455 for (; s < send; s++)
3470 register char *s = SvPV(sv,len);
3473 SvUTF8_off(TARG); /* decontaminate */
3475 (void)SvUPGRADE(TARG, SVt_PV);
3476 SvGROW(TARG, (len * 2) + 1);
3480 if (UTF8_IS_CONTINUED(*s)) {
3481 STRLEN ulen = UTF8SKIP(s);
3505 SvCUR_set(TARG, d - SvPVX(TARG));
3506 (void)SvPOK_only_UTF8(TARG);
3509 sv_setpvn(TARG, s, len);
3511 if (SvSMAGICAL(TARG))
3520 dSP; dMARK; dORIGMARK;
3522 register AV* av = (AV*)POPs;
3523 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3524 I32 arybase = PL_curcop->cop_arybase;
3527 if (SvTYPE(av) == SVt_PVAV) {
3528 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3530 for (svp = MARK + 1; svp <= SP; svp++) {
3535 if (max > AvMAX(av))
3538 while (++MARK <= SP) {
3539 elem = SvIVx(*MARK);
3543 svp = av_fetch(av, elem, lval);
3545 if (!svp || *svp == &PL_sv_undef)
3546 DIE(aTHX_ PL_no_aelem, elem);
3547 if (PL_op->op_private & OPpLVAL_INTRO)
3548 save_aelem(av, elem, svp);
3550 *MARK = svp ? *svp : &PL_sv_undef;
3553 if (GIMME != G_ARRAY) {
3561 /* Associative arrays. */
3566 HV *hash = (HV*)POPs;
3568 I32 gimme = GIMME_V;
3569 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3572 /* might clobber stack_sp */
3573 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3578 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3579 if (gimme == G_ARRAY) {
3582 /* might clobber stack_sp */
3584 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3589 else if (gimme == G_SCALAR)
3608 I32 gimme = GIMME_V;
3609 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3613 if (PL_op->op_private & OPpSLICE) {
3617 hvtype = SvTYPE(hv);
3618 if (hvtype == SVt_PVHV) { /* hash element */
3619 while (++MARK <= SP) {
3620 sv = hv_delete_ent(hv, *MARK, discard, 0);
3621 *MARK = sv ? sv : &PL_sv_undef;
3624 else if (hvtype == SVt_PVAV) {
3625 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3626 while (++MARK <= SP) {
3627 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3628 *MARK = sv ? sv : &PL_sv_undef;
3631 else { /* pseudo-hash element */
3632 while (++MARK <= SP) {
3633 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3634 *MARK = sv ? sv : &PL_sv_undef;
3639 DIE(aTHX_ "Not a HASH reference");
3642 else if (gimme == G_SCALAR) {
3651 if (SvTYPE(hv) == SVt_PVHV)
3652 sv = hv_delete_ent(hv, keysv, discard, 0);
3653 else if (SvTYPE(hv) == SVt_PVAV) {
3654 if (PL_op->op_flags & OPf_SPECIAL)
3655 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3657 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3660 DIE(aTHX_ "Not a HASH reference");
3675 if (PL_op->op_private & OPpEXISTS_SUB) {
3679 cv = sv_2cv(sv, &hv, &gv, FALSE);
3682 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3688 if (SvTYPE(hv) == SVt_PVHV) {
3689 if (hv_exists_ent(hv, tmpsv, 0))
3692 else if (SvTYPE(hv) == SVt_PVAV) {
3693 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3694 if (av_exists((AV*)hv, SvIV(tmpsv)))
3697 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3701 DIE(aTHX_ "Not a HASH reference");
3708 dSP; dMARK; dORIGMARK;
3709 register HV *hv = (HV*)POPs;
3710 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3711 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3713 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3714 DIE(aTHX_ "Can't localize pseudo-hash element");
3716 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3717 while (++MARK <= SP) {
3720 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3721 realhv ? hv_exists_ent(hv, keysv, 0)
3722 : avhv_exists_ent((AV*)hv, keysv, 0);
3724 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3725 svp = he ? &HeVAL(he) : 0;
3728 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3731 if (!svp || *svp == &PL_sv_undef) {
3733 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3735 if (PL_op->op_private & OPpLVAL_INTRO) {
3737 save_helem(hv, keysv, svp);
3740 char *key = SvPV(keysv, keylen);
3741 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3745 *MARK = svp ? *svp : &PL_sv_undef;
3748 if (GIMME != G_ARRAY) {
3756 /* List operators. */
3761 if (GIMME != G_ARRAY) {
3763 *MARK = *SP; /* unwanted list, return last item */
3765 *MARK = &PL_sv_undef;
3774 SV **lastrelem = PL_stack_sp;
3775 SV **lastlelem = PL_stack_base + POPMARK;
3776 SV **firstlelem = PL_stack_base + POPMARK + 1;
3777 register SV **firstrelem = lastlelem + 1;
3778 I32 arybase = PL_curcop->cop_arybase;
3779 I32 lval = PL_op->op_flags & OPf_MOD;
3780 I32 is_something_there = lval;
3782 register I32 max = lastrelem - lastlelem;
3783 register SV **lelem;
3786 if (GIMME != G_ARRAY) {
3787 ix = SvIVx(*lastlelem);
3792 if (ix < 0 || ix >= max)
3793 *firstlelem = &PL_sv_undef;
3795 *firstlelem = firstrelem[ix];
3801 SP = firstlelem - 1;
3805 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3811 if (ix < 0 || ix >= max)
3812 *lelem = &PL_sv_undef;
3814 is_something_there = TRUE;
3815 if (!(*lelem = firstrelem[ix]))
3816 *lelem = &PL_sv_undef;
3819 if (is_something_there)
3822 SP = firstlelem - 1;
3828 dSP; dMARK; dORIGMARK;
3829 I32 items = SP - MARK;
3830 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3831 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3838 dSP; dMARK; dORIGMARK;
3839 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3843 SV *val = NEWSV(46, 0);
3845 sv_setsv(val, *++MARK);
3846 else if (ckWARN(WARN_MISC))
3847 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3848 (void)hv_store_ent(hv,key,val,0);
3857 dSP; dMARK; dORIGMARK;
3858 register AV *ary = (AV*)*++MARK;
3862 register I32 offset;
3863 register I32 length;
3870 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3871 *MARK-- = SvTIED_obj((SV*)ary, mg);
3875 call_method("SPLICE",GIMME_V);
3884 offset = i = SvIVx(*MARK);
3886 offset += AvFILLp(ary) + 1;
3888 offset -= PL_curcop->cop_arybase;
3890 DIE(aTHX_ PL_no_aelem, i);
3892 length = SvIVx(*MARK++);
3894 length += AvFILLp(ary) - offset + 1;
3900 length = AvMAX(ary) + 1; /* close enough to infinity */
3904 length = AvMAX(ary) + 1;
3906 if (offset > AvFILLp(ary) + 1)
3907 offset = AvFILLp(ary) + 1;
3908 after = AvFILLp(ary) + 1 - (offset + length);
3909 if (after < 0) { /* not that much array */
3910 length += after; /* offset+length now in array */
3916 /* At this point, MARK .. SP-1 is our new LIST */
3919 diff = newlen - length;
3920 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3923 if (diff < 0) { /* shrinking the area */
3925 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3926 Copy(MARK, tmparyval, newlen, SV*);
3929 MARK = ORIGMARK + 1;
3930 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3931 MEXTEND(MARK, length);
3932 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3934 EXTEND_MORTAL(length);
3935 for (i = length, dst = MARK; i; i--) {
3936 sv_2mortal(*dst); /* free them eventualy */
3943 *MARK = AvARRAY(ary)[offset+length-1];
3946 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3947 SvREFCNT_dec(*dst++); /* free them now */
3950 AvFILLp(ary) += diff;
3952 /* pull up or down? */
3954 if (offset < after) { /* easier to pull up */
3955 if (offset) { /* esp. if nothing to pull */
3956 src = &AvARRAY(ary)[offset-1];
3957 dst = src - diff; /* diff is negative */
3958 for (i = offset; i > 0; i--) /* can't trust Copy */
3962 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3966 if (after) { /* anything to pull down? */
3967 src = AvARRAY(ary) + offset + length;
3968 dst = src + diff; /* diff is negative */
3969 Move(src, dst, after, SV*);
3971 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3972 /* avoid later double free */
3976 dst[--i] = &PL_sv_undef;
3979 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3981 *dst = NEWSV(46, 0);
3982 sv_setsv(*dst++, *src++);
3984 Safefree(tmparyval);
3987 else { /* no, expanding (or same) */
3989 New(452, tmparyval, length, SV*); /* so remember deletion */
3990 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3993 if (diff > 0) { /* expanding */
3995 /* push up or down? */
3997 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4001 Move(src, dst, offset, SV*);
4003 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4005 AvFILLp(ary) += diff;
4008 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4009 av_extend(ary, AvFILLp(ary) + diff);
4010 AvFILLp(ary) += diff;
4013 dst = AvARRAY(ary) + AvFILLp(ary);
4015 for (i = after; i; i--) {
4022 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4023 *dst = NEWSV(46, 0);
4024 sv_setsv(*dst++, *src++);
4026 MARK = ORIGMARK + 1;
4027 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4029 Copy(tmparyval, MARK, length, SV*);
4031 EXTEND_MORTAL(length);
4032 for (i = length, dst = MARK; i; i--) {
4033 sv_2mortal(*dst); /* free them eventualy */
4037 Safefree(tmparyval);
4041 else if (length--) {
4042 *MARK = tmparyval[length];
4045 while (length-- > 0)
4046 SvREFCNT_dec(tmparyval[length]);
4048 Safefree(tmparyval);
4051 *MARK = &PL_sv_undef;
4059 dSP; dMARK; dORIGMARK; dTARGET;
4060 register AV *ary = (AV*)*++MARK;
4061 register SV *sv = &PL_sv_undef;
4064 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4065 *MARK-- = SvTIED_obj((SV*)ary, mg);
4069 call_method("PUSH",G_SCALAR|G_DISCARD);
4074 /* Why no pre-extend of ary here ? */
4075 for (++MARK; MARK <= SP; MARK++) {
4078 sv_setsv(sv, *MARK);
4083 PUSHi( AvFILL(ary) + 1 );
4091 SV *sv = av_pop(av);
4093 (void)sv_2mortal(sv);
4102 SV *sv = av_shift(av);
4107 (void)sv_2mortal(sv);
4114 dSP; dMARK; dORIGMARK; dTARGET;
4115 register AV *ary = (AV*)*++MARK;
4120 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4121 *MARK-- = SvTIED_obj((SV*)ary, mg);
4125 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4130 av_unshift(ary, SP - MARK);
4133 sv_setsv(sv, *++MARK);
4134 (void)av_store(ary, i++, sv);
4138 PUSHi( AvFILL(ary) + 1 );
4148 if (GIMME == G_ARRAY) {
4155 /* safe as long as stack cannot get extended in the above */
4160 register char *down;
4165 SvUTF8_off(TARG); /* decontaminate */
4167 do_join(TARG, &PL_sv_no, MARK, SP);
4169 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4170 up = SvPV_force(TARG, len);
4172 if (DO_UTF8(TARG)) { /* first reverse each character */
4173 U8* s = (U8*)SvPVX(TARG);
4174 U8* send = (U8*)(s + len);
4176 if (UTF8_IS_INVARIANT(*s)) {
4181 if (!utf8_to_uvchr(s, 0))
4185 down = (char*)(s - 1);
4186 /* reverse this character */
4196 down = SvPVX(TARG) + len - 1;
4202 (void)SvPOK_only_UTF8(TARG);
4214 register IV limit = POPi; /* note, negative is forever */
4217 register char *s = SvPV(sv, len);
4218 bool do_utf8 = DO_UTF8(sv);
4219 char *strend = s + len;
4221 register REGEXP *rx;
4225 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4226 I32 maxiters = slen + 10;
4229 I32 origlimit = limit;
4232 AV *oldstack = PL_curstack;
4233 I32 gimme = GIMME_V;
4234 I32 oldsave = PL_savestack_ix;
4235 I32 make_mortal = 1;
4236 MAGIC *mg = (MAGIC *) NULL;
4239 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4244 DIE(aTHX_ "panic: pp_split");
4247 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4248 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4250 PL_reg_match_utf8 = do_utf8;
4252 if (pm->op_pmreplroot) {
4254 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4256 ary = GvAVn((GV*)pm->op_pmreplroot);
4259 else if (gimme != G_ARRAY)
4260 #ifdef USE_5005THREADS
4261 ary = (AV*)PL_curpad[0];
4263 ary = GvAVn(PL_defgv);
4264 #endif /* USE_5005THREADS */
4267 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4273 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4275 XPUSHs(SvTIED_obj((SV*)ary, mg));
4281 for (i = AvFILLp(ary); i >= 0; i--)
4282 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4284 /* temporarily switch stacks */
4285 SWITCHSTACK(PL_curstack, ary);
4289 base = SP - PL_stack_base;
4291 if (pm->op_pmflags & PMf_SKIPWHITE) {
4292 if (pm->op_pmflags & PMf_LOCALE) {
4293 while (isSPACE_LC(*s))
4301 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4302 SAVEINT(PL_multiline);
4303 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4307 limit = maxiters + 2;
4308 if (pm->op_pmflags & PMf_WHITE) {
4311 while (m < strend &&
4312 !((pm->op_pmflags & PMf_LOCALE)
4313 ? isSPACE_LC(*m) : isSPACE(*m)))
4318 dstr = NEWSV(30, m-s);
4319 sv_setpvn(dstr, s, m-s);
4323 (void)SvUTF8_on(dstr);
4327 while (s < strend &&
4328 ((pm->op_pmflags & PMf_LOCALE)
4329 ? isSPACE_LC(*s) : isSPACE(*s)))
4333 else if (strEQ("^", rx->precomp)) {
4336 for (m = s; m < strend && *m != '\n'; m++) ;
4340 dstr = NEWSV(30, m-s);
4341 sv_setpvn(dstr, s, m-s);
4345 (void)SvUTF8_on(dstr);
4350 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4351 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4352 && (rx->reganch & ROPT_CHECK_ALL)
4353 && !(rx->reganch & ROPT_ANCH)) {
4354 int tail = (rx->reganch & RE_INTUIT_TAIL);
4355 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4358 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4360 char c = *SvPV(csv, n_a);
4363 for (m = s; m < strend && *m != c; m++) ;
4366 dstr = NEWSV(30, m-s);
4367 sv_setpvn(dstr, s, m-s);
4371 (void)SvUTF8_on(dstr);
4373 /* The rx->minlen is in characters but we want to step
4374 * s ahead by bytes. */
4376 s = (char*)utf8_hop((U8*)m, len);
4378 s = m + len; /* Fake \n at the end */
4383 while (s < strend && --limit &&
4384 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4385 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4388 dstr = NEWSV(31, m-s);
4389 sv_setpvn(dstr, s, m-s);
4393 (void)SvUTF8_on(dstr);
4395 /* The rx->minlen is in characters but we want to step
4396 * s ahead by bytes. */
4398 s = (char*)utf8_hop((U8*)m, len);
4400 s = m + len; /* Fake \n at the end */
4405 maxiters += slen * rx->nparens;
4406 while (s < strend && --limit
4407 /* && (!rx->check_substr
4408 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4410 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4411 1 /* minend */, sv, NULL, 0))
4413 TAINT_IF(RX_MATCH_TAINTED(rx));
4414 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4419 strend = s + (strend - m);
4421 m = rx->startp[0] + orig;
4422 dstr = NEWSV(32, m-s);
4423 sv_setpvn(dstr, s, m-s);
4427 (void)SvUTF8_on(dstr);
4430 for (i = 1; i <= rx->nparens; i++) {
4431 s = rx->startp[i] + orig;
4432 m = rx->endp[i] + orig;
4434 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4435 parens that didn't match -- they should be set to
4436 undef, not the empty string */
4437 if (m >= orig && s >= orig) {
4438 dstr = NEWSV(33, m-s);
4439 sv_setpvn(dstr, s, m-s);
4442 dstr = &PL_sv_undef; /* undef, not "" */
4446 (void)SvUTF8_on(dstr);
4450 s = rx->endp[0] + orig;
4454 LEAVE_SCOPE(oldsave);
4455 iters = (SP - PL_stack_base) - base;
4456 if (iters > maxiters)
4457 DIE(aTHX_ "Split loop");
4459 /* keep field after final delim? */
4460 if (s < strend || (iters && origlimit)) {
4461 STRLEN l = strend - s;
4462 dstr = NEWSV(34, l);
4463 sv_setpvn(dstr, s, l);
4467 (void)SvUTF8_on(dstr);
4471 else if (!origlimit) {
4472 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4478 SWITCHSTACK(ary, oldstack);
4479 if (SvSMAGICAL(ary)) {
4484 if (gimme == G_ARRAY) {
4486 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4494 call_method("PUSH",G_SCALAR|G_DISCARD);
4497 if (gimme == G_ARRAY) {
4498 /* EXTEND should not be needed - we just popped them */
4500 for (i=0; i < iters; i++) {
4501 SV **svp = av_fetch(ary, i, FALSE);
4502 PUSHs((svp) ? *svp : &PL_sv_undef);
4509 if (gimme == G_ARRAY)
4512 if (iters || !pm->op_pmreplroot) {
4520 #ifdef USE_5005THREADS
4522 Perl_unlock_condpair(pTHX_ void *svv)
4524 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4527 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4528 MUTEX_LOCK(MgMUTEXP(mg));
4529 if (MgOWNER(mg) != thr)
4530 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4532 COND_SIGNAL(MgOWNERCONDP(mg));
4533 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4534 PTR2UV(thr), PTR2UV(svv)));
4535 MUTEX_UNLOCK(MgMUTEXP(mg));
4537 #endif /* USE_5005THREADS */
4544 #ifdef USE_5005THREADS
4546 #endif /* USE_5005THREADS */
4548 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4550 Perl_sharedsv_lock(aTHX_ ssv);
4551 #endif /* USE_ITHREADS */
4552 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4553 || SvTYPE(retsv) == SVt_PVCV) {
4554 retsv = refto(retsv);
4562 #ifdef USE_5005THREADS
4565 if (PL_op->op_private & OPpLVAL_INTRO)
4566 PUSHs(*save_threadsv(PL_op->op_targ));
4568 PUSHs(THREADSV(PL_op->op_targ));
4571 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4572 #endif /* USE_5005THREADS */