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")) /* XXX deprecate in 5.005 */
554 tmpRef = (SV*)GvIOp(gv);
556 if (strEQ(elem, "FORMAT"))
557 tmpRef = (SV*)GvFORM(gv);
560 if (strEQ(elem, "GLOB"))
564 if (strEQ(elem, "HASH"))
565 tmpRef = (SV*)GvHV(gv);
568 if (strEQ(elem, "IO"))
569 tmpRef = (SV*)GvIOp(gv);
572 if (strEQ(elem, "NAME"))
573 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
576 if (strEQ(elem, "PACKAGE"))
577 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
580 if (strEQ(elem, "SCALAR"))
594 /* Pattern matching */
599 register unsigned char *s;
602 register I32 *sfirst;
606 if (sv == PL_lastscream) {
612 SvSCREAM_off(PL_lastscream);
613 SvREFCNT_dec(PL_lastscream);
615 PL_lastscream = SvREFCNT_inc(sv);
618 s = (unsigned char*)(SvPV(sv, len));
622 if (pos > PL_maxscream) {
623 if (PL_maxscream < 0) {
624 PL_maxscream = pos + 80;
625 New(301, PL_screamfirst, 256, I32);
626 New(302, PL_screamnext, PL_maxscream, I32);
629 PL_maxscream = pos + pos / 4;
630 Renew(PL_screamnext, PL_maxscream, I32);
634 sfirst = PL_screamfirst;
635 snext = PL_screamnext;
637 if (!sfirst || !snext)
638 DIE(aTHX_ "do_study: out of memory");
640 for (ch = 256; ch; --ch)
647 snext[pos] = sfirst[ch] - pos;
654 /* piggyback on m//g magic */
655 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
664 if (PL_op->op_flags & OPf_STACKED)
670 TARG = sv_newmortal();
675 /* Lvalue operators. */
687 dSP; dMARK; dTARGET; dORIGMARK;
689 do_chop(TARG, *++MARK);
698 SETi(do_chomp(TOPs));
705 register I32 count = 0;
708 count += do_chomp(POPs);
719 if (!sv || !SvANY(sv))
721 switch (SvTYPE(sv)) {
723 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
724 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
728 if (HvARRAY(sv) || SvGMAGICAL(sv)
729 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
733 if (CvROOT(sv) || CvXSUB(sv))
750 if (!PL_op->op_private) {
759 if (SvTHINKFIRST(sv))
762 switch (SvTYPE(sv)) {
772 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
773 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
774 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
778 /* let user-undef'd sub keep its identity */
779 GV* gv = CvGV((CV*)sv);
786 SvSetMagicSV(sv, &PL_sv_undef);
790 Newz(602, gp, 1, GP);
791 GvGP(sv) = gp_ref(gp);
792 GvSV(sv) = NEWSV(72,0);
793 GvLINE(sv) = CopLINE(PL_curcop);
799 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
802 SvPV_set(sv, Nullch);
815 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
816 DIE(aTHX_ PL_no_modify);
817 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
818 SvIVX(TOPs) != IV_MIN)
821 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
832 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
833 DIE(aTHX_ PL_no_modify);
834 sv_setsv(TARG, TOPs);
835 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
836 SvIVX(TOPs) != IV_MAX)
839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
853 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
854 DIE(aTHX_ PL_no_modify);
855 sv_setsv(TARG, TOPs);
856 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
857 SvIVX(TOPs) != IV_MIN)
860 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
869 /* Ordinary operators. */
873 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
876 SETn( Perl_pow( left, right) );
883 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
884 #ifdef PERL_PRESERVE_IVUV
887 /* Unless the left argument is integer in range we are going to have to
888 use NV maths. Hence only attempt to coerce the right argument if
889 we know the left is integer. */
890 /* Left operand is defined, so is it IV? */
893 bool auvok = SvUOK(TOPm1s);
894 bool buvok = SvUOK(TOPs);
895 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
896 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
903 alow = SvUVX(TOPm1s);
905 IV aiv = SvIVX(TOPm1s);
908 auvok = TRUE; /* effectively it's a UV now */
910 alow = -aiv; /* abs, auvok == false records sign */
916 IV biv = SvIVX(TOPs);
919 buvok = TRUE; /* effectively it's a UV now */
921 blow = -biv; /* abs, buvok == false records sign */
925 /* If this does sign extension on unsigned it's time for plan B */
926 ahigh = alow >> (4 * sizeof (UV));
928 bhigh = blow >> (4 * sizeof (UV));
930 if (ahigh && bhigh) {
931 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
932 which is overflow. Drop to NVs below. */
933 } else if (!ahigh && !bhigh) {
934 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
935 so the unsigned multiply cannot overflow. */
936 UV product = alow * blow;
937 if (auvok == buvok) {
938 /* -ve * -ve or +ve * +ve gives a +ve result. */
942 } else if (product <= (UV)IV_MIN) {
943 /* 2s complement assumption that (UV)-IV_MIN is correct. */
944 /* -ve result, which could overflow an IV */
946 SETi( -(IV)product );
948 } /* else drop to NVs below. */
950 /* One operand is large, 1 small */
953 /* swap the operands */
955 bhigh = blow; /* bhigh now the temp var for the swap */
959 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
960 multiplies can't overflow. shift can, add can, -ve can. */
961 product_middle = ahigh * blow;
962 if (!(product_middle & topmask)) {
963 /* OK, (ahigh * blow) won't lose bits when we shift it. */
965 product_middle <<= (4 * sizeof (UV));
966 product_low = alow * blow;
968 /* as for pp_add, UV + something mustn't get smaller.
969 IIRC ANSI mandates this wrapping *behaviour* for
970 unsigned whatever the actual representation*/
971 product_low += product_middle;
972 if (product_low >= product_middle) {
973 /* didn't overflow */
974 if (auvok == buvok) {
975 /* -ve * -ve or +ve * +ve gives a +ve result. */
979 } else if (product_low <= (UV)IV_MIN) {
980 /* 2s complement assumption again */
981 /* -ve result, which could overflow an IV */
983 SETi( -(IV)product_low );
985 } /* else drop to NVs below. */
987 } /* product_middle too large */
988 } /* ahigh && bhigh */
989 } /* SvIOK(TOPm1s) */
994 SETn( left * right );
1001 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1002 /* Only try to do UV divide first
1003 if ((SLOPPYDIVIDE is true) or
1004 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1006 The assumption is that it is better to use floating point divide
1007 whenever possible, only doing integer divide first if we can't be sure.
1008 If NV_PRESERVES_UV is true then we know at compile time that no UV
1009 can be too large to preserve, so don't need to compile the code to
1010 test the size of UVs. */
1013 # define PERL_TRY_UV_DIVIDE
1014 /* ensure that 20./5. == 4. */
1016 # ifdef PERL_PRESERVE_IVUV
1017 # ifndef NV_PRESERVES_UV
1018 # define PERL_TRY_UV_DIVIDE
1023 #ifdef PERL_TRY_UV_DIVIDE
1026 SvIV_please(TOPm1s);
1027 if (SvIOK(TOPm1s)) {
1028 bool left_non_neg = SvUOK(TOPm1s);
1029 bool right_non_neg = SvUOK(TOPs);
1033 if (right_non_neg) {
1034 right = SvUVX(TOPs);
1037 IV biv = SvIVX(TOPs);
1040 right_non_neg = TRUE; /* effectively it's a UV now */
1046 /* historically undef()/0 gives a "Use of uninitialized value"
1047 warning before dieing, hence this test goes here.
1048 If it were immediately before the second SvIV_please, then
1049 DIE() would be invoked before left was even inspected, so
1050 no inpsection would give no warning. */
1052 DIE(aTHX_ "Illegal division by zero");
1055 left = SvUVX(TOPm1s);
1058 IV aiv = SvIVX(TOPm1s);
1061 left_non_neg = TRUE; /* effectively it's a UV now */
1070 /* For sloppy divide we always attempt integer division. */
1072 /* Otherwise we only attempt it if either or both operands
1073 would not be preserved by an NV. If both fit in NVs
1074 we fall through to the NV divide code below. */
1075 && ((left > ((UV)1 << NV_PRESERVES_UV_BITS))
1076 || (right > ((UV)1 << NV_PRESERVES_UV_BITS)))
1079 /* Integer division can't overflow, but it can be imprecise. */
1080 UV result = left / right;
1081 if (result * right == left) {
1082 SP--; /* result is valid */
1083 if (left_non_neg == right_non_neg) {
1084 /* signs identical, result is positive. */
1088 /* 2s complement assumption */
1089 if (result <= (UV)IV_MIN)
1092 /* It's exact but too negative for IV. */
1093 SETn( -(NV)result );
1096 } /* tried integer divide but it was not an integer result */
1097 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1098 } /* left wasn't SvIOK */
1099 } /* right wasn't SvIOK */
1100 #endif /* PERL_TRY_UV_DIVIDE */
1104 DIE(aTHX_ "Illegal division by zero");
1105 PUSHn( left / right );
1112 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1118 bool use_double = FALSE;
1119 bool dright_valid = FALSE;
1125 right_neg = !SvUOK(TOPs);
1127 right = SvUVX(POPs);
1129 IV biv = SvIVX(POPs);
1132 right_neg = FALSE; /* effectively it's a UV now */
1140 right_neg = dright < 0;
1143 if (dright < UV_MAX_P1) {
1144 right = U_V(dright);
1145 dright_valid = TRUE; /* In case we need to use double below. */
1151 /* At this point use_double is only true if right is out of range for
1152 a UV. In range NV has been rounded down to nearest UV and
1153 use_double false. */
1155 if (!use_double && SvIOK(TOPs)) {
1157 left_neg = !SvUOK(TOPs);
1161 IV aiv = SvIVX(POPs);
1164 left_neg = FALSE; /* effectively it's a UV now */
1173 left_neg = dleft < 0;
1177 /* This should be exactly the 5.6 behaviour - if left and right are
1178 both in range for UV then use U_V() rather than floor. */
1180 if (dleft < UV_MAX_P1) {
1181 /* right was in range, so is dleft, so use UVs not double.
1185 /* left is out of range for UV, right was in range, so promote
1186 right (back) to double. */
1188 /* The +0.5 is used in 5.6 even though it is not strictly
1189 consistent with the implicit +0 floor in the U_V()
1190 inside the #if 1. */
1191 dleft = Perl_floor(dleft + 0.5);
1194 dright = Perl_floor(dright + 0.5);
1204 DIE(aTHX_ "Illegal modulus zero");
1206 dans = Perl_fmod(dleft, dright);
1207 if ((left_neg != right_neg) && dans)
1208 dans = dright - dans;
1211 sv_setnv(TARG, dans);
1217 DIE(aTHX_ "Illegal modulus zero");
1220 if ((left_neg != right_neg) && ans)
1223 /* XXX may warn: unary minus operator applied to unsigned type */
1224 /* could change -foo to be (~foo)+1 instead */
1225 if (ans <= ~((UV)IV_MAX)+1)
1226 sv_setiv(TARG, ~ans+1);
1228 sv_setnv(TARG, -(NV)ans);
1231 sv_setuv(TARG, ans);
1240 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1242 register IV count = POPi;
1243 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1245 I32 items = SP - MARK;
1248 max = items * count;
1253 *SP = sv_2mortal(newSVsv(*SP));
1259 repeatcpy((char*)(MARK + items), (char*)MARK,
1260 items * sizeof(SV*), count - 1);
1263 else if (count <= 0)
1266 else { /* Note: mark already snarfed by pp_list */
1271 SvSetSV(TARG, tmpstr);
1272 SvPV_force(TARG, len);
1273 isutf = DO_UTF8(TARG);
1278 SvGROW(TARG, (count * len) + 1);
1279 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1280 SvCUR(TARG) *= count;
1282 *SvEND(TARG) = '\0';
1285 (void)SvPOK_only_UTF8(TARG);
1287 (void)SvPOK_only(TARG);
1289 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1290 /* The parser saw this as a list repeat, and there
1291 are probably several items on the stack. But we're
1292 in scalar context, and there's no pp_list to save us
1293 now. So drop the rest of the items -- robin@kitsite.com
1306 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1307 useleft = USE_LEFT(TOPm1s);
1308 #ifdef PERL_PRESERVE_IVUV
1309 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1310 "bad things" happen if you rely on signed integers wrapping. */
1313 /* Unless the left argument is integer in range we are going to have to
1314 use NV maths. Hence only attempt to coerce the right argument if
1315 we know the left is integer. */
1316 register UV auv = 0;
1322 a_valid = auvok = 1;
1323 /* left operand is undef, treat as zero. */
1325 /* Left operand is defined, so is it IV? */
1326 SvIV_please(TOPm1s);
1327 if (SvIOK(TOPm1s)) {
1328 if ((auvok = SvUOK(TOPm1s)))
1329 auv = SvUVX(TOPm1s);
1331 register IV aiv = SvIVX(TOPm1s);
1334 auvok = 1; /* Now acting as a sign flag. */
1335 } else { /* 2s complement assumption for IV_MIN */
1343 bool result_good = 0;
1346 bool buvok = SvUOK(TOPs);
1351 register IV biv = SvIVX(TOPs);
1358 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1359 else "IV" now, independant of how it came in.
1360 if a, b represents positive, A, B negative, a maps to -A etc
1365 all UV maths. negate result if A negative.
1366 subtract if signs same, add if signs differ. */
1368 if (auvok ^ buvok) {
1377 /* Must get smaller */
1382 if (result <= buv) {
1383 /* result really should be -(auv-buv). as its negation
1384 of true value, need to swap our result flag */
1396 if (result <= (UV)IV_MIN)
1397 SETi( -(IV)result );
1399 /* result valid, but out of range for IV. */
1400 SETn( -(NV)result );
1404 } /* Overflow, drop through to NVs. */
1408 useleft = USE_LEFT(TOPm1s);
1412 /* left operand is undef, treat as zero - value */
1416 SETn( TOPn - value );
1423 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1426 if (PL_op->op_private & HINT_INTEGER) {
1440 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1443 if (PL_op->op_private & HINT_INTEGER) {
1457 dSP; tryAMAGICbinSET(lt,0);
1458 #ifdef PERL_PRESERVE_IVUV
1461 SvIV_please(TOPm1s);
1462 if (SvIOK(TOPm1s)) {
1463 bool auvok = SvUOK(TOPm1s);
1464 bool buvok = SvUOK(TOPs);
1466 if (!auvok && !buvok) { /* ## IV < IV ## */
1467 IV aiv = SvIVX(TOPm1s);
1468 IV biv = SvIVX(TOPs);
1471 SETs(boolSV(aiv < biv));
1474 if (auvok && buvok) { /* ## UV < UV ## */
1475 UV auv = SvUVX(TOPm1s);
1476 UV buv = SvUVX(TOPs);
1479 SETs(boolSV(auv < buv));
1482 if (auvok) { /* ## UV < IV ## */
1489 /* As (a) is a UV, it's >=0, so it cannot be < */
1494 if (auv >= (UV) IV_MAX) {
1495 /* As (b) is an IV, it cannot be > IV_MAX */
1499 SETs(boolSV(auv < (UV)biv));
1502 { /* ## IV < UV ## */
1506 aiv = SvIVX(TOPm1s);
1508 /* As (b) is a UV, it's >=0, so it must be < */
1515 if (buv > (UV) IV_MAX) {
1516 /* As (a) is an IV, it cannot be > IV_MAX */
1520 SETs(boolSV((UV)aiv < buv));
1528 SETs(boolSV(TOPn < value));
1535 dSP; tryAMAGICbinSET(gt,0);
1536 #ifdef PERL_PRESERVE_IVUV
1539 SvIV_please(TOPm1s);
1540 if (SvIOK(TOPm1s)) {
1541 bool auvok = SvUOK(TOPm1s);
1542 bool buvok = SvUOK(TOPs);
1544 if (!auvok && !buvok) { /* ## IV > IV ## */
1545 IV aiv = SvIVX(TOPm1s);
1546 IV biv = SvIVX(TOPs);
1549 SETs(boolSV(aiv > biv));
1552 if (auvok && buvok) { /* ## UV > UV ## */
1553 UV auv = SvUVX(TOPm1s);
1554 UV buv = SvUVX(TOPs);
1557 SETs(boolSV(auv > buv));
1560 if (auvok) { /* ## UV > IV ## */
1567 /* As (a) is a UV, it's >=0, so it must be > */
1572 if (auv > (UV) IV_MAX) {
1573 /* As (b) is an IV, it cannot be > IV_MAX */
1577 SETs(boolSV(auv > (UV)biv));
1580 { /* ## IV > UV ## */
1584 aiv = SvIVX(TOPm1s);
1586 /* As (b) is a UV, it's >=0, so it cannot be > */
1593 if (buv >= (UV) IV_MAX) {
1594 /* As (a) is an IV, it cannot be > IV_MAX */
1598 SETs(boolSV((UV)aiv > buv));
1606 SETs(boolSV(TOPn > value));
1613 dSP; tryAMAGICbinSET(le,0);
1614 #ifdef PERL_PRESERVE_IVUV
1617 SvIV_please(TOPm1s);
1618 if (SvIOK(TOPm1s)) {
1619 bool auvok = SvUOK(TOPm1s);
1620 bool buvok = SvUOK(TOPs);
1622 if (!auvok && !buvok) { /* ## IV <= IV ## */
1623 IV aiv = SvIVX(TOPm1s);
1624 IV biv = SvIVX(TOPs);
1627 SETs(boolSV(aiv <= biv));
1630 if (auvok && buvok) { /* ## UV <= UV ## */
1631 UV auv = SvUVX(TOPm1s);
1632 UV buv = SvUVX(TOPs);
1635 SETs(boolSV(auv <= buv));
1638 if (auvok) { /* ## UV <= IV ## */
1645 /* As (a) is a UV, it's >=0, so a cannot be <= */
1650 if (auv > (UV) IV_MAX) {
1651 /* As (b) is an IV, it cannot be > IV_MAX */
1655 SETs(boolSV(auv <= (UV)biv));
1658 { /* ## IV <= UV ## */
1662 aiv = SvIVX(TOPm1s);
1664 /* As (b) is a UV, it's >=0, so a must be <= */
1671 if (buv >= (UV) IV_MAX) {
1672 /* As (a) is an IV, it cannot be > IV_MAX */
1676 SETs(boolSV((UV)aiv <= buv));
1684 SETs(boolSV(TOPn <= value));
1691 dSP; tryAMAGICbinSET(ge,0);
1692 #ifdef PERL_PRESERVE_IVUV
1695 SvIV_please(TOPm1s);
1696 if (SvIOK(TOPm1s)) {
1697 bool auvok = SvUOK(TOPm1s);
1698 bool buvok = SvUOK(TOPs);
1700 if (!auvok && !buvok) { /* ## IV >= IV ## */
1701 IV aiv = SvIVX(TOPm1s);
1702 IV biv = SvIVX(TOPs);
1705 SETs(boolSV(aiv >= biv));
1708 if (auvok && buvok) { /* ## UV >= UV ## */
1709 UV auv = SvUVX(TOPm1s);
1710 UV buv = SvUVX(TOPs);
1713 SETs(boolSV(auv >= buv));
1716 if (auvok) { /* ## UV >= IV ## */
1723 /* As (a) is a UV, it's >=0, so it must be >= */
1728 if (auv >= (UV) IV_MAX) {
1729 /* As (b) is an IV, it cannot be > IV_MAX */
1733 SETs(boolSV(auv >= (UV)biv));
1736 { /* ## IV >= UV ## */
1740 aiv = SvIVX(TOPm1s);
1742 /* As (b) is a UV, it's >=0, so a cannot be >= */
1749 if (buv > (UV) IV_MAX) {
1750 /* As (a) is an IV, it cannot be > IV_MAX */
1754 SETs(boolSV((UV)aiv >= buv));
1762 SETs(boolSV(TOPn >= value));
1769 dSP; tryAMAGICbinSET(ne,0);
1770 #ifndef NV_PRESERVES_UV
1771 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1772 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1776 #ifdef PERL_PRESERVE_IVUV
1779 SvIV_please(TOPm1s);
1780 if (SvIOK(TOPm1s)) {
1781 bool auvok = SvUOK(TOPm1s);
1782 bool buvok = SvUOK(TOPs);
1784 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1785 IV aiv = SvIVX(TOPm1s);
1786 IV biv = SvIVX(TOPs);
1789 SETs(boolSV(aiv != biv));
1792 if (auvok && buvok) { /* ## UV != UV ## */
1793 UV auv = SvUVX(TOPm1s);
1794 UV buv = SvUVX(TOPs);
1797 SETs(boolSV(auv != buv));
1800 { /* ## Mixed IV,UV ## */
1804 /* != is commutative so swap if needed (save code) */
1806 /* swap. top of stack (b) is the iv */
1810 /* As (a) is a UV, it's >0, so it cannot be == */
1819 /* As (b) is a UV, it's >0, so it cannot be == */
1823 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1825 /* we know iv is >= 0 */
1826 if (uv > (UV) IV_MAX) {
1830 SETs(boolSV((UV)iv != uv));
1838 SETs(boolSV(TOPn != value));
1845 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1846 #ifndef NV_PRESERVES_UV
1847 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1848 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1852 #ifdef PERL_PRESERVE_IVUV
1853 /* Fortunately it seems NaN isn't IOK */
1856 SvIV_please(TOPm1s);
1857 if (SvIOK(TOPm1s)) {
1858 bool leftuvok = SvUOK(TOPm1s);
1859 bool rightuvok = SvUOK(TOPs);
1861 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1862 IV leftiv = SvIVX(TOPm1s);
1863 IV rightiv = SvIVX(TOPs);
1865 if (leftiv > rightiv)
1867 else if (leftiv < rightiv)
1871 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1872 UV leftuv = SvUVX(TOPm1s);
1873 UV rightuv = SvUVX(TOPs);
1875 if (leftuv > rightuv)
1877 else if (leftuv < rightuv)
1881 } else if (leftuvok) { /* ## UV <=> IV ## */
1885 rightiv = SvIVX(TOPs);
1887 /* As (a) is a UV, it's >=0, so it cannot be < */
1890 leftuv = SvUVX(TOPm1s);
1891 if (leftuv > (UV) IV_MAX) {
1892 /* As (b) is an IV, it cannot be > IV_MAX */
1894 } else if (leftuv > (UV)rightiv) {
1896 } else if (leftuv < (UV)rightiv) {
1902 } else { /* ## IV <=> UV ## */
1906 leftiv = SvIVX(TOPm1s);
1908 /* As (b) is a UV, it's >=0, so it must be < */
1911 rightuv = SvUVX(TOPs);
1912 if (rightuv > (UV) IV_MAX) {
1913 /* As (a) is an IV, it cannot be > IV_MAX */
1915 } else if (leftiv > (UV)rightuv) {
1917 } else if (leftiv < (UV)rightuv) {
1935 if (Perl_isnan(left) || Perl_isnan(right)) {
1939 value = (left > right) - (left < right);
1943 else if (left < right)
1945 else if (left > right)
1959 dSP; tryAMAGICbinSET(slt,0);
1962 int cmp = (IN_LOCALE_RUNTIME
1963 ? sv_cmp_locale(left, right)
1964 : sv_cmp(left, right));
1965 SETs(boolSV(cmp < 0));
1972 dSP; tryAMAGICbinSET(sgt,0);
1975 int cmp = (IN_LOCALE_RUNTIME
1976 ? sv_cmp_locale(left, right)
1977 : sv_cmp(left, right));
1978 SETs(boolSV(cmp > 0));
1985 dSP; tryAMAGICbinSET(sle,0);
1988 int cmp = (IN_LOCALE_RUNTIME
1989 ? sv_cmp_locale(left, right)
1990 : sv_cmp(left, right));
1991 SETs(boolSV(cmp <= 0));
1998 dSP; tryAMAGICbinSET(sge,0);
2001 int cmp = (IN_LOCALE_RUNTIME
2002 ? sv_cmp_locale(left, right)
2003 : sv_cmp(left, right));
2004 SETs(boolSV(cmp >= 0));
2011 dSP; tryAMAGICbinSET(seq,0);
2014 SETs(boolSV(sv_eq(left, right)));
2021 dSP; tryAMAGICbinSET(sne,0);
2024 SETs(boolSV(!sv_eq(left, right)));
2031 dSP; dTARGET; tryAMAGICbin(scmp,0);
2034 int cmp = (IN_LOCALE_RUNTIME
2035 ? sv_cmp_locale(left, right)
2036 : sv_cmp(left, right));
2044 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2047 if (SvNIOKp(left) || SvNIOKp(right)) {
2048 if (PL_op->op_private & HINT_INTEGER) {
2049 IV i = SvIV(left) & SvIV(right);
2053 UV u = SvUV(left) & SvUV(right);
2058 do_vop(PL_op->op_type, TARG, left, right);
2067 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2070 if (SvNIOKp(left) || SvNIOKp(right)) {
2071 if (PL_op->op_private & HINT_INTEGER) {
2072 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2076 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2081 do_vop(PL_op->op_type, TARG, left, right);
2090 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2093 if (SvNIOKp(left) || SvNIOKp(right)) {
2094 if (PL_op->op_private & HINT_INTEGER) {
2095 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2099 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2104 do_vop(PL_op->op_type, TARG, left, right);
2113 dSP; dTARGET; tryAMAGICun(neg);
2116 int flags = SvFLAGS(sv);
2119 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2120 /* It's publicly an integer, or privately an integer-not-float */
2123 if (SvIVX(sv) == IV_MIN) {
2124 /* 2s complement assumption. */
2125 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2128 else if (SvUVX(sv) <= IV_MAX) {
2133 else if (SvIVX(sv) != IV_MIN) {
2137 #ifdef PERL_PRESERVE_IVUV
2146 else if (SvPOKp(sv)) {
2148 char *s = SvPV(sv, len);
2149 if (isIDFIRST(*s)) {
2150 sv_setpvn(TARG, "-", 1);
2153 else if (*s == '+' || *s == '-') {
2155 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2157 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2158 sv_setpvn(TARG, "-", 1);
2164 goto oops_its_an_int;
2165 sv_setnv(TARG, -SvNV(sv));
2177 dSP; tryAMAGICunSET(not);
2178 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2184 dSP; dTARGET; tryAMAGICun(compl);
2188 if (PL_op->op_private & HINT_INTEGER) {
2203 tmps = (U8*)SvPV_force(TARG, len);
2206 /* Calculate exact length, let's not estimate. */
2215 while (tmps < send) {
2216 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2217 tmps += UTF8SKIP(tmps);
2218 targlen += UNISKIP(~c);
2224 /* Now rewind strings and write them. */
2228 Newz(0, result, targlen + 1, U8);
2229 while (tmps < send) {
2230 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2231 tmps += UTF8SKIP(tmps);
2232 result = uvchr_to_utf8(result, ~c);
2236 sv_setpvn(TARG, (char*)result, targlen);
2240 Newz(0, result, nchar + 1, U8);
2241 while (tmps < send) {
2242 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2243 tmps += UTF8SKIP(tmps);
2248 sv_setpvn(TARG, (char*)result, nchar);
2256 register long *tmpl;
2257 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2260 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2265 for ( ; anum > 0; anum--, tmps++)
2274 /* integer versions of some of the above */
2278 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2281 SETi( left * right );
2288 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2292 DIE(aTHX_ "Illegal division by zero");
2293 value = POPi / value;
2301 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2305 DIE(aTHX_ "Illegal modulus zero");
2306 SETi( left % right );
2313 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2316 SETi( left + right );
2323 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2326 SETi( left - right );
2333 dSP; tryAMAGICbinSET(lt,0);
2336 SETs(boolSV(left < right));
2343 dSP; tryAMAGICbinSET(gt,0);
2346 SETs(boolSV(left > right));
2353 dSP; tryAMAGICbinSET(le,0);
2356 SETs(boolSV(left <= right));
2363 dSP; tryAMAGICbinSET(ge,0);
2366 SETs(boolSV(left >= right));
2373 dSP; tryAMAGICbinSET(eq,0);
2376 SETs(boolSV(left == right));
2383 dSP; tryAMAGICbinSET(ne,0);
2386 SETs(boolSV(left != right));
2393 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2400 else if (left < right)
2411 dSP; dTARGET; tryAMAGICun(neg);
2416 /* High falutin' math. */
2420 dSP; dTARGET; tryAMAGICbin(atan2,0);
2423 SETn(Perl_atan2(left, right));
2430 dSP; dTARGET; tryAMAGICun(sin);
2434 value = Perl_sin(value);
2442 dSP; dTARGET; tryAMAGICun(cos);
2446 value = Perl_cos(value);
2452 /* Support Configure command-line overrides for rand() functions.
2453 After 5.005, perhaps we should replace this by Configure support
2454 for drand48(), random(), or rand(). For 5.005, though, maintain
2455 compatibility by calling rand() but allow the user to override it.
2456 See INSTALL for details. --Andy Dougherty 15 July 1998
2458 /* Now it's after 5.005, and Configure supports drand48() and random(),
2459 in addition to rand(). So the overrides should not be needed any more.
2460 --Jarkko Hietaniemi 27 September 1998
2463 #ifndef HAS_DRAND48_PROTO
2464 extern double drand48 (void);
2477 if (!PL_srand_called) {
2478 (void)seedDrand01((Rand_seed_t)seed());
2479 PL_srand_called = TRUE;
2494 (void)seedDrand01((Rand_seed_t)anum);
2495 PL_srand_called = TRUE;
2504 * This is really just a quick hack which grabs various garbage
2505 * values. It really should be a real hash algorithm which
2506 * spreads the effect of every input bit onto every output bit,
2507 * if someone who knows about such things would bother to write it.
2508 * Might be a good idea to add that function to CORE as well.
2509 * No numbers below come from careful analysis or anything here,
2510 * except they are primes and SEED_C1 > 1E6 to get a full-width
2511 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2512 * probably be bigger too.
2515 # define SEED_C1 1000003
2516 #define SEED_C4 73819
2518 # define SEED_C1 25747
2519 #define SEED_C4 20639
2523 #define SEED_C5 26107
2525 #ifndef PERL_NO_DEV_RANDOM
2530 # include <starlet.h>
2531 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2532 * in 100-ns units, typically incremented ever 10 ms. */
2533 unsigned int when[2];
2535 # ifdef HAS_GETTIMEOFDAY
2536 struct timeval when;
2542 /* This test is an escape hatch, this symbol isn't set by Configure. */
2543 #ifndef PERL_NO_DEV_RANDOM
2544 #ifndef PERL_RANDOM_DEVICE
2545 /* /dev/random isn't used by default because reads from it will block
2546 * if there isn't enough entropy available. You can compile with
2547 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2548 * is enough real entropy to fill the seed. */
2549 # define PERL_RANDOM_DEVICE "/dev/urandom"
2551 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2553 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2562 _ckvmssts(sys$gettim(when));
2563 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2565 # ifdef HAS_GETTIMEOFDAY
2566 gettimeofday(&when,(struct timezone *) 0);
2567 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2570 u = (U32)SEED_C1 * when;
2573 u += SEED_C3 * (U32)PerlProc_getpid();
2574 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2575 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2576 u += SEED_C5 * (U32)PTR2UV(&when);
2583 dSP; dTARGET; tryAMAGICun(exp);
2587 value = Perl_exp(value);
2595 dSP; dTARGET; tryAMAGICun(log);
2600 SET_NUMERIC_STANDARD();
2601 DIE(aTHX_ "Can't take log of %g", value);
2603 value = Perl_log(value);
2611 dSP; dTARGET; tryAMAGICun(sqrt);
2616 SET_NUMERIC_STANDARD();
2617 DIE(aTHX_ "Can't take sqrt of %g", value);
2619 value = Perl_sqrt(value);
2627 dSP; dTARGET; tryAMAGICun(int);
2630 IV iv = TOPi; /* attempt to convert to IV if possible. */
2631 /* XXX it's arguable that compiler casting to IV might be subtly
2632 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2633 else preferring IV has introduced a subtle behaviour change bug. OTOH
2634 relying on floating point to be accurate is a bug. */
2645 if (value < (NV)UV_MAX + 0.5) {
2648 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2649 # ifdef HAS_MODFL_POW32_BUG
2650 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2652 NV offset = Perl_modf(value, &value);
2653 (void)Perl_modf(offset, &offset);
2657 (void)Perl_modf(value, &value);
2660 double tmp = (double)value;
2661 (void)Perl_modf(tmp, &tmp);
2668 if (value > (NV)IV_MIN - 0.5) {
2671 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2672 # ifdef HAS_MODFL_POW32_BUG
2673 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2675 NV offset = Perl_modf(-value, &value);
2676 (void)Perl_modf(offset, &offset);
2680 (void)Perl_modf(-value, &value);
2684 double tmp = (double)value;
2685 (void)Perl_modf(-tmp, &tmp);
2698 dSP; dTARGET; tryAMAGICun(abs);
2700 /* This will cache the NV value if string isn't actually integer */
2704 /* IVX is precise */
2706 SETu(TOPu); /* force it to be numeric only */
2714 /* 2s complement assumption. Also, not really needed as
2715 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2737 tmps = (SvPVx(POPs, len));
2738 argtype = 1; /* allow underscores */
2739 XPUSHn(scan_hex(tmps, len, &argtype));
2751 tmps = (SvPVx(POPs, len));
2752 while (*tmps && len && isSPACE(*tmps))
2756 argtype = 1; /* allow underscores */
2758 value = scan_hex(++tmps, --len, &argtype);
2759 else if (*tmps == 'b')
2760 value = scan_bin(++tmps, --len, &argtype);
2762 value = scan_oct(tmps, len, &argtype);
2775 SETi(sv_len_utf8(sv));
2791 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2793 I32 arybase = PL_curcop->cop_arybase;
2797 int num_args = PL_op->op_private & 7;
2798 bool repl_need_utf8_upgrade = FALSE;
2799 bool repl_is_utf8 = FALSE;
2801 SvTAINTED_off(TARG); /* decontaminate */
2802 SvUTF8_off(TARG); /* decontaminate */
2806 repl = SvPV(repl_sv, repl_len);
2807 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2817 sv_utf8_upgrade(sv);
2819 else if (DO_UTF8(sv))
2820 repl_need_utf8_upgrade = TRUE;
2822 tmps = SvPV(sv, curlen);
2824 utf8_curlen = sv_len_utf8(sv);
2825 if (utf8_curlen == curlen)
2828 curlen = utf8_curlen;
2833 if (pos >= arybase) {
2851 else if (len >= 0) {
2853 if (rem > (I32)curlen)
2868 Perl_croak(aTHX_ "substr outside of string");
2869 if (ckWARN(WARN_SUBSTR))
2870 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2877 sv_pos_u2b(sv, &pos, &rem);
2879 sv_setpvn(TARG, tmps, rem);
2880 #ifdef USE_LOCALE_COLLATE
2881 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2886 SV* repl_sv_copy = NULL;
2888 if (repl_need_utf8_upgrade) {
2889 repl_sv_copy = newSVsv(repl_sv);
2890 sv_utf8_upgrade(repl_sv_copy);
2891 repl = SvPV(repl_sv_copy, repl_len);
2892 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2894 sv_insert(sv, pos, rem, repl, repl_len);
2898 SvREFCNT_dec(repl_sv_copy);
2900 else if (lvalue) { /* it's an lvalue! */
2901 if (!SvGMAGICAL(sv)) {
2905 if (ckWARN(WARN_SUBSTR))
2906 Perl_warner(aTHX_ WARN_SUBSTR,
2907 "Attempt to use reference as lvalue in substr");
2909 if (SvOK(sv)) /* is it defined ? */
2910 (void)SvPOK_only_UTF8(sv);
2912 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2915 if (SvTYPE(TARG) < SVt_PVLV) {
2916 sv_upgrade(TARG, SVt_PVLV);
2917 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2921 if (LvTARG(TARG) != sv) {
2923 SvREFCNT_dec(LvTARG(TARG));
2924 LvTARG(TARG) = SvREFCNT_inc(sv);
2926 LvTARGOFF(TARG) = upos;
2927 LvTARGLEN(TARG) = urem;
2931 PUSHs(TARG); /* avoid SvSETMAGIC here */
2938 register IV size = POPi;
2939 register IV offset = POPi;
2940 register SV *src = POPs;
2941 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2943 SvTAINTED_off(TARG); /* decontaminate */
2944 if (lvalue) { /* it's an lvalue! */
2945 if (SvTYPE(TARG) < SVt_PVLV) {
2946 sv_upgrade(TARG, SVt_PVLV);
2947 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2950 if (LvTARG(TARG) != src) {
2952 SvREFCNT_dec(LvTARG(TARG));
2953 LvTARG(TARG) = SvREFCNT_inc(src);
2955 LvTARGOFF(TARG) = offset;
2956 LvTARGLEN(TARG) = size;
2959 sv_setuv(TARG, do_vecget(src, offset, size));
2974 I32 arybase = PL_curcop->cop_arybase;
2979 offset = POPi - arybase;
2982 tmps = SvPV(big, biglen);
2983 if (offset > 0 && DO_UTF8(big))
2984 sv_pos_u2b(big, &offset, 0);
2987 else if (offset > biglen)
2989 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2990 (unsigned char*)tmps + biglen, little, 0)))
2993 retval = tmps2 - tmps;
2994 if (retval > 0 && DO_UTF8(big))
2995 sv_pos_b2u(big, &retval);
2996 PUSHi(retval + arybase);
3011 I32 arybase = PL_curcop->cop_arybase;
3017 tmps2 = SvPV(little, llen);
3018 tmps = SvPV(big, blen);
3022 if (offset > 0 && DO_UTF8(big))
3023 sv_pos_u2b(big, &offset, 0);
3024 offset = offset - arybase + llen;
3028 else if (offset > blen)
3030 if (!(tmps2 = rninstr(tmps, tmps + offset,
3031 tmps2, tmps2 + llen)))
3034 retval = tmps2 - tmps;
3035 if (retval > 0 && DO_UTF8(big))
3036 sv_pos_b2u(big, &retval);
3037 PUSHi(retval + arybase);
3043 dSP; dMARK; dORIGMARK; dTARGET;
3044 do_sprintf(TARG, SP-MARK, MARK+1);
3045 TAINT_IF(SvTAINTED(TARG));
3046 if (DO_UTF8(*(MARK+1)))
3058 U8 *s = (U8*)SvPVx(argsv, len);
3060 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3070 (void)SvUPGRADE(TARG,SVt_PV);
3072 if (value > 255 && !IN_BYTES) {
3073 SvGROW(TARG, UNISKIP(value)+1);
3074 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3075 SvCUR_set(TARG, tmps - SvPVX(TARG));
3077 (void)SvPOK_only(TARG);
3088 (void)SvPOK_only(TARG);
3095 dSP; dTARGET; dPOPTOPssrl;
3099 char *tmps = SvPV(left, len);
3101 if (DO_UTF8(left)) {
3102 /* If Unicode take the crypt() of the low 8 bits
3103 * of the characters of the string. */
3105 char *send = tmps + len;
3107 Newz(688, t, len, char);
3109 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3115 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3117 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3122 "The crypt() function is unimplemented due to excessive paranoia.");
3135 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3137 U8 tmpbuf[UTF8_MAXLEN+1];
3141 if (IN_LOCALE_RUNTIME) {
3144 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3147 uv = toTITLE_utf8(s);
3151 tend = uvchr_to_utf8(tmpbuf, uv);
3153 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3155 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3156 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3161 s = (U8*)SvPV_force(sv, slen);
3162 Copy(tmpbuf, s, ulen, U8);
3166 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3168 SvUTF8_off(TARG); /* decontaminate */
3173 s = (U8*)SvPV_force(sv, slen);
3175 if (IN_LOCALE_RUNTIME) {
3178 *s = toUPPER_LC(*s);
3196 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3198 U8 tmpbuf[UTF8_MAXLEN+1];
3202 if (IN_LOCALE_RUNTIME) {
3205 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3208 uv = toLOWER_utf8(s);
3212 tend = uvchr_to_utf8(tmpbuf, uv);
3214 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3216 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3217 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3222 s = (U8*)SvPV_force(sv, slen);
3223 Copy(tmpbuf, s, ulen, U8);
3227 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3229 SvUTF8_off(TARG); /* decontaminate */
3234 s = (U8*)SvPV_force(sv, slen);
3236 if (IN_LOCALE_RUNTIME) {
3239 *s = toLOWER_LC(*s);
3263 s = (U8*)SvPV(sv,len);
3265 SvUTF8_off(TARG); /* decontaminate */
3266 sv_setpvn(TARG, "", 0);
3270 (void)SvUPGRADE(TARG, SVt_PV);
3271 SvGROW(TARG, (len * 2) + 1);
3272 (void)SvPOK_only(TARG);
3273 d = (U8*)SvPVX(TARG);
3275 if (IN_LOCALE_RUNTIME) {
3279 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3285 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3291 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3296 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3298 SvUTF8_off(TARG); /* decontaminate */
3303 s = (U8*)SvPV_force(sv, len);
3305 register U8 *send = s + len;
3307 if (IN_LOCALE_RUNTIME) {
3310 for (; s < send; s++)
3311 *s = toUPPER_LC(*s);
3314 for (; s < send; s++)
3337 s = (U8*)SvPV(sv,len);
3339 SvUTF8_off(TARG); /* decontaminate */
3340 sv_setpvn(TARG, "", 0);
3344 (void)SvUPGRADE(TARG, SVt_PV);
3345 SvGROW(TARG, (len * 2) + 1);
3346 (void)SvPOK_only(TARG);
3347 d = (U8*)SvPVX(TARG);
3349 if (IN_LOCALE_RUNTIME) {
3353 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3359 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3365 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3370 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3372 SvUTF8_off(TARG); /* decontaminate */
3378 s = (U8*)SvPV_force(sv, len);
3380 register U8 *send = s + len;
3382 if (IN_LOCALE_RUNTIME) {
3385 for (; s < send; s++)
3386 *s = toLOWER_LC(*s);
3389 for (; s < send; s++)
3404 register char *s = SvPV(sv,len);
3407 SvUTF8_off(TARG); /* decontaminate */
3409 (void)SvUPGRADE(TARG, SVt_PV);
3410 SvGROW(TARG, (len * 2) + 1);
3414 if (UTF8_IS_CONTINUED(*s)) {
3415 STRLEN ulen = UTF8SKIP(s);
3439 SvCUR_set(TARG, d - SvPVX(TARG));
3440 (void)SvPOK_only_UTF8(TARG);
3443 sv_setpvn(TARG, s, len);
3445 if (SvSMAGICAL(TARG))
3454 dSP; dMARK; dORIGMARK;
3456 register AV* av = (AV*)POPs;
3457 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3458 I32 arybase = PL_curcop->cop_arybase;
3461 if (SvTYPE(av) == SVt_PVAV) {
3462 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3464 for (svp = MARK + 1; svp <= SP; svp++) {
3469 if (max > AvMAX(av))
3472 while (++MARK <= SP) {
3473 elem = SvIVx(*MARK);
3477 svp = av_fetch(av, elem, lval);
3479 if (!svp || *svp == &PL_sv_undef)
3480 DIE(aTHX_ PL_no_aelem, elem);
3481 if (PL_op->op_private & OPpLVAL_INTRO)
3482 save_aelem(av, elem, svp);
3484 *MARK = svp ? *svp : &PL_sv_undef;
3487 if (GIMME != G_ARRAY) {
3495 /* Associative arrays. */
3500 HV *hash = (HV*)POPs;
3502 I32 gimme = GIMME_V;
3503 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3506 /* might clobber stack_sp */
3507 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3512 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3513 if (gimme == G_ARRAY) {
3516 /* might clobber stack_sp */
3518 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3523 else if (gimme == G_SCALAR)
3542 I32 gimme = GIMME_V;
3543 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3547 if (PL_op->op_private & OPpSLICE) {
3551 hvtype = SvTYPE(hv);
3552 if (hvtype == SVt_PVHV) { /* hash element */
3553 while (++MARK <= SP) {
3554 sv = hv_delete_ent(hv, *MARK, discard, 0);
3555 *MARK = sv ? sv : &PL_sv_undef;
3558 else if (hvtype == SVt_PVAV) {
3559 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3560 while (++MARK <= SP) {
3561 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3562 *MARK = sv ? sv : &PL_sv_undef;
3565 else { /* pseudo-hash element */
3566 while (++MARK <= SP) {
3567 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3568 *MARK = sv ? sv : &PL_sv_undef;
3573 DIE(aTHX_ "Not a HASH reference");
3576 else if (gimme == G_SCALAR) {
3585 if (SvTYPE(hv) == SVt_PVHV)
3586 sv = hv_delete_ent(hv, keysv, discard, 0);
3587 else if (SvTYPE(hv) == SVt_PVAV) {
3588 if (PL_op->op_flags & OPf_SPECIAL)
3589 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3591 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3594 DIE(aTHX_ "Not a HASH reference");
3609 if (PL_op->op_private & OPpEXISTS_SUB) {
3613 cv = sv_2cv(sv, &hv, &gv, FALSE);
3616 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3622 if (SvTYPE(hv) == SVt_PVHV) {
3623 if (hv_exists_ent(hv, tmpsv, 0))
3626 else if (SvTYPE(hv) == SVt_PVAV) {
3627 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3628 if (av_exists((AV*)hv, SvIV(tmpsv)))
3631 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3635 DIE(aTHX_ "Not a HASH reference");
3642 dSP; dMARK; dORIGMARK;
3643 register HV *hv = (HV*)POPs;
3644 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3645 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3647 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3648 DIE(aTHX_ "Can't localize pseudo-hash element");
3650 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3651 while (++MARK <= SP) {
3654 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3655 realhv ? hv_exists_ent(hv, keysv, 0)
3656 : avhv_exists_ent((AV*)hv, keysv, 0);
3658 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3659 svp = he ? &HeVAL(he) : 0;
3662 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3665 if (!svp || *svp == &PL_sv_undef) {
3667 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3669 if (PL_op->op_private & OPpLVAL_INTRO) {
3671 save_helem(hv, keysv, svp);
3674 char *key = SvPV(keysv, keylen);
3675 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3679 *MARK = svp ? *svp : &PL_sv_undef;
3682 if (GIMME != G_ARRAY) {
3690 /* List operators. */
3695 if (GIMME != G_ARRAY) {
3697 *MARK = *SP; /* unwanted list, return last item */
3699 *MARK = &PL_sv_undef;
3708 SV **lastrelem = PL_stack_sp;
3709 SV **lastlelem = PL_stack_base + POPMARK;
3710 SV **firstlelem = PL_stack_base + POPMARK + 1;
3711 register SV **firstrelem = lastlelem + 1;
3712 I32 arybase = PL_curcop->cop_arybase;
3713 I32 lval = PL_op->op_flags & OPf_MOD;
3714 I32 is_something_there = lval;
3716 register I32 max = lastrelem - lastlelem;
3717 register SV **lelem;
3720 if (GIMME != G_ARRAY) {
3721 ix = SvIVx(*lastlelem);
3726 if (ix < 0 || ix >= max)
3727 *firstlelem = &PL_sv_undef;
3729 *firstlelem = firstrelem[ix];
3735 SP = firstlelem - 1;
3739 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3745 if (ix < 0 || ix >= max)
3746 *lelem = &PL_sv_undef;
3748 is_something_there = TRUE;
3749 if (!(*lelem = firstrelem[ix]))
3750 *lelem = &PL_sv_undef;
3753 if (is_something_there)
3756 SP = firstlelem - 1;
3762 dSP; dMARK; dORIGMARK;
3763 I32 items = SP - MARK;
3764 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3765 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3772 dSP; dMARK; dORIGMARK;
3773 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3777 SV *val = NEWSV(46, 0);
3779 sv_setsv(val, *++MARK);
3780 else if (ckWARN(WARN_MISC))
3781 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3782 (void)hv_store_ent(hv,key,val,0);
3791 dSP; dMARK; dORIGMARK;
3792 register AV *ary = (AV*)*++MARK;
3796 register I32 offset;
3797 register I32 length;
3804 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3805 *MARK-- = SvTIED_obj((SV*)ary, mg);
3809 call_method("SPLICE",GIMME_V);
3818 offset = i = SvIVx(*MARK);
3820 offset += AvFILLp(ary) + 1;
3822 offset -= PL_curcop->cop_arybase;
3824 DIE(aTHX_ PL_no_aelem, i);
3826 length = SvIVx(*MARK++);
3828 length += AvFILLp(ary) - offset + 1;
3834 length = AvMAX(ary) + 1; /* close enough to infinity */
3838 length = AvMAX(ary) + 1;
3840 if (offset > AvFILLp(ary) + 1)
3841 offset = AvFILLp(ary) + 1;
3842 after = AvFILLp(ary) + 1 - (offset + length);
3843 if (after < 0) { /* not that much array */
3844 length += after; /* offset+length now in array */
3850 /* At this point, MARK .. SP-1 is our new LIST */
3853 diff = newlen - length;
3854 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3857 if (diff < 0) { /* shrinking the area */
3859 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3860 Copy(MARK, tmparyval, newlen, SV*);
3863 MARK = ORIGMARK + 1;
3864 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3865 MEXTEND(MARK, length);
3866 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3868 EXTEND_MORTAL(length);
3869 for (i = length, dst = MARK; i; i--) {
3870 sv_2mortal(*dst); /* free them eventualy */
3877 *MARK = AvARRAY(ary)[offset+length-1];
3880 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3881 SvREFCNT_dec(*dst++); /* free them now */
3884 AvFILLp(ary) += diff;
3886 /* pull up or down? */
3888 if (offset < after) { /* easier to pull up */
3889 if (offset) { /* esp. if nothing to pull */
3890 src = &AvARRAY(ary)[offset-1];
3891 dst = src - diff; /* diff is negative */
3892 for (i = offset; i > 0; i--) /* can't trust Copy */
3896 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3900 if (after) { /* anything to pull down? */
3901 src = AvARRAY(ary) + offset + length;
3902 dst = src + diff; /* diff is negative */
3903 Move(src, dst, after, SV*);
3905 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3906 /* avoid later double free */
3910 dst[--i] = &PL_sv_undef;
3913 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3915 *dst = NEWSV(46, 0);
3916 sv_setsv(*dst++, *src++);
3918 Safefree(tmparyval);
3921 else { /* no, expanding (or same) */
3923 New(452, tmparyval, length, SV*); /* so remember deletion */
3924 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3927 if (diff > 0) { /* expanding */
3929 /* push up or down? */
3931 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3935 Move(src, dst, offset, SV*);
3937 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3939 AvFILLp(ary) += diff;
3942 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3943 av_extend(ary, AvFILLp(ary) + diff);
3944 AvFILLp(ary) += diff;
3947 dst = AvARRAY(ary) + AvFILLp(ary);
3949 for (i = after; i; i--) {
3956 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3957 *dst = NEWSV(46, 0);
3958 sv_setsv(*dst++, *src++);
3960 MARK = ORIGMARK + 1;
3961 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3963 Copy(tmparyval, MARK, length, SV*);
3965 EXTEND_MORTAL(length);
3966 for (i = length, dst = MARK; i; i--) {
3967 sv_2mortal(*dst); /* free them eventualy */
3971 Safefree(tmparyval);
3975 else if (length--) {
3976 *MARK = tmparyval[length];
3979 while (length-- > 0)
3980 SvREFCNT_dec(tmparyval[length]);
3982 Safefree(tmparyval);
3985 *MARK = &PL_sv_undef;
3993 dSP; dMARK; dORIGMARK; dTARGET;
3994 register AV *ary = (AV*)*++MARK;
3995 register SV *sv = &PL_sv_undef;
3998 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3999 *MARK-- = SvTIED_obj((SV*)ary, mg);
4003 call_method("PUSH",G_SCALAR|G_DISCARD);
4008 /* Why no pre-extend of ary here ? */
4009 for (++MARK; MARK <= SP; MARK++) {
4012 sv_setsv(sv, *MARK);
4017 PUSHi( AvFILL(ary) + 1 );
4025 SV *sv = av_pop(av);
4027 (void)sv_2mortal(sv);
4036 SV *sv = av_shift(av);
4041 (void)sv_2mortal(sv);
4048 dSP; dMARK; dORIGMARK; dTARGET;
4049 register AV *ary = (AV*)*++MARK;
4054 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4055 *MARK-- = SvTIED_obj((SV*)ary, mg);
4059 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4064 av_unshift(ary, SP - MARK);
4067 sv_setsv(sv, *++MARK);
4068 (void)av_store(ary, i++, sv);
4072 PUSHi( AvFILL(ary) + 1 );
4082 if (GIMME == G_ARRAY) {
4089 /* safe as long as stack cannot get extended in the above */
4094 register char *down;
4099 SvUTF8_off(TARG); /* decontaminate */
4101 do_join(TARG, &PL_sv_no, MARK, SP);
4103 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4104 up = SvPV_force(TARG, len);
4106 if (DO_UTF8(TARG)) { /* first reverse each character */
4107 U8* s = (U8*)SvPVX(TARG);
4108 U8* send = (U8*)(s + len);
4110 if (UTF8_IS_INVARIANT(*s)) {
4115 if (!utf8_to_uvchr(s, 0))
4119 down = (char*)(s - 1);
4120 /* reverse this character */
4130 down = SvPVX(TARG) + len - 1;
4136 (void)SvPOK_only_UTF8(TARG);
4148 register IV limit = POPi; /* note, negative is forever */
4151 register char *s = SvPV(sv, len);
4152 bool do_utf8 = DO_UTF8(sv);
4153 char *strend = s + len;
4155 register REGEXP *rx;
4159 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4160 I32 maxiters = slen + 10;
4163 I32 origlimit = limit;
4166 AV *oldstack = PL_curstack;
4167 I32 gimme = GIMME_V;
4168 I32 oldsave = PL_savestack_ix;
4169 I32 make_mortal = 1;
4170 MAGIC *mg = (MAGIC *) NULL;
4173 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4178 DIE(aTHX_ "panic: pp_split");
4181 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4182 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4184 PL_reg_match_utf8 = do_utf8;
4186 if (pm->op_pmreplroot) {
4188 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4190 ary = GvAVn((GV*)pm->op_pmreplroot);
4193 else if (gimme != G_ARRAY)
4194 #ifdef USE_5005THREADS
4195 ary = (AV*)PL_curpad[0];
4197 ary = GvAVn(PL_defgv);
4198 #endif /* USE_5005THREADS */
4201 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4207 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4209 XPUSHs(SvTIED_obj((SV*)ary, mg));
4215 for (i = AvFILLp(ary); i >= 0; i--)
4216 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4218 /* temporarily switch stacks */
4219 SWITCHSTACK(PL_curstack, ary);
4223 base = SP - PL_stack_base;
4225 if (pm->op_pmflags & PMf_SKIPWHITE) {
4226 if (pm->op_pmflags & PMf_LOCALE) {
4227 while (isSPACE_LC(*s))
4235 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4236 SAVEINT(PL_multiline);
4237 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4241 limit = maxiters + 2;
4242 if (pm->op_pmflags & PMf_WHITE) {
4245 while (m < strend &&
4246 !((pm->op_pmflags & PMf_LOCALE)
4247 ? isSPACE_LC(*m) : isSPACE(*m)))
4252 dstr = NEWSV(30, m-s);
4253 sv_setpvn(dstr, s, m-s);
4257 (void)SvUTF8_on(dstr);
4261 while (s < strend &&
4262 ((pm->op_pmflags & PMf_LOCALE)
4263 ? isSPACE_LC(*s) : isSPACE(*s)))
4267 else if (strEQ("^", rx->precomp)) {
4270 for (m = s; m < strend && *m != '\n'; m++) ;
4274 dstr = NEWSV(30, m-s);
4275 sv_setpvn(dstr, s, m-s);
4279 (void)SvUTF8_on(dstr);
4284 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4285 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4286 && (rx->reganch & ROPT_CHECK_ALL)
4287 && !(rx->reganch & ROPT_ANCH)) {
4288 int tail = (rx->reganch & RE_INTUIT_TAIL);
4289 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4292 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4294 char c = *SvPV(csv, n_a);
4297 for (m = s; m < strend && *m != c; m++) ;
4300 dstr = NEWSV(30, m-s);
4301 sv_setpvn(dstr, s, m-s);
4305 (void)SvUTF8_on(dstr);
4307 /* The rx->minlen is in characters but we want to step
4308 * s ahead by bytes. */
4310 s = (char*)utf8_hop((U8*)m, len);
4312 s = m + len; /* Fake \n at the end */
4317 while (s < strend && --limit &&
4318 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4319 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4322 dstr = NEWSV(31, m-s);
4323 sv_setpvn(dstr, s, m-s);
4327 (void)SvUTF8_on(dstr);
4329 /* The rx->minlen is in characters but we want to step
4330 * s ahead by bytes. */
4332 s = (char*)utf8_hop((U8*)m, len);
4334 s = m + len; /* Fake \n at the end */
4339 maxiters += slen * rx->nparens;
4340 while (s < strend && --limit
4341 /* && (!rx->check_substr
4342 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4344 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4345 1 /* minend */, sv, NULL, 0))
4347 TAINT_IF(RX_MATCH_TAINTED(rx));
4348 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4353 strend = s + (strend - m);
4355 m = rx->startp[0] + orig;
4356 dstr = NEWSV(32, m-s);
4357 sv_setpvn(dstr, s, m-s);
4361 (void)SvUTF8_on(dstr);
4364 for (i = 1; i <= rx->nparens; i++) {
4365 s = rx->startp[i] + orig;
4366 m = rx->endp[i] + orig;
4368 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4369 parens that didn't match -- they should be set to
4370 undef, not the empty string */
4371 if (m >= orig && s >= orig) {
4372 dstr = NEWSV(33, m-s);
4373 sv_setpvn(dstr, s, m-s);
4376 dstr = &PL_sv_undef; /* undef, not "" */
4380 (void)SvUTF8_on(dstr);
4384 s = rx->endp[0] + orig;
4388 LEAVE_SCOPE(oldsave);
4389 iters = (SP - PL_stack_base) - base;
4390 if (iters > maxiters)
4391 DIE(aTHX_ "Split loop");
4393 /* keep field after final delim? */
4394 if (s < strend || (iters && origlimit)) {
4395 STRLEN l = strend - s;
4396 dstr = NEWSV(34, l);
4397 sv_setpvn(dstr, s, l);
4401 (void)SvUTF8_on(dstr);
4405 else if (!origlimit) {
4406 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4412 SWITCHSTACK(ary, oldstack);
4413 if (SvSMAGICAL(ary)) {
4418 if (gimme == G_ARRAY) {
4420 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4428 call_method("PUSH",G_SCALAR|G_DISCARD);
4431 if (gimme == G_ARRAY) {
4432 /* EXTEND should not be needed - we just popped them */
4434 for (i=0; i < iters; i++) {
4435 SV **svp = av_fetch(ary, i, FALSE);
4436 PUSHs((svp) ? *svp : &PL_sv_undef);
4443 if (gimme == G_ARRAY)
4446 if (iters || !pm->op_pmreplroot) {
4454 #ifdef USE_5005THREADS
4456 Perl_unlock_condpair(pTHX_ void *svv)
4458 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4461 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4462 MUTEX_LOCK(MgMUTEXP(mg));
4463 if (MgOWNER(mg) != thr)
4464 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4466 COND_SIGNAL(MgOWNERCONDP(mg));
4467 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4468 PTR2UV(thr), PTR2UV(svv)));
4469 MUTEX_UNLOCK(MgMUTEXP(mg));
4471 #endif /* USE_5005THREADS */
4478 #ifdef USE_5005THREADS
4480 #endif /* USE_5005THREADS */
4482 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4484 Perl_sharedsv_lock(aTHX_ ssv);
4485 #endif /* USE_ITHREADS */
4486 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4487 || SvTYPE(retsv) == SVt_PVCV) {
4488 retsv = refto(retsv);
4496 #ifdef USE_5005THREADS
4499 if (PL_op->op_private & OPpLVAL_INTRO)
4500 PUSHs(*save_threadsv(PL_op->op_targ));
4502 PUSHs(THREADSV(PL_op->op_targ));
4505 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4506 #endif /* USE_5005THREADS */