3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
19 /* variations on pp_null */
21 /* XXX I can't imagine anyone who doesn't have this actually _needs_
22 it, since pid_t is an integral type.
25 #ifdef NEED_GETPID_PROTO
26 extern Pid_t getpid (void);
32 if (GIMME_V == G_SCALAR)
47 if (PL_op->op_private & OPpLVAL_INTRO)
48 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
50 if (PL_op->op_flags & OPf_REF) {
54 if (GIMME == G_SCALAR)
55 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
59 if (GIMME == G_ARRAY) {
60 I32 maxarg = AvFILL((AV*)TARG) + 1;
62 if (SvMAGICAL(TARG)) {
64 for (i=0; i < maxarg; i++) {
65 SV **svp = av_fetch((AV*)TARG, i, FALSE);
66 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
70 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
75 SV* sv = sv_newmortal();
76 I32 maxarg = AvFILL((AV*)TARG) + 1;
89 if (PL_op->op_private & OPpLVAL_INTRO)
90 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
91 if (PL_op->op_flags & OPf_REF)
94 if (GIMME == G_SCALAR)
95 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
99 if (gimme == G_ARRAY) {
102 else if (gimme == G_SCALAR) {
103 SV* sv = sv_newmortal();
104 if (HvFILL((HV*)TARG))
105 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
106 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
116 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
127 tryAMAGICunDEREF(to_gv);
130 if (SvTYPE(sv) == SVt_PVIO) {
131 GV *gv = (GV*) sv_newmortal();
132 gv_init(gv, 0, "", 0, 0);
133 GvIOp(gv) = (IO *)sv;
134 (void)SvREFCNT_inc(sv);
137 else if (SvTYPE(sv) != SVt_PVGV)
138 DIE(aTHX_ "Not a GLOB reference");
141 if (SvTYPE(sv) != SVt_PVGV) {
145 if (SvGMAGICAL(sv)) {
150 if (!SvOK(sv) && sv != &PL_sv_undef) {
151 /* If this is a 'my' scalar and flag is set then vivify
154 if (PL_op->op_private & OPpDEREF) {
157 if (cUNOP->op_targ) {
159 SV *namesv = PL_curpad[cUNOP->op_targ];
160 name = SvPV(namesv, len);
161 gv = (GV*)NEWSV(0,0);
162 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
165 name = CopSTASHPV(PL_curcop);
168 if (SvTYPE(sv) < SVt_RV)
169 sv_upgrade(sv, SVt_RV);
175 if (PL_op->op_flags & OPf_REF ||
176 PL_op->op_private & HINT_STRICT_REFS)
177 DIE(aTHX_ PL_no_usym, "a symbol");
178 if (ckWARN(WARN_UNINITIALIZED))
183 if ((PL_op->op_flags & OPf_SPECIAL) &&
184 !(PL_op->op_flags & OPf_MOD))
186 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
188 && (!is_gv_magical(sym,len,0)
189 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
195 if (PL_op->op_private & HINT_STRICT_REFS)
196 DIE(aTHX_ PL_no_symref, sym, "a symbol");
197 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
213 tryAMAGICunDEREF(to_sv);
216 switch (SvTYPE(sv)) {
220 DIE(aTHX_ "Not a SCALAR reference");
228 if (SvTYPE(gv) != SVt_PVGV) {
229 if (SvGMAGICAL(sv)) {
235 if (PL_op->op_flags & OPf_REF ||
236 PL_op->op_private & HINT_STRICT_REFS)
237 DIE(aTHX_ PL_no_usym, "a SCALAR");
238 if (ckWARN(WARN_UNINITIALIZED))
243 if ((PL_op->op_flags & OPf_SPECIAL) &&
244 !(PL_op->op_flags & OPf_MOD))
246 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
248 && (!is_gv_magical(sym,len,0)
249 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
255 if (PL_op->op_private & HINT_STRICT_REFS)
256 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
257 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
262 if (PL_op->op_flags & OPf_MOD) {
263 if (PL_op->op_private & OPpLVAL_INTRO)
264 sv = save_scalar((GV*)TOPs);
265 else if (PL_op->op_private & OPpDEREF)
266 vivify_ref(sv, PL_op->op_private & OPpDEREF);
276 SV *sv = AvARYLEN(av);
278 AvARYLEN(av) = sv = NEWSV(0,0);
279 sv_upgrade(sv, SVt_IV);
280 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
288 dSP; dTARGET; dPOPss;
290 if (PL_op->op_flags & OPf_MOD || LVRET) {
291 if (SvTYPE(TARG) < SVt_PVLV) {
292 sv_upgrade(TARG, SVt_PVLV);
293 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
297 if (LvTARG(TARG) != sv) {
299 SvREFCNT_dec(LvTARG(TARG));
300 LvTARG(TARG) = SvREFCNT_inc(sv);
302 PUSHs(TARG); /* no SvSETMAGIC */
308 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
309 mg = mg_find(sv, PERL_MAGIC_regex_global);
310 if (mg && mg->mg_len >= 0) {
314 PUSHi(i + PL_curcop->cop_arybase);
328 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
329 /* (But not in defined().) */
330 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
333 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
334 if ((PL_op->op_private & OPpLVAL_INTRO)) {
335 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
338 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
342 cv = (CV*)&PL_sv_undef;
356 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
357 char *s = SvPVX(TOPs);
358 if (strnEQ(s, "CORE::", 6)) {
361 code = keyword(s + 6, SvCUR(TOPs) - 6);
362 if (code < 0) { /* Overridable. */
363 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
364 int i = 0, n = 0, seen_question = 0;
366 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
368 while (i < MAXO) { /* The slow way. */
369 if (strEQ(s + 6, PL_op_name[i])
370 || strEQ(s + 6, PL_op_desc[i]))
376 goto nonesuch; /* Should not happen... */
378 oa = PL_opargs[i] >> OASHIFT;
380 if (oa & OA_OPTIONAL && !seen_question) {
384 else if (n && str[0] == ';' && seen_question)
385 goto set; /* XXXX system, exec */
386 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
387 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
388 /* But globs are already references (kinda) */
389 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
393 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
397 ret = sv_2mortal(newSVpvn(str, n - 1));
399 else if (code) /* Non-Overridable */
401 else { /* None such */
403 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
407 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
409 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
418 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
420 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
436 if (GIMME != G_ARRAY) {
440 *MARK = &PL_sv_undef;
441 *MARK = refto(*MARK);
445 EXTEND_MORTAL(SP - MARK);
447 *MARK = refto(*MARK);
452 S_refto(pTHX_ SV *sv)
456 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
459 if (!(sv = LvTARG(sv)))
462 (void)SvREFCNT_inc(sv);
464 else if (SvTYPE(sv) == SVt_PVAV) {
465 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
468 (void)SvREFCNT_inc(sv);
470 else if (SvPADTMP(sv) && !IS_PADGV(sv))
474 (void)SvREFCNT_inc(sv);
477 sv_upgrade(rv, SVt_RV);
491 if (sv && SvGMAGICAL(sv))
494 if (!sv || !SvROK(sv))
498 pv = sv_reftype(sv,TRUE);
499 PUSHp(pv, strlen(pv));
509 stash = CopSTASH(PL_curcop);
515 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
516 Perl_croak(aTHX_ "Attempt to bless into a reference");
518 if (ckWARN(WARN_MISC) && len == 0)
519 Perl_warner(aTHX_ WARN_MISC,
520 "Explicit blessing to '' (assuming package main)");
521 stash = gv_stashpvn(ptr, len, TRUE);
524 (void)sv_bless(TOPs, stash);
538 elem = SvPV(sv, n_a);
542 switch (elem ? *elem : '\0')
545 if (strEQ(elem, "ARRAY"))
546 tmpRef = (SV*)GvAV(gv);
549 if (strEQ(elem, "CODE"))
550 tmpRef = (SV*)GvCVu(gv);
553 if (strEQ(elem, "FILEHANDLE")) {
554 /* finally deprecated in 5.8.0 */
555 deprecate("*glob{FILEHANDLE}");
556 tmpRef = (SV*)GvIOp(gv);
559 if (strEQ(elem, "FORMAT"))
560 tmpRef = (SV*)GvFORM(gv);
563 if (strEQ(elem, "GLOB"))
567 if (strEQ(elem, "HASH"))
568 tmpRef = (SV*)GvHV(gv);
571 if (strEQ(elem, "IO"))
572 tmpRef = (SV*)GvIOp(gv);
575 if (strEQ(elem, "NAME"))
576 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
579 if (strEQ(elem, "PACKAGE"))
580 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
583 if (strEQ(elem, "SCALAR"))
597 /* Pattern matching */
602 register unsigned char *s;
605 register I32 *sfirst;
609 if (sv == PL_lastscream) {
615 SvSCREAM_off(PL_lastscream);
616 SvREFCNT_dec(PL_lastscream);
618 PL_lastscream = SvREFCNT_inc(sv);
621 s = (unsigned char*)(SvPV(sv, len));
625 if (pos > PL_maxscream) {
626 if (PL_maxscream < 0) {
627 PL_maxscream = pos + 80;
628 New(301, PL_screamfirst, 256, I32);
629 New(302, PL_screamnext, PL_maxscream, I32);
632 PL_maxscream = pos + pos / 4;
633 Renew(PL_screamnext, PL_maxscream, I32);
637 sfirst = PL_screamfirst;
638 snext = PL_screamnext;
640 if (!sfirst || !snext)
641 DIE(aTHX_ "do_study: out of memory");
643 for (ch = 256; ch; --ch)
650 snext[pos] = sfirst[ch] - pos;
657 /* piggyback on m//g magic */
658 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
667 if (PL_op->op_flags & OPf_STACKED)
673 TARG = sv_newmortal();
678 /* Lvalue operators. */
690 dSP; dMARK; dTARGET; dORIGMARK;
692 do_chop(TARG, *++MARK);
701 SETi(do_chomp(TOPs));
708 register I32 count = 0;
711 count += do_chomp(POPs);
722 if (!sv || !SvANY(sv))
724 switch (SvTYPE(sv)) {
726 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
727 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
731 if (HvARRAY(sv) || SvGMAGICAL(sv)
732 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
736 if (CvROOT(sv) || CvXSUB(sv))
753 if (!PL_op->op_private) {
762 if (SvTHINKFIRST(sv))
765 switch (SvTYPE(sv)) {
775 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
776 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
777 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
781 /* let user-undef'd sub keep its identity */
782 GV* gv = CvGV((CV*)sv);
789 SvSetMagicSV(sv, &PL_sv_undef);
793 Newz(602, gp, 1, GP);
794 GvGP(sv) = gp_ref(gp);
795 GvSV(sv) = NEWSV(72,0);
796 GvLINE(sv) = CopLINE(PL_curcop);
802 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
805 SvPV_set(sv, Nullch);
818 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
819 DIE(aTHX_ PL_no_modify);
820 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
821 SvIVX(TOPs) != IV_MIN)
824 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
835 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
836 DIE(aTHX_ PL_no_modify);
837 sv_setsv(TARG, TOPs);
838 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
839 SvIVX(TOPs) != IV_MAX)
842 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
856 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
857 DIE(aTHX_ PL_no_modify);
858 sv_setsv(TARG, TOPs);
859 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
860 SvIVX(TOPs) != IV_MIN)
863 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 /* Ordinary operators. */
876 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
879 SETn( Perl_pow( left, right) );
886 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
887 #ifdef PERL_PRESERVE_IVUV
890 /* Unless the left argument is integer in range we are going to have to
891 use NV maths. Hence only attempt to coerce the right argument if
892 we know the left is integer. */
893 /* Left operand is defined, so is it IV? */
896 bool auvok = SvUOK(TOPm1s);
897 bool buvok = SvUOK(TOPs);
898 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
899 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
906 alow = SvUVX(TOPm1s);
908 IV aiv = SvIVX(TOPm1s);
911 auvok = TRUE; /* effectively it's a UV now */
913 alow = -aiv; /* abs, auvok == false records sign */
919 IV biv = SvIVX(TOPs);
922 buvok = TRUE; /* effectively it's a UV now */
924 blow = -biv; /* abs, buvok == false records sign */
928 /* If this does sign extension on unsigned it's time for plan B */
929 ahigh = alow >> (4 * sizeof (UV));
931 bhigh = blow >> (4 * sizeof (UV));
933 if (ahigh && bhigh) {
934 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
935 which is overflow. Drop to NVs below. */
936 } else if (!ahigh && !bhigh) {
937 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
938 so the unsigned multiply cannot overflow. */
939 UV product = alow * blow;
940 if (auvok == buvok) {
941 /* -ve * -ve or +ve * +ve gives a +ve result. */
945 } else if (product <= (UV)IV_MIN) {
946 /* 2s complement assumption that (UV)-IV_MIN is correct. */
947 /* -ve result, which could overflow an IV */
949 SETi( -(IV)product );
951 } /* else drop to NVs below. */
953 /* One operand is large, 1 small */
956 /* swap the operands */
958 bhigh = blow; /* bhigh now the temp var for the swap */
962 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
963 multiplies can't overflow. shift can, add can, -ve can. */
964 product_middle = ahigh * blow;
965 if (!(product_middle & topmask)) {
966 /* OK, (ahigh * blow) won't lose bits when we shift it. */
968 product_middle <<= (4 * sizeof (UV));
969 product_low = alow * blow;
971 /* as for pp_add, UV + something mustn't get smaller.
972 IIRC ANSI mandates this wrapping *behaviour* for
973 unsigned whatever the actual representation*/
974 product_low += product_middle;
975 if (product_low >= product_middle) {
976 /* didn't overflow */
977 if (auvok == buvok) {
978 /* -ve * -ve or +ve * +ve gives a +ve result. */
982 } else if (product_low <= (UV)IV_MIN) {
983 /* 2s complement assumption again */
984 /* -ve result, which could overflow an IV */
986 SETi( -(IV)product_low );
988 } /* else drop to NVs below. */
990 } /* product_middle too large */
991 } /* ahigh && bhigh */
992 } /* SvIOK(TOPm1s) */
997 SETn( left * right );
1004 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1005 /* Only try to do UV divide first
1006 if ((SLOPPYDIVIDE is true) or
1007 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1009 The assumption is that it is better to use floating point divide
1010 whenever possible, only doing integer divide first if we can't be sure.
1011 If NV_PRESERVES_UV is true then we know at compile time that no UV
1012 can be too large to preserve, so don't need to compile the code to
1013 test the size of UVs. */
1016 # define PERL_TRY_UV_DIVIDE
1017 /* ensure that 20./5. == 4. */
1019 # ifdef PERL_PRESERVE_IVUV
1020 # ifndef NV_PRESERVES_UV
1021 # define PERL_TRY_UV_DIVIDE
1026 #ifdef PERL_TRY_UV_DIVIDE
1029 SvIV_please(TOPm1s);
1030 if (SvIOK(TOPm1s)) {
1031 bool left_non_neg = SvUOK(TOPm1s);
1032 bool right_non_neg = SvUOK(TOPs);
1036 if (right_non_neg) {
1037 right = SvUVX(TOPs);
1040 IV biv = SvIVX(TOPs);
1043 right_non_neg = TRUE; /* effectively it's a UV now */
1049 /* historically undef()/0 gives a "Use of uninitialized value"
1050 warning before dieing, hence this test goes here.
1051 If it were immediately before the second SvIV_please, then
1052 DIE() would be invoked before left was even inspected, so
1053 no inpsection would give no warning. */
1055 DIE(aTHX_ "Illegal division by zero");
1058 left = SvUVX(TOPm1s);
1061 IV aiv = SvIVX(TOPm1s);
1064 left_non_neg = TRUE; /* effectively it's a UV now */
1073 /* For sloppy divide we always attempt integer division. */
1075 /* Otherwise we only attempt it if either or both operands
1076 would not be preserved by an NV. If both fit in NVs
1077 we fall through to the NV divide code below. */
1078 && ((left > ((UV)1 << NV_PRESERVES_UV_BITS))
1079 || (right > ((UV)1 << NV_PRESERVES_UV_BITS)))
1082 /* Integer division can't overflow, but it can be imprecise. */
1083 UV result = left / right;
1084 if (result * right == left) {
1085 SP--; /* result is valid */
1086 if (left_non_neg == right_non_neg) {
1087 /* signs identical, result is positive. */
1091 /* 2s complement assumption */
1092 if (result <= (UV)IV_MIN)
1095 /* It's exact but too negative for IV. */
1096 SETn( -(NV)result );
1099 } /* tried integer divide but it was not an integer result */
1100 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1101 } /* left wasn't SvIOK */
1102 } /* right wasn't SvIOK */
1103 #endif /* PERL_TRY_UV_DIVIDE */
1107 DIE(aTHX_ "Illegal division by zero");
1108 PUSHn( left / right );
1115 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1121 bool use_double = FALSE;
1122 bool dright_valid = FALSE;
1128 right_neg = !SvUOK(TOPs);
1130 right = SvUVX(POPs);
1132 IV biv = SvIVX(POPs);
1135 right_neg = FALSE; /* effectively it's a UV now */
1143 right_neg = dright < 0;
1146 if (dright < UV_MAX_P1) {
1147 right = U_V(dright);
1148 dright_valid = TRUE; /* In case we need to use double below. */
1154 /* At this point use_double is only true if right is out of range for
1155 a UV. In range NV has been rounded down to nearest UV and
1156 use_double false. */
1158 if (!use_double && SvIOK(TOPs)) {
1160 left_neg = !SvUOK(TOPs);
1164 IV aiv = SvIVX(POPs);
1167 left_neg = FALSE; /* effectively it's a UV now */
1176 left_neg = dleft < 0;
1180 /* This should be exactly the 5.6 behaviour - if left and right are
1181 both in range for UV then use U_V() rather than floor. */
1183 if (dleft < UV_MAX_P1) {
1184 /* right was in range, so is dleft, so use UVs not double.
1188 /* left is out of range for UV, right was in range, so promote
1189 right (back) to double. */
1191 /* The +0.5 is used in 5.6 even though it is not strictly
1192 consistent with the implicit +0 floor in the U_V()
1193 inside the #if 1. */
1194 dleft = Perl_floor(dleft + 0.5);
1197 dright = Perl_floor(dright + 0.5);
1207 DIE(aTHX_ "Illegal modulus zero");
1209 dans = Perl_fmod(dleft, dright);
1210 if ((left_neg != right_neg) && dans)
1211 dans = dright - dans;
1214 sv_setnv(TARG, dans);
1220 DIE(aTHX_ "Illegal modulus zero");
1223 if ((left_neg != right_neg) && ans)
1226 /* XXX may warn: unary minus operator applied to unsigned type */
1227 /* could change -foo to be (~foo)+1 instead */
1228 if (ans <= ~((UV)IV_MAX)+1)
1229 sv_setiv(TARG, ~ans+1);
1231 sv_setnv(TARG, -(NV)ans);
1234 sv_setuv(TARG, ans);
1243 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1245 register IV count = POPi;
1246 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1248 I32 items = SP - MARK;
1251 max = items * count;
1256 *SP = sv_2mortal(newSVsv(*SP));
1262 repeatcpy((char*)(MARK + items), (char*)MARK,
1263 items * sizeof(SV*), count - 1);
1266 else if (count <= 0)
1269 else { /* Note: mark already snarfed by pp_list */
1274 SvSetSV(TARG, tmpstr);
1275 SvPV_force(TARG, len);
1276 isutf = DO_UTF8(TARG);
1281 SvGROW(TARG, (count * len) + 1);
1282 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1283 SvCUR(TARG) *= count;
1285 *SvEND(TARG) = '\0';
1288 (void)SvPOK_only_UTF8(TARG);
1290 (void)SvPOK_only(TARG);
1292 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1293 /* The parser saw this as a list repeat, and there
1294 are probably several items on the stack. But we're
1295 in scalar context, and there's no pp_list to save us
1296 now. So drop the rest of the items -- robin@kitsite.com
1309 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1310 useleft = USE_LEFT(TOPm1s);
1311 #ifdef PERL_PRESERVE_IVUV
1312 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1313 "bad things" happen if you rely on signed integers wrapping. */
1316 /* Unless the left argument is integer in range we are going to have to
1317 use NV maths. Hence only attempt to coerce the right argument if
1318 we know the left is integer. */
1319 register UV auv = 0;
1325 a_valid = auvok = 1;
1326 /* left operand is undef, treat as zero. */
1328 /* Left operand is defined, so is it IV? */
1329 SvIV_please(TOPm1s);
1330 if (SvIOK(TOPm1s)) {
1331 if ((auvok = SvUOK(TOPm1s)))
1332 auv = SvUVX(TOPm1s);
1334 register IV aiv = SvIVX(TOPm1s);
1337 auvok = 1; /* Now acting as a sign flag. */
1338 } else { /* 2s complement assumption for IV_MIN */
1346 bool result_good = 0;
1349 bool buvok = SvUOK(TOPs);
1354 register IV biv = SvIVX(TOPs);
1361 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1362 else "IV" now, independant of how it came in.
1363 if a, b represents positive, A, B negative, a maps to -A etc
1368 all UV maths. negate result if A negative.
1369 subtract if signs same, add if signs differ. */
1371 if (auvok ^ buvok) {
1380 /* Must get smaller */
1385 if (result <= buv) {
1386 /* result really should be -(auv-buv). as its negation
1387 of true value, need to swap our result flag */
1399 if (result <= (UV)IV_MIN)
1400 SETi( -(IV)result );
1402 /* result valid, but out of range for IV. */
1403 SETn( -(NV)result );
1407 } /* Overflow, drop through to NVs. */
1411 useleft = USE_LEFT(TOPm1s);
1415 /* left operand is undef, treat as zero - value */
1419 SETn( TOPn - value );
1426 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1429 if (PL_op->op_private & HINT_INTEGER) {
1443 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1446 if (PL_op->op_private & HINT_INTEGER) {
1460 dSP; tryAMAGICbinSET(lt,0);
1461 #ifdef PERL_PRESERVE_IVUV
1464 SvIV_please(TOPm1s);
1465 if (SvIOK(TOPm1s)) {
1466 bool auvok = SvUOK(TOPm1s);
1467 bool buvok = SvUOK(TOPs);
1469 if (!auvok && !buvok) { /* ## IV < IV ## */
1470 IV aiv = SvIVX(TOPm1s);
1471 IV biv = SvIVX(TOPs);
1474 SETs(boolSV(aiv < biv));
1477 if (auvok && buvok) { /* ## UV < UV ## */
1478 UV auv = SvUVX(TOPm1s);
1479 UV buv = SvUVX(TOPs);
1482 SETs(boolSV(auv < buv));
1485 if (auvok) { /* ## UV < IV ## */
1492 /* As (a) is a UV, it's >=0, so it cannot be < */
1497 if (auv >= (UV) IV_MAX) {
1498 /* As (b) is an IV, it cannot be > IV_MAX */
1502 SETs(boolSV(auv < (UV)biv));
1505 { /* ## IV < UV ## */
1509 aiv = SvIVX(TOPm1s);
1511 /* As (b) is a UV, it's >=0, so it must be < */
1518 if (buv > (UV) IV_MAX) {
1519 /* As (a) is an IV, it cannot be > IV_MAX */
1523 SETs(boolSV((UV)aiv < buv));
1531 SETs(boolSV(TOPn < value));
1538 dSP; tryAMAGICbinSET(gt,0);
1539 #ifdef PERL_PRESERVE_IVUV
1542 SvIV_please(TOPm1s);
1543 if (SvIOK(TOPm1s)) {
1544 bool auvok = SvUOK(TOPm1s);
1545 bool buvok = SvUOK(TOPs);
1547 if (!auvok && !buvok) { /* ## IV > IV ## */
1548 IV aiv = SvIVX(TOPm1s);
1549 IV biv = SvIVX(TOPs);
1552 SETs(boolSV(aiv > biv));
1555 if (auvok && buvok) { /* ## UV > UV ## */
1556 UV auv = SvUVX(TOPm1s);
1557 UV buv = SvUVX(TOPs);
1560 SETs(boolSV(auv > buv));
1563 if (auvok) { /* ## UV > IV ## */
1570 /* As (a) is a UV, it's >=0, so it must be > */
1575 if (auv > (UV) IV_MAX) {
1576 /* As (b) is an IV, it cannot be > IV_MAX */
1580 SETs(boolSV(auv > (UV)biv));
1583 { /* ## IV > UV ## */
1587 aiv = SvIVX(TOPm1s);
1589 /* As (b) is a UV, it's >=0, so it cannot be > */
1596 if (buv >= (UV) IV_MAX) {
1597 /* As (a) is an IV, it cannot be > IV_MAX */
1601 SETs(boolSV((UV)aiv > buv));
1609 SETs(boolSV(TOPn > value));
1616 dSP; tryAMAGICbinSET(le,0);
1617 #ifdef PERL_PRESERVE_IVUV
1620 SvIV_please(TOPm1s);
1621 if (SvIOK(TOPm1s)) {
1622 bool auvok = SvUOK(TOPm1s);
1623 bool buvok = SvUOK(TOPs);
1625 if (!auvok && !buvok) { /* ## IV <= IV ## */
1626 IV aiv = SvIVX(TOPm1s);
1627 IV biv = SvIVX(TOPs);
1630 SETs(boolSV(aiv <= biv));
1633 if (auvok && buvok) { /* ## UV <= UV ## */
1634 UV auv = SvUVX(TOPm1s);
1635 UV buv = SvUVX(TOPs);
1638 SETs(boolSV(auv <= buv));
1641 if (auvok) { /* ## UV <= IV ## */
1648 /* As (a) is a UV, it's >=0, so a cannot be <= */
1653 if (auv > (UV) IV_MAX) {
1654 /* As (b) is an IV, it cannot be > IV_MAX */
1658 SETs(boolSV(auv <= (UV)biv));
1661 { /* ## IV <= UV ## */
1665 aiv = SvIVX(TOPm1s);
1667 /* As (b) is a UV, it's >=0, so a must be <= */
1674 if (buv >= (UV) IV_MAX) {
1675 /* As (a) is an IV, it cannot be > IV_MAX */
1679 SETs(boolSV((UV)aiv <= buv));
1687 SETs(boolSV(TOPn <= value));
1694 dSP; tryAMAGICbinSET(ge,0);
1695 #ifdef PERL_PRESERVE_IVUV
1698 SvIV_please(TOPm1s);
1699 if (SvIOK(TOPm1s)) {
1700 bool auvok = SvUOK(TOPm1s);
1701 bool buvok = SvUOK(TOPs);
1703 if (!auvok && !buvok) { /* ## IV >= IV ## */
1704 IV aiv = SvIVX(TOPm1s);
1705 IV biv = SvIVX(TOPs);
1708 SETs(boolSV(aiv >= biv));
1711 if (auvok && buvok) { /* ## UV >= UV ## */
1712 UV auv = SvUVX(TOPm1s);
1713 UV buv = SvUVX(TOPs);
1716 SETs(boolSV(auv >= buv));
1719 if (auvok) { /* ## UV >= IV ## */
1726 /* As (a) is a UV, it's >=0, so it must be >= */
1731 if (auv >= (UV) IV_MAX) {
1732 /* As (b) is an IV, it cannot be > IV_MAX */
1736 SETs(boolSV(auv >= (UV)biv));
1739 { /* ## IV >= UV ## */
1743 aiv = SvIVX(TOPm1s);
1745 /* As (b) is a UV, it's >=0, so a cannot be >= */
1752 if (buv > (UV) IV_MAX) {
1753 /* As (a) is an IV, it cannot be > IV_MAX */
1757 SETs(boolSV((UV)aiv >= buv));
1765 SETs(boolSV(TOPn >= value));
1772 dSP; tryAMAGICbinSET(ne,0);
1773 #ifndef NV_PRESERVES_UV
1774 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1775 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1779 #ifdef PERL_PRESERVE_IVUV
1782 SvIV_please(TOPm1s);
1783 if (SvIOK(TOPm1s)) {
1784 bool auvok = SvUOK(TOPm1s);
1785 bool buvok = SvUOK(TOPs);
1787 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1788 IV aiv = SvIVX(TOPm1s);
1789 IV biv = SvIVX(TOPs);
1792 SETs(boolSV(aiv != biv));
1795 if (auvok && buvok) { /* ## UV != UV ## */
1796 UV auv = SvUVX(TOPm1s);
1797 UV buv = SvUVX(TOPs);
1800 SETs(boolSV(auv != buv));
1803 { /* ## Mixed IV,UV ## */
1807 /* != is commutative so swap if needed (save code) */
1809 /* swap. top of stack (b) is the iv */
1813 /* As (a) is a UV, it's >0, so it cannot be == */
1822 /* As (b) is a UV, it's >0, so it cannot be == */
1826 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1828 /* we know iv is >= 0 */
1829 if (uv > (UV) IV_MAX) {
1833 SETs(boolSV((UV)iv != uv));
1841 SETs(boolSV(TOPn != value));
1848 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1849 #ifndef NV_PRESERVES_UV
1850 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1851 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1855 #ifdef PERL_PRESERVE_IVUV
1856 /* Fortunately it seems NaN isn't IOK */
1859 SvIV_please(TOPm1s);
1860 if (SvIOK(TOPm1s)) {
1861 bool leftuvok = SvUOK(TOPm1s);
1862 bool rightuvok = SvUOK(TOPs);
1864 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1865 IV leftiv = SvIVX(TOPm1s);
1866 IV rightiv = SvIVX(TOPs);
1868 if (leftiv > rightiv)
1870 else if (leftiv < rightiv)
1874 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1875 UV leftuv = SvUVX(TOPm1s);
1876 UV rightuv = SvUVX(TOPs);
1878 if (leftuv > rightuv)
1880 else if (leftuv < rightuv)
1884 } else if (leftuvok) { /* ## UV <=> IV ## */
1888 rightiv = SvIVX(TOPs);
1890 /* As (a) is a UV, it's >=0, so it cannot be < */
1893 leftuv = SvUVX(TOPm1s);
1894 if (leftuv > (UV) IV_MAX) {
1895 /* As (b) is an IV, it cannot be > IV_MAX */
1897 } else if (leftuv > (UV)rightiv) {
1899 } else if (leftuv < (UV)rightiv) {
1905 } else { /* ## IV <=> UV ## */
1909 leftiv = SvIVX(TOPm1s);
1911 /* As (b) is a UV, it's >=0, so it must be < */
1914 rightuv = SvUVX(TOPs);
1915 if (rightuv > (UV) IV_MAX) {
1916 /* As (a) is an IV, it cannot be > IV_MAX */
1918 } else if (leftiv > (UV)rightuv) {
1920 } else if (leftiv < (UV)rightuv) {
1938 if (Perl_isnan(left) || Perl_isnan(right)) {
1942 value = (left > right) - (left < right);
1946 else if (left < right)
1948 else if (left > right)
1962 dSP; tryAMAGICbinSET(slt,0);
1965 int cmp = (IN_LOCALE_RUNTIME
1966 ? sv_cmp_locale(left, right)
1967 : sv_cmp(left, right));
1968 SETs(boolSV(cmp < 0));
1975 dSP; tryAMAGICbinSET(sgt,0);
1978 int cmp = (IN_LOCALE_RUNTIME
1979 ? sv_cmp_locale(left, right)
1980 : sv_cmp(left, right));
1981 SETs(boolSV(cmp > 0));
1988 dSP; tryAMAGICbinSET(sle,0);
1991 int cmp = (IN_LOCALE_RUNTIME
1992 ? sv_cmp_locale(left, right)
1993 : sv_cmp(left, right));
1994 SETs(boolSV(cmp <= 0));
2001 dSP; tryAMAGICbinSET(sge,0);
2004 int cmp = (IN_LOCALE_RUNTIME
2005 ? sv_cmp_locale(left, right)
2006 : sv_cmp(left, right));
2007 SETs(boolSV(cmp >= 0));
2014 dSP; tryAMAGICbinSET(seq,0);
2017 SETs(boolSV(sv_eq(left, right)));
2024 dSP; tryAMAGICbinSET(sne,0);
2027 SETs(boolSV(!sv_eq(left, right)));
2034 dSP; dTARGET; tryAMAGICbin(scmp,0);
2037 int cmp = (IN_LOCALE_RUNTIME
2038 ? sv_cmp_locale(left, right)
2039 : sv_cmp(left, right));
2047 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2050 if (SvNIOKp(left) || SvNIOKp(right)) {
2051 if (PL_op->op_private & HINT_INTEGER) {
2052 IV i = SvIV(left) & SvIV(right);
2056 UV u = SvUV(left) & SvUV(right);
2061 do_vop(PL_op->op_type, TARG, left, right);
2070 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2073 if (SvNIOKp(left) || SvNIOKp(right)) {
2074 if (PL_op->op_private & HINT_INTEGER) {
2075 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2079 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2084 do_vop(PL_op->op_type, TARG, left, right);
2093 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2096 if (SvNIOKp(left) || SvNIOKp(right)) {
2097 if (PL_op->op_private & HINT_INTEGER) {
2098 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2102 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2107 do_vop(PL_op->op_type, TARG, left, right);
2116 dSP; dTARGET; tryAMAGICun(neg);
2119 int flags = SvFLAGS(sv);
2122 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2123 /* It's publicly an integer, or privately an integer-not-float */
2126 if (SvIVX(sv) == IV_MIN) {
2127 /* 2s complement assumption. */
2128 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2131 else if (SvUVX(sv) <= IV_MAX) {
2136 else if (SvIVX(sv) != IV_MIN) {
2140 #ifdef PERL_PRESERVE_IVUV
2149 else if (SvPOKp(sv)) {
2151 char *s = SvPV(sv, len);
2152 if (isIDFIRST(*s)) {
2153 sv_setpvn(TARG, "-", 1);
2156 else if (*s == '+' || *s == '-') {
2158 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2160 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2161 sv_setpvn(TARG, "-", 1);
2167 goto oops_its_an_int;
2168 sv_setnv(TARG, -SvNV(sv));
2180 dSP; tryAMAGICunSET(not);
2181 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2187 dSP; dTARGET; tryAMAGICun(compl);
2191 if (PL_op->op_private & HINT_INTEGER) {
2206 tmps = (U8*)SvPV_force(TARG, len);
2209 /* Calculate exact length, let's not estimate. */
2218 while (tmps < send) {
2219 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2220 tmps += UTF8SKIP(tmps);
2221 targlen += UNISKIP(~c);
2227 /* Now rewind strings and write them. */
2231 Newz(0, result, targlen + 1, U8);
2232 while (tmps < send) {
2233 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2234 tmps += UTF8SKIP(tmps);
2235 result = uvchr_to_utf8(result, ~c);
2239 sv_setpvn(TARG, (char*)result, targlen);
2243 Newz(0, result, nchar + 1, U8);
2244 while (tmps < send) {
2245 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2246 tmps += UTF8SKIP(tmps);
2251 sv_setpvn(TARG, (char*)result, nchar);
2259 register long *tmpl;
2260 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2263 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2268 for ( ; anum > 0; anum--, tmps++)
2277 /* integer versions of some of the above */
2281 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2284 SETi( left * right );
2291 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2295 DIE(aTHX_ "Illegal division by zero");
2296 value = POPi / value;
2304 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2308 DIE(aTHX_ "Illegal modulus zero");
2309 SETi( left % right );
2316 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2319 SETi( left + right );
2326 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2329 SETi( left - right );
2336 dSP; tryAMAGICbinSET(lt,0);
2339 SETs(boolSV(left < right));
2346 dSP; tryAMAGICbinSET(gt,0);
2349 SETs(boolSV(left > right));
2356 dSP; tryAMAGICbinSET(le,0);
2359 SETs(boolSV(left <= right));
2366 dSP; tryAMAGICbinSET(ge,0);
2369 SETs(boolSV(left >= right));
2376 dSP; tryAMAGICbinSET(eq,0);
2379 SETs(boolSV(left == right));
2386 dSP; tryAMAGICbinSET(ne,0);
2389 SETs(boolSV(left != right));
2396 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2403 else if (left < right)
2414 dSP; dTARGET; tryAMAGICun(neg);
2419 /* High falutin' math. */
2423 dSP; dTARGET; tryAMAGICbin(atan2,0);
2426 SETn(Perl_atan2(left, right));
2433 dSP; dTARGET; tryAMAGICun(sin);
2437 value = Perl_sin(value);
2445 dSP; dTARGET; tryAMAGICun(cos);
2449 value = Perl_cos(value);
2455 /* Support Configure command-line overrides for rand() functions.
2456 After 5.005, perhaps we should replace this by Configure support
2457 for drand48(), random(), or rand(). For 5.005, though, maintain
2458 compatibility by calling rand() but allow the user to override it.
2459 See INSTALL for details. --Andy Dougherty 15 July 1998
2461 /* Now it's after 5.005, and Configure supports drand48() and random(),
2462 in addition to rand(). So the overrides should not be needed any more.
2463 --Jarkko Hietaniemi 27 September 1998
2466 #ifndef HAS_DRAND48_PROTO
2467 extern double drand48 (void);
2480 if (!PL_srand_called) {
2481 (void)seedDrand01((Rand_seed_t)seed());
2482 PL_srand_called = TRUE;
2497 (void)seedDrand01((Rand_seed_t)anum);
2498 PL_srand_called = TRUE;
2507 * This is really just a quick hack which grabs various garbage
2508 * values. It really should be a real hash algorithm which
2509 * spreads the effect of every input bit onto every output bit,
2510 * if someone who knows about such things would bother to write it.
2511 * Might be a good idea to add that function to CORE as well.
2512 * No numbers below come from careful analysis or anything here,
2513 * except they are primes and SEED_C1 > 1E6 to get a full-width
2514 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2515 * probably be bigger too.
2518 # define SEED_C1 1000003
2519 #define SEED_C4 73819
2521 # define SEED_C1 25747
2522 #define SEED_C4 20639
2526 #define SEED_C5 26107
2528 #ifndef PERL_NO_DEV_RANDOM
2533 # include <starlet.h>
2534 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2535 * in 100-ns units, typically incremented ever 10 ms. */
2536 unsigned int when[2];
2538 # ifdef HAS_GETTIMEOFDAY
2539 struct timeval when;
2545 /* This test is an escape hatch, this symbol isn't set by Configure. */
2546 #ifndef PERL_NO_DEV_RANDOM
2547 #ifndef PERL_RANDOM_DEVICE
2548 /* /dev/random isn't used by default because reads from it will block
2549 * if there isn't enough entropy available. You can compile with
2550 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2551 * is enough real entropy to fill the seed. */
2552 # define PERL_RANDOM_DEVICE "/dev/urandom"
2554 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2556 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2565 _ckvmssts(sys$gettim(when));
2566 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2568 # ifdef HAS_GETTIMEOFDAY
2569 gettimeofday(&when,(struct timezone *) 0);
2570 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2573 u = (U32)SEED_C1 * when;
2576 u += SEED_C3 * (U32)PerlProc_getpid();
2577 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2578 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2579 u += SEED_C5 * (U32)PTR2UV(&when);
2586 dSP; dTARGET; tryAMAGICun(exp);
2590 value = Perl_exp(value);
2598 dSP; dTARGET; tryAMAGICun(log);
2603 SET_NUMERIC_STANDARD();
2604 DIE(aTHX_ "Can't take log of %g", value);
2606 value = Perl_log(value);
2614 dSP; dTARGET; tryAMAGICun(sqrt);
2619 SET_NUMERIC_STANDARD();
2620 DIE(aTHX_ "Can't take sqrt of %g", value);
2622 value = Perl_sqrt(value);
2630 dSP; dTARGET; tryAMAGICun(int);
2633 IV iv = TOPi; /* attempt to convert to IV if possible. */
2634 /* XXX it's arguable that compiler casting to IV might be subtly
2635 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2636 else preferring IV has introduced a subtle behaviour change bug. OTOH
2637 relying on floating point to be accurate is a bug. */
2648 if (value < (NV)UV_MAX + 0.5) {
2651 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2652 # ifdef HAS_MODFL_POW32_BUG
2653 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2655 NV offset = Perl_modf(value, &value);
2656 (void)Perl_modf(offset, &offset);
2660 (void)Perl_modf(value, &value);
2663 double tmp = (double)value;
2664 (void)Perl_modf(tmp, &tmp);
2671 if (value > (NV)IV_MIN - 0.5) {
2674 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2675 # ifdef HAS_MODFL_POW32_BUG
2676 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2678 NV offset = Perl_modf(-value, &value);
2679 (void)Perl_modf(offset, &offset);
2683 (void)Perl_modf(-value, &value);
2687 double tmp = (double)value;
2688 (void)Perl_modf(-tmp, &tmp);
2701 dSP; dTARGET; tryAMAGICun(abs);
2703 /* This will cache the NV value if string isn't actually integer */
2707 /* IVX is precise */
2709 SETu(TOPu); /* force it to be numeric only */
2717 /* 2s complement assumption. Also, not really needed as
2718 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2738 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2743 tmps = (SvPVx(POPs, len));
2744 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2745 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2758 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2763 tmps = (SvPVx(POPs, len));
2764 while (*tmps && len && isSPACE(*tmps))
2769 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2770 else if (*tmps == 'b')
2771 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2773 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2775 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2792 SETi(sv_len_utf8(sv));
2808 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2810 I32 arybase = PL_curcop->cop_arybase;
2814 int num_args = PL_op->op_private & 7;
2815 bool repl_need_utf8_upgrade = FALSE;
2816 bool repl_is_utf8 = FALSE;
2818 SvTAINTED_off(TARG); /* decontaminate */
2819 SvUTF8_off(TARG); /* decontaminate */
2823 repl = SvPV(repl_sv, repl_len);
2824 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2834 sv_utf8_upgrade(sv);
2836 else if (DO_UTF8(sv))
2837 repl_need_utf8_upgrade = TRUE;
2839 tmps = SvPV(sv, curlen);
2841 utf8_curlen = sv_len_utf8(sv);
2842 if (utf8_curlen == curlen)
2845 curlen = utf8_curlen;
2850 if (pos >= arybase) {
2868 else if (len >= 0) {
2870 if (rem > (I32)curlen)
2885 Perl_croak(aTHX_ "substr outside of string");
2886 if (ckWARN(WARN_SUBSTR))
2887 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2894 sv_pos_u2b(sv, &pos, &rem);
2896 sv_setpvn(TARG, tmps, rem);
2897 #ifdef USE_LOCALE_COLLATE
2898 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2903 SV* repl_sv_copy = NULL;
2905 if (repl_need_utf8_upgrade) {
2906 repl_sv_copy = newSVsv(repl_sv);
2907 sv_utf8_upgrade(repl_sv_copy);
2908 repl = SvPV(repl_sv_copy, repl_len);
2909 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2911 sv_insert(sv, pos, rem, repl, repl_len);
2915 SvREFCNT_dec(repl_sv_copy);
2917 else if (lvalue) { /* it's an lvalue! */
2918 if (!SvGMAGICAL(sv)) {
2922 if (ckWARN(WARN_SUBSTR))
2923 Perl_warner(aTHX_ WARN_SUBSTR,
2924 "Attempt to use reference as lvalue in substr");
2926 if (SvOK(sv)) /* is it defined ? */
2927 (void)SvPOK_only_UTF8(sv);
2929 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2932 if (SvTYPE(TARG) < SVt_PVLV) {
2933 sv_upgrade(TARG, SVt_PVLV);
2934 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2938 if (LvTARG(TARG) != sv) {
2940 SvREFCNT_dec(LvTARG(TARG));
2941 LvTARG(TARG) = SvREFCNT_inc(sv);
2943 LvTARGOFF(TARG) = upos;
2944 LvTARGLEN(TARG) = urem;
2948 PUSHs(TARG); /* avoid SvSETMAGIC here */
2955 register IV size = POPi;
2956 register IV offset = POPi;
2957 register SV *src = POPs;
2958 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2960 SvTAINTED_off(TARG); /* decontaminate */
2961 if (lvalue) { /* it's an lvalue! */
2962 if (SvTYPE(TARG) < SVt_PVLV) {
2963 sv_upgrade(TARG, SVt_PVLV);
2964 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2967 if (LvTARG(TARG) != src) {
2969 SvREFCNT_dec(LvTARG(TARG));
2970 LvTARG(TARG) = SvREFCNT_inc(src);
2972 LvTARGOFF(TARG) = offset;
2973 LvTARGLEN(TARG) = size;
2976 sv_setuv(TARG, do_vecget(src, offset, size));
2991 I32 arybase = PL_curcop->cop_arybase;
2996 offset = POPi - arybase;
2999 tmps = SvPV(big, biglen);
3000 if (offset > 0 && DO_UTF8(big))
3001 sv_pos_u2b(big, &offset, 0);
3004 else if (offset > biglen)
3006 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3007 (unsigned char*)tmps + biglen, little, 0)))
3010 retval = tmps2 - tmps;
3011 if (retval > 0 && DO_UTF8(big))
3012 sv_pos_b2u(big, &retval);
3013 PUSHi(retval + arybase);
3028 I32 arybase = PL_curcop->cop_arybase;
3034 tmps2 = SvPV(little, llen);
3035 tmps = SvPV(big, blen);
3039 if (offset > 0 && DO_UTF8(big))
3040 sv_pos_u2b(big, &offset, 0);
3041 offset = offset - arybase + llen;
3045 else if (offset > blen)
3047 if (!(tmps2 = rninstr(tmps, tmps + offset,
3048 tmps2, tmps2 + llen)))
3051 retval = tmps2 - tmps;
3052 if (retval > 0 && DO_UTF8(big))
3053 sv_pos_b2u(big, &retval);
3054 PUSHi(retval + arybase);
3060 dSP; dMARK; dORIGMARK; dTARGET;
3061 do_sprintf(TARG, SP-MARK, MARK+1);
3062 TAINT_IF(SvTAINTED(TARG));
3063 if (DO_UTF8(*(MARK+1)))
3075 U8 *s = (U8*)SvPVx(argsv, len);
3077 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3087 (void)SvUPGRADE(TARG,SVt_PV);
3089 if (value > 255 && !IN_BYTES) {
3090 SvGROW(TARG, UNISKIP(value)+1);
3091 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3092 SvCUR_set(TARG, tmps - SvPVX(TARG));
3094 (void)SvPOK_only(TARG);
3105 (void)SvPOK_only(TARG);
3112 dSP; dTARGET; dPOPTOPssrl;
3116 char *tmps = SvPV(left, len);
3118 if (DO_UTF8(left)) {
3119 /* If Unicode take the crypt() of the low 8 bits
3120 * of the characters of the string. */
3122 char *send = tmps + len;
3124 Newz(688, t, len, char);
3126 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3132 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3134 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3139 "The crypt() function is unimplemented due to excessive paranoia.");
3152 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3154 U8 tmpbuf[UTF8_MAXLEN+1];
3158 if (IN_LOCALE_RUNTIME) {
3161 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3164 uv = toTITLE_utf8(s);
3168 tend = uvchr_to_utf8(tmpbuf, uv);
3170 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3172 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3173 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3178 s = (U8*)SvPV_force(sv, slen);
3179 Copy(tmpbuf, s, ulen, U8);
3183 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3185 SvUTF8_off(TARG); /* decontaminate */
3190 s = (U8*)SvPV_force(sv, slen);
3192 if (IN_LOCALE_RUNTIME) {
3195 *s = toUPPER_LC(*s);
3213 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3215 U8 tmpbuf[UTF8_MAXLEN+1];
3219 if (IN_LOCALE_RUNTIME) {
3222 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3225 uv = toLOWER_utf8(s);
3229 tend = uvchr_to_utf8(tmpbuf, uv);
3231 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3233 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3234 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3239 s = (U8*)SvPV_force(sv, slen);
3240 Copy(tmpbuf, s, ulen, U8);
3244 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3246 SvUTF8_off(TARG); /* decontaminate */
3251 s = (U8*)SvPV_force(sv, slen);
3253 if (IN_LOCALE_RUNTIME) {
3256 *s = toLOWER_LC(*s);
3280 s = (U8*)SvPV(sv,len);
3282 SvUTF8_off(TARG); /* decontaminate */
3283 sv_setpvn(TARG, "", 0);
3287 (void)SvUPGRADE(TARG, SVt_PV);
3288 SvGROW(TARG, (len * 2) + 1);
3289 (void)SvPOK_only(TARG);
3290 d = (U8*)SvPVX(TARG);
3292 if (IN_LOCALE_RUNTIME) {
3296 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3302 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3308 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3313 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3315 SvUTF8_off(TARG); /* decontaminate */
3320 s = (U8*)SvPV_force(sv, len);
3322 register U8 *send = s + len;
3324 if (IN_LOCALE_RUNTIME) {
3327 for (; s < send; s++)
3328 *s = toUPPER_LC(*s);
3331 for (; s < send; s++)
3354 s = (U8*)SvPV(sv,len);
3356 SvUTF8_off(TARG); /* decontaminate */
3357 sv_setpvn(TARG, "", 0);
3361 (void)SvUPGRADE(TARG, SVt_PV);
3362 SvGROW(TARG, (len * 2) + 1);
3363 (void)SvPOK_only(TARG);
3364 d = (U8*)SvPVX(TARG);
3366 if (IN_LOCALE_RUNTIME) {
3370 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3376 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3382 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3387 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3389 SvUTF8_off(TARG); /* decontaminate */
3395 s = (U8*)SvPV_force(sv, len);
3397 register U8 *send = s + len;
3399 if (IN_LOCALE_RUNTIME) {
3402 for (; s < send; s++)
3403 *s = toLOWER_LC(*s);
3406 for (; s < send; s++)
3421 register char *s = SvPV(sv,len);
3424 SvUTF8_off(TARG); /* decontaminate */
3426 (void)SvUPGRADE(TARG, SVt_PV);
3427 SvGROW(TARG, (len * 2) + 1);
3431 if (UTF8_IS_CONTINUED(*s)) {
3432 STRLEN ulen = UTF8SKIP(s);
3456 SvCUR_set(TARG, d - SvPVX(TARG));
3457 (void)SvPOK_only_UTF8(TARG);
3460 sv_setpvn(TARG, s, len);
3462 if (SvSMAGICAL(TARG))
3471 dSP; dMARK; dORIGMARK;
3473 register AV* av = (AV*)POPs;
3474 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3475 I32 arybase = PL_curcop->cop_arybase;
3478 if (SvTYPE(av) == SVt_PVAV) {
3479 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3481 for (svp = MARK + 1; svp <= SP; svp++) {
3486 if (max > AvMAX(av))
3489 while (++MARK <= SP) {
3490 elem = SvIVx(*MARK);
3494 svp = av_fetch(av, elem, lval);
3496 if (!svp || *svp == &PL_sv_undef)
3497 DIE(aTHX_ PL_no_aelem, elem);
3498 if (PL_op->op_private & OPpLVAL_INTRO)
3499 save_aelem(av, elem, svp);
3501 *MARK = svp ? *svp : &PL_sv_undef;
3504 if (GIMME != G_ARRAY) {
3512 /* Associative arrays. */
3517 HV *hash = (HV*)POPs;
3519 I32 gimme = GIMME_V;
3520 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3523 /* might clobber stack_sp */
3524 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3529 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3530 if (gimme == G_ARRAY) {
3533 /* might clobber stack_sp */
3535 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3540 else if (gimme == G_SCALAR)
3559 I32 gimme = GIMME_V;
3560 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3564 if (PL_op->op_private & OPpSLICE) {
3568 hvtype = SvTYPE(hv);
3569 if (hvtype == SVt_PVHV) { /* hash element */
3570 while (++MARK <= SP) {
3571 sv = hv_delete_ent(hv, *MARK, discard, 0);
3572 *MARK = sv ? sv : &PL_sv_undef;
3575 else if (hvtype == SVt_PVAV) {
3576 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3577 while (++MARK <= SP) {
3578 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3579 *MARK = sv ? sv : &PL_sv_undef;
3582 else { /* pseudo-hash element */
3583 while (++MARK <= SP) {
3584 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3585 *MARK = sv ? sv : &PL_sv_undef;
3590 DIE(aTHX_ "Not a HASH reference");
3593 else if (gimme == G_SCALAR) {
3602 if (SvTYPE(hv) == SVt_PVHV)
3603 sv = hv_delete_ent(hv, keysv, discard, 0);
3604 else if (SvTYPE(hv) == SVt_PVAV) {
3605 if (PL_op->op_flags & OPf_SPECIAL)
3606 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3608 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3611 DIE(aTHX_ "Not a HASH reference");
3626 if (PL_op->op_private & OPpEXISTS_SUB) {
3630 cv = sv_2cv(sv, &hv, &gv, FALSE);
3633 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3639 if (SvTYPE(hv) == SVt_PVHV) {
3640 if (hv_exists_ent(hv, tmpsv, 0))
3643 else if (SvTYPE(hv) == SVt_PVAV) {
3644 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3645 if (av_exists((AV*)hv, SvIV(tmpsv)))
3648 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3652 DIE(aTHX_ "Not a HASH reference");
3659 dSP; dMARK; dORIGMARK;
3660 register HV *hv = (HV*)POPs;
3661 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3662 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3664 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3665 DIE(aTHX_ "Can't localize pseudo-hash element");
3667 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3668 while (++MARK <= SP) {
3671 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3672 realhv ? hv_exists_ent(hv, keysv, 0)
3673 : avhv_exists_ent((AV*)hv, keysv, 0);
3675 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3676 svp = he ? &HeVAL(he) : 0;
3679 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3682 if (!svp || *svp == &PL_sv_undef) {
3684 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3686 if (PL_op->op_private & OPpLVAL_INTRO) {
3688 save_helem(hv, keysv, svp);
3691 char *key = SvPV(keysv, keylen);
3692 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3696 *MARK = svp ? *svp : &PL_sv_undef;
3699 if (GIMME != G_ARRAY) {
3707 /* List operators. */
3712 if (GIMME != G_ARRAY) {
3714 *MARK = *SP; /* unwanted list, return last item */
3716 *MARK = &PL_sv_undef;
3725 SV **lastrelem = PL_stack_sp;
3726 SV **lastlelem = PL_stack_base + POPMARK;
3727 SV **firstlelem = PL_stack_base + POPMARK + 1;
3728 register SV **firstrelem = lastlelem + 1;
3729 I32 arybase = PL_curcop->cop_arybase;
3730 I32 lval = PL_op->op_flags & OPf_MOD;
3731 I32 is_something_there = lval;
3733 register I32 max = lastrelem - lastlelem;
3734 register SV **lelem;
3737 if (GIMME != G_ARRAY) {
3738 ix = SvIVx(*lastlelem);
3743 if (ix < 0 || ix >= max)
3744 *firstlelem = &PL_sv_undef;
3746 *firstlelem = firstrelem[ix];
3752 SP = firstlelem - 1;
3756 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3762 if (ix < 0 || ix >= max)
3763 *lelem = &PL_sv_undef;
3765 is_something_there = TRUE;
3766 if (!(*lelem = firstrelem[ix]))
3767 *lelem = &PL_sv_undef;
3770 if (is_something_there)
3773 SP = firstlelem - 1;
3779 dSP; dMARK; dORIGMARK;
3780 I32 items = SP - MARK;
3781 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3782 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3789 dSP; dMARK; dORIGMARK;
3790 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3794 SV *val = NEWSV(46, 0);
3796 sv_setsv(val, *++MARK);
3797 else if (ckWARN(WARN_MISC))
3798 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3799 (void)hv_store_ent(hv,key,val,0);
3808 dSP; dMARK; dORIGMARK;
3809 register AV *ary = (AV*)*++MARK;
3813 register I32 offset;
3814 register I32 length;
3821 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3822 *MARK-- = SvTIED_obj((SV*)ary, mg);
3826 call_method("SPLICE",GIMME_V);
3835 offset = i = SvIVx(*MARK);
3837 offset += AvFILLp(ary) + 1;
3839 offset -= PL_curcop->cop_arybase;
3841 DIE(aTHX_ PL_no_aelem, i);
3843 length = SvIVx(*MARK++);
3845 length += AvFILLp(ary) - offset + 1;
3851 length = AvMAX(ary) + 1; /* close enough to infinity */
3855 length = AvMAX(ary) + 1;
3857 if (offset > AvFILLp(ary) + 1)
3858 offset = AvFILLp(ary) + 1;
3859 after = AvFILLp(ary) + 1 - (offset + length);
3860 if (after < 0) { /* not that much array */
3861 length += after; /* offset+length now in array */
3867 /* At this point, MARK .. SP-1 is our new LIST */
3870 diff = newlen - length;
3871 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3874 if (diff < 0) { /* shrinking the area */
3876 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3877 Copy(MARK, tmparyval, newlen, SV*);
3880 MARK = ORIGMARK + 1;
3881 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3882 MEXTEND(MARK, length);
3883 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3885 EXTEND_MORTAL(length);
3886 for (i = length, dst = MARK; i; i--) {
3887 sv_2mortal(*dst); /* free them eventualy */
3894 *MARK = AvARRAY(ary)[offset+length-1];
3897 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3898 SvREFCNT_dec(*dst++); /* free them now */
3901 AvFILLp(ary) += diff;
3903 /* pull up or down? */
3905 if (offset < after) { /* easier to pull up */
3906 if (offset) { /* esp. if nothing to pull */
3907 src = &AvARRAY(ary)[offset-1];
3908 dst = src - diff; /* diff is negative */
3909 for (i = offset; i > 0; i--) /* can't trust Copy */
3913 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3917 if (after) { /* anything to pull down? */
3918 src = AvARRAY(ary) + offset + length;
3919 dst = src + diff; /* diff is negative */
3920 Move(src, dst, after, SV*);
3922 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3923 /* avoid later double free */
3927 dst[--i] = &PL_sv_undef;
3930 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3932 *dst = NEWSV(46, 0);
3933 sv_setsv(*dst++, *src++);
3935 Safefree(tmparyval);
3938 else { /* no, expanding (or same) */
3940 New(452, tmparyval, length, SV*); /* so remember deletion */
3941 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3944 if (diff > 0) { /* expanding */
3946 /* push up or down? */
3948 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3952 Move(src, dst, offset, SV*);
3954 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3956 AvFILLp(ary) += diff;
3959 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3960 av_extend(ary, AvFILLp(ary) + diff);
3961 AvFILLp(ary) += diff;
3964 dst = AvARRAY(ary) + AvFILLp(ary);
3966 for (i = after; i; i--) {
3973 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3974 *dst = NEWSV(46, 0);
3975 sv_setsv(*dst++, *src++);
3977 MARK = ORIGMARK + 1;
3978 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3980 Copy(tmparyval, MARK, length, SV*);
3982 EXTEND_MORTAL(length);
3983 for (i = length, dst = MARK; i; i--) {
3984 sv_2mortal(*dst); /* free them eventualy */
3988 Safefree(tmparyval);
3992 else if (length--) {
3993 *MARK = tmparyval[length];
3996 while (length-- > 0)
3997 SvREFCNT_dec(tmparyval[length]);
3999 Safefree(tmparyval);
4002 *MARK = &PL_sv_undef;
4010 dSP; dMARK; dORIGMARK; dTARGET;
4011 register AV *ary = (AV*)*++MARK;
4012 register SV *sv = &PL_sv_undef;
4015 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4016 *MARK-- = SvTIED_obj((SV*)ary, mg);
4020 call_method("PUSH",G_SCALAR|G_DISCARD);
4025 /* Why no pre-extend of ary here ? */
4026 for (++MARK; MARK <= SP; MARK++) {
4029 sv_setsv(sv, *MARK);
4034 PUSHi( AvFILL(ary) + 1 );
4042 SV *sv = av_pop(av);
4044 (void)sv_2mortal(sv);
4053 SV *sv = av_shift(av);
4058 (void)sv_2mortal(sv);
4065 dSP; dMARK; dORIGMARK; dTARGET;
4066 register AV *ary = (AV*)*++MARK;
4071 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4072 *MARK-- = SvTIED_obj((SV*)ary, mg);
4076 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4081 av_unshift(ary, SP - MARK);
4084 sv_setsv(sv, *++MARK);
4085 (void)av_store(ary, i++, sv);
4089 PUSHi( AvFILL(ary) + 1 );
4099 if (GIMME == G_ARRAY) {
4106 /* safe as long as stack cannot get extended in the above */
4111 register char *down;
4116 SvUTF8_off(TARG); /* decontaminate */
4118 do_join(TARG, &PL_sv_no, MARK, SP);
4120 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4121 up = SvPV_force(TARG, len);
4123 if (DO_UTF8(TARG)) { /* first reverse each character */
4124 U8* s = (U8*)SvPVX(TARG);
4125 U8* send = (U8*)(s + len);
4127 if (UTF8_IS_INVARIANT(*s)) {
4132 if (!utf8_to_uvchr(s, 0))
4136 down = (char*)(s - 1);
4137 /* reverse this character */
4147 down = SvPVX(TARG) + len - 1;
4153 (void)SvPOK_only_UTF8(TARG);
4165 register IV limit = POPi; /* note, negative is forever */
4168 register char *s = SvPV(sv, len);
4169 bool do_utf8 = DO_UTF8(sv);
4170 char *strend = s + len;
4172 register REGEXP *rx;
4176 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4177 I32 maxiters = slen + 10;
4180 I32 origlimit = limit;
4183 AV *oldstack = PL_curstack;
4184 I32 gimme = GIMME_V;
4185 I32 oldsave = PL_savestack_ix;
4186 I32 make_mortal = 1;
4187 MAGIC *mg = (MAGIC *) NULL;
4190 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4195 DIE(aTHX_ "panic: pp_split");
4198 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4199 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4201 PL_reg_match_utf8 = do_utf8;
4203 if (pm->op_pmreplroot) {
4205 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4207 ary = GvAVn((GV*)pm->op_pmreplroot);
4210 else if (gimme != G_ARRAY)
4211 #ifdef USE_5005THREADS
4212 ary = (AV*)PL_curpad[0];
4214 ary = GvAVn(PL_defgv);
4215 #endif /* USE_5005THREADS */
4218 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4224 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4226 XPUSHs(SvTIED_obj((SV*)ary, mg));
4232 for (i = AvFILLp(ary); i >= 0; i--)
4233 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4235 /* temporarily switch stacks */
4236 SWITCHSTACK(PL_curstack, ary);
4240 base = SP - PL_stack_base;
4242 if (pm->op_pmflags & PMf_SKIPWHITE) {
4243 if (pm->op_pmflags & PMf_LOCALE) {
4244 while (isSPACE_LC(*s))
4252 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4253 SAVEINT(PL_multiline);
4254 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4258 limit = maxiters + 2;
4259 if (pm->op_pmflags & PMf_WHITE) {
4262 while (m < strend &&
4263 !((pm->op_pmflags & PMf_LOCALE)
4264 ? isSPACE_LC(*m) : isSPACE(*m)))
4269 dstr = NEWSV(30, m-s);
4270 sv_setpvn(dstr, s, m-s);
4274 (void)SvUTF8_on(dstr);
4278 while (s < strend &&
4279 ((pm->op_pmflags & PMf_LOCALE)
4280 ? isSPACE_LC(*s) : isSPACE(*s)))
4284 else if (strEQ("^", rx->precomp)) {
4287 for (m = s; m < strend && *m != '\n'; m++) ;
4291 dstr = NEWSV(30, m-s);
4292 sv_setpvn(dstr, s, m-s);
4296 (void)SvUTF8_on(dstr);
4301 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4302 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4303 && (rx->reganch & ROPT_CHECK_ALL)
4304 && !(rx->reganch & ROPT_ANCH)) {
4305 int tail = (rx->reganch & RE_INTUIT_TAIL);
4306 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4309 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4311 char c = *SvPV(csv, n_a);
4314 for (m = s; m < strend && *m != c; m++) ;
4317 dstr = NEWSV(30, m-s);
4318 sv_setpvn(dstr, s, m-s);
4322 (void)SvUTF8_on(dstr);
4324 /* The rx->minlen is in characters but we want to step
4325 * s ahead by bytes. */
4327 s = (char*)utf8_hop((U8*)m, len);
4329 s = m + len; /* Fake \n at the end */
4334 while (s < strend && --limit &&
4335 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4336 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4339 dstr = NEWSV(31, m-s);
4340 sv_setpvn(dstr, s, m-s);
4344 (void)SvUTF8_on(dstr);
4346 /* The rx->minlen is in characters but we want to step
4347 * s ahead by bytes. */
4349 s = (char*)utf8_hop((U8*)m, len);
4351 s = m + len; /* Fake \n at the end */
4356 maxiters += slen * rx->nparens;
4357 while (s < strend && --limit
4358 /* && (!rx->check_substr
4359 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4361 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4362 1 /* minend */, sv, NULL, 0))
4364 TAINT_IF(RX_MATCH_TAINTED(rx));
4365 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4370 strend = s + (strend - m);
4372 m = rx->startp[0] + orig;
4373 dstr = NEWSV(32, m-s);
4374 sv_setpvn(dstr, s, m-s);
4378 (void)SvUTF8_on(dstr);
4381 for (i = 1; i <= rx->nparens; i++) {
4382 s = rx->startp[i] + orig;
4383 m = rx->endp[i] + orig;
4385 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4386 parens that didn't match -- they should be set to
4387 undef, not the empty string */
4388 if (m >= orig && s >= orig) {
4389 dstr = NEWSV(33, m-s);
4390 sv_setpvn(dstr, s, m-s);
4393 dstr = &PL_sv_undef; /* undef, not "" */
4397 (void)SvUTF8_on(dstr);
4401 s = rx->endp[0] + orig;
4405 LEAVE_SCOPE(oldsave);
4406 iters = (SP - PL_stack_base) - base;
4407 if (iters > maxiters)
4408 DIE(aTHX_ "Split loop");
4410 /* keep field after final delim? */
4411 if (s < strend || (iters && origlimit)) {
4412 STRLEN l = strend - s;
4413 dstr = NEWSV(34, l);
4414 sv_setpvn(dstr, s, l);
4418 (void)SvUTF8_on(dstr);
4422 else if (!origlimit) {
4423 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4429 SWITCHSTACK(ary, oldstack);
4430 if (SvSMAGICAL(ary)) {
4435 if (gimme == G_ARRAY) {
4437 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4445 call_method("PUSH",G_SCALAR|G_DISCARD);
4448 if (gimme == G_ARRAY) {
4449 /* EXTEND should not be needed - we just popped them */
4451 for (i=0; i < iters; i++) {
4452 SV **svp = av_fetch(ary, i, FALSE);
4453 PUSHs((svp) ? *svp : &PL_sv_undef);
4460 if (gimme == G_ARRAY)
4463 if (iters || !pm->op_pmreplroot) {
4471 #ifdef USE_5005THREADS
4473 Perl_unlock_condpair(pTHX_ void *svv)
4475 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4478 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4479 MUTEX_LOCK(MgMUTEXP(mg));
4480 if (MgOWNER(mg) != thr)
4481 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4483 COND_SIGNAL(MgOWNERCONDP(mg));
4484 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4485 PTR2UV(thr), PTR2UV(svv)));
4486 MUTEX_UNLOCK(MgMUTEXP(mg));
4488 #endif /* USE_5005THREADS */
4495 #ifdef USE_5005THREADS
4497 #endif /* USE_5005THREADS */
4499 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4501 Perl_sharedsv_lock(aTHX_ ssv);
4502 #endif /* USE_ITHREADS */
4503 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4504 || SvTYPE(retsv) == SVt_PVCV) {
4505 retsv = refto(retsv);
4513 #ifdef USE_5005THREADS
4516 if (PL_op->op_private & OPpLVAL_INTRO)
4517 PUSHs(*save_threadsv(PL_op->op_targ));
4519 PUSHs(THREADSV(PL_op->op_targ));
4522 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4523 #endif /* USE_5005THREADS */