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
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,
3172 UNICODE_ALLOW_SUPER);
3173 SvCUR_set(TARG, tmps - SvPVX(TARG));
3175 (void)SvPOK_only(TARG);
3186 (void)SvPOK_only(TARG);
3188 Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3200 char *tmps = SvPV(left, len);
3202 if (DO_UTF8(left)) {
3203 /* If Unicode, try to downgrade.
3204 * If not possible, croak.
3205 * Yes, we made this up. */
3206 SV* tsv = sv_2mortal(newSVsv(left));
3209 sv_utf8_downgrade(tsv, FALSE);
3213 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3215 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3219 "The crypt() function is unimplemented due to excessive paranoia.");
3233 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3237 s = (U8*)SvPV(sv, slen);
3238 utf8_to_uvchr(s, &ulen);
3240 toTITLE_utf8(s, tmpbuf, &tculen);
3241 utf8_to_uvchr(tmpbuf, 0);
3243 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3245 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3246 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3251 s = (U8*)SvPV_force(sv, slen);
3252 Copy(tmpbuf, s, tculen, U8);
3256 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3258 SvUTF8_off(TARG); /* decontaminate */
3263 s = (U8*)SvPV_force(sv, slen);
3265 if (IN_LOCALE_RUNTIME) {
3268 *s = toUPPER_LC(*s);
3286 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3288 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3292 toLOWER_utf8(s, tmpbuf, &ulen);
3293 uv = utf8_to_uvchr(tmpbuf, 0);
3295 tend = uvchr_to_utf8(tmpbuf, uv);
3297 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3299 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3300 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3305 s = (U8*)SvPV_force(sv, slen);
3306 Copy(tmpbuf, s, ulen, U8);
3310 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3312 SvUTF8_off(TARG); /* decontaminate */
3317 s = (U8*)SvPV_force(sv, slen);
3319 if (IN_LOCALE_RUNTIME) {
3322 *s = toLOWER_LC(*s);
3345 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3347 s = (U8*)SvPV(sv,len);
3349 SvUTF8_off(TARG); /* decontaminate */
3350 sv_setpvn(TARG, "", 0);
3354 (void)SvUPGRADE(TARG, SVt_PV);
3355 SvGROW(TARG, (len * 2) + 1);
3356 (void)SvPOK_only(TARG);
3357 d = (U8*)SvPVX(TARG);
3360 toUPPER_utf8(s, tmpbuf, &ulen);
3361 Copy(tmpbuf, d, ulen, U8);
3367 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3372 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3374 SvUTF8_off(TARG); /* decontaminate */
3379 s = (U8*)SvPV_force(sv, len);
3381 register U8 *send = s + len;
3383 if (IN_LOCALE_RUNTIME) {
3386 for (; s < send; s++)
3387 *s = toUPPER_LC(*s);
3390 for (; s < send; s++)
3412 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3414 s = (U8*)SvPV(sv,len);
3416 SvUTF8_off(TARG); /* decontaminate */
3417 sv_setpvn(TARG, "", 0);
3421 (void)SvUPGRADE(TARG, SVt_PV);
3422 SvGROW(TARG, (len * 2) + 1);
3423 (void)SvPOK_only(TARG);
3424 d = (U8*)SvPVX(TARG);
3427 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3428 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3429 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3431 * Now if the sigma is NOT followed by
3432 * /$ignorable_sequence$cased_letter/;
3433 * and it IS preceded by
3434 * /$cased_letter$ignorable_sequence/;
3435 * where $ignorable_sequence is
3436 * [\x{2010}\x{AD}\p{Mn}]*
3437 * and $cased_letter is
3438 * [\p{Ll}\p{Lo}\p{Lt}]
3439 * then it should be mapped to 0x03C2,
3440 * (GREEK SMALL LETTER FINAL SIGMA),
3441 * instead of staying 0x03A3.
3442 * See lib/unicore/SpecCase.txt.
3445 Copy(tmpbuf, d, ulen, U8);
3451 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3456 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3458 SvUTF8_off(TARG); /* decontaminate */
3464 s = (U8*)SvPV_force(sv, len);
3466 register U8 *send = s + len;
3468 if (IN_LOCALE_RUNTIME) {
3471 for (; s < send; s++)
3472 *s = toLOWER_LC(*s);
3475 for (; s < send; s++)
3490 register char *s = SvPV(sv,len);
3493 SvUTF8_off(TARG); /* decontaminate */
3495 (void)SvUPGRADE(TARG, SVt_PV);
3496 SvGROW(TARG, (len * 2) + 1);
3500 if (UTF8_IS_CONTINUED(*s)) {
3501 STRLEN ulen = UTF8SKIP(s);
3525 SvCUR_set(TARG, d - SvPVX(TARG));
3526 (void)SvPOK_only_UTF8(TARG);
3529 sv_setpvn(TARG, s, len);
3531 if (SvSMAGICAL(TARG))
3540 dSP; dMARK; dORIGMARK;
3542 register AV* av = (AV*)POPs;
3543 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3544 I32 arybase = PL_curcop->cop_arybase;
3547 if (SvTYPE(av) == SVt_PVAV) {
3548 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3550 for (svp = MARK + 1; svp <= SP; svp++) {
3555 if (max > AvMAX(av))
3558 while (++MARK <= SP) {
3559 elem = SvIVx(*MARK);
3563 svp = av_fetch(av, elem, lval);
3565 if (!svp || *svp == &PL_sv_undef)
3566 DIE(aTHX_ PL_no_aelem, elem);
3567 if (PL_op->op_private & OPpLVAL_INTRO)
3568 save_aelem(av, elem, svp);
3570 *MARK = svp ? *svp : &PL_sv_undef;
3573 if (GIMME != G_ARRAY) {
3581 /* Associative arrays. */
3586 HV *hash = (HV*)POPs;
3588 I32 gimme = GIMME_V;
3589 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3592 /* might clobber stack_sp */
3593 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3598 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3599 if (gimme == G_ARRAY) {
3602 /* might clobber stack_sp */
3604 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3609 else if (gimme == G_SCALAR)
3628 I32 gimme = GIMME_V;
3629 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3633 if (PL_op->op_private & OPpSLICE) {
3637 hvtype = SvTYPE(hv);
3638 if (hvtype == SVt_PVHV) { /* hash element */
3639 while (++MARK <= SP) {
3640 sv = hv_delete_ent(hv, *MARK, discard, 0);
3641 *MARK = sv ? sv : &PL_sv_undef;
3644 else if (hvtype == SVt_PVAV) {
3645 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3646 while (++MARK <= SP) {
3647 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3648 *MARK = sv ? sv : &PL_sv_undef;
3651 else { /* pseudo-hash element */
3652 while (++MARK <= SP) {
3653 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3654 *MARK = sv ? sv : &PL_sv_undef;
3659 DIE(aTHX_ "Not a HASH reference");
3662 else if (gimme == G_SCALAR) {
3671 if (SvTYPE(hv) == SVt_PVHV)
3672 sv = hv_delete_ent(hv, keysv, discard, 0);
3673 else if (SvTYPE(hv) == SVt_PVAV) {
3674 if (PL_op->op_flags & OPf_SPECIAL)
3675 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3677 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3680 DIE(aTHX_ "Not a HASH reference");
3695 if (PL_op->op_private & OPpEXISTS_SUB) {
3699 cv = sv_2cv(sv, &hv, &gv, FALSE);
3702 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3708 if (SvTYPE(hv) == SVt_PVHV) {
3709 if (hv_exists_ent(hv, tmpsv, 0))
3712 else if (SvTYPE(hv) == SVt_PVAV) {
3713 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3714 if (av_exists((AV*)hv, SvIV(tmpsv)))
3717 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3721 DIE(aTHX_ "Not a HASH reference");
3728 dSP; dMARK; dORIGMARK;
3729 register HV *hv = (HV*)POPs;
3730 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3731 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3733 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3734 DIE(aTHX_ "Can't localize pseudo-hash element");
3736 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3737 while (++MARK <= SP) {
3740 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3741 realhv ? hv_exists_ent(hv, keysv, 0)
3742 : avhv_exists_ent((AV*)hv, keysv, 0);
3744 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3745 svp = he ? &HeVAL(he) : 0;
3748 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3751 if (!svp || *svp == &PL_sv_undef) {
3753 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3755 if (PL_op->op_private & OPpLVAL_INTRO) {
3757 save_helem(hv, keysv, svp);
3760 char *key = SvPV(keysv, keylen);
3761 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3765 *MARK = svp ? *svp : &PL_sv_undef;
3768 if (GIMME != G_ARRAY) {
3776 /* List operators. */
3781 if (GIMME != G_ARRAY) {
3783 *MARK = *SP; /* unwanted list, return last item */
3785 *MARK = &PL_sv_undef;
3794 SV **lastrelem = PL_stack_sp;
3795 SV **lastlelem = PL_stack_base + POPMARK;
3796 SV **firstlelem = PL_stack_base + POPMARK + 1;
3797 register SV **firstrelem = lastlelem + 1;
3798 I32 arybase = PL_curcop->cop_arybase;
3799 I32 lval = PL_op->op_flags & OPf_MOD;
3800 I32 is_something_there = lval;
3802 register I32 max = lastrelem - lastlelem;
3803 register SV **lelem;
3806 if (GIMME != G_ARRAY) {
3807 ix = SvIVx(*lastlelem);
3812 if (ix < 0 || ix >= max)
3813 *firstlelem = &PL_sv_undef;
3815 *firstlelem = firstrelem[ix];
3821 SP = firstlelem - 1;
3825 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3831 if (ix < 0 || ix >= max)
3832 *lelem = &PL_sv_undef;
3834 is_something_there = TRUE;
3835 if (!(*lelem = firstrelem[ix]))
3836 *lelem = &PL_sv_undef;
3839 if (is_something_there)
3842 SP = firstlelem - 1;
3848 dSP; dMARK; dORIGMARK;
3849 I32 items = SP - MARK;
3850 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3851 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3858 dSP; dMARK; dORIGMARK;
3859 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3863 SV *val = NEWSV(46, 0);
3865 sv_setsv(val, *++MARK);
3866 else if (ckWARN(WARN_MISC))
3867 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash");
3868 (void)hv_store_ent(hv,key,val,0);
3877 dSP; dMARK; dORIGMARK;
3878 register AV *ary = (AV*)*++MARK;
3882 register I32 offset;
3883 register I32 length;
3890 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3891 *MARK-- = SvTIED_obj((SV*)ary, mg);
3895 call_method("SPLICE",GIMME_V);
3904 offset = i = SvIVx(*MARK);
3906 offset += AvFILLp(ary) + 1;
3908 offset -= PL_curcop->cop_arybase;
3910 DIE(aTHX_ PL_no_aelem, i);
3912 length = SvIVx(*MARK++);
3914 length += AvFILLp(ary) - offset + 1;
3920 length = AvMAX(ary) + 1; /* close enough to infinity */
3924 length = AvMAX(ary) + 1;
3926 if (offset > AvFILLp(ary) + 1)
3927 offset = AvFILLp(ary) + 1;
3928 after = AvFILLp(ary) + 1 - (offset + length);
3929 if (after < 0) { /* not that much array */
3930 length += after; /* offset+length now in array */
3936 /* At this point, MARK .. SP-1 is our new LIST */
3939 diff = newlen - length;
3940 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3943 if (diff < 0) { /* shrinking the area */
3945 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3946 Copy(MARK, tmparyval, newlen, SV*);
3949 MARK = ORIGMARK + 1;
3950 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3951 MEXTEND(MARK, length);
3952 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3954 EXTEND_MORTAL(length);
3955 for (i = length, dst = MARK; i; i--) {
3956 sv_2mortal(*dst); /* free them eventualy */
3963 *MARK = AvARRAY(ary)[offset+length-1];
3966 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3967 SvREFCNT_dec(*dst++); /* free them now */
3970 AvFILLp(ary) += diff;
3972 /* pull up or down? */
3974 if (offset < after) { /* easier to pull up */
3975 if (offset) { /* esp. if nothing to pull */
3976 src = &AvARRAY(ary)[offset-1];
3977 dst = src - diff; /* diff is negative */
3978 for (i = offset; i > 0; i--) /* can't trust Copy */
3982 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3986 if (after) { /* anything to pull down? */
3987 src = AvARRAY(ary) + offset + length;
3988 dst = src + diff; /* diff is negative */
3989 Move(src, dst, after, SV*);
3991 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3992 /* avoid later double free */
3996 dst[--i] = &PL_sv_undef;
3999 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4001 *dst = NEWSV(46, 0);
4002 sv_setsv(*dst++, *src++);
4004 Safefree(tmparyval);
4007 else { /* no, expanding (or same) */
4009 New(452, tmparyval, length, SV*); /* so remember deletion */
4010 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4013 if (diff > 0) { /* expanding */
4015 /* push up or down? */
4017 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4021 Move(src, dst, offset, SV*);
4023 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4025 AvFILLp(ary) += diff;
4028 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4029 av_extend(ary, AvFILLp(ary) + diff);
4030 AvFILLp(ary) += diff;
4033 dst = AvARRAY(ary) + AvFILLp(ary);
4035 for (i = after; i; i--) {
4042 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4043 *dst = NEWSV(46, 0);
4044 sv_setsv(*dst++, *src++);
4046 MARK = ORIGMARK + 1;
4047 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4049 Copy(tmparyval, MARK, length, SV*);
4051 EXTEND_MORTAL(length);
4052 for (i = length, dst = MARK; i; i--) {
4053 sv_2mortal(*dst); /* free them eventualy */
4057 Safefree(tmparyval);
4061 else if (length--) {
4062 *MARK = tmparyval[length];
4065 while (length-- > 0)
4066 SvREFCNT_dec(tmparyval[length]);
4068 Safefree(tmparyval);
4071 *MARK = &PL_sv_undef;
4079 dSP; dMARK; dORIGMARK; dTARGET;
4080 register AV *ary = (AV*)*++MARK;
4081 register SV *sv = &PL_sv_undef;
4084 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4085 *MARK-- = SvTIED_obj((SV*)ary, mg);
4089 call_method("PUSH",G_SCALAR|G_DISCARD);
4094 /* Why no pre-extend of ary here ? */
4095 for (++MARK; MARK <= SP; MARK++) {
4098 sv_setsv(sv, *MARK);
4103 PUSHi( AvFILL(ary) + 1 );
4111 SV *sv = av_pop(av);
4113 (void)sv_2mortal(sv);
4122 SV *sv = av_shift(av);
4127 (void)sv_2mortal(sv);
4134 dSP; dMARK; dORIGMARK; dTARGET;
4135 register AV *ary = (AV*)*++MARK;
4140 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4141 *MARK-- = SvTIED_obj((SV*)ary, mg);
4145 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4150 av_unshift(ary, SP - MARK);
4153 sv_setsv(sv, *++MARK);
4154 (void)av_store(ary, i++, sv);
4158 PUSHi( AvFILL(ary) + 1 );
4168 if (GIMME == G_ARRAY) {
4175 /* safe as long as stack cannot get extended in the above */
4180 register char *down;
4185 SvUTF8_off(TARG); /* decontaminate */
4187 do_join(TARG, &PL_sv_no, MARK, SP);
4189 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4190 up = SvPV_force(TARG, len);
4192 if (DO_UTF8(TARG)) { /* first reverse each character */
4193 U8* s = (U8*)SvPVX(TARG);
4194 U8* send = (U8*)(s + len);
4196 if (UTF8_IS_INVARIANT(*s)) {
4201 if (!utf8_to_uvchr(s, 0))
4205 down = (char*)(s - 1);
4206 /* reverse this character */
4216 down = SvPVX(TARG) + len - 1;
4222 (void)SvPOK_only_UTF8(TARG);
4234 register IV limit = POPi; /* note, negative is forever */
4237 register char *s = SvPV(sv, len);
4238 bool do_utf8 = DO_UTF8(sv);
4239 char *strend = s + len;
4241 register REGEXP *rx;
4245 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4246 I32 maxiters = slen + 10;
4249 I32 origlimit = limit;
4252 AV *oldstack = PL_curstack;
4253 I32 gimme = GIMME_V;
4254 I32 oldsave = PL_savestack_ix;
4255 I32 make_mortal = 1;
4256 MAGIC *mg = (MAGIC *) NULL;
4259 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4264 DIE(aTHX_ "panic: pp_split");
4267 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4268 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4270 PL_reg_match_utf8 = do_utf8;
4272 if (pm->op_pmreplroot) {
4274 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4276 ary = GvAVn((GV*)pm->op_pmreplroot);
4279 else if (gimme != G_ARRAY)
4280 #ifdef USE_5005THREADS
4281 ary = (AV*)PL_curpad[0];
4283 ary = GvAVn(PL_defgv);
4284 #endif /* USE_5005THREADS */
4287 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4293 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4295 XPUSHs(SvTIED_obj((SV*)ary, mg));
4301 for (i = AvFILLp(ary); i >= 0; i--)
4302 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4304 /* temporarily switch stacks */
4305 SWITCHSTACK(PL_curstack, ary);
4309 base = SP - PL_stack_base;
4311 if (pm->op_pmflags & PMf_SKIPWHITE) {
4312 if (pm->op_pmflags & PMf_LOCALE) {
4313 while (isSPACE_LC(*s))
4321 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4322 SAVEINT(PL_multiline);
4323 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4327 limit = maxiters + 2;
4328 if (pm->op_pmflags & PMf_WHITE) {
4331 while (m < strend &&
4332 !((pm->op_pmflags & PMf_LOCALE)
4333 ? isSPACE_LC(*m) : isSPACE(*m)))
4338 dstr = NEWSV(30, m-s);
4339 sv_setpvn(dstr, s, m-s);
4343 (void)SvUTF8_on(dstr);
4347 while (s < strend &&
4348 ((pm->op_pmflags & PMf_LOCALE)
4349 ? isSPACE_LC(*s) : isSPACE(*s)))
4353 else if (strEQ("^", rx->precomp)) {
4356 for (m = s; m < strend && *m != '\n'; m++) ;
4360 dstr = NEWSV(30, m-s);
4361 sv_setpvn(dstr, s, m-s);
4365 (void)SvUTF8_on(dstr);
4370 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4371 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4372 && (rx->reganch & ROPT_CHECK_ALL)
4373 && !(rx->reganch & ROPT_ANCH)) {
4374 int tail = (rx->reganch & RE_INTUIT_TAIL);
4375 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4378 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4380 char c = *SvPV(csv, n_a);
4383 for (m = s; m < strend && *m != c; m++) ;
4386 dstr = NEWSV(30, m-s);
4387 sv_setpvn(dstr, s, m-s);
4391 (void)SvUTF8_on(dstr);
4393 /* The rx->minlen is in characters but we want to step
4394 * s ahead by bytes. */
4396 s = (char*)utf8_hop((U8*)m, len);
4398 s = m + len; /* Fake \n at the end */
4403 while (s < strend && --limit &&
4404 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4405 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4408 dstr = NEWSV(31, m-s);
4409 sv_setpvn(dstr, s, m-s);
4413 (void)SvUTF8_on(dstr);
4415 /* The rx->minlen is in characters but we want to step
4416 * s ahead by bytes. */
4418 s = (char*)utf8_hop((U8*)m, len);
4420 s = m + len; /* Fake \n at the end */
4425 maxiters += slen * rx->nparens;
4426 while (s < strend && --limit
4427 /* && (!rx->check_substr
4428 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4430 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4431 1 /* minend */, sv, NULL, 0))
4433 TAINT_IF(RX_MATCH_TAINTED(rx));
4434 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4439 strend = s + (strend - m);
4441 m = rx->startp[0] + orig;
4442 dstr = NEWSV(32, m-s);
4443 sv_setpvn(dstr, s, m-s);
4447 (void)SvUTF8_on(dstr);
4450 for (i = 1; i <= rx->nparens; i++) {
4451 s = rx->startp[i] + orig;
4452 m = rx->endp[i] + orig;
4454 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4455 parens that didn't match -- they should be set to
4456 undef, not the empty string */
4457 if (m >= orig && s >= orig) {
4458 dstr = NEWSV(33, m-s);
4459 sv_setpvn(dstr, s, m-s);
4462 dstr = &PL_sv_undef; /* undef, not "" */
4466 (void)SvUTF8_on(dstr);
4470 s = rx->endp[0] + orig;
4474 LEAVE_SCOPE(oldsave);
4475 iters = (SP - PL_stack_base) - base;
4476 if (iters > maxiters)
4477 DIE(aTHX_ "Split loop");
4479 /* keep field after final delim? */
4480 if (s < strend || (iters && origlimit)) {
4481 STRLEN l = strend - s;
4482 dstr = NEWSV(34, l);
4483 sv_setpvn(dstr, s, l);
4487 (void)SvUTF8_on(dstr);
4491 else if (!origlimit) {
4492 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4498 SWITCHSTACK(ary, oldstack);
4499 if (SvSMAGICAL(ary)) {
4504 if (gimme == G_ARRAY) {
4506 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4514 call_method("PUSH",G_SCALAR|G_DISCARD);
4517 if (gimme == G_ARRAY) {
4518 /* EXTEND should not be needed - we just popped them */
4520 for (i=0; i < iters; i++) {
4521 SV **svp = av_fetch(ary, i, FALSE);
4522 PUSHs((svp) ? *svp : &PL_sv_undef);
4529 if (gimme == G_ARRAY)
4532 if (iters || !pm->op_pmreplroot) {
4540 #ifdef USE_5005THREADS
4542 Perl_unlock_condpair(pTHX_ void *svv)
4544 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4547 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4548 MUTEX_LOCK(MgMUTEXP(mg));
4549 if (MgOWNER(mg) != thr)
4550 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4552 COND_SIGNAL(MgOWNERCONDP(mg));
4553 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4554 PTR2UV(thr), PTR2UV(svv)));
4555 MUTEX_UNLOCK(MgMUTEXP(mg));
4557 #endif /* USE_5005THREADS */
4564 #ifdef USE_5005THREADS
4566 #endif /* USE_5005THREADS */
4568 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4570 Perl_sharedsv_lock(aTHX_ ssv);
4571 #endif /* USE_ITHREADS */
4572 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4573 || SvTYPE(retsv) == SVt_PVCV) {
4574 retsv = refto(retsv);
4582 #ifdef USE_5005THREADS
4585 if (PL_op->op_private & OPpLVAL_INTRO)
4586 PUSHs(*save_threadsv(PL_op->op_targ));
4588 PUSHs(THREADSV(PL_op->op_targ));
4591 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4592 #endif /* USE_5005THREADS */