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;
3098 char *tmps = SvPV(left, n_a);
3100 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3102 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3106 "The crypt() function is unimplemented due to excessive paranoia.");
3119 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3121 U8 tmpbuf[UTF8_MAXLEN+1];
3125 if (IN_LOCALE_RUNTIME) {
3128 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3131 uv = toTITLE_utf8(s);
3135 tend = uvchr_to_utf8(tmpbuf, uv);
3137 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3139 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3140 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3145 s = (U8*)SvPV_force(sv, slen);
3146 Copy(tmpbuf, s, ulen, U8);
3150 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3152 SvUTF8_off(TARG); /* decontaminate */
3157 s = (U8*)SvPV_force(sv, slen);
3159 if (IN_LOCALE_RUNTIME) {
3162 *s = toUPPER_LC(*s);
3180 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3182 U8 tmpbuf[UTF8_MAXLEN+1];
3186 if (IN_LOCALE_RUNTIME) {
3189 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3192 uv = toLOWER_utf8(s);
3196 tend = uvchr_to_utf8(tmpbuf, uv);
3198 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3200 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3201 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3206 s = (U8*)SvPV_force(sv, slen);
3207 Copy(tmpbuf, s, ulen, U8);
3211 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3213 SvUTF8_off(TARG); /* decontaminate */
3218 s = (U8*)SvPV_force(sv, slen);
3220 if (IN_LOCALE_RUNTIME) {
3223 *s = toLOWER_LC(*s);
3247 s = (U8*)SvPV(sv,len);
3249 SvUTF8_off(TARG); /* decontaminate */
3250 sv_setpvn(TARG, "", 0);
3254 (void)SvUPGRADE(TARG, SVt_PV);
3255 SvGROW(TARG, (len * 2) + 1);
3256 (void)SvPOK_only(TARG);
3257 d = (U8*)SvPVX(TARG);
3259 if (IN_LOCALE_RUNTIME) {
3263 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3269 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3275 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3280 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3282 SvUTF8_off(TARG); /* decontaminate */
3287 s = (U8*)SvPV_force(sv, len);
3289 register U8 *send = s + len;
3291 if (IN_LOCALE_RUNTIME) {
3294 for (; s < send; s++)
3295 *s = toUPPER_LC(*s);
3298 for (; s < send; s++)
3321 s = (U8*)SvPV(sv,len);
3323 SvUTF8_off(TARG); /* decontaminate */
3324 sv_setpvn(TARG, "", 0);
3328 (void)SvUPGRADE(TARG, SVt_PV);
3329 SvGROW(TARG, (len * 2) + 1);
3330 (void)SvPOK_only(TARG);
3331 d = (U8*)SvPVX(TARG);
3333 if (IN_LOCALE_RUNTIME) {
3337 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3343 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3349 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3354 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3356 SvUTF8_off(TARG); /* decontaminate */
3362 s = (U8*)SvPV_force(sv, len);
3364 register U8 *send = s + len;
3366 if (IN_LOCALE_RUNTIME) {
3369 for (; s < send; s++)
3370 *s = toLOWER_LC(*s);
3373 for (; s < send; s++)
3388 register char *s = SvPV(sv,len);
3391 SvUTF8_off(TARG); /* decontaminate */
3393 (void)SvUPGRADE(TARG, SVt_PV);
3394 SvGROW(TARG, (len * 2) + 1);
3398 if (UTF8_IS_CONTINUED(*s)) {
3399 STRLEN ulen = UTF8SKIP(s);
3423 SvCUR_set(TARG, d - SvPVX(TARG));
3424 (void)SvPOK_only_UTF8(TARG);
3427 sv_setpvn(TARG, s, len);
3429 if (SvSMAGICAL(TARG))
3438 dSP; dMARK; dORIGMARK;
3440 register AV* av = (AV*)POPs;
3441 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3442 I32 arybase = PL_curcop->cop_arybase;
3445 if (SvTYPE(av) == SVt_PVAV) {
3446 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3448 for (svp = MARK + 1; svp <= SP; svp++) {
3453 if (max > AvMAX(av))
3456 while (++MARK <= SP) {
3457 elem = SvIVx(*MARK);
3461 svp = av_fetch(av, elem, lval);
3463 if (!svp || *svp == &PL_sv_undef)
3464 DIE(aTHX_ PL_no_aelem, elem);
3465 if (PL_op->op_private & OPpLVAL_INTRO)
3466 save_aelem(av, elem, svp);
3468 *MARK = svp ? *svp : &PL_sv_undef;
3471 if (GIMME != G_ARRAY) {
3479 /* Associative arrays. */
3484 HV *hash = (HV*)POPs;
3486 I32 gimme = GIMME_V;
3487 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3490 /* might clobber stack_sp */
3491 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3496 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3497 if (gimme == G_ARRAY) {
3500 /* might clobber stack_sp */
3502 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3507 else if (gimme == G_SCALAR)
3526 I32 gimme = GIMME_V;
3527 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3531 if (PL_op->op_private & OPpSLICE) {
3535 hvtype = SvTYPE(hv);
3536 if (hvtype == SVt_PVHV) { /* hash element */
3537 while (++MARK <= SP) {
3538 sv = hv_delete_ent(hv, *MARK, discard, 0);
3539 *MARK = sv ? sv : &PL_sv_undef;
3542 else if (hvtype == SVt_PVAV) {
3543 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3544 while (++MARK <= SP) {
3545 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3546 *MARK = sv ? sv : &PL_sv_undef;
3549 else { /* pseudo-hash element */
3550 while (++MARK <= SP) {
3551 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3552 *MARK = sv ? sv : &PL_sv_undef;
3557 DIE(aTHX_ "Not a HASH reference");
3560 else if (gimme == G_SCALAR) {
3569 if (SvTYPE(hv) == SVt_PVHV)
3570 sv = hv_delete_ent(hv, keysv, discard, 0);
3571 else if (SvTYPE(hv) == SVt_PVAV) {
3572 if (PL_op->op_flags & OPf_SPECIAL)
3573 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3575 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3578 DIE(aTHX_ "Not a HASH reference");
3593 if (PL_op->op_private & OPpEXISTS_SUB) {
3597 cv = sv_2cv(sv, &hv, &gv, FALSE);
3600 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3606 if (SvTYPE(hv) == SVt_PVHV) {
3607 if (hv_exists_ent(hv, tmpsv, 0))
3610 else if (SvTYPE(hv) == SVt_PVAV) {
3611 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3612 if (av_exists((AV*)hv, SvIV(tmpsv)))
3615 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3619 DIE(aTHX_ "Not a HASH reference");
3626 dSP; dMARK; dORIGMARK;
3627 register HV *hv = (HV*)POPs;
3628 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3629 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3631 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3632 DIE(aTHX_ "Can't localize pseudo-hash element");
3634 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3635 while (++MARK <= SP) {
3638 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3639 realhv ? hv_exists_ent(hv, keysv, 0)
3640 : avhv_exists_ent((AV*)hv, keysv, 0);
3642 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3643 svp = he ? &HeVAL(he) : 0;
3646 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3649 if (!svp || *svp == &PL_sv_undef) {
3651 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3653 if (PL_op->op_private & OPpLVAL_INTRO) {
3655 save_helem(hv, keysv, svp);
3658 char *key = SvPV(keysv, keylen);
3659 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3663 *MARK = svp ? *svp : &PL_sv_undef;
3666 if (GIMME != G_ARRAY) {
3674 /* List operators. */
3679 if (GIMME != G_ARRAY) {
3681 *MARK = *SP; /* unwanted list, return last item */
3683 *MARK = &PL_sv_undef;
3692 SV **lastrelem = PL_stack_sp;
3693 SV **lastlelem = PL_stack_base + POPMARK;
3694 SV **firstlelem = PL_stack_base + POPMARK + 1;
3695 register SV **firstrelem = lastlelem + 1;
3696 I32 arybase = PL_curcop->cop_arybase;
3697 I32 lval = PL_op->op_flags & OPf_MOD;
3698 I32 is_something_there = lval;
3700 register I32 max = lastrelem - lastlelem;
3701 register SV **lelem;
3704 if (GIMME != G_ARRAY) {
3705 ix = SvIVx(*lastlelem);
3710 if (ix < 0 || ix >= max)
3711 *firstlelem = &PL_sv_undef;
3713 *firstlelem = firstrelem[ix];
3719 SP = firstlelem - 1;
3723 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3729 if (ix < 0 || ix >= max)
3730 *lelem = &PL_sv_undef;
3732 is_something_there = TRUE;
3733 if (!(*lelem = firstrelem[ix]))
3734 *lelem = &PL_sv_undef;
3737 if (is_something_there)
3740 SP = firstlelem - 1;
3746 dSP; dMARK; dORIGMARK;
3747 I32 items = SP - MARK;
3748 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3749 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3756 dSP; dMARK; dORIGMARK;
3757 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3761 SV *val = NEWSV(46, 0);
3763 sv_setsv(val, *++MARK);
3764 else if (ckWARN(WARN_MISC))
3765 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3766 (void)hv_store_ent(hv,key,val,0);
3775 dSP; dMARK; dORIGMARK;
3776 register AV *ary = (AV*)*++MARK;
3780 register I32 offset;
3781 register I32 length;
3788 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3789 *MARK-- = SvTIED_obj((SV*)ary, mg);
3793 call_method("SPLICE",GIMME_V);
3802 offset = i = SvIVx(*MARK);
3804 offset += AvFILLp(ary) + 1;
3806 offset -= PL_curcop->cop_arybase;
3808 DIE(aTHX_ PL_no_aelem, i);
3810 length = SvIVx(*MARK++);
3812 length += AvFILLp(ary) - offset + 1;
3818 length = AvMAX(ary) + 1; /* close enough to infinity */
3822 length = AvMAX(ary) + 1;
3824 if (offset > AvFILLp(ary) + 1)
3825 offset = AvFILLp(ary) + 1;
3826 after = AvFILLp(ary) + 1 - (offset + length);
3827 if (after < 0) { /* not that much array */
3828 length += after; /* offset+length now in array */
3834 /* At this point, MARK .. SP-1 is our new LIST */
3837 diff = newlen - length;
3838 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3841 if (diff < 0) { /* shrinking the area */
3843 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3844 Copy(MARK, tmparyval, newlen, SV*);
3847 MARK = ORIGMARK + 1;
3848 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3849 MEXTEND(MARK, length);
3850 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3852 EXTEND_MORTAL(length);
3853 for (i = length, dst = MARK; i; i--) {
3854 sv_2mortal(*dst); /* free them eventualy */
3861 *MARK = AvARRAY(ary)[offset+length-1];
3864 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3865 SvREFCNT_dec(*dst++); /* free them now */
3868 AvFILLp(ary) += diff;
3870 /* pull up or down? */
3872 if (offset < after) { /* easier to pull up */
3873 if (offset) { /* esp. if nothing to pull */
3874 src = &AvARRAY(ary)[offset-1];
3875 dst = src - diff; /* diff is negative */
3876 for (i = offset; i > 0; i--) /* can't trust Copy */
3880 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3884 if (after) { /* anything to pull down? */
3885 src = AvARRAY(ary) + offset + length;
3886 dst = src + diff; /* diff is negative */
3887 Move(src, dst, after, SV*);
3889 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3890 /* avoid later double free */
3894 dst[--i] = &PL_sv_undef;
3897 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3899 *dst = NEWSV(46, 0);
3900 sv_setsv(*dst++, *src++);
3902 Safefree(tmparyval);
3905 else { /* no, expanding (or same) */
3907 New(452, tmparyval, length, SV*); /* so remember deletion */
3908 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3911 if (diff > 0) { /* expanding */
3913 /* push up or down? */
3915 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3919 Move(src, dst, offset, SV*);
3921 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3923 AvFILLp(ary) += diff;
3926 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3927 av_extend(ary, AvFILLp(ary) + diff);
3928 AvFILLp(ary) += diff;
3931 dst = AvARRAY(ary) + AvFILLp(ary);
3933 for (i = after; i; i--) {
3940 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3941 *dst = NEWSV(46, 0);
3942 sv_setsv(*dst++, *src++);
3944 MARK = ORIGMARK + 1;
3945 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3947 Copy(tmparyval, MARK, length, SV*);
3949 EXTEND_MORTAL(length);
3950 for (i = length, dst = MARK; i; i--) {
3951 sv_2mortal(*dst); /* free them eventualy */
3955 Safefree(tmparyval);
3959 else if (length--) {
3960 *MARK = tmparyval[length];
3963 while (length-- > 0)
3964 SvREFCNT_dec(tmparyval[length]);
3966 Safefree(tmparyval);
3969 *MARK = &PL_sv_undef;
3977 dSP; dMARK; dORIGMARK; dTARGET;
3978 register AV *ary = (AV*)*++MARK;
3979 register SV *sv = &PL_sv_undef;
3982 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3983 *MARK-- = SvTIED_obj((SV*)ary, mg);
3987 call_method("PUSH",G_SCALAR|G_DISCARD);
3992 /* Why no pre-extend of ary here ? */
3993 for (++MARK; MARK <= SP; MARK++) {
3996 sv_setsv(sv, *MARK);
4001 PUSHi( AvFILL(ary) + 1 );
4009 SV *sv = av_pop(av);
4011 (void)sv_2mortal(sv);
4020 SV *sv = av_shift(av);
4025 (void)sv_2mortal(sv);
4032 dSP; dMARK; dORIGMARK; dTARGET;
4033 register AV *ary = (AV*)*++MARK;
4038 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4039 *MARK-- = SvTIED_obj((SV*)ary, mg);
4043 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4048 av_unshift(ary, SP - MARK);
4051 sv_setsv(sv, *++MARK);
4052 (void)av_store(ary, i++, sv);
4056 PUSHi( AvFILL(ary) + 1 );
4066 if (GIMME == G_ARRAY) {
4073 /* safe as long as stack cannot get extended in the above */
4078 register char *down;
4083 SvUTF8_off(TARG); /* decontaminate */
4085 do_join(TARG, &PL_sv_no, MARK, SP);
4087 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4088 up = SvPV_force(TARG, len);
4090 if (DO_UTF8(TARG)) { /* first reverse each character */
4091 U8* s = (U8*)SvPVX(TARG);
4092 U8* send = (U8*)(s + len);
4094 if (UTF8_IS_INVARIANT(*s)) {
4099 if (!utf8_to_uvchr(s, 0))
4103 down = (char*)(s - 1);
4104 /* reverse this character */
4114 down = SvPVX(TARG) + len - 1;
4120 (void)SvPOK_only_UTF8(TARG);
4132 register IV limit = POPi; /* note, negative is forever */
4135 register char *s = SvPV(sv, len);
4136 bool do_utf8 = DO_UTF8(sv);
4137 char *strend = s + len;
4139 register REGEXP *rx;
4143 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4144 I32 maxiters = slen + 10;
4147 I32 origlimit = limit;
4150 AV *oldstack = PL_curstack;
4151 I32 gimme = GIMME_V;
4152 I32 oldsave = PL_savestack_ix;
4153 I32 make_mortal = 1;
4154 MAGIC *mg = (MAGIC *) NULL;
4157 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4162 DIE(aTHX_ "panic: pp_split");
4165 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4166 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4168 PL_reg_match_utf8 = do_utf8;
4170 if (pm->op_pmreplroot) {
4172 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4174 ary = GvAVn((GV*)pm->op_pmreplroot);
4177 else if (gimme != G_ARRAY)
4178 #ifdef USE_5005THREADS
4179 ary = (AV*)PL_curpad[0];
4181 ary = GvAVn(PL_defgv);
4182 #endif /* USE_5005THREADS */
4185 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4191 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4193 XPUSHs(SvTIED_obj((SV*)ary, mg));
4199 for (i = AvFILLp(ary); i >= 0; i--)
4200 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4202 /* temporarily switch stacks */
4203 SWITCHSTACK(PL_curstack, ary);
4207 base = SP - PL_stack_base;
4209 if (pm->op_pmflags & PMf_SKIPWHITE) {
4210 if (pm->op_pmflags & PMf_LOCALE) {
4211 while (isSPACE_LC(*s))
4219 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4220 SAVEINT(PL_multiline);
4221 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4225 limit = maxiters + 2;
4226 if (pm->op_pmflags & PMf_WHITE) {
4229 while (m < strend &&
4230 !((pm->op_pmflags & PMf_LOCALE)
4231 ? isSPACE_LC(*m) : isSPACE(*m)))
4236 dstr = NEWSV(30, m-s);
4237 sv_setpvn(dstr, s, m-s);
4241 (void)SvUTF8_on(dstr);
4245 while (s < strend &&
4246 ((pm->op_pmflags & PMf_LOCALE)
4247 ? isSPACE_LC(*s) : isSPACE(*s)))
4251 else if (strEQ("^", rx->precomp)) {
4254 for (m = s; m < strend && *m != '\n'; m++) ;
4258 dstr = NEWSV(30, m-s);
4259 sv_setpvn(dstr, s, m-s);
4263 (void)SvUTF8_on(dstr);
4268 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4269 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4270 && (rx->reganch & ROPT_CHECK_ALL)
4271 && !(rx->reganch & ROPT_ANCH)) {
4272 int tail = (rx->reganch & RE_INTUIT_TAIL);
4273 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4276 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4278 char c = *SvPV(csv, n_a);
4281 for (m = s; m < strend && *m != c; m++) ;
4284 dstr = NEWSV(30, m-s);
4285 sv_setpvn(dstr, s, m-s);
4289 (void)SvUTF8_on(dstr);
4291 /* The rx->minlen is in characters but we want to step
4292 * s ahead by bytes. */
4294 s = (char*)utf8_hop((U8*)m, len);
4296 s = m + len; /* Fake \n at the end */
4301 while (s < strend && --limit &&
4302 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4303 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4306 dstr = NEWSV(31, m-s);
4307 sv_setpvn(dstr, s, m-s);
4311 (void)SvUTF8_on(dstr);
4313 /* The rx->minlen is in characters but we want to step
4314 * s ahead by bytes. */
4316 s = (char*)utf8_hop((U8*)m, len);
4318 s = m + len; /* Fake \n at the end */
4323 maxiters += slen * rx->nparens;
4324 while (s < strend && --limit
4325 /* && (!rx->check_substr
4326 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4328 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4329 1 /* minend */, sv, NULL, 0))
4331 TAINT_IF(RX_MATCH_TAINTED(rx));
4332 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4337 strend = s + (strend - m);
4339 m = rx->startp[0] + orig;
4340 dstr = NEWSV(32, m-s);
4341 sv_setpvn(dstr, s, m-s);
4345 (void)SvUTF8_on(dstr);
4348 for (i = 1; i <= rx->nparens; i++) {
4349 s = rx->startp[i] + orig;
4350 m = rx->endp[i] + orig;
4352 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4353 parens that didn't match -- they should be set to
4354 undef, not the empty string */
4355 if (m >= orig && s >= orig) {
4356 dstr = NEWSV(33, m-s);
4357 sv_setpvn(dstr, s, m-s);
4360 dstr = &PL_sv_undef; /* undef, not "" */
4364 (void)SvUTF8_on(dstr);
4368 s = rx->endp[0] + orig;
4372 LEAVE_SCOPE(oldsave);
4373 iters = (SP - PL_stack_base) - base;
4374 if (iters > maxiters)
4375 DIE(aTHX_ "Split loop");
4377 /* keep field after final delim? */
4378 if (s < strend || (iters && origlimit)) {
4379 STRLEN l = strend - s;
4380 dstr = NEWSV(34, l);
4381 sv_setpvn(dstr, s, l);
4385 (void)SvUTF8_on(dstr);
4389 else if (!origlimit) {
4390 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4396 SWITCHSTACK(ary, oldstack);
4397 if (SvSMAGICAL(ary)) {
4402 if (gimme == G_ARRAY) {
4404 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4412 call_method("PUSH",G_SCALAR|G_DISCARD);
4415 if (gimme == G_ARRAY) {
4416 /* EXTEND should not be needed - we just popped them */
4418 for (i=0; i < iters; i++) {
4419 SV **svp = av_fetch(ary, i, FALSE);
4420 PUSHs((svp) ? *svp : &PL_sv_undef);
4427 if (gimme == G_ARRAY)
4430 if (iters || !pm->op_pmreplroot) {
4438 #ifdef USE_5005THREADS
4440 Perl_unlock_condpair(pTHX_ void *svv)
4442 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4445 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4446 MUTEX_LOCK(MgMUTEXP(mg));
4447 if (MgOWNER(mg) != thr)
4448 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4450 COND_SIGNAL(MgOWNERCONDP(mg));
4451 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4452 PTR2UV(thr), PTR2UV(svv)));
4453 MUTEX_UNLOCK(MgMUTEXP(mg));
4455 #endif /* USE_5005THREADS */
4462 #ifdef USE_5005THREADS
4464 #endif /* USE_5005THREADS */
4466 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4468 Perl_sharedsv_lock(aTHX_ ssv);
4469 #endif /* USE_ITHREADS */
4470 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4471 || SvTYPE(retsv) == SVt_PVCV) {
4472 retsv = refto(retsv);
4480 #ifdef USE_5005THREADS
4483 if (PL_op->op_private & OPpLVAL_INTRO)
4484 PUSHs(*save_threadsv(PL_op->op_targ));
4486 PUSHs(THREADSV(PL_op->op_targ));
4489 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4490 #endif /* USE_5005THREADS */