3 * Copyright (c) 1991-2002, 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
20 /* variations on pp_null */
22 /* XXX I can't imagine anyone who doesn't have this actually _needs_
23 it, since pid_t is an integral type.
26 #ifdef NEED_GETPID_PROTO
27 extern Pid_t getpid (void);
33 if (GIMME_V == G_SCALAR)
48 if (PL_op->op_private & OPpLVAL_INTRO)
49 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
51 if (PL_op->op_flags & OPf_REF) {
55 if (GIMME == G_SCALAR)
56 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
60 if (GIMME == G_ARRAY) {
61 I32 maxarg = AvFILL((AV*)TARG) + 1;
63 if (SvMAGICAL(TARG)) {
65 for (i=0; i < maxarg; i++) {
66 SV **svp = av_fetch((AV*)TARG, i, FALSE);
67 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
71 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
76 SV* sv = sv_newmortal();
77 I32 maxarg = AvFILL((AV*)TARG) + 1;
90 if (PL_op->op_private & OPpLVAL_INTRO)
91 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
92 if (PL_op->op_flags & OPf_REF)
95 if (GIMME == G_SCALAR)
96 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
100 if (gimme == G_ARRAY) {
103 else if (gimme == G_SCALAR) {
104 SV* sv = sv_newmortal();
105 if (HvFILL((HV*)TARG))
106 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
107 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
117 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
128 tryAMAGICunDEREF(to_gv);
131 if (SvTYPE(sv) == SVt_PVIO) {
132 GV *gv = (GV*) sv_newmortal();
133 gv_init(gv, 0, "", 0, 0);
134 GvIOp(gv) = (IO *)sv;
135 (void)SvREFCNT_inc(sv);
138 else if (SvTYPE(sv) != SVt_PVGV)
139 DIE(aTHX_ "Not a GLOB reference");
142 if (SvTYPE(sv) != SVt_PVGV) {
146 if (SvGMAGICAL(sv)) {
151 if (!SvOK(sv) && sv != &PL_sv_undef) {
152 /* If this is a 'my' scalar and flag is set then vivify
155 if (PL_op->op_private & OPpDEREF) {
158 if (cUNOP->op_targ) {
160 SV *namesv = PL_curpad[cUNOP->op_targ];
161 name = SvPV(namesv, len);
162 gv = (GV*)NEWSV(0,0);
163 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
166 name = CopSTASHPV(PL_curcop);
169 if (SvTYPE(sv) < SVt_RV)
170 sv_upgrade(sv, SVt_RV);
176 if (PL_op->op_flags & OPf_REF ||
177 PL_op->op_private & HINT_STRICT_REFS)
178 DIE(aTHX_ PL_no_usym, "a symbol");
179 if (ckWARN(WARN_UNINITIALIZED))
184 if ((PL_op->op_flags & OPf_SPECIAL) &&
185 !(PL_op->op_flags & OPf_MOD))
187 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
189 && (!is_gv_magical(sym,len,0)
190 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
196 if (PL_op->op_private & HINT_STRICT_REFS)
197 DIE(aTHX_ PL_no_symref, sym, "a symbol");
198 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
202 if (PL_op->op_private & OPpLVAL_INTRO)
203 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
214 tryAMAGICunDEREF(to_sv);
217 switch (SvTYPE(sv)) {
221 DIE(aTHX_ "Not a SCALAR reference");
229 if (SvTYPE(gv) != SVt_PVGV) {
230 if (SvGMAGICAL(sv)) {
236 if (PL_op->op_flags & OPf_REF ||
237 PL_op->op_private & HINT_STRICT_REFS)
238 DIE(aTHX_ PL_no_usym, "a SCALAR");
239 if (ckWARN(WARN_UNINITIALIZED))
244 if ((PL_op->op_flags & OPf_SPECIAL) &&
245 !(PL_op->op_flags & OPf_MOD))
247 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
249 && (!is_gv_magical(sym,len,0)
250 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
256 if (PL_op->op_private & HINT_STRICT_REFS)
257 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
258 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
263 if (PL_op->op_flags & OPf_MOD) {
264 if (PL_op->op_private & OPpLVAL_INTRO)
265 sv = save_scalar((GV*)TOPs);
266 else if (PL_op->op_private & OPpDEREF)
267 vivify_ref(sv, PL_op->op_private & OPpDEREF);
277 SV *sv = AvARYLEN(av);
279 AvARYLEN(av) = sv = NEWSV(0,0);
280 sv_upgrade(sv, SVt_IV);
281 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
289 dSP; dTARGET; dPOPss;
291 if (PL_op->op_flags & OPf_MOD || LVRET) {
292 if (SvTYPE(TARG) < SVt_PVLV) {
293 sv_upgrade(TARG, SVt_PVLV);
294 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
298 if (LvTARG(TARG) != sv) {
300 SvREFCNT_dec(LvTARG(TARG));
301 LvTARG(TARG) = SvREFCNT_inc(sv);
303 PUSHs(TARG); /* no SvSETMAGIC */
309 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
310 mg = mg_find(sv, PERL_MAGIC_regex_global);
311 if (mg && mg->mg_len >= 0) {
315 PUSHi(i + PL_curcop->cop_arybase);
329 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
330 /* (But not in defined().) */
331 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
334 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
335 if ((PL_op->op_private & OPpLVAL_INTRO)) {
336 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
339 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
343 cv = (CV*)&PL_sv_undef;
357 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
358 char *s = SvPVX(TOPs);
359 if (strnEQ(s, "CORE::", 6)) {
362 code = keyword(s + 6, SvCUR(TOPs) - 6);
363 if (code < 0) { /* Overridable. */
364 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
365 int i = 0, n = 0, seen_question = 0;
367 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
369 if (code == -KEY_chop || code == -KEY_chomp)
371 while (i < MAXO) { /* The slow way. */
372 if (strEQ(s + 6, PL_op_name[i])
373 || strEQ(s + 6, PL_op_desc[i]))
379 goto nonesuch; /* Should not happen... */
381 oa = PL_opargs[i] >> OASHIFT;
383 if (oa & OA_OPTIONAL && !seen_question) {
387 else if (n && str[0] == ';' && seen_question)
388 goto set; /* XXXX system, exec */
389 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
390 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
391 /* But globs are already references (kinda) */
392 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
396 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
400 ret = sv_2mortal(newSVpvn(str, n - 1));
402 else if (code) /* Non-Overridable */
404 else { /* None such */
406 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
410 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
412 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
421 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
423 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
439 if (GIMME != G_ARRAY) {
443 *MARK = &PL_sv_undef;
444 *MARK = refto(*MARK);
448 EXTEND_MORTAL(SP - MARK);
450 *MARK = refto(*MARK);
455 S_refto(pTHX_ SV *sv)
459 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
462 if (!(sv = LvTARG(sv)))
465 (void)SvREFCNT_inc(sv);
467 else if (SvTYPE(sv) == SVt_PVAV) {
468 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
471 (void)SvREFCNT_inc(sv);
473 else if (SvPADTMP(sv) && !IS_PADGV(sv))
477 (void)SvREFCNT_inc(sv);
480 sv_upgrade(rv, SVt_RV);
494 if (sv && SvGMAGICAL(sv))
497 if (!sv || !SvROK(sv))
501 pv = sv_reftype(sv,TRUE);
502 PUSHp(pv, strlen(pv));
512 stash = CopSTASH(PL_curcop);
518 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
519 Perl_croak(aTHX_ "Attempt to bless into a reference");
521 if (ckWARN(WARN_MISC) && len == 0)
522 Perl_warner(aTHX_ WARN_MISC,
523 "Explicit blessing to '' (assuming package main)");
524 stash = gv_stashpvn(ptr, len, TRUE);
527 (void)sv_bless(TOPs, stash);
541 elem = SvPV(sv, n_a);
545 switch (elem ? *elem : '\0')
548 if (strEQ(elem, "ARRAY"))
549 tmpRef = (SV*)GvAV(gv);
552 if (strEQ(elem, "CODE"))
553 tmpRef = (SV*)GvCVu(gv);
556 if (strEQ(elem, "FILEHANDLE")) {
557 /* finally deprecated in 5.8.0 */
558 deprecate("*glob{FILEHANDLE}");
559 tmpRef = (SV*)GvIOp(gv);
562 if (strEQ(elem, "FORMAT"))
563 tmpRef = (SV*)GvFORM(gv);
566 if (strEQ(elem, "GLOB"))
570 if (strEQ(elem, "HASH"))
571 tmpRef = (SV*)GvHV(gv);
574 if (strEQ(elem, "IO"))
575 tmpRef = (SV*)GvIOp(gv);
578 if (strEQ(elem, "NAME"))
579 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
582 if (strEQ(elem, "PACKAGE"))
583 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
586 if (strEQ(elem, "SCALAR"))
600 /* Pattern matching */
605 register unsigned char *s;
608 register I32 *sfirst;
612 if (sv == PL_lastscream) {
618 SvSCREAM_off(PL_lastscream);
619 SvREFCNT_dec(PL_lastscream);
621 PL_lastscream = SvREFCNT_inc(sv);
624 s = (unsigned char*)(SvPV(sv, len));
628 if (pos > PL_maxscream) {
629 if (PL_maxscream < 0) {
630 PL_maxscream = pos + 80;
631 New(301, PL_screamfirst, 256, I32);
632 New(302, PL_screamnext, PL_maxscream, I32);
635 PL_maxscream = pos + pos / 4;
636 Renew(PL_screamnext, PL_maxscream, I32);
640 sfirst = PL_screamfirst;
641 snext = PL_screamnext;
643 if (!sfirst || !snext)
644 DIE(aTHX_ "do_study: out of memory");
646 for (ch = 256; ch; --ch)
653 snext[pos] = sfirst[ch] - pos;
660 /* piggyback on m//g magic */
661 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
670 if (PL_op->op_flags & OPf_STACKED)
676 TARG = sv_newmortal();
681 /* Lvalue operators. */
693 dSP; dMARK; dTARGET; dORIGMARK;
695 do_chop(TARG, *++MARK);
704 SETi(do_chomp(TOPs));
711 register I32 count = 0;
714 count += do_chomp(POPs);
725 if (!sv || !SvANY(sv))
727 switch (SvTYPE(sv)) {
729 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
730 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
734 if (HvARRAY(sv) || SvGMAGICAL(sv)
735 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
739 if (CvROOT(sv) || CvXSUB(sv))
756 if (!PL_op->op_private) {
765 if (SvTHINKFIRST(sv))
768 switch (SvTYPE(sv)) {
778 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
779 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
780 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
784 /* let user-undef'd sub keep its identity */
785 GV* gv = CvGV((CV*)sv);
792 SvSetMagicSV(sv, &PL_sv_undef);
796 Newz(602, gp, 1, GP);
797 GvGP(sv) = gp_ref(gp);
798 GvSV(sv) = NEWSV(72,0);
799 GvLINE(sv) = CopLINE(PL_curcop);
805 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
808 SvPV_set(sv, Nullch);
821 if (SvTYPE(TOPs) > SVt_PVLV)
822 DIE(aTHX_ PL_no_modify);
823 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
824 && SvIVX(TOPs) != IV_MIN)
827 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
838 if (SvTYPE(TOPs) > SVt_PVLV)
839 DIE(aTHX_ PL_no_modify);
840 sv_setsv(TARG, TOPs);
841 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
842 && SvIVX(TOPs) != IV_MAX)
845 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
859 if (SvTYPE(TOPs) > SVt_PVLV)
860 DIE(aTHX_ PL_no_modify);
861 sv_setsv(TARG, TOPs);
862 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
863 && SvIVX(TOPs) != IV_MIN)
866 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
875 /* Ordinary operators. */
879 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
882 SETn( Perl_pow( left, right) );
889 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
890 #ifdef PERL_PRESERVE_IVUV
893 /* Unless the left argument is integer in range we are going to have to
894 use NV maths. Hence only attempt to coerce the right argument if
895 we know the left is integer. */
896 /* Left operand is defined, so is it IV? */
899 bool auvok = SvUOK(TOPm1s);
900 bool buvok = SvUOK(TOPs);
901 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
902 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
909 alow = SvUVX(TOPm1s);
911 IV aiv = SvIVX(TOPm1s);
914 auvok = TRUE; /* effectively it's a UV now */
916 alow = -aiv; /* abs, auvok == false records sign */
922 IV biv = SvIVX(TOPs);
925 buvok = TRUE; /* effectively it's a UV now */
927 blow = -biv; /* abs, buvok == false records sign */
931 /* If this does sign extension on unsigned it's time for plan B */
932 ahigh = alow >> (4 * sizeof (UV));
934 bhigh = blow >> (4 * sizeof (UV));
936 if (ahigh && bhigh) {
937 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
938 which is overflow. Drop to NVs below. */
939 } else if (!ahigh && !bhigh) {
940 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
941 so the unsigned multiply cannot overflow. */
942 UV product = alow * blow;
943 if (auvok == buvok) {
944 /* -ve * -ve or +ve * +ve gives a +ve result. */
948 } else if (product <= (UV)IV_MIN) {
949 /* 2s complement assumption that (UV)-IV_MIN is correct. */
950 /* -ve result, which could overflow an IV */
952 SETi( -(IV)product );
954 } /* else drop to NVs below. */
956 /* One operand is large, 1 small */
959 /* swap the operands */
961 bhigh = blow; /* bhigh now the temp var for the swap */
965 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
966 multiplies can't overflow. shift can, add can, -ve can. */
967 product_middle = ahigh * blow;
968 if (!(product_middle & topmask)) {
969 /* OK, (ahigh * blow) won't lose bits when we shift it. */
971 product_middle <<= (4 * sizeof (UV));
972 product_low = alow * blow;
974 /* as for pp_add, UV + something mustn't get smaller.
975 IIRC ANSI mandates this wrapping *behaviour* for
976 unsigned whatever the actual representation*/
977 product_low += product_middle;
978 if (product_low >= product_middle) {
979 /* didn't overflow */
980 if (auvok == buvok) {
981 /* -ve * -ve or +ve * +ve gives a +ve result. */
985 } else if (product_low <= (UV)IV_MIN) {
986 /* 2s complement assumption again */
987 /* -ve result, which could overflow an IV */
989 SETi( -(IV)product_low );
991 } /* else drop to NVs below. */
993 } /* product_middle too large */
994 } /* ahigh && bhigh */
995 } /* SvIOK(TOPm1s) */
1000 SETn( left * right );
1007 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1008 /* Only try to do UV divide first
1009 if ((SLOPPYDIVIDE is true) or
1010 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1012 The assumption is that it is better to use floating point divide
1013 whenever possible, only doing integer divide first if we can't be sure.
1014 If NV_PRESERVES_UV is true then we know at compile time that no UV
1015 can be too large to preserve, so don't need to compile the code to
1016 test the size of UVs. */
1019 # define PERL_TRY_UV_DIVIDE
1020 /* ensure that 20./5. == 4. */
1022 # ifdef PERL_PRESERVE_IVUV
1023 # ifndef NV_PRESERVES_UV
1024 # define PERL_TRY_UV_DIVIDE
1029 #ifdef PERL_TRY_UV_DIVIDE
1032 SvIV_please(TOPm1s);
1033 if (SvIOK(TOPm1s)) {
1034 bool left_non_neg = SvUOK(TOPm1s);
1035 bool right_non_neg = SvUOK(TOPs);
1039 if (right_non_neg) {
1040 right = SvUVX(TOPs);
1043 IV biv = SvIVX(TOPs);
1046 right_non_neg = TRUE; /* effectively it's a UV now */
1052 /* historically undef()/0 gives a "Use of uninitialized value"
1053 warning before dieing, hence this test goes here.
1054 If it were immediately before the second SvIV_please, then
1055 DIE() would be invoked before left was even inspected, so
1056 no inpsection would give no warning. */
1058 DIE(aTHX_ "Illegal division by zero");
1061 left = SvUVX(TOPm1s);
1064 IV aiv = SvIVX(TOPm1s);
1067 left_non_neg = TRUE; /* effectively it's a UV now */
1076 /* For sloppy divide we always attempt integer division. */
1078 /* Otherwise we only attempt it if either or both operands
1079 would not be preserved by an NV. If both fit in NVs
1080 we fall through to the NV divide code below. However,
1081 as left >= right to ensure integer result here, we know that
1082 we can skip the test on the right operand - right big
1083 enough not to be preserved can't get here unless left is
1086 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1089 /* Integer division can't overflow, but it can be imprecise. */
1090 UV result = left / right;
1091 if (result * right == left) {
1092 SP--; /* result is valid */
1093 if (left_non_neg == right_non_neg) {
1094 /* signs identical, result is positive. */
1098 /* 2s complement assumption */
1099 if (result <= (UV)IV_MIN)
1102 /* It's exact but too negative for IV. */
1103 SETn( -(NV)result );
1106 } /* tried integer divide but it was not an integer result */
1107 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1108 } /* left wasn't SvIOK */
1109 } /* right wasn't SvIOK */
1110 #endif /* PERL_TRY_UV_DIVIDE */
1114 DIE(aTHX_ "Illegal division by zero");
1115 PUSHn( left / right );
1122 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1126 bool left_neg = FALSE;
1127 bool right_neg = FALSE;
1128 bool use_double = FALSE;
1129 bool dright_valid = FALSE;
1135 right_neg = !SvUOK(TOPs);
1137 right = SvUVX(POPs);
1139 IV biv = SvIVX(POPs);
1142 right_neg = FALSE; /* effectively it's a UV now */
1150 right_neg = dright < 0;
1153 if (dright < UV_MAX_P1) {
1154 right = U_V(dright);
1155 dright_valid = TRUE; /* In case we need to use double below. */
1161 /* At this point use_double is only true if right is out of range for
1162 a UV. In range NV has been rounded down to nearest UV and
1163 use_double false. */
1165 if (!use_double && SvIOK(TOPs)) {
1167 left_neg = !SvUOK(TOPs);
1171 IV aiv = SvIVX(POPs);
1174 left_neg = FALSE; /* effectively it's a UV now */
1183 left_neg = dleft < 0;
1187 /* This should be exactly the 5.6 behaviour - if left and right are
1188 both in range for UV then use U_V() rather than floor. */
1190 if (dleft < UV_MAX_P1) {
1191 /* right was in range, so is dleft, so use UVs not double.
1195 /* left is out of range for UV, right was in range, so promote
1196 right (back) to double. */
1198 /* The +0.5 is used in 5.6 even though it is not strictly
1199 consistent with the implicit +0 floor in the U_V()
1200 inside the #if 1. */
1201 dleft = Perl_floor(dleft + 0.5);
1204 dright = Perl_floor(dright + 0.5);
1214 DIE(aTHX_ "Illegal modulus zero");
1216 dans = Perl_fmod(dleft, dright);
1217 if ((left_neg != right_neg) && dans)
1218 dans = dright - dans;
1221 sv_setnv(TARG, dans);
1227 DIE(aTHX_ "Illegal modulus zero");
1230 if ((left_neg != right_neg) && ans)
1233 /* XXX may warn: unary minus operator applied to unsigned type */
1234 /* could change -foo to be (~foo)+1 instead */
1235 if (ans <= ~((UV)IV_MAX)+1)
1236 sv_setiv(TARG, ~ans+1);
1238 sv_setnv(TARG, -(NV)ans);
1241 sv_setuv(TARG, ans);
1250 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1252 register IV count = POPi;
1253 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1255 I32 items = SP - MARK;
1258 max = items * count;
1263 /* This code was intended to fix 20010809.028:
1266 for (($x =~ /./g) x 2) {
1267 print chop; # "abcdabcd" expected as output.
1270 * but that change (#11635) broke this code:
1272 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1274 * I can't think of a better fix that doesn't introduce
1275 * an efficiency hit by copying the SVs. The stack isn't
1276 * refcounted, and mortalisation obviously doesn't
1277 * Do The Right Thing when the stack has more than
1278 * one pointer to the same mortal value.
1282 *SP = sv_2mortal(newSVsv(*SP));
1292 repeatcpy((char*)(MARK + items), (char*)MARK,
1293 items * sizeof(SV*), count - 1);
1296 else if (count <= 0)
1299 else { /* Note: mark already snarfed by pp_list */
1304 SvSetSV(TARG, tmpstr);
1305 SvPV_force(TARG, len);
1306 isutf = DO_UTF8(TARG);
1311 SvGROW(TARG, (count * len) + 1);
1312 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1313 SvCUR(TARG) *= count;
1315 *SvEND(TARG) = '\0';
1318 (void)SvPOK_only_UTF8(TARG);
1320 (void)SvPOK_only(TARG);
1322 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1323 /* The parser saw this as a list repeat, and there
1324 are probably several items on the stack. But we're
1325 in scalar context, and there's no pp_list to save us
1326 now. So drop the rest of the items -- robin@kitsite.com
1339 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1340 useleft = USE_LEFT(TOPm1s);
1341 #ifdef PERL_PRESERVE_IVUV
1342 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1343 "bad things" happen if you rely on signed integers wrapping. */
1346 /* Unless the left argument is integer in range we are going to have to
1347 use NV maths. Hence only attempt to coerce the right argument if
1348 we know the left is integer. */
1349 register UV auv = 0;
1355 a_valid = auvok = 1;
1356 /* left operand is undef, treat as zero. */
1358 /* Left operand is defined, so is it IV? */
1359 SvIV_please(TOPm1s);
1360 if (SvIOK(TOPm1s)) {
1361 if ((auvok = SvUOK(TOPm1s)))
1362 auv = SvUVX(TOPm1s);
1364 register IV aiv = SvIVX(TOPm1s);
1367 auvok = 1; /* Now acting as a sign flag. */
1368 } else { /* 2s complement assumption for IV_MIN */
1376 bool result_good = 0;
1379 bool buvok = SvUOK(TOPs);
1384 register IV biv = SvIVX(TOPs);
1391 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1392 else "IV" now, independant of how it came in.
1393 if a, b represents positive, A, B negative, a maps to -A etc
1398 all UV maths. negate result if A negative.
1399 subtract if signs same, add if signs differ. */
1401 if (auvok ^ buvok) {
1410 /* Must get smaller */
1415 if (result <= buv) {
1416 /* result really should be -(auv-buv). as its negation
1417 of true value, need to swap our result flag */
1429 if (result <= (UV)IV_MIN)
1430 SETi( -(IV)result );
1432 /* result valid, but out of range for IV. */
1433 SETn( -(NV)result );
1437 } /* Overflow, drop through to NVs. */
1441 useleft = USE_LEFT(TOPm1s);
1445 /* left operand is undef, treat as zero - value */
1449 SETn( TOPn - value );
1456 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1459 if (PL_op->op_private & HINT_INTEGER) {
1473 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1476 if (PL_op->op_private & HINT_INTEGER) {
1490 dSP; tryAMAGICbinSET(lt,0);
1491 #ifdef PERL_PRESERVE_IVUV
1494 SvIV_please(TOPm1s);
1495 if (SvIOK(TOPm1s)) {
1496 bool auvok = SvUOK(TOPm1s);
1497 bool buvok = SvUOK(TOPs);
1499 if (!auvok && !buvok) { /* ## IV < IV ## */
1500 IV aiv = SvIVX(TOPm1s);
1501 IV biv = SvIVX(TOPs);
1504 SETs(boolSV(aiv < biv));
1507 if (auvok && buvok) { /* ## UV < UV ## */
1508 UV auv = SvUVX(TOPm1s);
1509 UV buv = SvUVX(TOPs);
1512 SETs(boolSV(auv < buv));
1515 if (auvok) { /* ## UV < IV ## */
1522 /* As (a) is a UV, it's >=0, so it cannot be < */
1527 SETs(boolSV(auv < (UV)biv));
1530 { /* ## IV < UV ## */
1534 aiv = SvIVX(TOPm1s);
1536 /* As (b) is a UV, it's >=0, so it must be < */
1543 SETs(boolSV((UV)aiv < buv));
1549 #ifndef NV_PRESERVES_UV
1550 #ifdef PERL_PRESERVE_IVUV
1553 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1555 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1561 SETs(boolSV(TOPn < value));
1568 dSP; tryAMAGICbinSET(gt,0);
1569 #ifdef PERL_PRESERVE_IVUV
1572 SvIV_please(TOPm1s);
1573 if (SvIOK(TOPm1s)) {
1574 bool auvok = SvUOK(TOPm1s);
1575 bool buvok = SvUOK(TOPs);
1577 if (!auvok && !buvok) { /* ## IV > IV ## */
1578 IV aiv = SvIVX(TOPm1s);
1579 IV biv = SvIVX(TOPs);
1582 SETs(boolSV(aiv > biv));
1585 if (auvok && buvok) { /* ## UV > UV ## */
1586 UV auv = SvUVX(TOPm1s);
1587 UV buv = SvUVX(TOPs);
1590 SETs(boolSV(auv > buv));
1593 if (auvok) { /* ## UV > IV ## */
1600 /* As (a) is a UV, it's >=0, so it must be > */
1605 SETs(boolSV(auv > (UV)biv));
1608 { /* ## IV > UV ## */
1612 aiv = SvIVX(TOPm1s);
1614 /* As (b) is a UV, it's >=0, so it cannot be > */
1621 SETs(boolSV((UV)aiv > buv));
1627 #ifndef NV_PRESERVES_UV
1628 #ifdef PERL_PRESERVE_IVUV
1631 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1633 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1639 SETs(boolSV(TOPn > value));
1646 dSP; tryAMAGICbinSET(le,0);
1647 #ifdef PERL_PRESERVE_IVUV
1650 SvIV_please(TOPm1s);
1651 if (SvIOK(TOPm1s)) {
1652 bool auvok = SvUOK(TOPm1s);
1653 bool buvok = SvUOK(TOPs);
1655 if (!auvok && !buvok) { /* ## IV <= IV ## */
1656 IV aiv = SvIVX(TOPm1s);
1657 IV biv = SvIVX(TOPs);
1660 SETs(boolSV(aiv <= biv));
1663 if (auvok && buvok) { /* ## UV <= UV ## */
1664 UV auv = SvUVX(TOPm1s);
1665 UV buv = SvUVX(TOPs);
1668 SETs(boolSV(auv <= buv));
1671 if (auvok) { /* ## UV <= IV ## */
1678 /* As (a) is a UV, it's >=0, so a cannot be <= */
1683 SETs(boolSV(auv <= (UV)biv));
1686 { /* ## IV <= UV ## */
1690 aiv = SvIVX(TOPm1s);
1692 /* As (b) is a UV, it's >=0, so a must be <= */
1699 SETs(boolSV((UV)aiv <= buv));
1705 #ifndef NV_PRESERVES_UV
1706 #ifdef PERL_PRESERVE_IVUV
1709 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1711 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1717 SETs(boolSV(TOPn <= value));
1724 dSP; tryAMAGICbinSET(ge,0);
1725 #ifdef PERL_PRESERVE_IVUV
1728 SvIV_please(TOPm1s);
1729 if (SvIOK(TOPm1s)) {
1730 bool auvok = SvUOK(TOPm1s);
1731 bool buvok = SvUOK(TOPs);
1733 if (!auvok && !buvok) { /* ## IV >= IV ## */
1734 IV aiv = SvIVX(TOPm1s);
1735 IV biv = SvIVX(TOPs);
1738 SETs(boolSV(aiv >= biv));
1741 if (auvok && buvok) { /* ## UV >= UV ## */
1742 UV auv = SvUVX(TOPm1s);
1743 UV buv = SvUVX(TOPs);
1746 SETs(boolSV(auv >= buv));
1749 if (auvok) { /* ## UV >= IV ## */
1756 /* As (a) is a UV, it's >=0, so it must be >= */
1761 SETs(boolSV(auv >= (UV)biv));
1764 { /* ## IV >= UV ## */
1768 aiv = SvIVX(TOPm1s);
1770 /* As (b) is a UV, it's >=0, so a cannot be >= */
1777 SETs(boolSV((UV)aiv >= buv));
1783 #ifndef NV_PRESERVES_UV
1784 #ifdef PERL_PRESERVE_IVUV
1787 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1789 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1795 SETs(boolSV(TOPn >= value));
1802 dSP; tryAMAGICbinSET(ne,0);
1803 #ifndef NV_PRESERVES_UV
1804 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1806 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1810 #ifdef PERL_PRESERVE_IVUV
1813 SvIV_please(TOPm1s);
1814 if (SvIOK(TOPm1s)) {
1815 bool auvok = SvUOK(TOPm1s);
1816 bool buvok = SvUOK(TOPs);
1818 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1819 /* Casting IV to UV before comparison isn't going to matter
1820 on 2s complement. On 1s complement or sign&magnitude
1821 (if we have any of them) it could make negative zero
1822 differ from normal zero. As I understand it. (Need to
1823 check - is negative zero implementation defined behaviour
1825 UV buv = SvUVX(POPs);
1826 UV auv = SvUVX(TOPs);
1828 SETs(boolSV(auv != buv));
1831 { /* ## Mixed IV,UV ## */
1835 /* != is commutative so swap if needed (save code) */
1837 /* swap. top of stack (b) is the iv */
1841 /* As (a) is a UV, it's >0, so it cannot be == */
1850 /* As (b) is a UV, it's >0, so it cannot be == */
1854 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1856 SETs(boolSV((UV)iv != uv));
1864 SETs(boolSV(TOPn != value));
1871 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1872 #ifndef NV_PRESERVES_UV
1873 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1874 UV right = PTR2UV(SvRV(POPs));
1875 UV left = PTR2UV(SvRV(TOPs));
1876 SETi((left > right) - (left < right));
1880 #ifdef PERL_PRESERVE_IVUV
1881 /* Fortunately it seems NaN isn't IOK */
1884 SvIV_please(TOPm1s);
1885 if (SvIOK(TOPm1s)) {
1886 bool leftuvok = SvUOK(TOPm1s);
1887 bool rightuvok = SvUOK(TOPs);
1889 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1890 IV leftiv = SvIVX(TOPm1s);
1891 IV rightiv = SvIVX(TOPs);
1893 if (leftiv > rightiv)
1895 else if (leftiv < rightiv)
1899 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1900 UV leftuv = SvUVX(TOPm1s);
1901 UV rightuv = SvUVX(TOPs);
1903 if (leftuv > rightuv)
1905 else if (leftuv < rightuv)
1909 } else if (leftuvok) { /* ## UV <=> IV ## */
1913 rightiv = SvIVX(TOPs);
1915 /* As (a) is a UV, it's >=0, so it cannot be < */
1918 leftuv = SvUVX(TOPm1s);
1919 if (leftuv > (UV)rightiv) {
1921 } else if (leftuv < (UV)rightiv) {
1927 } else { /* ## IV <=> UV ## */
1931 leftiv = SvIVX(TOPm1s);
1933 /* As (b) is a UV, it's >=0, so it must be < */
1936 rightuv = SvUVX(TOPs);
1937 if ((UV)leftiv > rightuv) {
1939 } else if ((UV)leftiv < rightuv) {
1957 if (Perl_isnan(left) || Perl_isnan(right)) {
1961 value = (left > right) - (left < right);
1965 else if (left < right)
1967 else if (left > right)
1981 dSP; tryAMAGICbinSET(slt,0);
1984 int cmp = (IN_LOCALE_RUNTIME
1985 ? sv_cmp_locale(left, right)
1986 : sv_cmp(left, right));
1987 SETs(boolSV(cmp < 0));
1994 dSP; tryAMAGICbinSET(sgt,0);
1997 int cmp = (IN_LOCALE_RUNTIME
1998 ? sv_cmp_locale(left, right)
1999 : sv_cmp(left, right));
2000 SETs(boolSV(cmp > 0));
2007 dSP; tryAMAGICbinSET(sle,0);
2010 int cmp = (IN_LOCALE_RUNTIME
2011 ? sv_cmp_locale(left, right)
2012 : sv_cmp(left, right));
2013 SETs(boolSV(cmp <= 0));
2020 dSP; tryAMAGICbinSET(sge,0);
2023 int cmp = (IN_LOCALE_RUNTIME
2024 ? sv_cmp_locale(left, right)
2025 : sv_cmp(left, right));
2026 SETs(boolSV(cmp >= 0));
2033 dSP; tryAMAGICbinSET(seq,0);
2036 SETs(boolSV(sv_eq(left, right)));
2043 dSP; tryAMAGICbinSET(sne,0);
2046 SETs(boolSV(!sv_eq(left, right)));
2053 dSP; dTARGET; tryAMAGICbin(scmp,0);
2056 int cmp = (IN_LOCALE_RUNTIME
2057 ? sv_cmp_locale(left, right)
2058 : sv_cmp(left, right));
2066 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2069 if (SvNIOKp(left) || SvNIOKp(right)) {
2070 if (PL_op->op_private & HINT_INTEGER) {
2071 IV i = SvIV(left) & SvIV(right);
2075 UV u = SvUV(left) & SvUV(right);
2080 do_vop(PL_op->op_type, TARG, left, right);
2089 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2092 if (SvNIOKp(left) || SvNIOKp(right)) {
2093 if (PL_op->op_private & HINT_INTEGER) {
2094 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2098 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2103 do_vop(PL_op->op_type, TARG, left, right);
2112 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2115 if (SvNIOKp(left) || SvNIOKp(right)) {
2116 if (PL_op->op_private & HINT_INTEGER) {
2117 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2121 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2126 do_vop(PL_op->op_type, TARG, left, right);
2135 dSP; dTARGET; tryAMAGICun(neg);
2138 int flags = SvFLAGS(sv);
2141 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2142 /* It's publicly an integer, or privately an integer-not-float */
2145 if (SvIVX(sv) == IV_MIN) {
2146 /* 2s complement assumption. */
2147 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2150 else if (SvUVX(sv) <= IV_MAX) {
2155 else if (SvIVX(sv) != IV_MIN) {
2159 #ifdef PERL_PRESERVE_IVUV
2168 else if (SvPOKp(sv)) {
2170 char *s = SvPV(sv, len);
2171 if (isIDFIRST(*s)) {
2172 sv_setpvn(TARG, "-", 1);
2175 else if (*s == '+' || *s == '-') {
2177 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2179 else if (DO_UTF8(sv)) {
2182 goto oops_its_an_int;
2184 sv_setnv(TARG, -SvNV(sv));
2186 sv_setpvn(TARG, "-", 1);
2193 goto oops_its_an_int;
2194 sv_setnv(TARG, -SvNV(sv));
2206 dSP; tryAMAGICunSET(not);
2207 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2213 dSP; dTARGET; tryAMAGICun(compl);
2217 if (PL_op->op_private & HINT_INTEGER) {
2232 tmps = (U8*)SvPV_force(TARG, len);
2235 /* Calculate exact length, let's not estimate. */
2244 while (tmps < send) {
2245 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2246 tmps += UTF8SKIP(tmps);
2247 targlen += UNISKIP(~c);
2253 /* Now rewind strings and write them. */
2257 Newz(0, result, targlen + 1, U8);
2258 while (tmps < send) {
2259 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2260 tmps += UTF8SKIP(tmps);
2261 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2265 sv_setpvn(TARG, (char*)result, targlen);
2269 Newz(0, result, nchar + 1, U8);
2270 while (tmps < send) {
2271 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2272 tmps += UTF8SKIP(tmps);
2277 sv_setpvn(TARG, (char*)result, nchar);
2285 register long *tmpl;
2286 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2289 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2294 for ( ; anum > 0; anum--, tmps++)
2303 /* integer versions of some of the above */
2307 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2310 SETi( left * right );
2317 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2321 DIE(aTHX_ "Illegal division by zero");
2322 value = POPi / value;
2330 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2334 DIE(aTHX_ "Illegal modulus zero");
2335 SETi( left % right );
2342 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2345 SETi( left + right );
2352 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2355 SETi( left - right );
2362 dSP; tryAMAGICbinSET(lt,0);
2365 SETs(boolSV(left < right));
2372 dSP; tryAMAGICbinSET(gt,0);
2375 SETs(boolSV(left > right));
2382 dSP; tryAMAGICbinSET(le,0);
2385 SETs(boolSV(left <= right));
2392 dSP; tryAMAGICbinSET(ge,0);
2395 SETs(boolSV(left >= right));
2402 dSP; tryAMAGICbinSET(eq,0);
2405 SETs(boolSV(left == right));
2412 dSP; tryAMAGICbinSET(ne,0);
2415 SETs(boolSV(left != right));
2422 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2429 else if (left < right)
2440 dSP; dTARGET; tryAMAGICun(neg);
2445 /* High falutin' math. */
2449 dSP; dTARGET; tryAMAGICbin(atan2,0);
2452 SETn(Perl_atan2(left, right));
2459 dSP; dTARGET; tryAMAGICun(sin);
2463 value = Perl_sin(value);
2471 dSP; dTARGET; tryAMAGICun(cos);
2475 value = Perl_cos(value);
2481 /* Support Configure command-line overrides for rand() functions.
2482 After 5.005, perhaps we should replace this by Configure support
2483 for drand48(), random(), or rand(). For 5.005, though, maintain
2484 compatibility by calling rand() but allow the user to override it.
2485 See INSTALL for details. --Andy Dougherty 15 July 1998
2487 /* Now it's after 5.005, and Configure supports drand48() and random(),
2488 in addition to rand(). So the overrides should not be needed any more.
2489 --Jarkko Hietaniemi 27 September 1998
2492 #ifndef HAS_DRAND48_PROTO
2493 extern double drand48 (void);
2506 if (!PL_srand_called) {
2507 (void)seedDrand01((Rand_seed_t)seed());
2508 PL_srand_called = TRUE;
2523 (void)seedDrand01((Rand_seed_t)anum);
2524 PL_srand_called = TRUE;
2533 * This is really just a quick hack which grabs various garbage
2534 * values. It really should be a real hash algorithm which
2535 * spreads the effect of every input bit onto every output bit,
2536 * if someone who knows about such things would bother to write it.
2537 * Might be a good idea to add that function to CORE as well.
2538 * No numbers below come from careful analysis or anything here,
2539 * except they are primes and SEED_C1 > 1E6 to get a full-width
2540 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2541 * probably be bigger too.
2544 # define SEED_C1 1000003
2545 #define SEED_C4 73819
2547 # define SEED_C1 25747
2548 #define SEED_C4 20639
2552 #define SEED_C5 26107
2554 #ifndef PERL_NO_DEV_RANDOM
2559 # include <starlet.h>
2560 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2561 * in 100-ns units, typically incremented ever 10 ms. */
2562 unsigned int when[2];
2564 # ifdef HAS_GETTIMEOFDAY
2565 struct timeval when;
2571 /* This test is an escape hatch, this symbol isn't set by Configure. */
2572 #ifndef PERL_NO_DEV_RANDOM
2573 #ifndef PERL_RANDOM_DEVICE
2574 /* /dev/random isn't used by default because reads from it will block
2575 * if there isn't enough entropy available. You can compile with
2576 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2577 * is enough real entropy to fill the seed. */
2578 # define PERL_RANDOM_DEVICE "/dev/urandom"
2580 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2582 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2591 _ckvmssts(sys$gettim(when));
2592 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2594 # ifdef HAS_GETTIMEOFDAY
2595 gettimeofday(&when,(struct timezone *) 0);
2596 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2599 u = (U32)SEED_C1 * when;
2602 u += SEED_C3 * (U32)PerlProc_getpid();
2603 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2604 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2605 u += SEED_C5 * (U32)PTR2UV(&when);
2612 dSP; dTARGET; tryAMAGICun(exp);
2616 value = Perl_exp(value);
2624 dSP; dTARGET; tryAMAGICun(log);
2629 SET_NUMERIC_STANDARD();
2630 DIE(aTHX_ "Can't take log of %"NVgf, value);
2632 value = Perl_log(value);
2640 dSP; dTARGET; tryAMAGICun(sqrt);
2645 SET_NUMERIC_STANDARD();
2646 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2648 value = Perl_sqrt(value);
2655 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2656 * These need to be revisited when a newer toolchain becomes available.
2658 #if defined(__sparc64__) && defined(__GNUC__)
2659 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2660 # undef SPARC64_MODF_WORKAROUND
2661 # define SPARC64_MODF_WORKAROUND 1
2665 #if defined(SPARC64_MODF_WORKAROUND)
2667 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2670 ret = Perl_modf(theVal, &res);
2678 dSP; dTARGET; tryAMAGICun(int);
2681 IV iv = TOPi; /* attempt to convert to IV if possible. */
2682 /* XXX it's arguable that compiler casting to IV might be subtly
2683 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2684 else preferring IV has introduced a subtle behaviour change bug. OTOH
2685 relying on floating point to be accurate is a bug. */
2696 if (value < (NV)UV_MAX + 0.5) {
2699 #if defined(SPARC64_MODF_WORKAROUND)
2700 (void)sparc64_workaround_modf(value, &value);
2702 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2703 # ifdef HAS_MODFL_POW32_BUG
2704 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2706 NV offset = Perl_modf(value, &value);
2707 (void)Perl_modf(offset, &offset);
2711 (void)Perl_modf(value, &value);
2714 double tmp = (double)value;
2715 (void)Perl_modf(tmp, &tmp);
2723 if (value > (NV)IV_MIN - 0.5) {
2726 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2727 # ifdef HAS_MODFL_POW32_BUG
2728 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2730 NV offset = Perl_modf(-value, &value);
2731 (void)Perl_modf(offset, &offset);
2735 (void)Perl_modf(-value, &value);
2739 double tmp = (double)value;
2740 (void)Perl_modf(-tmp, &tmp);
2753 dSP; dTARGET; tryAMAGICun(abs);
2755 /* This will cache the NV value if string isn't actually integer */
2759 /* IVX is precise */
2761 SETu(TOPu); /* force it to be numeric only */
2769 /* 2s complement assumption. Also, not really needed as
2770 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2790 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2796 tmps = (SvPVx(sv, len));
2798 /* If Unicode, try to downgrade
2799 * If not possible, croak. */
2800 SV* tsv = sv_2mortal(newSVsv(sv));
2803 sv_utf8_downgrade(tsv, FALSE);
2806 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2807 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2820 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2826 tmps = (SvPVx(sv, len));
2828 /* If Unicode, try to downgrade
2829 * If not possible, croak. */
2830 SV* tsv = sv_2mortal(newSVsv(sv));
2833 sv_utf8_downgrade(tsv, FALSE);
2836 while (*tmps && len && isSPACE(*tmps))
2841 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2842 else if (*tmps == 'b')
2843 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2845 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2847 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2864 SETi(sv_len_utf8(sv));
2880 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2882 I32 arybase = PL_curcop->cop_arybase;
2886 int num_args = PL_op->op_private & 7;
2887 bool repl_need_utf8_upgrade = FALSE;
2888 bool repl_is_utf8 = FALSE;
2890 SvTAINTED_off(TARG); /* decontaminate */
2891 SvUTF8_off(TARG); /* decontaminate */
2895 repl = SvPV(repl_sv, repl_len);
2896 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2906 sv_utf8_upgrade(sv);
2908 else if (DO_UTF8(sv))
2909 repl_need_utf8_upgrade = TRUE;
2911 tmps = SvPV(sv, curlen);
2913 utf8_curlen = sv_len_utf8(sv);
2914 if (utf8_curlen == curlen)
2917 curlen = utf8_curlen;
2922 if (pos >= arybase) {
2940 else if (len >= 0) {
2942 if (rem > (I32)curlen)
2957 Perl_croak(aTHX_ "substr outside of string");
2958 if (ckWARN(WARN_SUBSTR))
2959 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2966 sv_pos_u2b(sv, &pos, &rem);
2968 sv_setpvn(TARG, tmps, rem);
2969 #ifdef USE_LOCALE_COLLATE
2970 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2975 SV* repl_sv_copy = NULL;
2977 if (repl_need_utf8_upgrade) {
2978 repl_sv_copy = newSVsv(repl_sv);
2979 sv_utf8_upgrade(repl_sv_copy);
2980 repl = SvPV(repl_sv_copy, repl_len);
2981 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2983 sv_insert(sv, pos, rem, repl, repl_len);
2987 SvREFCNT_dec(repl_sv_copy);
2989 else if (lvalue) { /* it's an lvalue! */
2990 if (!SvGMAGICAL(sv)) {
2994 if (ckWARN(WARN_SUBSTR))
2995 Perl_warner(aTHX_ WARN_SUBSTR,
2996 "Attempt to use reference as lvalue in substr");
2998 if (SvOK(sv)) /* is it defined ? */
2999 (void)SvPOK_only_UTF8(sv);
3001 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3004 if (SvTYPE(TARG) < SVt_PVLV) {
3005 sv_upgrade(TARG, SVt_PVLV);
3006 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3010 if (LvTARG(TARG) != sv) {
3012 SvREFCNT_dec(LvTARG(TARG));
3013 LvTARG(TARG) = SvREFCNT_inc(sv);
3015 LvTARGOFF(TARG) = upos;
3016 LvTARGLEN(TARG) = urem;
3020 PUSHs(TARG); /* avoid SvSETMAGIC here */
3027 register IV size = POPi;
3028 register IV offset = POPi;
3029 register SV *src = POPs;
3030 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3032 SvTAINTED_off(TARG); /* decontaminate */
3033 if (lvalue) { /* it's an lvalue! */
3034 if (SvTYPE(TARG) < SVt_PVLV) {
3035 sv_upgrade(TARG, SVt_PVLV);
3036 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3039 if (LvTARG(TARG) != src) {
3041 SvREFCNT_dec(LvTARG(TARG));
3042 LvTARG(TARG) = SvREFCNT_inc(src);
3044 LvTARGOFF(TARG) = offset;
3045 LvTARGLEN(TARG) = size;
3048 sv_setuv(TARG, do_vecget(src, offset, size));
3063 I32 arybase = PL_curcop->cop_arybase;
3068 offset = POPi - arybase;
3071 tmps = SvPV(big, biglen);
3072 if (offset > 0 && DO_UTF8(big))
3073 sv_pos_u2b(big, &offset, 0);
3076 else if (offset > biglen)
3078 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3079 (unsigned char*)tmps + biglen, little, 0)))
3082 retval = tmps2 - tmps;
3083 if (retval > 0 && DO_UTF8(big))
3084 sv_pos_b2u(big, &retval);
3085 PUSHi(retval + arybase);
3100 I32 arybase = PL_curcop->cop_arybase;
3106 tmps2 = SvPV(little, llen);
3107 tmps = SvPV(big, blen);
3111 if (offset > 0 && DO_UTF8(big))
3112 sv_pos_u2b(big, &offset, 0);
3113 offset = offset - arybase + llen;
3117 else if (offset > blen)
3119 if (!(tmps2 = rninstr(tmps, tmps + offset,
3120 tmps2, tmps2 + llen)))
3123 retval = tmps2 - tmps;
3124 if (retval > 0 && DO_UTF8(big))
3125 sv_pos_b2u(big, &retval);
3126 PUSHi(retval + arybase);
3132 dSP; dMARK; dORIGMARK; dTARGET;
3133 do_sprintf(TARG, SP-MARK, MARK+1);
3134 TAINT_IF(SvTAINTED(TARG));
3135 if (DO_UTF8(*(MARK+1)))
3147 U8 *s = (U8*)SvPVx(argsv, len);
3150 if (PL_encoding && !DO_UTF8(argsv)) {
3151 tmpsv = sv_2mortal(newSVsv(argsv));
3152 s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3156 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3167 (void)SvUPGRADE(TARG,SVt_PV);
3169 if (value > 255 && !IN_BYTES) {
3170 SvGROW(TARG, UNISKIP(value)+1);
3171 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3172 SvCUR_set(TARG, tmps - SvPVX(TARG));
3174 (void)SvPOK_only(TARG);
3185 (void)SvPOK_only(TARG);
3187 Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3199 char *tmps = SvPV(left, len);
3201 if (DO_UTF8(left)) {
3202 /* If Unicode, try to downgrade.
3203 * If not possible, croak.
3204 * Yes, we made this up. */
3205 SV* tsv = sv_2mortal(newSVsv(left));
3208 sv_utf8_downgrade(tsv, FALSE);
3212 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3214 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3218 "The crypt() function is unimplemented due to excessive paranoia.");
3232 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3236 s = (U8*)SvPV(sv, slen);
3237 utf8_to_uvchr(s, &ulen);
3239 toTITLE_utf8(s, tmpbuf, &tculen);
3240 utf8_to_uvchr(tmpbuf, 0);
3242 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3244 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3245 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3250 s = (U8*)SvPV_force(sv, slen);
3251 Copy(tmpbuf, s, tculen, U8);
3255 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3257 SvUTF8_off(TARG); /* decontaminate */
3262 s = (U8*)SvPV_force(sv, slen);
3264 if (IN_LOCALE_RUNTIME) {
3267 *s = toUPPER_LC(*s);
3285 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3287 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3291 toLOWER_utf8(s, tmpbuf, &ulen);
3292 uv = utf8_to_uvchr(tmpbuf, 0);
3294 tend = uvchr_to_utf8(tmpbuf, uv);
3296 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3298 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3299 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3304 s = (U8*)SvPV_force(sv, slen);
3305 Copy(tmpbuf, s, ulen, U8);
3309 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3311 SvUTF8_off(TARG); /* decontaminate */
3316 s = (U8*)SvPV_force(sv, slen);
3318 if (IN_LOCALE_RUNTIME) {
3321 *s = toLOWER_LC(*s);
3344 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3346 s = (U8*)SvPV(sv,len);
3348 SvUTF8_off(TARG); /* decontaminate */
3349 sv_setpvn(TARG, "", 0);
3353 (void)SvUPGRADE(TARG, SVt_PV);
3354 SvGROW(TARG, (len * 2) + 1);
3355 (void)SvPOK_only(TARG);
3356 d = (U8*)SvPVX(TARG);
3359 toUPPER_utf8(s, tmpbuf, &ulen);
3360 Copy(tmpbuf, d, ulen, U8);
3366 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3371 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3373 SvUTF8_off(TARG); /* decontaminate */
3378 s = (U8*)SvPV_force(sv, len);
3380 register U8 *send = s + len;
3382 if (IN_LOCALE_RUNTIME) {
3385 for (; s < send; s++)
3386 *s = toUPPER_LC(*s);
3389 for (; s < send; s++)
3411 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3413 s = (U8*)SvPV(sv,len);
3415 SvUTF8_off(TARG); /* decontaminate */
3416 sv_setpvn(TARG, "", 0);
3420 (void)SvUPGRADE(TARG, SVt_PV);
3421 SvGROW(TARG, (len * 2) + 1);
3422 (void)SvPOK_only(TARG);
3423 d = (U8*)SvPVX(TARG);
3426 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3427 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3428 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3430 * Now if the sigma is NOT followed by
3431 * /$ignorable_sequence$cased_letter/;
3432 * and it IS preceded by
3433 * /$cased_letter$ignorable_sequence/;
3434 * where $ignorable_sequence is
3435 * [\x{2010}\x{AD}\p{Mn}]*
3436 * and $cased_letter is
3437 * [\p{Ll}\p{Lo}\p{Lt}]
3438 * then it should be mapped to 0x03C2,
3439 * (GREEK SMALL LETTER FINAL SIGMA),
3440 * instead of staying 0x03A3.
3441 * See lib/unicore/SpecCase.txt.
3444 Copy(tmpbuf, d, ulen, U8);
3450 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3455 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3457 SvUTF8_off(TARG); /* decontaminate */
3463 s = (U8*)SvPV_force(sv, len);
3465 register U8 *send = s + len;
3467 if (IN_LOCALE_RUNTIME) {
3470 for (; s < send; s++)
3471 *s = toLOWER_LC(*s);
3474 for (; s < send; s++)
3489 register char *s = SvPV(sv,len);
3492 SvUTF8_off(TARG); /* decontaminate */
3494 (void)SvUPGRADE(TARG, SVt_PV);
3495 SvGROW(TARG, (len * 2) + 1);
3499 if (UTF8_IS_CONTINUED(*s)) {
3500 STRLEN ulen = UTF8SKIP(s);
3524 SvCUR_set(TARG, d - SvPVX(TARG));
3525 (void)SvPOK_only_UTF8(TARG);
3528 sv_setpvn(TARG, s, len);
3530 if (SvSMAGICAL(TARG))
3539 dSP; dMARK; dORIGMARK;
3541 register AV* av = (AV*)POPs;
3542 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3543 I32 arybase = PL_curcop->cop_arybase;
3546 if (SvTYPE(av) == SVt_PVAV) {
3547 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3549 for (svp = MARK + 1; svp <= SP; svp++) {
3554 if (max > AvMAX(av))
3557 while (++MARK <= SP) {
3558 elem = SvIVx(*MARK);
3562 svp = av_fetch(av, elem, lval);
3564 if (!svp || *svp == &PL_sv_undef)
3565 DIE(aTHX_ PL_no_aelem, elem);
3566 if (PL_op->op_private & OPpLVAL_INTRO)
3567 save_aelem(av, elem, svp);
3569 *MARK = svp ? *svp : &PL_sv_undef;
3572 if (GIMME != G_ARRAY) {
3580 /* Associative arrays. */
3585 HV *hash = (HV*)POPs;
3587 I32 gimme = GIMME_V;
3588 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3591 /* might clobber stack_sp */
3592 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3597 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3598 if (gimme == G_ARRAY) {
3601 /* might clobber stack_sp */
3603 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3608 else if (gimme == G_SCALAR)
3627 I32 gimme = GIMME_V;
3628 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3632 if (PL_op->op_private & OPpSLICE) {
3636 hvtype = SvTYPE(hv);
3637 if (hvtype == SVt_PVHV) { /* hash element */
3638 while (++MARK <= SP) {
3639 sv = hv_delete_ent(hv, *MARK, discard, 0);
3640 *MARK = sv ? sv : &PL_sv_undef;
3643 else if (hvtype == SVt_PVAV) {
3644 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3645 while (++MARK <= SP) {
3646 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3647 *MARK = sv ? sv : &PL_sv_undef;
3650 else { /* pseudo-hash element */
3651 while (++MARK <= SP) {
3652 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3653 *MARK = sv ? sv : &PL_sv_undef;
3658 DIE(aTHX_ "Not a HASH reference");
3661 else if (gimme == G_SCALAR) {
3670 if (SvTYPE(hv) == SVt_PVHV)
3671 sv = hv_delete_ent(hv, keysv, discard, 0);
3672 else if (SvTYPE(hv) == SVt_PVAV) {
3673 if (PL_op->op_flags & OPf_SPECIAL)
3674 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3676 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3679 DIE(aTHX_ "Not a HASH reference");
3694 if (PL_op->op_private & OPpEXISTS_SUB) {
3698 cv = sv_2cv(sv, &hv, &gv, FALSE);
3701 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3707 if (SvTYPE(hv) == SVt_PVHV) {
3708 if (hv_exists_ent(hv, tmpsv, 0))
3711 else if (SvTYPE(hv) == SVt_PVAV) {
3712 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3713 if (av_exists((AV*)hv, SvIV(tmpsv)))
3716 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3720 DIE(aTHX_ "Not a HASH reference");
3727 dSP; dMARK; dORIGMARK;
3728 register HV *hv = (HV*)POPs;
3729 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3730 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3732 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3733 DIE(aTHX_ "Can't localize pseudo-hash element");
3735 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3736 while (++MARK <= SP) {
3739 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3740 realhv ? hv_exists_ent(hv, keysv, 0)
3741 : avhv_exists_ent((AV*)hv, keysv, 0);
3743 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3744 svp = he ? &HeVAL(he) : 0;
3747 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3750 if (!svp || *svp == &PL_sv_undef) {
3752 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3754 if (PL_op->op_private & OPpLVAL_INTRO) {
3756 save_helem(hv, keysv, svp);
3759 char *key = SvPV(keysv, keylen);
3760 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3764 *MARK = svp ? *svp : &PL_sv_undef;
3767 if (GIMME != G_ARRAY) {
3775 /* List operators. */
3780 if (GIMME != G_ARRAY) {
3782 *MARK = *SP; /* unwanted list, return last item */
3784 *MARK = &PL_sv_undef;
3793 SV **lastrelem = PL_stack_sp;
3794 SV **lastlelem = PL_stack_base + POPMARK;
3795 SV **firstlelem = PL_stack_base + POPMARK + 1;
3796 register SV **firstrelem = lastlelem + 1;
3797 I32 arybase = PL_curcop->cop_arybase;
3798 I32 lval = PL_op->op_flags & OPf_MOD;
3799 I32 is_something_there = lval;
3801 register I32 max = lastrelem - lastlelem;
3802 register SV **lelem;
3805 if (GIMME != G_ARRAY) {
3806 ix = SvIVx(*lastlelem);
3811 if (ix < 0 || ix >= max)
3812 *firstlelem = &PL_sv_undef;
3814 *firstlelem = firstrelem[ix];
3820 SP = firstlelem - 1;
3824 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3830 if (ix < 0 || ix >= max)
3831 *lelem = &PL_sv_undef;
3833 is_something_there = TRUE;
3834 if (!(*lelem = firstrelem[ix]))
3835 *lelem = &PL_sv_undef;
3838 if (is_something_there)
3841 SP = firstlelem - 1;
3847 dSP; dMARK; dORIGMARK;
3848 I32 items = SP - MARK;
3849 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3850 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3857 dSP; dMARK; dORIGMARK;
3858 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3862 SV *val = NEWSV(46, 0);
3864 sv_setsv(val, *++MARK);
3865 else if (ckWARN(WARN_MISC))
3866 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash");
3867 (void)hv_store_ent(hv,key,val,0);
3876 dSP; dMARK; dORIGMARK;
3877 register AV *ary = (AV*)*++MARK;
3881 register I32 offset;
3882 register I32 length;
3889 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3890 *MARK-- = SvTIED_obj((SV*)ary, mg);
3894 call_method("SPLICE",GIMME_V);
3903 offset = i = SvIVx(*MARK);
3905 offset += AvFILLp(ary) + 1;
3907 offset -= PL_curcop->cop_arybase;
3909 DIE(aTHX_ PL_no_aelem, i);
3911 length = SvIVx(*MARK++);
3913 length += AvFILLp(ary) - offset + 1;
3919 length = AvMAX(ary) + 1; /* close enough to infinity */
3923 length = AvMAX(ary) + 1;
3925 if (offset > AvFILLp(ary) + 1)
3926 offset = AvFILLp(ary) + 1;
3927 after = AvFILLp(ary) + 1 - (offset + length);
3928 if (after < 0) { /* not that much array */
3929 length += after; /* offset+length now in array */
3935 /* At this point, MARK .. SP-1 is our new LIST */
3938 diff = newlen - length;
3939 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3942 if (diff < 0) { /* shrinking the area */
3944 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3945 Copy(MARK, tmparyval, newlen, SV*);
3948 MARK = ORIGMARK + 1;
3949 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3950 MEXTEND(MARK, length);
3951 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3953 EXTEND_MORTAL(length);
3954 for (i = length, dst = MARK; i; i--) {
3955 sv_2mortal(*dst); /* free them eventualy */
3962 *MARK = AvARRAY(ary)[offset+length-1];
3965 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3966 SvREFCNT_dec(*dst++); /* free them now */
3969 AvFILLp(ary) += diff;
3971 /* pull up or down? */
3973 if (offset < after) { /* easier to pull up */
3974 if (offset) { /* esp. if nothing to pull */
3975 src = &AvARRAY(ary)[offset-1];
3976 dst = src - diff; /* diff is negative */
3977 for (i = offset; i > 0; i--) /* can't trust Copy */
3981 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3985 if (after) { /* anything to pull down? */
3986 src = AvARRAY(ary) + offset + length;
3987 dst = src + diff; /* diff is negative */
3988 Move(src, dst, after, SV*);
3990 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3991 /* avoid later double free */
3995 dst[--i] = &PL_sv_undef;
3998 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4000 *dst = NEWSV(46, 0);
4001 sv_setsv(*dst++, *src++);
4003 Safefree(tmparyval);
4006 else { /* no, expanding (or same) */
4008 New(452, tmparyval, length, SV*); /* so remember deletion */
4009 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4012 if (diff > 0) { /* expanding */
4014 /* push up or down? */
4016 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4020 Move(src, dst, offset, SV*);
4022 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4024 AvFILLp(ary) += diff;
4027 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4028 av_extend(ary, AvFILLp(ary) + diff);
4029 AvFILLp(ary) += diff;
4032 dst = AvARRAY(ary) + AvFILLp(ary);
4034 for (i = after; i; i--) {
4041 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4042 *dst = NEWSV(46, 0);
4043 sv_setsv(*dst++, *src++);
4045 MARK = ORIGMARK + 1;
4046 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4048 Copy(tmparyval, MARK, length, SV*);
4050 EXTEND_MORTAL(length);
4051 for (i = length, dst = MARK; i; i--) {
4052 sv_2mortal(*dst); /* free them eventualy */
4056 Safefree(tmparyval);
4060 else if (length--) {
4061 *MARK = tmparyval[length];
4064 while (length-- > 0)
4065 SvREFCNT_dec(tmparyval[length]);
4067 Safefree(tmparyval);
4070 *MARK = &PL_sv_undef;
4078 dSP; dMARK; dORIGMARK; dTARGET;
4079 register AV *ary = (AV*)*++MARK;
4080 register SV *sv = &PL_sv_undef;
4083 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4084 *MARK-- = SvTIED_obj((SV*)ary, mg);
4088 call_method("PUSH",G_SCALAR|G_DISCARD);
4093 /* Why no pre-extend of ary here ? */
4094 for (++MARK; MARK <= SP; MARK++) {
4097 sv_setsv(sv, *MARK);
4102 PUSHi( AvFILL(ary) + 1 );
4110 SV *sv = av_pop(av);
4112 (void)sv_2mortal(sv);
4121 SV *sv = av_shift(av);
4126 (void)sv_2mortal(sv);
4133 dSP; dMARK; dORIGMARK; dTARGET;
4134 register AV *ary = (AV*)*++MARK;
4139 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4140 *MARK-- = SvTIED_obj((SV*)ary, mg);
4144 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4149 av_unshift(ary, SP - MARK);
4152 sv_setsv(sv, *++MARK);
4153 (void)av_store(ary, i++, sv);
4157 PUSHi( AvFILL(ary) + 1 );
4167 if (GIMME == G_ARRAY) {
4174 /* safe as long as stack cannot get extended in the above */
4179 register char *down;
4184 SvUTF8_off(TARG); /* decontaminate */
4186 do_join(TARG, &PL_sv_no, MARK, SP);
4188 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4189 up = SvPV_force(TARG, len);
4191 if (DO_UTF8(TARG)) { /* first reverse each character */
4192 U8* s = (U8*)SvPVX(TARG);
4193 U8* send = (U8*)(s + len);
4195 if (UTF8_IS_INVARIANT(*s)) {
4200 if (!utf8_to_uvchr(s, 0))
4204 down = (char*)(s - 1);
4205 /* reverse this character */
4215 down = SvPVX(TARG) + len - 1;
4221 (void)SvPOK_only_UTF8(TARG);
4233 register IV limit = POPi; /* note, negative is forever */
4236 register char *s = SvPV(sv, len);
4237 bool do_utf8 = DO_UTF8(sv);
4238 char *strend = s + len;
4240 register REGEXP *rx;
4244 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4245 I32 maxiters = slen + 10;
4248 I32 origlimit = limit;
4251 AV *oldstack = PL_curstack;
4252 I32 gimme = GIMME_V;
4253 I32 oldsave = PL_savestack_ix;
4254 I32 make_mortal = 1;
4255 MAGIC *mg = (MAGIC *) NULL;
4258 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4263 DIE(aTHX_ "panic: pp_split");
4266 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4267 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4269 PL_reg_match_utf8 = do_utf8;
4271 if (pm->op_pmreplroot) {
4273 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4275 ary = GvAVn((GV*)pm->op_pmreplroot);
4278 else if (gimme != G_ARRAY)
4279 #ifdef USE_5005THREADS
4280 ary = (AV*)PL_curpad[0];
4282 ary = GvAVn(PL_defgv);
4283 #endif /* USE_5005THREADS */
4286 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4292 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4294 XPUSHs(SvTIED_obj((SV*)ary, mg));
4300 for (i = AvFILLp(ary); i >= 0; i--)
4301 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4303 /* temporarily switch stacks */
4304 SWITCHSTACK(PL_curstack, ary);
4308 base = SP - PL_stack_base;
4310 if (pm->op_pmflags & PMf_SKIPWHITE) {
4311 if (pm->op_pmflags & PMf_LOCALE) {
4312 while (isSPACE_LC(*s))
4320 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4321 SAVEINT(PL_multiline);
4322 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4326 limit = maxiters + 2;
4327 if (pm->op_pmflags & PMf_WHITE) {
4330 while (m < strend &&
4331 !((pm->op_pmflags & PMf_LOCALE)
4332 ? isSPACE_LC(*m) : isSPACE(*m)))
4337 dstr = NEWSV(30, m-s);
4338 sv_setpvn(dstr, s, m-s);
4342 (void)SvUTF8_on(dstr);
4346 while (s < strend &&
4347 ((pm->op_pmflags & PMf_LOCALE)
4348 ? isSPACE_LC(*s) : isSPACE(*s)))
4352 else if (strEQ("^", rx->precomp)) {
4355 for (m = s; m < strend && *m != '\n'; m++) ;
4359 dstr = NEWSV(30, m-s);
4360 sv_setpvn(dstr, s, m-s);
4364 (void)SvUTF8_on(dstr);
4369 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4370 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4371 && (rx->reganch & ROPT_CHECK_ALL)
4372 && !(rx->reganch & ROPT_ANCH)) {
4373 int tail = (rx->reganch & RE_INTUIT_TAIL);
4374 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4377 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4379 char c = *SvPV(csv, n_a);
4382 for (m = s; m < strend && *m != c; m++) ;
4385 dstr = NEWSV(30, m-s);
4386 sv_setpvn(dstr, s, m-s);
4390 (void)SvUTF8_on(dstr);
4392 /* The rx->minlen is in characters but we want to step
4393 * s ahead by bytes. */
4395 s = (char*)utf8_hop((U8*)m, len);
4397 s = m + len; /* Fake \n at the end */
4402 while (s < strend && --limit &&
4403 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4404 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4407 dstr = NEWSV(31, m-s);
4408 sv_setpvn(dstr, s, m-s);
4412 (void)SvUTF8_on(dstr);
4414 /* The rx->minlen is in characters but we want to step
4415 * s ahead by bytes. */
4417 s = (char*)utf8_hop((U8*)m, len);
4419 s = m + len; /* Fake \n at the end */
4424 maxiters += slen * rx->nparens;
4425 while (s < strend && --limit
4426 /* && (!rx->check_substr
4427 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4429 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4430 1 /* minend */, sv, NULL, 0))
4432 TAINT_IF(RX_MATCH_TAINTED(rx));
4433 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4438 strend = s + (strend - m);
4440 m = rx->startp[0] + orig;
4441 dstr = NEWSV(32, m-s);
4442 sv_setpvn(dstr, s, m-s);
4446 (void)SvUTF8_on(dstr);
4449 for (i = 1; i <= rx->nparens; i++) {
4450 s = rx->startp[i] + orig;
4451 m = rx->endp[i] + orig;
4453 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4454 parens that didn't match -- they should be set to
4455 undef, not the empty string */
4456 if (m >= orig && s >= orig) {
4457 dstr = NEWSV(33, m-s);
4458 sv_setpvn(dstr, s, m-s);
4461 dstr = &PL_sv_undef; /* undef, not "" */
4465 (void)SvUTF8_on(dstr);
4469 s = rx->endp[0] + orig;
4473 LEAVE_SCOPE(oldsave);
4474 iters = (SP - PL_stack_base) - base;
4475 if (iters > maxiters)
4476 DIE(aTHX_ "Split loop");
4478 /* keep field after final delim? */
4479 if (s < strend || (iters && origlimit)) {
4480 STRLEN l = strend - s;
4481 dstr = NEWSV(34, l);
4482 sv_setpvn(dstr, s, l);
4486 (void)SvUTF8_on(dstr);
4490 else if (!origlimit) {
4491 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4497 SWITCHSTACK(ary, oldstack);
4498 if (SvSMAGICAL(ary)) {
4503 if (gimme == G_ARRAY) {
4505 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4513 call_method("PUSH",G_SCALAR|G_DISCARD);
4516 if (gimme == G_ARRAY) {
4517 /* EXTEND should not be needed - we just popped them */
4519 for (i=0; i < iters; i++) {
4520 SV **svp = av_fetch(ary, i, FALSE);
4521 PUSHs((svp) ? *svp : &PL_sv_undef);
4528 if (gimme == G_ARRAY)
4531 if (iters || !pm->op_pmreplroot) {
4539 #ifdef USE_5005THREADS
4541 Perl_unlock_condpair(pTHX_ void *svv)
4543 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4546 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4547 MUTEX_LOCK(MgMUTEXP(mg));
4548 if (MgOWNER(mg) != thr)
4549 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4551 COND_SIGNAL(MgOWNERCONDP(mg));
4552 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4553 PTR2UV(thr), PTR2UV(svv)));
4554 MUTEX_UNLOCK(MgMUTEXP(mg));
4556 #endif /* USE_5005THREADS */
4564 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4565 || SvTYPE(retsv) == SVt_PVCV) {
4566 retsv = refto(retsv);
4574 #ifdef USE_5005THREADS
4577 if (PL_op->op_private & OPpLVAL_INTRO)
4578 PUSHs(*save_threadsv(PL_op->op_targ));
4580 PUSHs(THREADSV(PL_op->op_targ));
4583 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4584 #endif /* USE_5005THREADS */