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 */
2735 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2740 tmps = (SvPVx(POPs, len));
2741 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2742 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2755 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2760 tmps = (SvPVx(POPs, len));
2761 while (*tmps && len && isSPACE(*tmps))
2766 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2767 else if (*tmps == 'b')
2768 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2770 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2772 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2789 SETi(sv_len_utf8(sv));
2805 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2807 I32 arybase = PL_curcop->cop_arybase;
2811 int num_args = PL_op->op_private & 7;
2812 bool repl_need_utf8_upgrade = FALSE;
2813 bool repl_is_utf8 = FALSE;
2815 SvTAINTED_off(TARG); /* decontaminate */
2816 SvUTF8_off(TARG); /* decontaminate */
2820 repl = SvPV(repl_sv, repl_len);
2821 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2831 sv_utf8_upgrade(sv);
2833 else if (DO_UTF8(sv))
2834 repl_need_utf8_upgrade = TRUE;
2836 tmps = SvPV(sv, curlen);
2838 utf8_curlen = sv_len_utf8(sv);
2839 if (utf8_curlen == curlen)
2842 curlen = utf8_curlen;
2847 if (pos >= arybase) {
2865 else if (len >= 0) {
2867 if (rem > (I32)curlen)
2882 Perl_croak(aTHX_ "substr outside of string");
2883 if (ckWARN(WARN_SUBSTR))
2884 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2891 sv_pos_u2b(sv, &pos, &rem);
2893 sv_setpvn(TARG, tmps, rem);
2894 #ifdef USE_LOCALE_COLLATE
2895 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2900 SV* repl_sv_copy = NULL;
2902 if (repl_need_utf8_upgrade) {
2903 repl_sv_copy = newSVsv(repl_sv);
2904 sv_utf8_upgrade(repl_sv_copy);
2905 repl = SvPV(repl_sv_copy, repl_len);
2906 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2908 sv_insert(sv, pos, rem, repl, repl_len);
2912 SvREFCNT_dec(repl_sv_copy);
2914 else if (lvalue) { /* it's an lvalue! */
2915 if (!SvGMAGICAL(sv)) {
2919 if (ckWARN(WARN_SUBSTR))
2920 Perl_warner(aTHX_ WARN_SUBSTR,
2921 "Attempt to use reference as lvalue in substr");
2923 if (SvOK(sv)) /* is it defined ? */
2924 (void)SvPOK_only_UTF8(sv);
2926 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2929 if (SvTYPE(TARG) < SVt_PVLV) {
2930 sv_upgrade(TARG, SVt_PVLV);
2931 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2935 if (LvTARG(TARG) != sv) {
2937 SvREFCNT_dec(LvTARG(TARG));
2938 LvTARG(TARG) = SvREFCNT_inc(sv);
2940 LvTARGOFF(TARG) = upos;
2941 LvTARGLEN(TARG) = urem;
2945 PUSHs(TARG); /* avoid SvSETMAGIC here */
2952 register IV size = POPi;
2953 register IV offset = POPi;
2954 register SV *src = POPs;
2955 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2957 SvTAINTED_off(TARG); /* decontaminate */
2958 if (lvalue) { /* it's an lvalue! */
2959 if (SvTYPE(TARG) < SVt_PVLV) {
2960 sv_upgrade(TARG, SVt_PVLV);
2961 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2964 if (LvTARG(TARG) != src) {
2966 SvREFCNT_dec(LvTARG(TARG));
2967 LvTARG(TARG) = SvREFCNT_inc(src);
2969 LvTARGOFF(TARG) = offset;
2970 LvTARGLEN(TARG) = size;
2973 sv_setuv(TARG, do_vecget(src, offset, size));
2988 I32 arybase = PL_curcop->cop_arybase;
2993 offset = POPi - arybase;
2996 tmps = SvPV(big, biglen);
2997 if (offset > 0 && DO_UTF8(big))
2998 sv_pos_u2b(big, &offset, 0);
3001 else if (offset > biglen)
3003 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3004 (unsigned char*)tmps + biglen, little, 0)))
3007 retval = tmps2 - tmps;
3008 if (retval > 0 && DO_UTF8(big))
3009 sv_pos_b2u(big, &retval);
3010 PUSHi(retval + arybase);
3025 I32 arybase = PL_curcop->cop_arybase;
3031 tmps2 = SvPV(little, llen);
3032 tmps = SvPV(big, blen);
3036 if (offset > 0 && DO_UTF8(big))
3037 sv_pos_u2b(big, &offset, 0);
3038 offset = offset - arybase + llen;
3042 else if (offset > blen)
3044 if (!(tmps2 = rninstr(tmps, tmps + offset,
3045 tmps2, tmps2 + llen)))
3048 retval = tmps2 - tmps;
3049 if (retval > 0 && DO_UTF8(big))
3050 sv_pos_b2u(big, &retval);
3051 PUSHi(retval + arybase);
3057 dSP; dMARK; dORIGMARK; dTARGET;
3058 do_sprintf(TARG, SP-MARK, MARK+1);
3059 TAINT_IF(SvTAINTED(TARG));
3060 if (DO_UTF8(*(MARK+1)))
3072 U8 *s = (U8*)SvPVx(argsv, len);
3074 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3084 (void)SvUPGRADE(TARG,SVt_PV);
3086 if (value > 255 && !IN_BYTES) {
3087 SvGROW(TARG, UNISKIP(value)+1);
3088 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3089 SvCUR_set(TARG, tmps - SvPVX(TARG));
3091 (void)SvPOK_only(TARG);
3102 (void)SvPOK_only(TARG);
3109 dSP; dTARGET; dPOPTOPssrl;
3113 char *tmps = SvPV(left, len);
3115 if (DO_UTF8(left)) {
3116 /* If Unicode take the crypt() of the low 8 bits
3117 * of the characters of the string. */
3119 char *send = tmps + len;
3121 Newz(688, t, len, char);
3123 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3129 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3131 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3136 "The crypt() function is unimplemented due to excessive paranoia.");
3149 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3151 U8 tmpbuf[UTF8_MAXLEN+1];
3155 if (IN_LOCALE_RUNTIME) {
3158 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3161 uv = toTITLE_utf8(s);
3165 tend = uvchr_to_utf8(tmpbuf, uv);
3167 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3169 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3170 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3175 s = (U8*)SvPV_force(sv, slen);
3176 Copy(tmpbuf, s, ulen, U8);
3180 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3182 SvUTF8_off(TARG); /* decontaminate */
3187 s = (U8*)SvPV_force(sv, slen);
3189 if (IN_LOCALE_RUNTIME) {
3192 *s = toUPPER_LC(*s);
3210 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3212 U8 tmpbuf[UTF8_MAXLEN+1];
3216 if (IN_LOCALE_RUNTIME) {
3219 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3222 uv = toLOWER_utf8(s);
3226 tend = uvchr_to_utf8(tmpbuf, uv);
3228 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3230 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3231 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3236 s = (U8*)SvPV_force(sv, slen);
3237 Copy(tmpbuf, s, ulen, U8);
3241 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3243 SvUTF8_off(TARG); /* decontaminate */
3248 s = (U8*)SvPV_force(sv, slen);
3250 if (IN_LOCALE_RUNTIME) {
3253 *s = toLOWER_LC(*s);
3277 s = (U8*)SvPV(sv,len);
3279 SvUTF8_off(TARG); /* decontaminate */
3280 sv_setpvn(TARG, "", 0);
3284 (void)SvUPGRADE(TARG, SVt_PV);
3285 SvGROW(TARG, (len * 2) + 1);
3286 (void)SvPOK_only(TARG);
3287 d = (U8*)SvPVX(TARG);
3289 if (IN_LOCALE_RUNTIME) {
3293 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3299 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3305 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3310 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3312 SvUTF8_off(TARG); /* decontaminate */
3317 s = (U8*)SvPV_force(sv, len);
3319 register U8 *send = s + len;
3321 if (IN_LOCALE_RUNTIME) {
3324 for (; s < send; s++)
3325 *s = toUPPER_LC(*s);
3328 for (; s < send; s++)
3351 s = (U8*)SvPV(sv,len);
3353 SvUTF8_off(TARG); /* decontaminate */
3354 sv_setpvn(TARG, "", 0);
3358 (void)SvUPGRADE(TARG, SVt_PV);
3359 SvGROW(TARG, (len * 2) + 1);
3360 (void)SvPOK_only(TARG);
3361 d = (U8*)SvPVX(TARG);
3363 if (IN_LOCALE_RUNTIME) {
3367 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3373 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3379 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3384 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3386 SvUTF8_off(TARG); /* decontaminate */
3392 s = (U8*)SvPV_force(sv, len);
3394 register U8 *send = s + len;
3396 if (IN_LOCALE_RUNTIME) {
3399 for (; s < send; s++)
3400 *s = toLOWER_LC(*s);
3403 for (; s < send; s++)
3418 register char *s = SvPV(sv,len);
3421 SvUTF8_off(TARG); /* decontaminate */
3423 (void)SvUPGRADE(TARG, SVt_PV);
3424 SvGROW(TARG, (len * 2) + 1);
3428 if (UTF8_IS_CONTINUED(*s)) {
3429 STRLEN ulen = UTF8SKIP(s);
3453 SvCUR_set(TARG, d - SvPVX(TARG));
3454 (void)SvPOK_only_UTF8(TARG);
3457 sv_setpvn(TARG, s, len);
3459 if (SvSMAGICAL(TARG))
3468 dSP; dMARK; dORIGMARK;
3470 register AV* av = (AV*)POPs;
3471 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3472 I32 arybase = PL_curcop->cop_arybase;
3475 if (SvTYPE(av) == SVt_PVAV) {
3476 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3478 for (svp = MARK + 1; svp <= SP; svp++) {
3483 if (max > AvMAX(av))
3486 while (++MARK <= SP) {
3487 elem = SvIVx(*MARK);
3491 svp = av_fetch(av, elem, lval);
3493 if (!svp || *svp == &PL_sv_undef)
3494 DIE(aTHX_ PL_no_aelem, elem);
3495 if (PL_op->op_private & OPpLVAL_INTRO)
3496 save_aelem(av, elem, svp);
3498 *MARK = svp ? *svp : &PL_sv_undef;
3501 if (GIMME != G_ARRAY) {
3509 /* Associative arrays. */
3514 HV *hash = (HV*)POPs;
3516 I32 gimme = GIMME_V;
3517 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3520 /* might clobber stack_sp */
3521 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3526 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3527 if (gimme == G_ARRAY) {
3530 /* might clobber stack_sp */
3532 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3537 else if (gimme == G_SCALAR)
3556 I32 gimme = GIMME_V;
3557 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3561 if (PL_op->op_private & OPpSLICE) {
3565 hvtype = SvTYPE(hv);
3566 if (hvtype == SVt_PVHV) { /* hash element */
3567 while (++MARK <= SP) {
3568 sv = hv_delete_ent(hv, *MARK, discard, 0);
3569 *MARK = sv ? sv : &PL_sv_undef;
3572 else if (hvtype == SVt_PVAV) {
3573 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3574 while (++MARK <= SP) {
3575 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3576 *MARK = sv ? sv : &PL_sv_undef;
3579 else { /* pseudo-hash element */
3580 while (++MARK <= SP) {
3581 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3582 *MARK = sv ? sv : &PL_sv_undef;
3587 DIE(aTHX_ "Not a HASH reference");
3590 else if (gimme == G_SCALAR) {
3599 if (SvTYPE(hv) == SVt_PVHV)
3600 sv = hv_delete_ent(hv, keysv, discard, 0);
3601 else if (SvTYPE(hv) == SVt_PVAV) {
3602 if (PL_op->op_flags & OPf_SPECIAL)
3603 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3605 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3608 DIE(aTHX_ "Not a HASH reference");
3623 if (PL_op->op_private & OPpEXISTS_SUB) {
3627 cv = sv_2cv(sv, &hv, &gv, FALSE);
3630 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3636 if (SvTYPE(hv) == SVt_PVHV) {
3637 if (hv_exists_ent(hv, tmpsv, 0))
3640 else if (SvTYPE(hv) == SVt_PVAV) {
3641 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3642 if (av_exists((AV*)hv, SvIV(tmpsv)))
3645 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3649 DIE(aTHX_ "Not a HASH reference");
3656 dSP; dMARK; dORIGMARK;
3657 register HV *hv = (HV*)POPs;
3658 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3659 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3661 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3662 DIE(aTHX_ "Can't localize pseudo-hash element");
3664 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3665 while (++MARK <= SP) {
3668 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3669 realhv ? hv_exists_ent(hv, keysv, 0)
3670 : avhv_exists_ent((AV*)hv, keysv, 0);
3672 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3673 svp = he ? &HeVAL(he) : 0;
3676 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3679 if (!svp || *svp == &PL_sv_undef) {
3681 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3683 if (PL_op->op_private & OPpLVAL_INTRO) {
3685 save_helem(hv, keysv, svp);
3688 char *key = SvPV(keysv, keylen);
3689 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3693 *MARK = svp ? *svp : &PL_sv_undef;
3696 if (GIMME != G_ARRAY) {
3704 /* List operators. */
3709 if (GIMME != G_ARRAY) {
3711 *MARK = *SP; /* unwanted list, return last item */
3713 *MARK = &PL_sv_undef;
3722 SV **lastrelem = PL_stack_sp;
3723 SV **lastlelem = PL_stack_base + POPMARK;
3724 SV **firstlelem = PL_stack_base + POPMARK + 1;
3725 register SV **firstrelem = lastlelem + 1;
3726 I32 arybase = PL_curcop->cop_arybase;
3727 I32 lval = PL_op->op_flags & OPf_MOD;
3728 I32 is_something_there = lval;
3730 register I32 max = lastrelem - lastlelem;
3731 register SV **lelem;
3734 if (GIMME != G_ARRAY) {
3735 ix = SvIVx(*lastlelem);
3740 if (ix < 0 || ix >= max)
3741 *firstlelem = &PL_sv_undef;
3743 *firstlelem = firstrelem[ix];
3749 SP = firstlelem - 1;
3753 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3759 if (ix < 0 || ix >= max)
3760 *lelem = &PL_sv_undef;
3762 is_something_there = TRUE;
3763 if (!(*lelem = firstrelem[ix]))
3764 *lelem = &PL_sv_undef;
3767 if (is_something_there)
3770 SP = firstlelem - 1;
3776 dSP; dMARK; dORIGMARK;
3777 I32 items = SP - MARK;
3778 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3779 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3786 dSP; dMARK; dORIGMARK;
3787 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3791 SV *val = NEWSV(46, 0);
3793 sv_setsv(val, *++MARK);
3794 else if (ckWARN(WARN_MISC))
3795 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3796 (void)hv_store_ent(hv,key,val,0);
3805 dSP; dMARK; dORIGMARK;
3806 register AV *ary = (AV*)*++MARK;
3810 register I32 offset;
3811 register I32 length;
3818 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3819 *MARK-- = SvTIED_obj((SV*)ary, mg);
3823 call_method("SPLICE",GIMME_V);
3832 offset = i = SvIVx(*MARK);
3834 offset += AvFILLp(ary) + 1;
3836 offset -= PL_curcop->cop_arybase;
3838 DIE(aTHX_ PL_no_aelem, i);
3840 length = SvIVx(*MARK++);
3842 length += AvFILLp(ary) - offset + 1;
3848 length = AvMAX(ary) + 1; /* close enough to infinity */
3852 length = AvMAX(ary) + 1;
3854 if (offset > AvFILLp(ary) + 1)
3855 offset = AvFILLp(ary) + 1;
3856 after = AvFILLp(ary) + 1 - (offset + length);
3857 if (after < 0) { /* not that much array */
3858 length += after; /* offset+length now in array */
3864 /* At this point, MARK .. SP-1 is our new LIST */
3867 diff = newlen - length;
3868 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3871 if (diff < 0) { /* shrinking the area */
3873 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3874 Copy(MARK, tmparyval, newlen, SV*);
3877 MARK = ORIGMARK + 1;
3878 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3879 MEXTEND(MARK, length);
3880 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3882 EXTEND_MORTAL(length);
3883 for (i = length, dst = MARK; i; i--) {
3884 sv_2mortal(*dst); /* free them eventualy */
3891 *MARK = AvARRAY(ary)[offset+length-1];
3894 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3895 SvREFCNT_dec(*dst++); /* free them now */
3898 AvFILLp(ary) += diff;
3900 /* pull up or down? */
3902 if (offset < after) { /* easier to pull up */
3903 if (offset) { /* esp. if nothing to pull */
3904 src = &AvARRAY(ary)[offset-1];
3905 dst = src - diff; /* diff is negative */
3906 for (i = offset; i > 0; i--) /* can't trust Copy */
3910 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3914 if (after) { /* anything to pull down? */
3915 src = AvARRAY(ary) + offset + length;
3916 dst = src + diff; /* diff is negative */
3917 Move(src, dst, after, SV*);
3919 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3920 /* avoid later double free */
3924 dst[--i] = &PL_sv_undef;
3927 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3929 *dst = NEWSV(46, 0);
3930 sv_setsv(*dst++, *src++);
3932 Safefree(tmparyval);
3935 else { /* no, expanding (or same) */
3937 New(452, tmparyval, length, SV*); /* so remember deletion */
3938 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3941 if (diff > 0) { /* expanding */
3943 /* push up or down? */
3945 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3949 Move(src, dst, offset, SV*);
3951 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3953 AvFILLp(ary) += diff;
3956 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3957 av_extend(ary, AvFILLp(ary) + diff);
3958 AvFILLp(ary) += diff;
3961 dst = AvARRAY(ary) + AvFILLp(ary);
3963 for (i = after; i; i--) {
3970 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3971 *dst = NEWSV(46, 0);
3972 sv_setsv(*dst++, *src++);
3974 MARK = ORIGMARK + 1;
3975 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3977 Copy(tmparyval, MARK, length, SV*);
3979 EXTEND_MORTAL(length);
3980 for (i = length, dst = MARK; i; i--) {
3981 sv_2mortal(*dst); /* free them eventualy */
3985 Safefree(tmparyval);
3989 else if (length--) {
3990 *MARK = tmparyval[length];
3993 while (length-- > 0)
3994 SvREFCNT_dec(tmparyval[length]);
3996 Safefree(tmparyval);
3999 *MARK = &PL_sv_undef;
4007 dSP; dMARK; dORIGMARK; dTARGET;
4008 register AV *ary = (AV*)*++MARK;
4009 register SV *sv = &PL_sv_undef;
4012 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4013 *MARK-- = SvTIED_obj((SV*)ary, mg);
4017 call_method("PUSH",G_SCALAR|G_DISCARD);
4022 /* Why no pre-extend of ary here ? */
4023 for (++MARK; MARK <= SP; MARK++) {
4026 sv_setsv(sv, *MARK);
4031 PUSHi( AvFILL(ary) + 1 );
4039 SV *sv = av_pop(av);
4041 (void)sv_2mortal(sv);
4050 SV *sv = av_shift(av);
4055 (void)sv_2mortal(sv);
4062 dSP; dMARK; dORIGMARK; dTARGET;
4063 register AV *ary = (AV*)*++MARK;
4068 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4069 *MARK-- = SvTIED_obj((SV*)ary, mg);
4073 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4078 av_unshift(ary, SP - MARK);
4081 sv_setsv(sv, *++MARK);
4082 (void)av_store(ary, i++, sv);
4086 PUSHi( AvFILL(ary) + 1 );
4096 if (GIMME == G_ARRAY) {
4103 /* safe as long as stack cannot get extended in the above */
4108 register char *down;
4113 SvUTF8_off(TARG); /* decontaminate */
4115 do_join(TARG, &PL_sv_no, MARK, SP);
4117 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4118 up = SvPV_force(TARG, len);
4120 if (DO_UTF8(TARG)) { /* first reverse each character */
4121 U8* s = (U8*)SvPVX(TARG);
4122 U8* send = (U8*)(s + len);
4124 if (UTF8_IS_INVARIANT(*s)) {
4129 if (!utf8_to_uvchr(s, 0))
4133 down = (char*)(s - 1);
4134 /* reverse this character */
4144 down = SvPVX(TARG) + len - 1;
4150 (void)SvPOK_only_UTF8(TARG);
4162 register IV limit = POPi; /* note, negative is forever */
4165 register char *s = SvPV(sv, len);
4166 bool do_utf8 = DO_UTF8(sv);
4167 char *strend = s + len;
4169 register REGEXP *rx;
4173 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4174 I32 maxiters = slen + 10;
4177 I32 origlimit = limit;
4180 AV *oldstack = PL_curstack;
4181 I32 gimme = GIMME_V;
4182 I32 oldsave = PL_savestack_ix;
4183 I32 make_mortal = 1;
4184 MAGIC *mg = (MAGIC *) NULL;
4187 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4192 DIE(aTHX_ "panic: pp_split");
4195 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4196 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4198 PL_reg_match_utf8 = do_utf8;
4200 if (pm->op_pmreplroot) {
4202 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4204 ary = GvAVn((GV*)pm->op_pmreplroot);
4207 else if (gimme != G_ARRAY)
4208 #ifdef USE_5005THREADS
4209 ary = (AV*)PL_curpad[0];
4211 ary = GvAVn(PL_defgv);
4212 #endif /* USE_5005THREADS */
4215 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4221 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4223 XPUSHs(SvTIED_obj((SV*)ary, mg));
4229 for (i = AvFILLp(ary); i >= 0; i--)
4230 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4232 /* temporarily switch stacks */
4233 SWITCHSTACK(PL_curstack, ary);
4237 base = SP - PL_stack_base;
4239 if (pm->op_pmflags & PMf_SKIPWHITE) {
4240 if (pm->op_pmflags & PMf_LOCALE) {
4241 while (isSPACE_LC(*s))
4249 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4250 SAVEINT(PL_multiline);
4251 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4255 limit = maxiters + 2;
4256 if (pm->op_pmflags & PMf_WHITE) {
4259 while (m < strend &&
4260 !((pm->op_pmflags & PMf_LOCALE)
4261 ? isSPACE_LC(*m) : isSPACE(*m)))
4266 dstr = NEWSV(30, m-s);
4267 sv_setpvn(dstr, s, m-s);
4271 (void)SvUTF8_on(dstr);
4275 while (s < strend &&
4276 ((pm->op_pmflags & PMf_LOCALE)
4277 ? isSPACE_LC(*s) : isSPACE(*s)))
4281 else if (strEQ("^", rx->precomp)) {
4284 for (m = s; m < strend && *m != '\n'; m++) ;
4288 dstr = NEWSV(30, m-s);
4289 sv_setpvn(dstr, s, m-s);
4293 (void)SvUTF8_on(dstr);
4298 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4299 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4300 && (rx->reganch & ROPT_CHECK_ALL)
4301 && !(rx->reganch & ROPT_ANCH)) {
4302 int tail = (rx->reganch & RE_INTUIT_TAIL);
4303 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4306 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4308 char c = *SvPV(csv, n_a);
4311 for (m = s; m < strend && *m != c; m++) ;
4314 dstr = NEWSV(30, m-s);
4315 sv_setpvn(dstr, s, m-s);
4319 (void)SvUTF8_on(dstr);
4321 /* The rx->minlen is in characters but we want to step
4322 * s ahead by bytes. */
4324 s = (char*)utf8_hop((U8*)m, len);
4326 s = m + len; /* Fake \n at the end */
4331 while (s < strend && --limit &&
4332 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4333 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4336 dstr = NEWSV(31, m-s);
4337 sv_setpvn(dstr, s, m-s);
4341 (void)SvUTF8_on(dstr);
4343 /* The rx->minlen is in characters but we want to step
4344 * s ahead by bytes. */
4346 s = (char*)utf8_hop((U8*)m, len);
4348 s = m + len; /* Fake \n at the end */
4353 maxiters += slen * rx->nparens;
4354 while (s < strend && --limit
4355 /* && (!rx->check_substr
4356 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4358 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4359 1 /* minend */, sv, NULL, 0))
4361 TAINT_IF(RX_MATCH_TAINTED(rx));
4362 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4367 strend = s + (strend - m);
4369 m = rx->startp[0] + orig;
4370 dstr = NEWSV(32, m-s);
4371 sv_setpvn(dstr, s, m-s);
4375 (void)SvUTF8_on(dstr);
4378 for (i = 1; i <= rx->nparens; i++) {
4379 s = rx->startp[i] + orig;
4380 m = rx->endp[i] + orig;
4382 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4383 parens that didn't match -- they should be set to
4384 undef, not the empty string */
4385 if (m >= orig && s >= orig) {
4386 dstr = NEWSV(33, m-s);
4387 sv_setpvn(dstr, s, m-s);
4390 dstr = &PL_sv_undef; /* undef, not "" */
4394 (void)SvUTF8_on(dstr);
4398 s = rx->endp[0] + orig;
4402 LEAVE_SCOPE(oldsave);
4403 iters = (SP - PL_stack_base) - base;
4404 if (iters > maxiters)
4405 DIE(aTHX_ "Split loop");
4407 /* keep field after final delim? */
4408 if (s < strend || (iters && origlimit)) {
4409 STRLEN l = strend - s;
4410 dstr = NEWSV(34, l);
4411 sv_setpvn(dstr, s, l);
4415 (void)SvUTF8_on(dstr);
4419 else if (!origlimit) {
4420 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4426 SWITCHSTACK(ary, oldstack);
4427 if (SvSMAGICAL(ary)) {
4432 if (gimme == G_ARRAY) {
4434 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4442 call_method("PUSH",G_SCALAR|G_DISCARD);
4445 if (gimme == G_ARRAY) {
4446 /* EXTEND should not be needed - we just popped them */
4448 for (i=0; i < iters; i++) {
4449 SV **svp = av_fetch(ary, i, FALSE);
4450 PUSHs((svp) ? *svp : &PL_sv_undef);
4457 if (gimme == G_ARRAY)
4460 if (iters || !pm->op_pmreplroot) {
4468 #ifdef USE_5005THREADS
4470 Perl_unlock_condpair(pTHX_ void *svv)
4472 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4475 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4476 MUTEX_LOCK(MgMUTEXP(mg));
4477 if (MgOWNER(mg) != thr)
4478 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4480 COND_SIGNAL(MgOWNERCONDP(mg));
4481 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4482 PTR2UV(thr), PTR2UV(svv)));
4483 MUTEX_UNLOCK(MgMUTEXP(mg));
4485 #endif /* USE_5005THREADS */
4492 #ifdef USE_5005THREADS
4494 #endif /* USE_5005THREADS */
4496 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4498 Perl_sharedsv_lock(aTHX_ ssv);
4499 #endif /* USE_ITHREADS */
4500 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4501 || SvTYPE(retsv) == SVt_PVCV) {
4502 retsv = refto(retsv);
4510 #ifdef USE_5005THREADS
4513 if (PL_op->op_private & OPpLVAL_INTRO)
4514 PUSHs(*save_threadsv(PL_op->op_targ));
4516 PUSHs(THREADSV(PL_op->op_targ));
4519 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4520 #endif /* USE_5005THREADS */