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*2+1];
3158 toTITLE_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
3159 uv = utf8_to_uvchr(tmpbuf, 0);
3161 tend = uvchr_to_utf8(tmpbuf, uv);
3163 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3165 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3166 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3171 s = (U8*)SvPV_force(sv, slen);
3172 Copy(tmpbuf, s, ulen, U8);
3176 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3178 SvUTF8_off(TARG); /* decontaminate */
3183 s = (U8*)SvPV_force(sv, slen);
3185 if (IN_LOCALE_RUNTIME) {
3188 *s = toUPPER_LC(*s);
3206 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3208 U8 tmpbuf[UTF8_MAXLEN*2+1];
3212 toLOWER_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
3213 uv = utf8_to_uvchr(tmpbuf, 0);
3215 tend = uvchr_to_utf8(tmpbuf, uv);
3217 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3219 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3220 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3225 s = (U8*)SvPV_force(sv, slen);
3226 Copy(tmpbuf, s, ulen, U8);
3230 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3232 SvUTF8_off(TARG); /* decontaminate */
3237 s = (U8*)SvPV_force(sv, slen);
3239 if (IN_LOCALE_RUNTIME) {
3242 *s = toLOWER_LC(*s);
3265 U8 tmpbuf[UTF8_MAXLEN*2+1];
3267 s = (U8*)SvPV(sv,len);
3269 SvUTF8_off(TARG); /* decontaminate */
3270 sv_setpvn(TARG, "", 0);
3274 (void)SvUPGRADE(TARG, SVt_PV);
3275 SvGROW(TARG, (len * 2) + 1);
3276 (void)SvPOK_only(TARG);
3277 d = (U8*)SvPVX(TARG);
3280 toUPPER_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
3281 Copy(tmpbuf, d, ulen, U8);
3287 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3292 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3294 SvUTF8_off(TARG); /* decontaminate */
3299 s = (U8*)SvPV_force(sv, len);
3301 register U8 *send = s + len;
3303 if (IN_LOCALE_RUNTIME) {
3306 for (; s < send; s++)
3307 *s = toUPPER_LC(*s);
3310 for (; s < send; s++)
3332 U8 tmpbuf[UTF8_MAXLEN*2+1];
3334 s = (U8*)SvPV(sv,len);
3336 SvUTF8_off(TARG); /* decontaminate */
3337 sv_setpvn(TARG, "", 0);
3341 (void)SvUPGRADE(TARG, SVt_PV);
3342 SvGROW(TARG, (len * 2) + 1);
3343 (void)SvPOK_only(TARG);
3344 d = (U8*)SvPVX(TARG);
3347 toLOWER_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
3348 Copy(tmpbuf, d, ulen, U8);
3354 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3359 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3361 SvUTF8_off(TARG); /* decontaminate */
3367 s = (U8*)SvPV_force(sv, len);
3369 register U8 *send = s + len;
3371 if (IN_LOCALE_RUNTIME) {
3374 for (; s < send; s++)
3375 *s = toLOWER_LC(*s);
3378 for (; s < send; s++)
3393 register char *s = SvPV(sv,len);
3396 SvUTF8_off(TARG); /* decontaminate */
3398 (void)SvUPGRADE(TARG, SVt_PV);
3399 SvGROW(TARG, (len * 2) + 1);
3403 if (UTF8_IS_CONTINUED(*s)) {
3404 STRLEN ulen = UTF8SKIP(s);
3428 SvCUR_set(TARG, d - SvPVX(TARG));
3429 (void)SvPOK_only_UTF8(TARG);
3432 sv_setpvn(TARG, s, len);
3434 if (SvSMAGICAL(TARG))
3443 dSP; dMARK; dORIGMARK;
3445 register AV* av = (AV*)POPs;
3446 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3447 I32 arybase = PL_curcop->cop_arybase;
3450 if (SvTYPE(av) == SVt_PVAV) {
3451 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3453 for (svp = MARK + 1; svp <= SP; svp++) {
3458 if (max > AvMAX(av))
3461 while (++MARK <= SP) {
3462 elem = SvIVx(*MARK);
3466 svp = av_fetch(av, elem, lval);
3468 if (!svp || *svp == &PL_sv_undef)
3469 DIE(aTHX_ PL_no_aelem, elem);
3470 if (PL_op->op_private & OPpLVAL_INTRO)
3471 save_aelem(av, elem, svp);
3473 *MARK = svp ? *svp : &PL_sv_undef;
3476 if (GIMME != G_ARRAY) {
3484 /* Associative arrays. */
3489 HV *hash = (HV*)POPs;
3491 I32 gimme = GIMME_V;
3492 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3495 /* might clobber stack_sp */
3496 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3501 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3502 if (gimme == G_ARRAY) {
3505 /* might clobber stack_sp */
3507 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3512 else if (gimme == G_SCALAR)
3531 I32 gimme = GIMME_V;
3532 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3536 if (PL_op->op_private & OPpSLICE) {
3540 hvtype = SvTYPE(hv);
3541 if (hvtype == SVt_PVHV) { /* hash element */
3542 while (++MARK <= SP) {
3543 sv = hv_delete_ent(hv, *MARK, discard, 0);
3544 *MARK = sv ? sv : &PL_sv_undef;
3547 else if (hvtype == SVt_PVAV) {
3548 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3549 while (++MARK <= SP) {
3550 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3551 *MARK = sv ? sv : &PL_sv_undef;
3554 else { /* pseudo-hash element */
3555 while (++MARK <= SP) {
3556 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3557 *MARK = sv ? sv : &PL_sv_undef;
3562 DIE(aTHX_ "Not a HASH reference");
3565 else if (gimme == G_SCALAR) {
3574 if (SvTYPE(hv) == SVt_PVHV)
3575 sv = hv_delete_ent(hv, keysv, discard, 0);
3576 else if (SvTYPE(hv) == SVt_PVAV) {
3577 if (PL_op->op_flags & OPf_SPECIAL)
3578 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3580 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3583 DIE(aTHX_ "Not a HASH reference");
3598 if (PL_op->op_private & OPpEXISTS_SUB) {
3602 cv = sv_2cv(sv, &hv, &gv, FALSE);
3605 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3611 if (SvTYPE(hv) == SVt_PVHV) {
3612 if (hv_exists_ent(hv, tmpsv, 0))
3615 else if (SvTYPE(hv) == SVt_PVAV) {
3616 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3617 if (av_exists((AV*)hv, SvIV(tmpsv)))
3620 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3624 DIE(aTHX_ "Not a HASH reference");
3631 dSP; dMARK; dORIGMARK;
3632 register HV *hv = (HV*)POPs;
3633 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3634 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3636 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3637 DIE(aTHX_ "Can't localize pseudo-hash element");
3639 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3640 while (++MARK <= SP) {
3643 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3644 realhv ? hv_exists_ent(hv, keysv, 0)
3645 : avhv_exists_ent((AV*)hv, keysv, 0);
3647 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3648 svp = he ? &HeVAL(he) : 0;
3651 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3654 if (!svp || *svp == &PL_sv_undef) {
3656 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3658 if (PL_op->op_private & OPpLVAL_INTRO) {
3660 save_helem(hv, keysv, svp);
3663 char *key = SvPV(keysv, keylen);
3664 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3668 *MARK = svp ? *svp : &PL_sv_undef;
3671 if (GIMME != G_ARRAY) {
3679 /* List operators. */
3684 if (GIMME != G_ARRAY) {
3686 *MARK = *SP; /* unwanted list, return last item */
3688 *MARK = &PL_sv_undef;
3697 SV **lastrelem = PL_stack_sp;
3698 SV **lastlelem = PL_stack_base + POPMARK;
3699 SV **firstlelem = PL_stack_base + POPMARK + 1;
3700 register SV **firstrelem = lastlelem + 1;
3701 I32 arybase = PL_curcop->cop_arybase;
3702 I32 lval = PL_op->op_flags & OPf_MOD;
3703 I32 is_something_there = lval;
3705 register I32 max = lastrelem - lastlelem;
3706 register SV **lelem;
3709 if (GIMME != G_ARRAY) {
3710 ix = SvIVx(*lastlelem);
3715 if (ix < 0 || ix >= max)
3716 *firstlelem = &PL_sv_undef;
3718 *firstlelem = firstrelem[ix];
3724 SP = firstlelem - 1;
3728 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3734 if (ix < 0 || ix >= max)
3735 *lelem = &PL_sv_undef;
3737 is_something_there = TRUE;
3738 if (!(*lelem = firstrelem[ix]))
3739 *lelem = &PL_sv_undef;
3742 if (is_something_there)
3745 SP = firstlelem - 1;
3751 dSP; dMARK; dORIGMARK;
3752 I32 items = SP - MARK;
3753 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3754 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3761 dSP; dMARK; dORIGMARK;
3762 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3766 SV *val = NEWSV(46, 0);
3768 sv_setsv(val, *++MARK);
3769 else if (ckWARN(WARN_MISC))
3770 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3771 (void)hv_store_ent(hv,key,val,0);
3780 dSP; dMARK; dORIGMARK;
3781 register AV *ary = (AV*)*++MARK;
3785 register I32 offset;
3786 register I32 length;
3793 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3794 *MARK-- = SvTIED_obj((SV*)ary, mg);
3798 call_method("SPLICE",GIMME_V);
3807 offset = i = SvIVx(*MARK);
3809 offset += AvFILLp(ary) + 1;
3811 offset -= PL_curcop->cop_arybase;
3813 DIE(aTHX_ PL_no_aelem, i);
3815 length = SvIVx(*MARK++);
3817 length += AvFILLp(ary) - offset + 1;
3823 length = AvMAX(ary) + 1; /* close enough to infinity */
3827 length = AvMAX(ary) + 1;
3829 if (offset > AvFILLp(ary) + 1)
3830 offset = AvFILLp(ary) + 1;
3831 after = AvFILLp(ary) + 1 - (offset + length);
3832 if (after < 0) { /* not that much array */
3833 length += after; /* offset+length now in array */
3839 /* At this point, MARK .. SP-1 is our new LIST */
3842 diff = newlen - length;
3843 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3846 if (diff < 0) { /* shrinking the area */
3848 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3849 Copy(MARK, tmparyval, newlen, SV*);
3852 MARK = ORIGMARK + 1;
3853 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3854 MEXTEND(MARK, length);
3855 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3857 EXTEND_MORTAL(length);
3858 for (i = length, dst = MARK; i; i--) {
3859 sv_2mortal(*dst); /* free them eventualy */
3866 *MARK = AvARRAY(ary)[offset+length-1];
3869 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3870 SvREFCNT_dec(*dst++); /* free them now */
3873 AvFILLp(ary) += diff;
3875 /* pull up or down? */
3877 if (offset < after) { /* easier to pull up */
3878 if (offset) { /* esp. if nothing to pull */
3879 src = &AvARRAY(ary)[offset-1];
3880 dst = src - diff; /* diff is negative */
3881 for (i = offset; i > 0; i--) /* can't trust Copy */
3885 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3889 if (after) { /* anything to pull down? */
3890 src = AvARRAY(ary) + offset + length;
3891 dst = src + diff; /* diff is negative */
3892 Move(src, dst, after, SV*);
3894 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3895 /* avoid later double free */
3899 dst[--i] = &PL_sv_undef;
3902 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3904 *dst = NEWSV(46, 0);
3905 sv_setsv(*dst++, *src++);
3907 Safefree(tmparyval);
3910 else { /* no, expanding (or same) */
3912 New(452, tmparyval, length, SV*); /* so remember deletion */
3913 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3916 if (diff > 0) { /* expanding */
3918 /* push up or down? */
3920 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3924 Move(src, dst, offset, SV*);
3926 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3928 AvFILLp(ary) += diff;
3931 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3932 av_extend(ary, AvFILLp(ary) + diff);
3933 AvFILLp(ary) += diff;
3936 dst = AvARRAY(ary) + AvFILLp(ary);
3938 for (i = after; i; i--) {
3945 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3946 *dst = NEWSV(46, 0);
3947 sv_setsv(*dst++, *src++);
3949 MARK = ORIGMARK + 1;
3950 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3952 Copy(tmparyval, MARK, length, SV*);
3954 EXTEND_MORTAL(length);
3955 for (i = length, dst = MARK; i; i--) {
3956 sv_2mortal(*dst); /* free them eventualy */
3960 Safefree(tmparyval);
3964 else if (length--) {
3965 *MARK = tmparyval[length];
3968 while (length-- > 0)
3969 SvREFCNT_dec(tmparyval[length]);
3971 Safefree(tmparyval);
3974 *MARK = &PL_sv_undef;
3982 dSP; dMARK; dORIGMARK; dTARGET;
3983 register AV *ary = (AV*)*++MARK;
3984 register SV *sv = &PL_sv_undef;
3987 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3988 *MARK-- = SvTIED_obj((SV*)ary, mg);
3992 call_method("PUSH",G_SCALAR|G_DISCARD);
3997 /* Why no pre-extend of ary here ? */
3998 for (++MARK; MARK <= SP; MARK++) {
4001 sv_setsv(sv, *MARK);
4006 PUSHi( AvFILL(ary) + 1 );
4014 SV *sv = av_pop(av);
4016 (void)sv_2mortal(sv);
4025 SV *sv = av_shift(av);
4030 (void)sv_2mortal(sv);
4037 dSP; dMARK; dORIGMARK; dTARGET;
4038 register AV *ary = (AV*)*++MARK;
4043 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4044 *MARK-- = SvTIED_obj((SV*)ary, mg);
4048 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4053 av_unshift(ary, SP - MARK);
4056 sv_setsv(sv, *++MARK);
4057 (void)av_store(ary, i++, sv);
4061 PUSHi( AvFILL(ary) + 1 );
4071 if (GIMME == G_ARRAY) {
4078 /* safe as long as stack cannot get extended in the above */
4083 register char *down;
4088 SvUTF8_off(TARG); /* decontaminate */
4090 do_join(TARG, &PL_sv_no, MARK, SP);
4092 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4093 up = SvPV_force(TARG, len);
4095 if (DO_UTF8(TARG)) { /* first reverse each character */
4096 U8* s = (U8*)SvPVX(TARG);
4097 U8* send = (U8*)(s + len);
4099 if (UTF8_IS_INVARIANT(*s)) {
4104 if (!utf8_to_uvchr(s, 0))
4108 down = (char*)(s - 1);
4109 /* reverse this character */
4119 down = SvPVX(TARG) + len - 1;
4125 (void)SvPOK_only_UTF8(TARG);
4137 register IV limit = POPi; /* note, negative is forever */
4140 register char *s = SvPV(sv, len);
4141 bool do_utf8 = DO_UTF8(sv);
4142 char *strend = s + len;
4144 register REGEXP *rx;
4148 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4149 I32 maxiters = slen + 10;
4152 I32 origlimit = limit;
4155 AV *oldstack = PL_curstack;
4156 I32 gimme = GIMME_V;
4157 I32 oldsave = PL_savestack_ix;
4158 I32 make_mortal = 1;
4159 MAGIC *mg = (MAGIC *) NULL;
4162 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4167 DIE(aTHX_ "panic: pp_split");
4170 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4171 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4173 PL_reg_match_utf8 = do_utf8;
4175 if (pm->op_pmreplroot) {
4177 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4179 ary = GvAVn((GV*)pm->op_pmreplroot);
4182 else if (gimme != G_ARRAY)
4183 #ifdef USE_5005THREADS
4184 ary = (AV*)PL_curpad[0];
4186 ary = GvAVn(PL_defgv);
4187 #endif /* USE_5005THREADS */
4190 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4196 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4198 XPUSHs(SvTIED_obj((SV*)ary, mg));
4204 for (i = AvFILLp(ary); i >= 0; i--)
4205 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4207 /* temporarily switch stacks */
4208 SWITCHSTACK(PL_curstack, ary);
4212 base = SP - PL_stack_base;
4214 if (pm->op_pmflags & PMf_SKIPWHITE) {
4215 if (pm->op_pmflags & PMf_LOCALE) {
4216 while (isSPACE_LC(*s))
4224 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4225 SAVEINT(PL_multiline);
4226 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4230 limit = maxiters + 2;
4231 if (pm->op_pmflags & PMf_WHITE) {
4234 while (m < strend &&
4235 !((pm->op_pmflags & PMf_LOCALE)
4236 ? isSPACE_LC(*m) : isSPACE(*m)))
4241 dstr = NEWSV(30, m-s);
4242 sv_setpvn(dstr, s, m-s);
4246 (void)SvUTF8_on(dstr);
4250 while (s < strend &&
4251 ((pm->op_pmflags & PMf_LOCALE)
4252 ? isSPACE_LC(*s) : isSPACE(*s)))
4256 else if (strEQ("^", rx->precomp)) {
4259 for (m = s; m < strend && *m != '\n'; m++) ;
4263 dstr = NEWSV(30, m-s);
4264 sv_setpvn(dstr, s, m-s);
4268 (void)SvUTF8_on(dstr);
4273 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4274 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4275 && (rx->reganch & ROPT_CHECK_ALL)
4276 && !(rx->reganch & ROPT_ANCH)) {
4277 int tail = (rx->reganch & RE_INTUIT_TAIL);
4278 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4281 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4283 char c = *SvPV(csv, n_a);
4286 for (m = s; m < strend && *m != c; m++) ;
4289 dstr = NEWSV(30, m-s);
4290 sv_setpvn(dstr, s, m-s);
4294 (void)SvUTF8_on(dstr);
4296 /* The rx->minlen is in characters but we want to step
4297 * s ahead by bytes. */
4299 s = (char*)utf8_hop((U8*)m, len);
4301 s = m + len; /* Fake \n at the end */
4306 while (s < strend && --limit &&
4307 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4308 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4311 dstr = NEWSV(31, m-s);
4312 sv_setpvn(dstr, s, m-s);
4316 (void)SvUTF8_on(dstr);
4318 /* The rx->minlen is in characters but we want to step
4319 * s ahead by bytes. */
4321 s = (char*)utf8_hop((U8*)m, len);
4323 s = m + len; /* Fake \n at the end */
4328 maxiters += slen * rx->nparens;
4329 while (s < strend && --limit
4330 /* && (!rx->check_substr
4331 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4333 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4334 1 /* minend */, sv, NULL, 0))
4336 TAINT_IF(RX_MATCH_TAINTED(rx));
4337 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4342 strend = s + (strend - m);
4344 m = rx->startp[0] + orig;
4345 dstr = NEWSV(32, m-s);
4346 sv_setpvn(dstr, s, m-s);
4350 (void)SvUTF8_on(dstr);
4353 for (i = 1; i <= rx->nparens; i++) {
4354 s = rx->startp[i] + orig;
4355 m = rx->endp[i] + orig;
4357 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4358 parens that didn't match -- they should be set to
4359 undef, not the empty string */
4360 if (m >= orig && s >= orig) {
4361 dstr = NEWSV(33, m-s);
4362 sv_setpvn(dstr, s, m-s);
4365 dstr = &PL_sv_undef; /* undef, not "" */
4369 (void)SvUTF8_on(dstr);
4373 s = rx->endp[0] + orig;
4377 LEAVE_SCOPE(oldsave);
4378 iters = (SP - PL_stack_base) - base;
4379 if (iters > maxiters)
4380 DIE(aTHX_ "Split loop");
4382 /* keep field after final delim? */
4383 if (s < strend || (iters && origlimit)) {
4384 STRLEN l = strend - s;
4385 dstr = NEWSV(34, l);
4386 sv_setpvn(dstr, s, l);
4390 (void)SvUTF8_on(dstr);
4394 else if (!origlimit) {
4395 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4401 SWITCHSTACK(ary, oldstack);
4402 if (SvSMAGICAL(ary)) {
4407 if (gimme == G_ARRAY) {
4409 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4417 call_method("PUSH",G_SCALAR|G_DISCARD);
4420 if (gimme == G_ARRAY) {
4421 /* EXTEND should not be needed - we just popped them */
4423 for (i=0; i < iters; i++) {
4424 SV **svp = av_fetch(ary, i, FALSE);
4425 PUSHs((svp) ? *svp : &PL_sv_undef);
4432 if (gimme == G_ARRAY)
4435 if (iters || !pm->op_pmreplroot) {
4443 #ifdef USE_5005THREADS
4445 Perl_unlock_condpair(pTHX_ void *svv)
4447 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4450 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4451 MUTEX_LOCK(MgMUTEXP(mg));
4452 if (MgOWNER(mg) != thr)
4453 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4455 COND_SIGNAL(MgOWNERCONDP(mg));
4456 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4457 PTR2UV(thr), PTR2UV(svv)));
4458 MUTEX_UNLOCK(MgMUTEXP(mg));
4460 #endif /* USE_5005THREADS */
4467 #ifdef USE_5005THREADS
4469 #endif /* USE_5005THREADS */
4471 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4473 Perl_sharedsv_lock(aTHX_ ssv);
4474 #endif /* USE_ITHREADS */
4475 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4476 || SvTYPE(retsv) == SVt_PVCV) {
4477 retsv = refto(retsv);
4485 #ifdef USE_5005THREADS
4488 if (PL_op->op_private & OPpLVAL_INTRO)
4489 PUSHs(*save_threadsv(PL_op->op_targ));
4491 PUSHs(THREADSV(PL_op->op_targ));
4494 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4495 #endif /* USE_5005THREADS */