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;
2795 tmps = (SvPVx(POPs, len));
2796 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2797 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2810 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2815 tmps = (SvPVx(POPs, len));
2816 while (*tmps && len && isSPACE(*tmps))
2821 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2822 else if (*tmps == 'b')
2823 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2825 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2827 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2844 SETi(sv_len_utf8(sv));
2860 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2862 I32 arybase = PL_curcop->cop_arybase;
2866 int num_args = PL_op->op_private & 7;
2867 bool repl_need_utf8_upgrade = FALSE;
2868 bool repl_is_utf8 = FALSE;
2870 SvTAINTED_off(TARG); /* decontaminate */
2871 SvUTF8_off(TARG); /* decontaminate */
2875 repl = SvPV(repl_sv, repl_len);
2876 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2886 sv_utf8_upgrade(sv);
2888 else if (DO_UTF8(sv))
2889 repl_need_utf8_upgrade = TRUE;
2891 tmps = SvPV(sv, curlen);
2893 utf8_curlen = sv_len_utf8(sv);
2894 if (utf8_curlen == curlen)
2897 curlen = utf8_curlen;
2902 if (pos >= arybase) {
2920 else if (len >= 0) {
2922 if (rem > (I32)curlen)
2937 Perl_croak(aTHX_ "substr outside of string");
2938 if (ckWARN(WARN_SUBSTR))
2939 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2946 sv_pos_u2b(sv, &pos, &rem);
2948 sv_setpvn(TARG, tmps, rem);
2949 #ifdef USE_LOCALE_COLLATE
2950 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2955 SV* repl_sv_copy = NULL;
2957 if (repl_need_utf8_upgrade) {
2958 repl_sv_copy = newSVsv(repl_sv);
2959 sv_utf8_upgrade(repl_sv_copy);
2960 repl = SvPV(repl_sv_copy, repl_len);
2961 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2963 sv_insert(sv, pos, rem, repl, repl_len);
2967 SvREFCNT_dec(repl_sv_copy);
2969 else if (lvalue) { /* it's an lvalue! */
2970 if (!SvGMAGICAL(sv)) {
2974 if (ckWARN(WARN_SUBSTR))
2975 Perl_warner(aTHX_ WARN_SUBSTR,
2976 "Attempt to use reference as lvalue in substr");
2978 if (SvOK(sv)) /* is it defined ? */
2979 (void)SvPOK_only_UTF8(sv);
2981 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2984 if (SvTYPE(TARG) < SVt_PVLV) {
2985 sv_upgrade(TARG, SVt_PVLV);
2986 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2990 if (LvTARG(TARG) != sv) {
2992 SvREFCNT_dec(LvTARG(TARG));
2993 LvTARG(TARG) = SvREFCNT_inc(sv);
2995 LvTARGOFF(TARG) = upos;
2996 LvTARGLEN(TARG) = urem;
3000 PUSHs(TARG); /* avoid SvSETMAGIC here */
3007 register IV size = POPi;
3008 register IV offset = POPi;
3009 register SV *src = POPs;
3010 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3012 SvTAINTED_off(TARG); /* decontaminate */
3013 if (lvalue) { /* it's an lvalue! */
3014 if (SvTYPE(TARG) < SVt_PVLV) {
3015 sv_upgrade(TARG, SVt_PVLV);
3016 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3019 if (LvTARG(TARG) != src) {
3021 SvREFCNT_dec(LvTARG(TARG));
3022 LvTARG(TARG) = SvREFCNT_inc(src);
3024 LvTARGOFF(TARG) = offset;
3025 LvTARGLEN(TARG) = size;
3028 sv_setuv(TARG, do_vecget(src, offset, size));
3043 I32 arybase = PL_curcop->cop_arybase;
3048 offset = POPi - arybase;
3051 tmps = SvPV(big, biglen);
3052 if (offset > 0 && DO_UTF8(big))
3053 sv_pos_u2b(big, &offset, 0);
3056 else if (offset > biglen)
3058 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3059 (unsigned char*)tmps + biglen, little, 0)))
3062 retval = tmps2 - tmps;
3063 if (retval > 0 && DO_UTF8(big))
3064 sv_pos_b2u(big, &retval);
3065 PUSHi(retval + arybase);
3080 I32 arybase = PL_curcop->cop_arybase;
3086 tmps2 = SvPV(little, llen);
3087 tmps = SvPV(big, blen);
3091 if (offset > 0 && DO_UTF8(big))
3092 sv_pos_u2b(big, &offset, 0);
3093 offset = offset - arybase + llen;
3097 else if (offset > blen)
3099 if (!(tmps2 = rninstr(tmps, tmps + offset,
3100 tmps2, tmps2 + llen)))
3103 retval = tmps2 - tmps;
3104 if (retval > 0 && DO_UTF8(big))
3105 sv_pos_b2u(big, &retval);
3106 PUSHi(retval + arybase);
3112 dSP; dMARK; dORIGMARK; dTARGET;
3113 do_sprintf(TARG, SP-MARK, MARK+1);
3114 TAINT_IF(SvTAINTED(TARG));
3115 if (DO_UTF8(*(MARK+1)))
3127 U8 *s = (U8*)SvPVx(argsv, len);
3130 if (PL_encoding && !DO_UTF8(argsv)) {
3131 tmpsv = sv_2mortal(newSVsv(argsv));
3132 s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3136 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3147 (void)SvUPGRADE(TARG,SVt_PV);
3149 if (value > 255 && !IN_BYTES) {
3150 SvGROW(TARG, UNISKIP(value)+1);
3151 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value,
3152 UNICODE_ALLOW_SUPER);
3153 SvCUR_set(TARG, tmps - SvPVX(TARG));
3155 (void)SvPOK_only(TARG);
3166 (void)SvPOK_only(TARG);
3168 Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3180 char *tmps = SvPV(left, len);
3182 if (DO_UTF8(left)) {
3183 /* If Unicode take the crypt() of the low 8 bits
3184 * of the characters of the string. */
3186 char *send = tmps + len;
3188 Newz(688, t, len, char);
3190 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3196 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3198 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3203 "The crypt() function is unimplemented due to excessive paranoia.");
3217 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3221 s = (U8*)SvPV(sv, slen);
3222 utf8_to_uvchr(s, &ulen);
3224 toTITLE_utf8(s, tmpbuf, &tculen);
3225 utf8_to_uvchr(tmpbuf, 0);
3227 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3229 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3230 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3235 s = (U8*)SvPV_force(sv, slen);
3236 Copy(tmpbuf, s, tculen, U8);
3240 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3242 SvUTF8_off(TARG); /* decontaminate */
3247 s = (U8*)SvPV_force(sv, slen);
3249 if (IN_LOCALE_RUNTIME) {
3252 *s = toUPPER_LC(*s);
3270 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3272 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3276 toLOWER_utf8(s, tmpbuf, &ulen);
3277 uv = utf8_to_uvchr(tmpbuf, 0);
3279 tend = uvchr_to_utf8(tmpbuf, uv);
3281 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3283 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3284 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3289 s = (U8*)SvPV_force(sv, slen);
3290 Copy(tmpbuf, s, ulen, U8);
3294 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3296 SvUTF8_off(TARG); /* decontaminate */
3301 s = (U8*)SvPV_force(sv, slen);
3303 if (IN_LOCALE_RUNTIME) {
3306 *s = toLOWER_LC(*s);
3329 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3331 s = (U8*)SvPV(sv,len);
3333 SvUTF8_off(TARG); /* decontaminate */
3334 sv_setpvn(TARG, "", 0);
3338 (void)SvUPGRADE(TARG, SVt_PV);
3339 SvGROW(TARG, (len * 2) + 1);
3340 (void)SvPOK_only(TARG);
3341 d = (U8*)SvPVX(TARG);
3344 toUPPER_utf8(s, tmpbuf, &ulen);
3345 Copy(tmpbuf, d, ulen, U8);
3351 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3356 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3358 SvUTF8_off(TARG); /* decontaminate */
3363 s = (U8*)SvPV_force(sv, len);
3365 register U8 *send = s + len;
3367 if (IN_LOCALE_RUNTIME) {
3370 for (; s < send; s++)
3371 *s = toUPPER_LC(*s);
3374 for (; s < send; s++)
3396 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3398 s = (U8*)SvPV(sv,len);
3400 SvUTF8_off(TARG); /* decontaminate */
3401 sv_setpvn(TARG, "", 0);
3405 (void)SvUPGRADE(TARG, SVt_PV);
3406 SvGROW(TARG, (len * 2) + 1);
3407 (void)SvPOK_only(TARG);
3408 d = (U8*)SvPVX(TARG);
3411 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3412 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3413 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3415 * Now if the sigma is NOT followed by
3416 * /$ignorable_sequence$cased_letter/;
3417 * and it IS preceded by
3418 * /$cased_letter$ignorable_sequence/;
3419 * where $ignorable_sequence is
3420 * [\x{2010}\x{AD}\p{Mn}]*
3421 * and $cased_letter is
3422 * [\p{Ll}\p{Lo}\p{Lt}]
3423 * then it should be mapped to 0x03C2,
3424 * (GREEK SMALL LETTER FINAL SIGMA),
3425 * instead of staying 0x03A3.
3426 * See lib/unicore/SpecCase.txt.
3429 Copy(tmpbuf, d, ulen, U8);
3435 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3440 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3442 SvUTF8_off(TARG); /* decontaminate */
3448 s = (U8*)SvPV_force(sv, len);
3450 register U8 *send = s + len;
3452 if (IN_LOCALE_RUNTIME) {
3455 for (; s < send; s++)
3456 *s = toLOWER_LC(*s);
3459 for (; s < send; s++)
3474 register char *s = SvPV(sv,len);
3477 SvUTF8_off(TARG); /* decontaminate */
3479 (void)SvUPGRADE(TARG, SVt_PV);
3480 SvGROW(TARG, (len * 2) + 1);
3484 if (UTF8_IS_CONTINUED(*s)) {
3485 STRLEN ulen = UTF8SKIP(s);
3509 SvCUR_set(TARG, d - SvPVX(TARG));
3510 (void)SvPOK_only_UTF8(TARG);
3513 sv_setpvn(TARG, s, len);
3515 if (SvSMAGICAL(TARG))
3524 dSP; dMARK; dORIGMARK;
3526 register AV* av = (AV*)POPs;
3527 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3528 I32 arybase = PL_curcop->cop_arybase;
3531 if (SvTYPE(av) == SVt_PVAV) {
3532 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3534 for (svp = MARK + 1; svp <= SP; svp++) {
3539 if (max > AvMAX(av))
3542 while (++MARK <= SP) {
3543 elem = SvIVx(*MARK);
3547 svp = av_fetch(av, elem, lval);
3549 if (!svp || *svp == &PL_sv_undef)
3550 DIE(aTHX_ PL_no_aelem, elem);
3551 if (PL_op->op_private & OPpLVAL_INTRO)
3552 save_aelem(av, elem, svp);
3554 *MARK = svp ? *svp : &PL_sv_undef;
3557 if (GIMME != G_ARRAY) {
3565 /* Associative arrays. */
3570 HV *hash = (HV*)POPs;
3572 I32 gimme = GIMME_V;
3573 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3576 /* might clobber stack_sp */
3577 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3582 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3583 if (gimme == G_ARRAY) {
3586 /* might clobber stack_sp */
3588 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3593 else if (gimme == G_SCALAR)
3612 I32 gimme = GIMME_V;
3613 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3617 if (PL_op->op_private & OPpSLICE) {
3621 hvtype = SvTYPE(hv);
3622 if (hvtype == SVt_PVHV) { /* hash element */
3623 while (++MARK <= SP) {
3624 sv = hv_delete_ent(hv, *MARK, discard, 0);
3625 *MARK = sv ? sv : &PL_sv_undef;
3628 else if (hvtype == SVt_PVAV) {
3629 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3630 while (++MARK <= SP) {
3631 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3632 *MARK = sv ? sv : &PL_sv_undef;
3635 else { /* pseudo-hash element */
3636 while (++MARK <= SP) {
3637 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3638 *MARK = sv ? sv : &PL_sv_undef;
3643 DIE(aTHX_ "Not a HASH reference");
3646 else if (gimme == G_SCALAR) {
3655 if (SvTYPE(hv) == SVt_PVHV)
3656 sv = hv_delete_ent(hv, keysv, discard, 0);
3657 else if (SvTYPE(hv) == SVt_PVAV) {
3658 if (PL_op->op_flags & OPf_SPECIAL)
3659 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3661 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3664 DIE(aTHX_ "Not a HASH reference");
3679 if (PL_op->op_private & OPpEXISTS_SUB) {
3683 cv = sv_2cv(sv, &hv, &gv, FALSE);
3686 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3692 if (SvTYPE(hv) == SVt_PVHV) {
3693 if (hv_exists_ent(hv, tmpsv, 0))
3696 else if (SvTYPE(hv) == SVt_PVAV) {
3697 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3698 if (av_exists((AV*)hv, SvIV(tmpsv)))
3701 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3705 DIE(aTHX_ "Not a HASH reference");
3712 dSP; dMARK; dORIGMARK;
3713 register HV *hv = (HV*)POPs;
3714 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3715 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3717 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3718 DIE(aTHX_ "Can't localize pseudo-hash element");
3720 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3721 while (++MARK <= SP) {
3724 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3725 realhv ? hv_exists_ent(hv, keysv, 0)
3726 : avhv_exists_ent((AV*)hv, keysv, 0);
3728 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3729 svp = he ? &HeVAL(he) : 0;
3732 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3735 if (!svp || *svp == &PL_sv_undef) {
3737 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3739 if (PL_op->op_private & OPpLVAL_INTRO) {
3741 save_helem(hv, keysv, svp);
3744 char *key = SvPV(keysv, keylen);
3745 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3749 *MARK = svp ? *svp : &PL_sv_undef;
3752 if (GIMME != G_ARRAY) {
3760 /* List operators. */
3765 if (GIMME != G_ARRAY) {
3767 *MARK = *SP; /* unwanted list, return last item */
3769 *MARK = &PL_sv_undef;
3778 SV **lastrelem = PL_stack_sp;
3779 SV **lastlelem = PL_stack_base + POPMARK;
3780 SV **firstlelem = PL_stack_base + POPMARK + 1;
3781 register SV **firstrelem = lastlelem + 1;
3782 I32 arybase = PL_curcop->cop_arybase;
3783 I32 lval = PL_op->op_flags & OPf_MOD;
3784 I32 is_something_there = lval;
3786 register I32 max = lastrelem - lastlelem;
3787 register SV **lelem;
3790 if (GIMME != G_ARRAY) {
3791 ix = SvIVx(*lastlelem);
3796 if (ix < 0 || ix >= max)
3797 *firstlelem = &PL_sv_undef;
3799 *firstlelem = firstrelem[ix];
3805 SP = firstlelem - 1;
3809 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3815 if (ix < 0 || ix >= max)
3816 *lelem = &PL_sv_undef;
3818 is_something_there = TRUE;
3819 if (!(*lelem = firstrelem[ix]))
3820 *lelem = &PL_sv_undef;
3823 if (is_something_there)
3826 SP = firstlelem - 1;
3832 dSP; dMARK; dORIGMARK;
3833 I32 items = SP - MARK;
3834 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3835 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3842 dSP; dMARK; dORIGMARK;
3843 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3847 SV *val = NEWSV(46, 0);
3849 sv_setsv(val, *++MARK);
3850 else if (ckWARN(WARN_MISC))
3851 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3852 (void)hv_store_ent(hv,key,val,0);
3861 dSP; dMARK; dORIGMARK;
3862 register AV *ary = (AV*)*++MARK;
3866 register I32 offset;
3867 register I32 length;
3874 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3875 *MARK-- = SvTIED_obj((SV*)ary, mg);
3879 call_method("SPLICE",GIMME_V);
3888 offset = i = SvIVx(*MARK);
3890 offset += AvFILLp(ary) + 1;
3892 offset -= PL_curcop->cop_arybase;
3894 DIE(aTHX_ PL_no_aelem, i);
3896 length = SvIVx(*MARK++);
3898 length += AvFILLp(ary) - offset + 1;
3904 length = AvMAX(ary) + 1; /* close enough to infinity */
3908 length = AvMAX(ary) + 1;
3910 if (offset > AvFILLp(ary) + 1)
3911 offset = AvFILLp(ary) + 1;
3912 after = AvFILLp(ary) + 1 - (offset + length);
3913 if (after < 0) { /* not that much array */
3914 length += after; /* offset+length now in array */
3920 /* At this point, MARK .. SP-1 is our new LIST */
3923 diff = newlen - length;
3924 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3927 if (diff < 0) { /* shrinking the area */
3929 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3930 Copy(MARK, tmparyval, newlen, SV*);
3933 MARK = ORIGMARK + 1;
3934 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3935 MEXTEND(MARK, length);
3936 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3938 EXTEND_MORTAL(length);
3939 for (i = length, dst = MARK; i; i--) {
3940 sv_2mortal(*dst); /* free them eventualy */
3947 *MARK = AvARRAY(ary)[offset+length-1];
3950 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3951 SvREFCNT_dec(*dst++); /* free them now */
3954 AvFILLp(ary) += diff;
3956 /* pull up or down? */
3958 if (offset < after) { /* easier to pull up */
3959 if (offset) { /* esp. if nothing to pull */
3960 src = &AvARRAY(ary)[offset-1];
3961 dst = src - diff; /* diff is negative */
3962 for (i = offset; i > 0; i--) /* can't trust Copy */
3966 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3970 if (after) { /* anything to pull down? */
3971 src = AvARRAY(ary) + offset + length;
3972 dst = src + diff; /* diff is negative */
3973 Move(src, dst, after, SV*);
3975 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3976 /* avoid later double free */
3980 dst[--i] = &PL_sv_undef;
3983 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3985 *dst = NEWSV(46, 0);
3986 sv_setsv(*dst++, *src++);
3988 Safefree(tmparyval);
3991 else { /* no, expanding (or same) */
3993 New(452, tmparyval, length, SV*); /* so remember deletion */
3994 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3997 if (diff > 0) { /* expanding */
3999 /* push up or down? */
4001 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4005 Move(src, dst, offset, SV*);
4007 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4009 AvFILLp(ary) += diff;
4012 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4013 av_extend(ary, AvFILLp(ary) + diff);
4014 AvFILLp(ary) += diff;
4017 dst = AvARRAY(ary) + AvFILLp(ary);
4019 for (i = after; i; i--) {
4026 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4027 *dst = NEWSV(46, 0);
4028 sv_setsv(*dst++, *src++);
4030 MARK = ORIGMARK + 1;
4031 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4033 Copy(tmparyval, MARK, length, SV*);
4035 EXTEND_MORTAL(length);
4036 for (i = length, dst = MARK; i; i--) {
4037 sv_2mortal(*dst); /* free them eventualy */
4041 Safefree(tmparyval);
4045 else if (length--) {
4046 *MARK = tmparyval[length];
4049 while (length-- > 0)
4050 SvREFCNT_dec(tmparyval[length]);
4052 Safefree(tmparyval);
4055 *MARK = &PL_sv_undef;
4063 dSP; dMARK; dORIGMARK; dTARGET;
4064 register AV *ary = (AV*)*++MARK;
4065 register SV *sv = &PL_sv_undef;
4068 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4069 *MARK-- = SvTIED_obj((SV*)ary, mg);
4073 call_method("PUSH",G_SCALAR|G_DISCARD);
4078 /* Why no pre-extend of ary here ? */
4079 for (++MARK; MARK <= SP; MARK++) {
4082 sv_setsv(sv, *MARK);
4087 PUSHi( AvFILL(ary) + 1 );
4095 SV *sv = av_pop(av);
4097 (void)sv_2mortal(sv);
4106 SV *sv = av_shift(av);
4111 (void)sv_2mortal(sv);
4118 dSP; dMARK; dORIGMARK; dTARGET;
4119 register AV *ary = (AV*)*++MARK;
4124 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4125 *MARK-- = SvTIED_obj((SV*)ary, mg);
4129 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4134 av_unshift(ary, SP - MARK);
4137 sv_setsv(sv, *++MARK);
4138 (void)av_store(ary, i++, sv);
4142 PUSHi( AvFILL(ary) + 1 );
4152 if (GIMME == G_ARRAY) {
4159 /* safe as long as stack cannot get extended in the above */
4164 register char *down;
4169 SvUTF8_off(TARG); /* decontaminate */
4171 do_join(TARG, &PL_sv_no, MARK, SP);
4173 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4174 up = SvPV_force(TARG, len);
4176 if (DO_UTF8(TARG)) { /* first reverse each character */
4177 U8* s = (U8*)SvPVX(TARG);
4178 U8* send = (U8*)(s + len);
4180 if (UTF8_IS_INVARIANT(*s)) {
4185 if (!utf8_to_uvchr(s, 0))
4189 down = (char*)(s - 1);
4190 /* reverse this character */
4200 down = SvPVX(TARG) + len - 1;
4206 (void)SvPOK_only_UTF8(TARG);
4218 register IV limit = POPi; /* note, negative is forever */
4221 register char *s = SvPV(sv, len);
4222 bool do_utf8 = DO_UTF8(sv);
4223 char *strend = s + len;
4225 register REGEXP *rx;
4229 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4230 I32 maxiters = slen + 10;
4233 I32 origlimit = limit;
4236 AV *oldstack = PL_curstack;
4237 I32 gimme = GIMME_V;
4238 I32 oldsave = PL_savestack_ix;
4239 I32 make_mortal = 1;
4240 MAGIC *mg = (MAGIC *) NULL;
4243 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4248 DIE(aTHX_ "panic: pp_split");
4251 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4252 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4254 PL_reg_match_utf8 = do_utf8;
4256 if (pm->op_pmreplroot) {
4258 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4260 ary = GvAVn((GV*)pm->op_pmreplroot);
4263 else if (gimme != G_ARRAY)
4264 #ifdef USE_5005THREADS
4265 ary = (AV*)PL_curpad[0];
4267 ary = GvAVn(PL_defgv);
4268 #endif /* USE_5005THREADS */
4271 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4277 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4279 XPUSHs(SvTIED_obj((SV*)ary, mg));
4285 for (i = AvFILLp(ary); i >= 0; i--)
4286 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4288 /* temporarily switch stacks */
4289 SWITCHSTACK(PL_curstack, ary);
4293 base = SP - PL_stack_base;
4295 if (pm->op_pmflags & PMf_SKIPWHITE) {
4296 if (pm->op_pmflags & PMf_LOCALE) {
4297 while (isSPACE_LC(*s))
4305 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4306 SAVEINT(PL_multiline);
4307 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4311 limit = maxiters + 2;
4312 if (pm->op_pmflags & PMf_WHITE) {
4315 while (m < strend &&
4316 !((pm->op_pmflags & PMf_LOCALE)
4317 ? isSPACE_LC(*m) : isSPACE(*m)))
4322 dstr = NEWSV(30, m-s);
4323 sv_setpvn(dstr, s, m-s);
4327 (void)SvUTF8_on(dstr);
4331 while (s < strend &&
4332 ((pm->op_pmflags & PMf_LOCALE)
4333 ? isSPACE_LC(*s) : isSPACE(*s)))
4337 else if (strEQ("^", rx->precomp)) {
4340 for (m = s; m < strend && *m != '\n'; m++) ;
4344 dstr = NEWSV(30, m-s);
4345 sv_setpvn(dstr, s, m-s);
4349 (void)SvUTF8_on(dstr);
4354 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4355 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4356 && (rx->reganch & ROPT_CHECK_ALL)
4357 && !(rx->reganch & ROPT_ANCH)) {
4358 int tail = (rx->reganch & RE_INTUIT_TAIL);
4359 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4362 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4364 char c = *SvPV(csv, n_a);
4367 for (m = s; m < strend && *m != c; m++) ;
4370 dstr = NEWSV(30, m-s);
4371 sv_setpvn(dstr, s, m-s);
4375 (void)SvUTF8_on(dstr);
4377 /* The rx->minlen is in characters but we want to step
4378 * s ahead by bytes. */
4380 s = (char*)utf8_hop((U8*)m, len);
4382 s = m + len; /* Fake \n at the end */
4387 while (s < strend && --limit &&
4388 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4389 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4392 dstr = NEWSV(31, m-s);
4393 sv_setpvn(dstr, s, m-s);
4397 (void)SvUTF8_on(dstr);
4399 /* The rx->minlen is in characters but we want to step
4400 * s ahead by bytes. */
4402 s = (char*)utf8_hop((U8*)m, len);
4404 s = m + len; /* Fake \n at the end */
4409 maxiters += slen * rx->nparens;
4410 while (s < strend && --limit
4411 /* && (!rx->check_substr
4412 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4414 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4415 1 /* minend */, sv, NULL, 0))
4417 TAINT_IF(RX_MATCH_TAINTED(rx));
4418 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4423 strend = s + (strend - m);
4425 m = rx->startp[0] + orig;
4426 dstr = NEWSV(32, m-s);
4427 sv_setpvn(dstr, s, m-s);
4431 (void)SvUTF8_on(dstr);
4434 for (i = 1; i <= rx->nparens; i++) {
4435 s = rx->startp[i] + orig;
4436 m = rx->endp[i] + orig;
4438 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4439 parens that didn't match -- they should be set to
4440 undef, not the empty string */
4441 if (m >= orig && s >= orig) {
4442 dstr = NEWSV(33, m-s);
4443 sv_setpvn(dstr, s, m-s);
4446 dstr = &PL_sv_undef; /* undef, not "" */
4450 (void)SvUTF8_on(dstr);
4454 s = rx->endp[0] + orig;
4458 LEAVE_SCOPE(oldsave);
4459 iters = (SP - PL_stack_base) - base;
4460 if (iters > maxiters)
4461 DIE(aTHX_ "Split loop");
4463 /* keep field after final delim? */
4464 if (s < strend || (iters && origlimit)) {
4465 STRLEN l = strend - s;
4466 dstr = NEWSV(34, l);
4467 sv_setpvn(dstr, s, l);
4471 (void)SvUTF8_on(dstr);
4475 else if (!origlimit) {
4476 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4482 SWITCHSTACK(ary, oldstack);
4483 if (SvSMAGICAL(ary)) {
4488 if (gimme == G_ARRAY) {
4490 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4498 call_method("PUSH",G_SCALAR|G_DISCARD);
4501 if (gimme == G_ARRAY) {
4502 /* EXTEND should not be needed - we just popped them */
4504 for (i=0; i < iters; i++) {
4505 SV **svp = av_fetch(ary, i, FALSE);
4506 PUSHs((svp) ? *svp : &PL_sv_undef);
4513 if (gimme == G_ARRAY)
4516 if (iters || !pm->op_pmreplroot) {
4524 #ifdef USE_5005THREADS
4526 Perl_unlock_condpair(pTHX_ void *svv)
4528 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4531 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4532 MUTEX_LOCK(MgMUTEXP(mg));
4533 if (MgOWNER(mg) != thr)
4534 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4536 COND_SIGNAL(MgOWNERCONDP(mg));
4537 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4538 PTR2UV(thr), PTR2UV(svv)));
4539 MUTEX_UNLOCK(MgMUTEXP(mg));
4541 #endif /* USE_5005THREADS */
4548 #ifdef USE_5005THREADS
4550 #endif /* USE_5005THREADS */
4552 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4554 Perl_sharedsv_lock(aTHX_ ssv);
4555 #endif /* USE_ITHREADS */
4556 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4557 || SvTYPE(retsv) == SVt_PVCV) {
4558 retsv = refto(retsv);
4566 #ifdef USE_5005THREADS
4569 if (PL_op->op_private & OPpLVAL_INTRO)
4570 PUSHs(*save_threadsv(PL_op->op_targ));
4572 PUSHs(THREADSV(PL_op->op_targ));
4575 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4576 #endif /* USE_5005THREADS */