3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
19 /* variations on pp_null */
21 /* XXX I can't imagine anyone who doesn't have this actually _needs_
22 it, since pid_t is an integral type.
25 #ifdef NEED_GETPID_PROTO
26 extern Pid_t getpid (void);
32 if (GIMME_V == G_SCALAR)
47 if (PL_op->op_private & OPpLVAL_INTRO)
48 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
50 if (PL_op->op_flags & OPf_REF) {
54 if (GIMME == G_SCALAR)
55 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
59 if (GIMME == G_ARRAY) {
60 I32 maxarg = AvFILL((AV*)TARG) + 1;
62 if (SvMAGICAL(TARG)) {
64 for (i=0; i < maxarg; i++) {
65 SV **svp = av_fetch((AV*)TARG, i, FALSE);
66 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
70 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
75 SV* sv = sv_newmortal();
76 I32 maxarg = AvFILL((AV*)TARG) + 1;
89 if (PL_op->op_private & OPpLVAL_INTRO)
90 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
91 if (PL_op->op_flags & OPf_REF)
94 if (GIMME == G_SCALAR)
95 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
99 if (gimme == G_ARRAY) {
102 else if (gimme == G_SCALAR) {
103 SV* sv = sv_newmortal();
104 if (HvFILL((HV*)TARG))
105 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
106 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
116 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
127 tryAMAGICunDEREF(to_gv);
130 if (SvTYPE(sv) == SVt_PVIO) {
131 GV *gv = (GV*) sv_newmortal();
132 gv_init(gv, 0, "", 0, 0);
133 GvIOp(gv) = (IO *)sv;
134 (void)SvREFCNT_inc(sv);
137 else if (SvTYPE(sv) != SVt_PVGV)
138 DIE(aTHX_ "Not a GLOB reference");
141 if (SvTYPE(sv) != SVt_PVGV) {
145 if (SvGMAGICAL(sv)) {
150 if (!SvOK(sv) && sv != &PL_sv_undef) {
151 /* If this is a 'my' scalar and flag is set then vivify
154 if (PL_op->op_private & OPpDEREF) {
157 if (cUNOP->op_targ) {
159 SV *namesv = PL_curpad[cUNOP->op_targ];
160 name = SvPV(namesv, len);
161 gv = (GV*)NEWSV(0,0);
162 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
165 name = CopSTASHPV(PL_curcop);
168 if (SvTYPE(sv) < SVt_RV)
169 sv_upgrade(sv, SVt_RV);
175 if (PL_op->op_flags & OPf_REF ||
176 PL_op->op_private & HINT_STRICT_REFS)
177 DIE(aTHX_ PL_no_usym, "a symbol");
178 if (ckWARN(WARN_UNINITIALIZED))
183 if ((PL_op->op_flags & OPf_SPECIAL) &&
184 !(PL_op->op_flags & OPf_MOD))
186 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
188 && (!is_gv_magical(sym,len,0)
189 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
195 if (PL_op->op_private & HINT_STRICT_REFS)
196 DIE(aTHX_ PL_no_symref, sym, "a symbol");
197 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
213 tryAMAGICunDEREF(to_sv);
216 switch (SvTYPE(sv)) {
220 DIE(aTHX_ "Not a SCALAR reference");
228 if (SvTYPE(gv) != SVt_PVGV) {
229 if (SvGMAGICAL(sv)) {
235 if (PL_op->op_flags & OPf_REF ||
236 PL_op->op_private & HINT_STRICT_REFS)
237 DIE(aTHX_ PL_no_usym, "a SCALAR");
238 if (ckWARN(WARN_UNINITIALIZED))
243 if ((PL_op->op_flags & OPf_SPECIAL) &&
244 !(PL_op->op_flags & OPf_MOD))
246 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
248 && (!is_gv_magical(sym,len,0)
249 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
255 if (PL_op->op_private & HINT_STRICT_REFS)
256 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
257 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
262 if (PL_op->op_flags & OPf_MOD) {
263 if (PL_op->op_private & OPpLVAL_INTRO)
264 sv = save_scalar((GV*)TOPs);
265 else if (PL_op->op_private & OPpDEREF)
266 vivify_ref(sv, PL_op->op_private & OPpDEREF);
276 SV *sv = AvARYLEN(av);
278 AvARYLEN(av) = sv = NEWSV(0,0);
279 sv_upgrade(sv, SVt_IV);
280 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
288 dSP; dTARGET; dPOPss;
290 if (PL_op->op_flags & OPf_MOD || LVRET) {
291 if (SvTYPE(TARG) < SVt_PVLV) {
292 sv_upgrade(TARG, SVt_PVLV);
293 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
297 if (LvTARG(TARG) != sv) {
299 SvREFCNT_dec(LvTARG(TARG));
300 LvTARG(TARG) = SvREFCNT_inc(sv);
302 PUSHs(TARG); /* no SvSETMAGIC */
308 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
309 mg = mg_find(sv, PERL_MAGIC_regex_global);
310 if (mg && mg->mg_len >= 0) {
314 PUSHi(i + PL_curcop->cop_arybase);
328 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
329 /* (But not in defined().) */
330 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
333 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
334 if ((PL_op->op_private & OPpLVAL_INTRO)) {
335 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
338 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
342 cv = (CV*)&PL_sv_undef;
356 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
357 char *s = SvPVX(TOPs);
358 if (strnEQ(s, "CORE::", 6)) {
361 code = keyword(s + 6, SvCUR(TOPs) - 6);
362 if (code < 0) { /* Overridable. */
363 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
364 int i = 0, n = 0, seen_question = 0;
366 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
368 while (i < MAXO) { /* The slow way. */
369 if (strEQ(s + 6, PL_op_name[i])
370 || strEQ(s + 6, PL_op_desc[i]))
376 goto nonesuch; /* Should not happen... */
378 oa = PL_opargs[i] >> OASHIFT;
380 if (oa & OA_OPTIONAL && !seen_question) {
384 else if (n && str[0] == ';' && seen_question)
385 goto set; /* XXXX system, exec */
386 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
387 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
388 /* But globs are already references (kinda) */
389 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
393 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
397 ret = sv_2mortal(newSVpvn(str, n - 1));
399 else if (code) /* Non-Overridable */
401 else { /* None such */
403 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
407 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
409 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
418 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
420 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
436 if (GIMME != G_ARRAY) {
440 *MARK = &PL_sv_undef;
441 *MARK = refto(*MARK);
445 EXTEND_MORTAL(SP - MARK);
447 *MARK = refto(*MARK);
452 S_refto(pTHX_ SV *sv)
456 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
459 if (!(sv = LvTARG(sv)))
462 (void)SvREFCNT_inc(sv);
464 else if (SvTYPE(sv) == SVt_PVAV) {
465 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
468 (void)SvREFCNT_inc(sv);
470 else if (SvPADTMP(sv) && !IS_PADGV(sv))
474 (void)SvREFCNT_inc(sv);
477 sv_upgrade(rv, SVt_RV);
491 if (sv && SvGMAGICAL(sv))
494 if (!sv || !SvROK(sv))
498 pv = sv_reftype(sv,TRUE);
499 PUSHp(pv, strlen(pv));
509 stash = CopSTASH(PL_curcop);
515 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
516 Perl_croak(aTHX_ "Attempt to bless into a reference");
518 if (ckWARN(WARN_MISC) && len == 0)
519 Perl_warner(aTHX_ WARN_MISC,
520 "Explicit blessing to '' (assuming package main)");
521 stash = gv_stashpvn(ptr, len, TRUE);
524 (void)sv_bless(TOPs, stash);
538 elem = SvPV(sv, n_a);
542 switch (elem ? *elem : '\0')
545 if (strEQ(elem, "ARRAY"))
546 tmpRef = (SV*)GvAV(gv);
549 if (strEQ(elem, "CODE"))
550 tmpRef = (SV*)GvCVu(gv);
553 if (strEQ(elem, "FILEHANDLE")) {
554 /* finally deprecated in 5.8.0 */
555 deprecate("*glob{FILEHANDLE}");
556 tmpRef = (SV*)GvIOp(gv);
559 if (strEQ(elem, "FORMAT"))
560 tmpRef = (SV*)GvFORM(gv);
563 if (strEQ(elem, "GLOB"))
567 if (strEQ(elem, "HASH"))
568 tmpRef = (SV*)GvHV(gv);
571 if (strEQ(elem, "IO"))
572 tmpRef = (SV*)GvIOp(gv);
575 if (strEQ(elem, "NAME"))
576 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
579 if (strEQ(elem, "PACKAGE"))
580 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
583 if (strEQ(elem, "SCALAR"))
597 /* Pattern matching */
602 register unsigned char *s;
605 register I32 *sfirst;
609 if (sv == PL_lastscream) {
615 SvSCREAM_off(PL_lastscream);
616 SvREFCNT_dec(PL_lastscream);
618 PL_lastscream = SvREFCNT_inc(sv);
621 s = (unsigned char*)(SvPV(sv, len));
625 if (pos > PL_maxscream) {
626 if (PL_maxscream < 0) {
627 PL_maxscream = pos + 80;
628 New(301, PL_screamfirst, 256, I32);
629 New(302, PL_screamnext, PL_maxscream, I32);
632 PL_maxscream = pos + pos / 4;
633 Renew(PL_screamnext, PL_maxscream, I32);
637 sfirst = PL_screamfirst;
638 snext = PL_screamnext;
640 if (!sfirst || !snext)
641 DIE(aTHX_ "do_study: out of memory");
643 for (ch = 256; ch; --ch)
650 snext[pos] = sfirst[ch] - pos;
657 /* piggyback on m//g magic */
658 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
667 if (PL_op->op_flags & OPf_STACKED)
673 TARG = sv_newmortal();
678 /* Lvalue operators. */
690 dSP; dMARK; dTARGET; dORIGMARK;
692 do_chop(TARG, *++MARK);
701 SETi(do_chomp(TOPs));
708 register I32 count = 0;
711 count += do_chomp(POPs);
722 if (!sv || !SvANY(sv))
724 switch (SvTYPE(sv)) {
726 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
727 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
731 if (HvARRAY(sv) || SvGMAGICAL(sv)
732 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
736 if (CvROOT(sv) || CvXSUB(sv))
753 if (!PL_op->op_private) {
762 if (SvTHINKFIRST(sv))
765 switch (SvTYPE(sv)) {
775 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
776 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
777 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
781 /* let user-undef'd sub keep its identity */
782 GV* gv = CvGV((CV*)sv);
789 SvSetMagicSV(sv, &PL_sv_undef);
793 Newz(602, gp, 1, GP);
794 GvGP(sv) = gp_ref(gp);
795 GvSV(sv) = NEWSV(72,0);
796 GvLINE(sv) = CopLINE(PL_curcop);
802 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
805 SvPV_set(sv, Nullch);
818 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
819 DIE(aTHX_ PL_no_modify);
820 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
821 SvIVX(TOPs) != IV_MIN)
824 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
835 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
836 DIE(aTHX_ PL_no_modify);
837 sv_setsv(TARG, TOPs);
838 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
839 SvIVX(TOPs) != IV_MAX)
842 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
856 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
857 DIE(aTHX_ PL_no_modify);
858 sv_setsv(TARG, TOPs);
859 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
860 SvIVX(TOPs) != IV_MIN)
863 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 /* Ordinary operators. */
876 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
879 SETn( Perl_pow( left, right) );
886 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
887 #ifdef PERL_PRESERVE_IVUV
890 /* Unless the left argument is integer in range we are going to have to
891 use NV maths. Hence only attempt to coerce the right argument if
892 we know the left is integer. */
893 /* Left operand is defined, so is it IV? */
896 bool auvok = SvUOK(TOPm1s);
897 bool buvok = SvUOK(TOPs);
898 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
899 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
906 alow = SvUVX(TOPm1s);
908 IV aiv = SvIVX(TOPm1s);
911 auvok = TRUE; /* effectively it's a UV now */
913 alow = -aiv; /* abs, auvok == false records sign */
919 IV biv = SvIVX(TOPs);
922 buvok = TRUE; /* effectively it's a UV now */
924 blow = -biv; /* abs, buvok == false records sign */
928 /* If this does sign extension on unsigned it's time for plan B */
929 ahigh = alow >> (4 * sizeof (UV));
931 bhigh = blow >> (4 * sizeof (UV));
933 if (ahigh && bhigh) {
934 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
935 which is overflow. Drop to NVs below. */
936 } else if (!ahigh && !bhigh) {
937 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
938 so the unsigned multiply cannot overflow. */
939 UV product = alow * blow;
940 if (auvok == buvok) {
941 /* -ve * -ve or +ve * +ve gives a +ve result. */
945 } else if (product <= (UV)IV_MIN) {
946 /* 2s complement assumption that (UV)-IV_MIN is correct. */
947 /* -ve result, which could overflow an IV */
949 SETi( -(IV)product );
951 } /* else drop to NVs below. */
953 /* One operand is large, 1 small */
956 /* swap the operands */
958 bhigh = blow; /* bhigh now the temp var for the swap */
962 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
963 multiplies can't overflow. shift can, add can, -ve can. */
964 product_middle = ahigh * blow;
965 if (!(product_middle & topmask)) {
966 /* OK, (ahigh * blow) won't lose bits when we shift it. */
968 product_middle <<= (4 * sizeof (UV));
969 product_low = alow * blow;
971 /* as for pp_add, UV + something mustn't get smaller.
972 IIRC ANSI mandates this wrapping *behaviour* for
973 unsigned whatever the actual representation*/
974 product_low += product_middle;
975 if (product_low >= product_middle) {
976 /* didn't overflow */
977 if (auvok == buvok) {
978 /* -ve * -ve or +ve * +ve gives a +ve result. */
982 } else if (product_low <= (UV)IV_MIN) {
983 /* 2s complement assumption again */
984 /* -ve result, which could overflow an IV */
986 SETi( -(IV)product_low );
988 } /* else drop to NVs below. */
990 } /* product_middle too large */
991 } /* ahigh && bhigh */
992 } /* SvIOK(TOPm1s) */
997 SETn( left * right );
1004 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1005 /* Only try to do UV divide first
1006 if ((SLOPPYDIVIDE is true) or
1007 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1009 The assumption is that it is better to use floating point divide
1010 whenever possible, only doing integer divide first if we can't be sure.
1011 If NV_PRESERVES_UV is true then we know at compile time that no UV
1012 can be too large to preserve, so don't need to compile the code to
1013 test the size of UVs. */
1016 # define PERL_TRY_UV_DIVIDE
1017 /* ensure that 20./5. == 4. */
1019 # ifdef PERL_PRESERVE_IVUV
1020 # ifndef NV_PRESERVES_UV
1021 # define PERL_TRY_UV_DIVIDE
1026 #ifdef PERL_TRY_UV_DIVIDE
1029 SvIV_please(TOPm1s);
1030 if (SvIOK(TOPm1s)) {
1031 bool left_non_neg = SvUOK(TOPm1s);
1032 bool right_non_neg = SvUOK(TOPs);
1036 if (right_non_neg) {
1037 right = SvUVX(TOPs);
1040 IV biv = SvIVX(TOPs);
1043 right_non_neg = TRUE; /* effectively it's a UV now */
1049 /* historically undef()/0 gives a "Use of uninitialized value"
1050 warning before dieing, hence this test goes here.
1051 If it were immediately before the second SvIV_please, then
1052 DIE() would be invoked before left was even inspected, so
1053 no inpsection would give no warning. */
1055 DIE(aTHX_ "Illegal division by zero");
1058 left = SvUVX(TOPm1s);
1061 IV aiv = SvIVX(TOPm1s);
1064 left_non_neg = TRUE; /* effectively it's a UV now */
1073 /* For sloppy divide we always attempt integer division. */
1075 /* Otherwise we only attempt it if either or both operands
1076 would not be preserved by an NV. If both fit in NVs
1077 we fall through to the NV divide code below. */
1078 && ((left > ((UV)1 << NV_PRESERVES_UV_BITS))
1079 || (right > ((UV)1 << NV_PRESERVES_UV_BITS)))
1082 /* Integer division can't overflow, but it can be imprecise. */
1083 UV result = left / right;
1084 if (result * right == left) {
1085 SP--; /* result is valid */
1086 if (left_non_neg == right_non_neg) {
1087 /* signs identical, result is positive. */
1091 /* 2s complement assumption */
1092 if (result <= (UV)IV_MIN)
1095 /* It's exact but too negative for IV. */
1096 SETn( -(NV)result );
1099 } /* tried integer divide but it was not an integer result */
1100 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1101 } /* left wasn't SvIOK */
1102 } /* right wasn't SvIOK */
1103 #endif /* PERL_TRY_UV_DIVIDE */
1107 DIE(aTHX_ "Illegal division by zero");
1108 PUSHn( left / right );
1115 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1121 bool use_double = FALSE;
1122 bool dright_valid = FALSE;
1128 right_neg = !SvUOK(TOPs);
1130 right = SvUVX(POPs);
1132 IV biv = SvIVX(POPs);
1135 right_neg = FALSE; /* effectively it's a UV now */
1143 right_neg = dright < 0;
1146 if (dright < UV_MAX_P1) {
1147 right = U_V(dright);
1148 dright_valid = TRUE; /* In case we need to use double below. */
1154 /* At this point use_double is only true if right is out of range for
1155 a UV. In range NV has been rounded down to nearest UV and
1156 use_double false. */
1158 if (!use_double && SvIOK(TOPs)) {
1160 left_neg = !SvUOK(TOPs);
1164 IV aiv = SvIVX(POPs);
1167 left_neg = FALSE; /* effectively it's a UV now */
1176 left_neg = dleft < 0;
1180 /* This should be exactly the 5.6 behaviour - if left and right are
1181 both in range for UV then use U_V() rather than floor. */
1183 if (dleft < UV_MAX_P1) {
1184 /* right was in range, so is dleft, so use UVs not double.
1188 /* left is out of range for UV, right was in range, so promote
1189 right (back) to double. */
1191 /* The +0.5 is used in 5.6 even though it is not strictly
1192 consistent with the implicit +0 floor in the U_V()
1193 inside the #if 1. */
1194 dleft = Perl_floor(dleft + 0.5);
1197 dright = Perl_floor(dright + 0.5);
1207 DIE(aTHX_ "Illegal modulus zero");
1209 dans = Perl_fmod(dleft, dright);
1210 if ((left_neg != right_neg) && dans)
1211 dans = dright - dans;
1214 sv_setnv(TARG, dans);
1220 DIE(aTHX_ "Illegal modulus zero");
1223 if ((left_neg != right_neg) && ans)
1226 /* XXX may warn: unary minus operator applied to unsigned type */
1227 /* could change -foo to be (~foo)+1 instead */
1228 if (ans <= ~((UV)IV_MAX)+1)
1229 sv_setiv(TARG, ~ans+1);
1231 sv_setnv(TARG, -(NV)ans);
1234 sv_setuv(TARG, ans);
1243 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1245 register IV count = POPi;
1246 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1248 I32 items = SP - MARK;
1251 max = items * count;
1256 *SP = sv_2mortal(newSVsv(*SP));
1262 repeatcpy((char*)(MARK + items), (char*)MARK,
1263 items * sizeof(SV*), count - 1);
1266 else if (count <= 0)
1269 else { /* Note: mark already snarfed by pp_list */
1274 SvSetSV(TARG, tmpstr);
1275 SvPV_force(TARG, len);
1276 isutf = DO_UTF8(TARG);
1281 SvGROW(TARG, (count * len) + 1);
1282 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1283 SvCUR(TARG) *= count;
1285 *SvEND(TARG) = '\0';
1288 (void)SvPOK_only_UTF8(TARG);
1290 (void)SvPOK_only(TARG);
1292 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1293 /* The parser saw this as a list repeat, and there
1294 are probably several items on the stack. But we're
1295 in scalar context, and there's no pp_list to save us
1296 now. So drop the rest of the items -- robin@kitsite.com
1309 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1310 useleft = USE_LEFT(TOPm1s);
1311 #ifdef PERL_PRESERVE_IVUV
1312 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1313 "bad things" happen if you rely on signed integers wrapping. */
1316 /* Unless the left argument is integer in range we are going to have to
1317 use NV maths. Hence only attempt to coerce the right argument if
1318 we know the left is integer. */
1319 register UV auv = 0;
1325 a_valid = auvok = 1;
1326 /* left operand is undef, treat as zero. */
1328 /* Left operand is defined, so is it IV? */
1329 SvIV_please(TOPm1s);
1330 if (SvIOK(TOPm1s)) {
1331 if ((auvok = SvUOK(TOPm1s)))
1332 auv = SvUVX(TOPm1s);
1334 register IV aiv = SvIVX(TOPm1s);
1337 auvok = 1; /* Now acting as a sign flag. */
1338 } else { /* 2s complement assumption for IV_MIN */
1346 bool result_good = 0;
1349 bool buvok = SvUOK(TOPs);
1354 register IV biv = SvIVX(TOPs);
1361 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1362 else "IV" now, independant of how it came in.
1363 if a, b represents positive, A, B negative, a maps to -A etc
1368 all UV maths. negate result if A negative.
1369 subtract if signs same, add if signs differ. */
1371 if (auvok ^ buvok) {
1380 /* Must get smaller */
1385 if (result <= buv) {
1386 /* result really should be -(auv-buv). as its negation
1387 of true value, need to swap our result flag */
1399 if (result <= (UV)IV_MIN)
1400 SETi( -(IV)result );
1402 /* result valid, but out of range for IV. */
1403 SETn( -(NV)result );
1407 } /* Overflow, drop through to NVs. */
1411 useleft = USE_LEFT(TOPm1s);
1415 /* left operand is undef, treat as zero - value */
1419 SETn( TOPn - value );
1426 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1429 if (PL_op->op_private & HINT_INTEGER) {
1443 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1446 if (PL_op->op_private & HINT_INTEGER) {
1460 dSP; tryAMAGICbinSET(lt,0);
1461 #ifdef PERL_PRESERVE_IVUV
1464 SvIV_please(TOPm1s);
1465 if (SvIOK(TOPm1s)) {
1466 bool auvok = SvUOK(TOPm1s);
1467 bool buvok = SvUOK(TOPs);
1469 if (!auvok && !buvok) { /* ## IV < IV ## */
1470 IV aiv = SvIVX(TOPm1s);
1471 IV biv = SvIVX(TOPs);
1474 SETs(boolSV(aiv < biv));
1477 if (auvok && buvok) { /* ## UV < UV ## */
1478 UV auv = SvUVX(TOPm1s);
1479 UV buv = SvUVX(TOPs);
1482 SETs(boolSV(auv < buv));
1485 if (auvok) { /* ## UV < IV ## */
1492 /* As (a) is a UV, it's >=0, so it cannot be < */
1497 if (auv >= (UV) IV_MAX) {
1498 /* As (b) is an IV, it cannot be > IV_MAX */
1502 SETs(boolSV(auv < (UV)biv));
1505 { /* ## IV < UV ## */
1509 aiv = SvIVX(TOPm1s);
1511 /* As (b) is a UV, it's >=0, so it must be < */
1518 if (buv > (UV) IV_MAX) {
1519 /* As (a) is an IV, it cannot be > IV_MAX */
1523 SETs(boolSV((UV)aiv < buv));
1531 SETs(boolSV(TOPn < value));
1538 dSP; tryAMAGICbinSET(gt,0);
1539 #ifdef PERL_PRESERVE_IVUV
1542 SvIV_please(TOPm1s);
1543 if (SvIOK(TOPm1s)) {
1544 bool auvok = SvUOK(TOPm1s);
1545 bool buvok = SvUOK(TOPs);
1547 if (!auvok && !buvok) { /* ## IV > IV ## */
1548 IV aiv = SvIVX(TOPm1s);
1549 IV biv = SvIVX(TOPs);
1552 SETs(boolSV(aiv > biv));
1555 if (auvok && buvok) { /* ## UV > UV ## */
1556 UV auv = SvUVX(TOPm1s);
1557 UV buv = SvUVX(TOPs);
1560 SETs(boolSV(auv > buv));
1563 if (auvok) { /* ## UV > IV ## */
1570 /* As (a) is a UV, it's >=0, so it must be > */
1575 if (auv > (UV) IV_MAX) {
1576 /* As (b) is an IV, it cannot be > IV_MAX */
1580 SETs(boolSV(auv > (UV)biv));
1583 { /* ## IV > UV ## */
1587 aiv = SvIVX(TOPm1s);
1589 /* As (b) is a UV, it's >=0, so it cannot be > */
1596 if (buv >= (UV) IV_MAX) {
1597 /* As (a) is an IV, it cannot be > IV_MAX */
1601 SETs(boolSV((UV)aiv > buv));
1609 SETs(boolSV(TOPn > value));
1616 dSP; tryAMAGICbinSET(le,0);
1617 #ifdef PERL_PRESERVE_IVUV
1620 SvIV_please(TOPm1s);
1621 if (SvIOK(TOPm1s)) {
1622 bool auvok = SvUOK(TOPm1s);
1623 bool buvok = SvUOK(TOPs);
1625 if (!auvok && !buvok) { /* ## IV <= IV ## */
1626 IV aiv = SvIVX(TOPm1s);
1627 IV biv = SvIVX(TOPs);
1630 SETs(boolSV(aiv <= biv));
1633 if (auvok && buvok) { /* ## UV <= UV ## */
1634 UV auv = SvUVX(TOPm1s);
1635 UV buv = SvUVX(TOPs);
1638 SETs(boolSV(auv <= buv));
1641 if (auvok) { /* ## UV <= IV ## */
1648 /* As (a) is a UV, it's >=0, so a cannot be <= */
1653 if (auv > (UV) IV_MAX) {
1654 /* As (b) is an IV, it cannot be > IV_MAX */
1658 SETs(boolSV(auv <= (UV)biv));
1661 { /* ## IV <= UV ## */
1665 aiv = SvIVX(TOPm1s);
1667 /* As (b) is a UV, it's >=0, so a must be <= */
1674 if (buv >= (UV) IV_MAX) {
1675 /* As (a) is an IV, it cannot be > IV_MAX */
1679 SETs(boolSV((UV)aiv <= buv));
1687 SETs(boolSV(TOPn <= value));
1694 dSP; tryAMAGICbinSET(ge,0);
1695 #ifdef PERL_PRESERVE_IVUV
1698 SvIV_please(TOPm1s);
1699 if (SvIOK(TOPm1s)) {
1700 bool auvok = SvUOK(TOPm1s);
1701 bool buvok = SvUOK(TOPs);
1703 if (!auvok && !buvok) { /* ## IV >= IV ## */
1704 IV aiv = SvIVX(TOPm1s);
1705 IV biv = SvIVX(TOPs);
1708 SETs(boolSV(aiv >= biv));
1711 if (auvok && buvok) { /* ## UV >= UV ## */
1712 UV auv = SvUVX(TOPm1s);
1713 UV buv = SvUVX(TOPs);
1716 SETs(boolSV(auv >= buv));
1719 if (auvok) { /* ## UV >= IV ## */
1726 /* As (a) is a UV, it's >=0, so it must be >= */
1731 if (auv >= (UV) IV_MAX) {
1732 /* As (b) is an IV, it cannot be > IV_MAX */
1736 SETs(boolSV(auv >= (UV)biv));
1739 { /* ## IV >= UV ## */
1743 aiv = SvIVX(TOPm1s);
1745 /* As (b) is a UV, it's >=0, so a cannot be >= */
1752 if (buv > (UV) IV_MAX) {
1753 /* As (a) is an IV, it cannot be > IV_MAX */
1757 SETs(boolSV((UV)aiv >= buv));
1765 SETs(boolSV(TOPn >= value));
1772 dSP; tryAMAGICbinSET(ne,0);
1773 #ifndef NV_PRESERVES_UV
1774 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1775 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1779 #ifdef PERL_PRESERVE_IVUV
1782 SvIV_please(TOPm1s);
1783 if (SvIOK(TOPm1s)) {
1784 bool auvok = SvUOK(TOPm1s);
1785 bool buvok = SvUOK(TOPs);
1787 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1788 IV aiv = SvIVX(TOPm1s);
1789 IV biv = SvIVX(TOPs);
1792 SETs(boolSV(aiv != biv));
1795 if (auvok && buvok) { /* ## UV != UV ## */
1796 UV auv = SvUVX(TOPm1s);
1797 UV buv = SvUVX(TOPs);
1800 SETs(boolSV(auv != buv));
1803 { /* ## Mixed IV,UV ## */
1807 /* != is commutative so swap if needed (save code) */
1809 /* swap. top of stack (b) is the iv */
1813 /* As (a) is a UV, it's >0, so it cannot be == */
1822 /* As (b) is a UV, it's >0, so it cannot be == */
1826 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1828 /* we know iv is >= 0 */
1829 if (uv > (UV) IV_MAX) {
1833 SETs(boolSV((UV)iv != uv));
1841 SETs(boolSV(TOPn != value));
1848 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1849 #ifndef NV_PRESERVES_UV
1850 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1851 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1855 #ifdef PERL_PRESERVE_IVUV
1856 /* Fortunately it seems NaN isn't IOK */
1859 SvIV_please(TOPm1s);
1860 if (SvIOK(TOPm1s)) {
1861 bool leftuvok = SvUOK(TOPm1s);
1862 bool rightuvok = SvUOK(TOPs);
1864 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1865 IV leftiv = SvIVX(TOPm1s);
1866 IV rightiv = SvIVX(TOPs);
1868 if (leftiv > rightiv)
1870 else if (leftiv < rightiv)
1874 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1875 UV leftuv = SvUVX(TOPm1s);
1876 UV rightuv = SvUVX(TOPs);
1878 if (leftuv > rightuv)
1880 else if (leftuv < rightuv)
1884 } else if (leftuvok) { /* ## UV <=> IV ## */
1888 rightiv = SvIVX(TOPs);
1890 /* As (a) is a UV, it's >=0, so it cannot be < */
1893 leftuv = SvUVX(TOPm1s);
1894 if (leftuv > (UV) IV_MAX) {
1895 /* As (b) is an IV, it cannot be > IV_MAX */
1897 } else if (leftuv > (UV)rightiv) {
1899 } else if (leftuv < (UV)rightiv) {
1905 } else { /* ## IV <=> UV ## */
1909 leftiv = SvIVX(TOPm1s);
1911 /* As (b) is a UV, it's >=0, so it must be < */
1914 rightuv = SvUVX(TOPs);
1915 if (rightuv > (UV) IV_MAX) {
1916 /* As (a) is an IV, it cannot be > IV_MAX */
1918 } else if (leftiv > (UV)rightuv) {
1920 } else if (leftiv < (UV)rightuv) {
1938 if (Perl_isnan(left) || Perl_isnan(right)) {
1942 value = (left > right) - (left < right);
1946 else if (left < right)
1948 else if (left > right)
1962 dSP; tryAMAGICbinSET(slt,0);
1965 int cmp = (IN_LOCALE_RUNTIME
1966 ? sv_cmp_locale(left, right)
1967 : sv_cmp(left, right));
1968 SETs(boolSV(cmp < 0));
1975 dSP; tryAMAGICbinSET(sgt,0);
1978 int cmp = (IN_LOCALE_RUNTIME
1979 ? sv_cmp_locale(left, right)
1980 : sv_cmp(left, right));
1981 SETs(boolSV(cmp > 0));
1988 dSP; tryAMAGICbinSET(sle,0);
1991 int cmp = (IN_LOCALE_RUNTIME
1992 ? sv_cmp_locale(left, right)
1993 : sv_cmp(left, right));
1994 SETs(boolSV(cmp <= 0));
2001 dSP; tryAMAGICbinSET(sge,0);
2004 int cmp = (IN_LOCALE_RUNTIME
2005 ? sv_cmp_locale(left, right)
2006 : sv_cmp(left, right));
2007 SETs(boolSV(cmp >= 0));
2014 dSP; tryAMAGICbinSET(seq,0);
2017 SETs(boolSV(sv_eq(left, right)));
2024 dSP; tryAMAGICbinSET(sne,0);
2027 SETs(boolSV(!sv_eq(left, right)));
2034 dSP; dTARGET; tryAMAGICbin(scmp,0);
2037 int cmp = (IN_LOCALE_RUNTIME
2038 ? sv_cmp_locale(left, right)
2039 : sv_cmp(left, right));
2047 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2050 if (SvNIOKp(left) || SvNIOKp(right)) {
2051 if (PL_op->op_private & HINT_INTEGER) {
2052 IV i = SvIV(left) & SvIV(right);
2056 UV u = SvUV(left) & SvUV(right);
2061 do_vop(PL_op->op_type, TARG, left, right);
2070 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2073 if (SvNIOKp(left) || SvNIOKp(right)) {
2074 if (PL_op->op_private & HINT_INTEGER) {
2075 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2079 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2084 do_vop(PL_op->op_type, TARG, left, right);
2093 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2096 if (SvNIOKp(left) || SvNIOKp(right)) {
2097 if (PL_op->op_private & HINT_INTEGER) {
2098 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2102 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2107 do_vop(PL_op->op_type, TARG, left, right);
2116 dSP; dTARGET; tryAMAGICun(neg);
2119 int flags = SvFLAGS(sv);
2122 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2123 /* It's publicly an integer, or privately an integer-not-float */
2126 if (SvIVX(sv) == IV_MIN) {
2127 /* 2s complement assumption. */
2128 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2131 else if (SvUVX(sv) <= IV_MAX) {
2136 else if (SvIVX(sv) != IV_MIN) {
2140 #ifdef PERL_PRESERVE_IVUV
2149 else if (SvPOKp(sv)) {
2151 char *s = SvPV(sv, len);
2152 if (isIDFIRST(*s)) {
2153 sv_setpvn(TARG, "-", 1);
2156 else if (*s == '+' || *s == '-') {
2158 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2160 else if (DO_UTF8(sv)) {
2163 goto oops_its_an_int;
2165 sv_setnv(TARG, -SvNV(sv));
2167 sv_setpvn(TARG, "-", 1);
2174 goto oops_its_an_int;
2175 sv_setnv(TARG, -SvNV(sv));
2187 dSP; tryAMAGICunSET(not);
2188 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2194 dSP; dTARGET; tryAMAGICun(compl);
2198 if (PL_op->op_private & HINT_INTEGER) {
2213 tmps = (U8*)SvPV_force(TARG, len);
2216 /* Calculate exact length, let's not estimate. */
2225 while (tmps < send) {
2226 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2227 tmps += UTF8SKIP(tmps);
2228 targlen += UNISKIP(~c);
2234 /* Now rewind strings and write them. */
2238 Newz(0, result, targlen + 1, U8);
2239 while (tmps < send) {
2240 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2241 tmps += UTF8SKIP(tmps);
2242 result = uvchr_to_utf8(result, ~c);
2246 sv_setpvn(TARG, (char*)result, targlen);
2250 Newz(0, result, nchar + 1, U8);
2251 while (tmps < send) {
2252 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2253 tmps += UTF8SKIP(tmps);
2258 sv_setpvn(TARG, (char*)result, nchar);
2266 register long *tmpl;
2267 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2270 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2275 for ( ; anum > 0; anum--, tmps++)
2284 /* integer versions of some of the above */
2288 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2291 SETi( left * right );
2298 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2302 DIE(aTHX_ "Illegal division by zero");
2303 value = POPi / value;
2311 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2315 DIE(aTHX_ "Illegal modulus zero");
2316 SETi( left % right );
2323 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2326 SETi( left + right );
2333 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2336 SETi( left - right );
2343 dSP; tryAMAGICbinSET(lt,0);
2346 SETs(boolSV(left < right));
2353 dSP; tryAMAGICbinSET(gt,0);
2356 SETs(boolSV(left > right));
2363 dSP; tryAMAGICbinSET(le,0);
2366 SETs(boolSV(left <= right));
2373 dSP; tryAMAGICbinSET(ge,0);
2376 SETs(boolSV(left >= right));
2383 dSP; tryAMAGICbinSET(eq,0);
2386 SETs(boolSV(left == right));
2393 dSP; tryAMAGICbinSET(ne,0);
2396 SETs(boolSV(left != right));
2403 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2410 else if (left < right)
2421 dSP; dTARGET; tryAMAGICun(neg);
2426 /* High falutin' math. */
2430 dSP; dTARGET; tryAMAGICbin(atan2,0);
2433 SETn(Perl_atan2(left, right));
2440 dSP; dTARGET; tryAMAGICun(sin);
2444 value = Perl_sin(value);
2452 dSP; dTARGET; tryAMAGICun(cos);
2456 value = Perl_cos(value);
2462 /* Support Configure command-line overrides for rand() functions.
2463 After 5.005, perhaps we should replace this by Configure support
2464 for drand48(), random(), or rand(). For 5.005, though, maintain
2465 compatibility by calling rand() but allow the user to override it.
2466 See INSTALL for details. --Andy Dougherty 15 July 1998
2468 /* Now it's after 5.005, and Configure supports drand48() and random(),
2469 in addition to rand(). So the overrides should not be needed any more.
2470 --Jarkko Hietaniemi 27 September 1998
2473 #ifndef HAS_DRAND48_PROTO
2474 extern double drand48 (void);
2487 if (!PL_srand_called) {
2488 (void)seedDrand01((Rand_seed_t)seed());
2489 PL_srand_called = TRUE;
2504 (void)seedDrand01((Rand_seed_t)anum);
2505 PL_srand_called = TRUE;
2514 * This is really just a quick hack which grabs various garbage
2515 * values. It really should be a real hash algorithm which
2516 * spreads the effect of every input bit onto every output bit,
2517 * if someone who knows about such things would bother to write it.
2518 * Might be a good idea to add that function to CORE as well.
2519 * No numbers below come from careful analysis or anything here,
2520 * except they are primes and SEED_C1 > 1E6 to get a full-width
2521 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2522 * probably be bigger too.
2525 # define SEED_C1 1000003
2526 #define SEED_C4 73819
2528 # define SEED_C1 25747
2529 #define SEED_C4 20639
2533 #define SEED_C5 26107
2535 #ifndef PERL_NO_DEV_RANDOM
2540 # include <starlet.h>
2541 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2542 * in 100-ns units, typically incremented ever 10 ms. */
2543 unsigned int when[2];
2545 # ifdef HAS_GETTIMEOFDAY
2546 struct timeval when;
2552 /* This test is an escape hatch, this symbol isn't set by Configure. */
2553 #ifndef PERL_NO_DEV_RANDOM
2554 #ifndef PERL_RANDOM_DEVICE
2555 /* /dev/random isn't used by default because reads from it will block
2556 * if there isn't enough entropy available. You can compile with
2557 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2558 * is enough real entropy to fill the seed. */
2559 # define PERL_RANDOM_DEVICE "/dev/urandom"
2561 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2563 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2572 _ckvmssts(sys$gettim(when));
2573 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2575 # ifdef HAS_GETTIMEOFDAY
2576 gettimeofday(&when,(struct timezone *) 0);
2577 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2580 u = (U32)SEED_C1 * when;
2583 u += SEED_C3 * (U32)PerlProc_getpid();
2584 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2585 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2586 u += SEED_C5 * (U32)PTR2UV(&when);
2593 dSP; dTARGET; tryAMAGICun(exp);
2597 value = Perl_exp(value);
2605 dSP; dTARGET; tryAMAGICun(log);
2610 SET_NUMERIC_STANDARD();
2611 DIE(aTHX_ "Can't take log of %g", value);
2613 value = Perl_log(value);
2621 dSP; dTARGET; tryAMAGICun(sqrt);
2626 SET_NUMERIC_STANDARD();
2627 DIE(aTHX_ "Can't take sqrt of %g", value);
2629 value = Perl_sqrt(value);
2637 dSP; dTARGET; tryAMAGICun(int);
2640 IV iv = TOPi; /* attempt to convert to IV if possible. */
2641 /* XXX it's arguable that compiler casting to IV might be subtly
2642 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2643 else preferring IV has introduced a subtle behaviour change bug. OTOH
2644 relying on floating point to be accurate is a bug. */
2655 if (value < (NV)UV_MAX + 0.5) {
2658 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2659 # ifdef HAS_MODFL_POW32_BUG
2660 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2662 NV offset = Perl_modf(value, &value);
2663 (void)Perl_modf(offset, &offset);
2667 (void)Perl_modf(value, &value);
2670 double tmp = (double)value;
2671 (void)Perl_modf(tmp, &tmp);
2678 if (value > (NV)IV_MIN - 0.5) {
2681 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2682 # ifdef HAS_MODFL_POW32_BUG
2683 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2685 NV offset = Perl_modf(-value, &value);
2686 (void)Perl_modf(offset, &offset);
2690 (void)Perl_modf(-value, &value);
2694 double tmp = (double)value;
2695 (void)Perl_modf(-tmp, &tmp);
2708 dSP; dTARGET; tryAMAGICun(abs);
2710 /* This will cache the NV value if string isn't actually integer */
2714 /* IVX is precise */
2716 SETu(TOPu); /* force it to be numeric only */
2724 /* 2s complement assumption. Also, not really needed as
2725 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2745 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2750 tmps = (SvPVx(POPs, len));
2751 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2752 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2765 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2770 tmps = (SvPVx(POPs, len));
2771 while (*tmps && len && isSPACE(*tmps))
2776 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2777 else if (*tmps == 'b')
2778 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2780 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2782 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2799 SETi(sv_len_utf8(sv));
2815 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2817 I32 arybase = PL_curcop->cop_arybase;
2821 int num_args = PL_op->op_private & 7;
2822 bool repl_need_utf8_upgrade = FALSE;
2823 bool repl_is_utf8 = FALSE;
2825 SvTAINTED_off(TARG); /* decontaminate */
2826 SvUTF8_off(TARG); /* decontaminate */
2830 repl = SvPV(repl_sv, repl_len);
2831 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2841 sv_utf8_upgrade(sv);
2843 else if (DO_UTF8(sv))
2844 repl_need_utf8_upgrade = TRUE;
2846 tmps = SvPV(sv, curlen);
2848 utf8_curlen = sv_len_utf8(sv);
2849 if (utf8_curlen == curlen)
2852 curlen = utf8_curlen;
2857 if (pos >= arybase) {
2875 else if (len >= 0) {
2877 if (rem > (I32)curlen)
2892 Perl_croak(aTHX_ "substr outside of string");
2893 if (ckWARN(WARN_SUBSTR))
2894 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2901 sv_pos_u2b(sv, &pos, &rem);
2903 sv_setpvn(TARG, tmps, rem);
2904 #ifdef USE_LOCALE_COLLATE
2905 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2910 SV* repl_sv_copy = NULL;
2912 if (repl_need_utf8_upgrade) {
2913 repl_sv_copy = newSVsv(repl_sv);
2914 sv_utf8_upgrade(repl_sv_copy);
2915 repl = SvPV(repl_sv_copy, repl_len);
2916 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2918 sv_insert(sv, pos, rem, repl, repl_len);
2922 SvREFCNT_dec(repl_sv_copy);
2924 else if (lvalue) { /* it's an lvalue! */
2925 if (!SvGMAGICAL(sv)) {
2929 if (ckWARN(WARN_SUBSTR))
2930 Perl_warner(aTHX_ WARN_SUBSTR,
2931 "Attempt to use reference as lvalue in substr");
2933 if (SvOK(sv)) /* is it defined ? */
2934 (void)SvPOK_only_UTF8(sv);
2936 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2939 if (SvTYPE(TARG) < SVt_PVLV) {
2940 sv_upgrade(TARG, SVt_PVLV);
2941 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2945 if (LvTARG(TARG) != sv) {
2947 SvREFCNT_dec(LvTARG(TARG));
2948 LvTARG(TARG) = SvREFCNT_inc(sv);
2950 LvTARGOFF(TARG) = upos;
2951 LvTARGLEN(TARG) = urem;
2955 PUSHs(TARG); /* avoid SvSETMAGIC here */
2962 register IV size = POPi;
2963 register IV offset = POPi;
2964 register SV *src = POPs;
2965 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2967 SvTAINTED_off(TARG); /* decontaminate */
2968 if (lvalue) { /* it's an lvalue! */
2969 if (SvTYPE(TARG) < SVt_PVLV) {
2970 sv_upgrade(TARG, SVt_PVLV);
2971 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2974 if (LvTARG(TARG) != src) {
2976 SvREFCNT_dec(LvTARG(TARG));
2977 LvTARG(TARG) = SvREFCNT_inc(src);
2979 LvTARGOFF(TARG) = offset;
2980 LvTARGLEN(TARG) = size;
2983 sv_setuv(TARG, do_vecget(src, offset, size));
2998 I32 arybase = PL_curcop->cop_arybase;
3003 offset = POPi - arybase;
3006 tmps = SvPV(big, biglen);
3007 if (offset > 0 && DO_UTF8(big))
3008 sv_pos_u2b(big, &offset, 0);
3011 else if (offset > biglen)
3013 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3014 (unsigned char*)tmps + biglen, little, 0)))
3017 retval = tmps2 - tmps;
3018 if (retval > 0 && DO_UTF8(big))
3019 sv_pos_b2u(big, &retval);
3020 PUSHi(retval + arybase);
3035 I32 arybase = PL_curcop->cop_arybase;
3041 tmps2 = SvPV(little, llen);
3042 tmps = SvPV(big, blen);
3046 if (offset > 0 && DO_UTF8(big))
3047 sv_pos_u2b(big, &offset, 0);
3048 offset = offset - arybase + llen;
3052 else if (offset > blen)
3054 if (!(tmps2 = rninstr(tmps, tmps + offset,
3055 tmps2, tmps2 + llen)))
3058 retval = tmps2 - tmps;
3059 if (retval > 0 && DO_UTF8(big))
3060 sv_pos_b2u(big, &retval);
3061 PUSHi(retval + arybase);
3067 dSP; dMARK; dORIGMARK; dTARGET;
3068 do_sprintf(TARG, SP-MARK, MARK+1);
3069 TAINT_IF(SvTAINTED(TARG));
3070 if (DO_UTF8(*(MARK+1)))
3082 U8 *s = (U8*)SvPVx(argsv, len);
3084 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3094 (void)SvUPGRADE(TARG,SVt_PV);
3096 if (value > 255 && !IN_BYTES) {
3097 SvGROW(TARG, UNISKIP(value)+1);
3098 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3099 SvCUR_set(TARG, tmps - SvPVX(TARG));
3101 (void)SvPOK_only(TARG);
3112 (void)SvPOK_only(TARG);
3119 dSP; dTARGET; dPOPTOPssrl;
3123 char *tmps = SvPV(left, len);
3125 if (DO_UTF8(left)) {
3126 /* If Unicode take the crypt() of the low 8 bits
3127 * of the characters of the string. */
3129 char *send = tmps + len;
3131 Newz(688, t, len, char);
3133 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3139 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3141 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3146 "The crypt() function is unimplemented due to excessive paranoia.");
3160 U8 tmpbuf[UTF8_MAXLEN*2+1];
3164 s = (U8*)SvPV(sv, slen);
3165 utf8_to_uvchr(s, &ulen);
3167 toTITLE_utf8(s, tmpbuf, &tculen);
3168 utf8_to_uvchr(tmpbuf, 0);
3170 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3172 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3173 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3178 s = (U8*)SvPV_force(sv, slen);
3179 Copy(tmpbuf, s, tculen, U8);
3183 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3185 SvUTF8_off(TARG); /* decontaminate */
3190 s = (U8*)SvPV_force(sv, slen);
3192 if (IN_LOCALE_RUNTIME) {
3195 *s = toUPPER_LC(*s);
3213 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3215 U8 tmpbuf[UTF8_MAXLEN*2+1];
3219 toLOWER_utf8(s, tmpbuf, &ulen);
3220 uv = utf8_to_uvchr(tmpbuf, 0);
3222 tend = uvchr_to_utf8(tmpbuf, uv);
3224 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3226 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3227 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3232 s = (U8*)SvPV_force(sv, slen);
3233 Copy(tmpbuf, s, ulen, U8);
3237 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3239 SvUTF8_off(TARG); /* decontaminate */
3244 s = (U8*)SvPV_force(sv, slen);
3246 if (IN_LOCALE_RUNTIME) {
3249 *s = toLOWER_LC(*s);
3272 U8 tmpbuf[UTF8_MAXLEN*2+1];
3274 s = (U8*)SvPV(sv,len);
3276 SvUTF8_off(TARG); /* decontaminate */
3277 sv_setpvn(TARG, "", 0);
3281 (void)SvUPGRADE(TARG, SVt_PV);
3282 SvGROW(TARG, (len * 2) + 1);
3283 (void)SvPOK_only(TARG);
3284 d = (U8*)SvPVX(TARG);
3287 toUPPER_utf8(s, tmpbuf, &ulen);
3288 Copy(tmpbuf, d, ulen, U8);
3294 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3299 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3301 SvUTF8_off(TARG); /* decontaminate */
3306 s = (U8*)SvPV_force(sv, len);
3308 register U8 *send = s + len;
3310 if (IN_LOCALE_RUNTIME) {
3313 for (; s < send; s++)
3314 *s = toUPPER_LC(*s);
3317 for (; s < send; s++)
3339 U8 tmpbuf[UTF8_MAXLEN*2+1];
3341 s = (U8*)SvPV(sv,len);
3343 SvUTF8_off(TARG); /* decontaminate */
3344 sv_setpvn(TARG, "", 0);
3348 (void)SvUPGRADE(TARG, SVt_PV);
3349 SvGROW(TARG, (len * 2) + 1);
3350 (void)SvPOK_only(TARG);
3351 d = (U8*)SvPVX(TARG);
3354 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3355 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3356 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3358 * Now if the sigma is NOT followed by
3359 * /$ignorable_sequence$cased_letter/;
3360 * and it IS preceded by
3361 * /$cased_letter$ignorable_sequence/;
3362 * where $ignorable_sequence is
3363 * [\x{2010}\x{AD}\p{Mn}]*
3364 * and $cased_letter is
3365 * [\p{Ll}\p{Lo}\p{Lt}]
3366 * then it should be mapped to 0x03C2,
3367 * (GREEK SMALL LETTER FINAL SIGMA),
3368 * instead of staying 0x03A3.
3369 * See lib/unicore/SpecCase.txt.
3372 Copy(tmpbuf, d, ulen, U8);
3378 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3383 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3385 SvUTF8_off(TARG); /* decontaminate */
3391 s = (U8*)SvPV_force(sv, len);
3393 register U8 *send = s + len;
3395 if (IN_LOCALE_RUNTIME) {
3398 for (; s < send; s++)
3399 *s = toLOWER_LC(*s);
3402 for (; s < send; s++)
3417 register char *s = SvPV(sv,len);
3420 SvUTF8_off(TARG); /* decontaminate */
3422 (void)SvUPGRADE(TARG, SVt_PV);
3423 SvGROW(TARG, (len * 2) + 1);
3427 if (UTF8_IS_CONTINUED(*s)) {
3428 STRLEN ulen = UTF8SKIP(s);
3452 SvCUR_set(TARG, d - SvPVX(TARG));
3453 (void)SvPOK_only_UTF8(TARG);
3456 sv_setpvn(TARG, s, len);
3458 if (SvSMAGICAL(TARG))
3467 dSP; dMARK; dORIGMARK;
3469 register AV* av = (AV*)POPs;
3470 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3471 I32 arybase = PL_curcop->cop_arybase;
3474 if (SvTYPE(av) == SVt_PVAV) {
3475 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3477 for (svp = MARK + 1; svp <= SP; svp++) {
3482 if (max > AvMAX(av))
3485 while (++MARK <= SP) {
3486 elem = SvIVx(*MARK);
3490 svp = av_fetch(av, elem, lval);
3492 if (!svp || *svp == &PL_sv_undef)
3493 DIE(aTHX_ PL_no_aelem, elem);
3494 if (PL_op->op_private & OPpLVAL_INTRO)
3495 save_aelem(av, elem, svp);
3497 *MARK = svp ? *svp : &PL_sv_undef;
3500 if (GIMME != G_ARRAY) {
3508 /* Associative arrays. */
3513 HV *hash = (HV*)POPs;
3515 I32 gimme = GIMME_V;
3516 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3519 /* might clobber stack_sp */
3520 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3525 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3526 if (gimme == G_ARRAY) {
3529 /* might clobber stack_sp */
3531 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3536 else if (gimme == G_SCALAR)
3555 I32 gimme = GIMME_V;
3556 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3560 if (PL_op->op_private & OPpSLICE) {
3564 hvtype = SvTYPE(hv);
3565 if (hvtype == SVt_PVHV) { /* hash element */
3566 while (++MARK <= SP) {
3567 sv = hv_delete_ent(hv, *MARK, discard, 0);
3568 *MARK = sv ? sv : &PL_sv_undef;
3571 else if (hvtype == SVt_PVAV) {
3572 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3573 while (++MARK <= SP) {
3574 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3575 *MARK = sv ? sv : &PL_sv_undef;
3578 else { /* pseudo-hash element */
3579 while (++MARK <= SP) {
3580 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3581 *MARK = sv ? sv : &PL_sv_undef;
3586 DIE(aTHX_ "Not a HASH reference");
3589 else if (gimme == G_SCALAR) {
3598 if (SvTYPE(hv) == SVt_PVHV)
3599 sv = hv_delete_ent(hv, keysv, discard, 0);
3600 else if (SvTYPE(hv) == SVt_PVAV) {
3601 if (PL_op->op_flags & OPf_SPECIAL)
3602 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3604 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3607 DIE(aTHX_ "Not a HASH reference");
3622 if (PL_op->op_private & OPpEXISTS_SUB) {
3626 cv = sv_2cv(sv, &hv, &gv, FALSE);
3629 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3635 if (SvTYPE(hv) == SVt_PVHV) {
3636 if (hv_exists_ent(hv, tmpsv, 0))
3639 else if (SvTYPE(hv) == SVt_PVAV) {
3640 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3641 if (av_exists((AV*)hv, SvIV(tmpsv)))
3644 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3648 DIE(aTHX_ "Not a HASH reference");
3655 dSP; dMARK; dORIGMARK;
3656 register HV *hv = (HV*)POPs;
3657 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3658 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3660 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3661 DIE(aTHX_ "Can't localize pseudo-hash element");
3663 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3664 while (++MARK <= SP) {
3667 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3668 realhv ? hv_exists_ent(hv, keysv, 0)
3669 : avhv_exists_ent((AV*)hv, keysv, 0);
3671 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3672 svp = he ? &HeVAL(he) : 0;
3675 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3678 if (!svp || *svp == &PL_sv_undef) {
3680 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3682 if (PL_op->op_private & OPpLVAL_INTRO) {
3684 save_helem(hv, keysv, svp);
3687 char *key = SvPV(keysv, keylen);
3688 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3692 *MARK = svp ? *svp : &PL_sv_undef;
3695 if (GIMME != G_ARRAY) {
3703 /* List operators. */
3708 if (GIMME != G_ARRAY) {
3710 *MARK = *SP; /* unwanted list, return last item */
3712 *MARK = &PL_sv_undef;
3721 SV **lastrelem = PL_stack_sp;
3722 SV **lastlelem = PL_stack_base + POPMARK;
3723 SV **firstlelem = PL_stack_base + POPMARK + 1;
3724 register SV **firstrelem = lastlelem + 1;
3725 I32 arybase = PL_curcop->cop_arybase;
3726 I32 lval = PL_op->op_flags & OPf_MOD;
3727 I32 is_something_there = lval;
3729 register I32 max = lastrelem - lastlelem;
3730 register SV **lelem;
3733 if (GIMME != G_ARRAY) {
3734 ix = SvIVx(*lastlelem);
3739 if (ix < 0 || ix >= max)
3740 *firstlelem = &PL_sv_undef;
3742 *firstlelem = firstrelem[ix];
3748 SP = firstlelem - 1;
3752 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3758 if (ix < 0 || ix >= max)
3759 *lelem = &PL_sv_undef;
3761 is_something_there = TRUE;
3762 if (!(*lelem = firstrelem[ix]))
3763 *lelem = &PL_sv_undef;
3766 if (is_something_there)
3769 SP = firstlelem - 1;
3775 dSP; dMARK; dORIGMARK;
3776 I32 items = SP - MARK;
3777 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3778 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3785 dSP; dMARK; dORIGMARK;
3786 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3790 SV *val = NEWSV(46, 0);
3792 sv_setsv(val, *++MARK);
3793 else if (ckWARN(WARN_MISC))
3794 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3795 (void)hv_store_ent(hv,key,val,0);
3804 dSP; dMARK; dORIGMARK;
3805 register AV *ary = (AV*)*++MARK;
3809 register I32 offset;
3810 register I32 length;
3817 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3818 *MARK-- = SvTIED_obj((SV*)ary, mg);
3822 call_method("SPLICE",GIMME_V);
3831 offset = i = SvIVx(*MARK);
3833 offset += AvFILLp(ary) + 1;
3835 offset -= PL_curcop->cop_arybase;
3837 DIE(aTHX_ PL_no_aelem, i);
3839 length = SvIVx(*MARK++);
3841 length += AvFILLp(ary) - offset + 1;
3847 length = AvMAX(ary) + 1; /* close enough to infinity */
3851 length = AvMAX(ary) + 1;
3853 if (offset > AvFILLp(ary) + 1)
3854 offset = AvFILLp(ary) + 1;
3855 after = AvFILLp(ary) + 1 - (offset + length);
3856 if (after < 0) { /* not that much array */
3857 length += after; /* offset+length now in array */
3863 /* At this point, MARK .. SP-1 is our new LIST */
3866 diff = newlen - length;
3867 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3870 if (diff < 0) { /* shrinking the area */
3872 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3873 Copy(MARK, tmparyval, newlen, SV*);
3876 MARK = ORIGMARK + 1;
3877 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3878 MEXTEND(MARK, length);
3879 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3881 EXTEND_MORTAL(length);
3882 for (i = length, dst = MARK; i; i--) {
3883 sv_2mortal(*dst); /* free them eventualy */
3890 *MARK = AvARRAY(ary)[offset+length-1];
3893 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3894 SvREFCNT_dec(*dst++); /* free them now */
3897 AvFILLp(ary) += diff;
3899 /* pull up or down? */
3901 if (offset < after) { /* easier to pull up */
3902 if (offset) { /* esp. if nothing to pull */
3903 src = &AvARRAY(ary)[offset-1];
3904 dst = src - diff; /* diff is negative */
3905 for (i = offset; i > 0; i--) /* can't trust Copy */
3909 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3913 if (after) { /* anything to pull down? */
3914 src = AvARRAY(ary) + offset + length;
3915 dst = src + diff; /* diff is negative */
3916 Move(src, dst, after, SV*);
3918 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3919 /* avoid later double free */
3923 dst[--i] = &PL_sv_undef;
3926 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3928 *dst = NEWSV(46, 0);
3929 sv_setsv(*dst++, *src++);
3931 Safefree(tmparyval);
3934 else { /* no, expanding (or same) */
3936 New(452, tmparyval, length, SV*); /* so remember deletion */
3937 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3940 if (diff > 0) { /* expanding */
3942 /* push up or down? */
3944 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3948 Move(src, dst, offset, SV*);
3950 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3952 AvFILLp(ary) += diff;
3955 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3956 av_extend(ary, AvFILLp(ary) + diff);
3957 AvFILLp(ary) += diff;
3960 dst = AvARRAY(ary) + AvFILLp(ary);
3962 for (i = after; i; i--) {
3969 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3970 *dst = NEWSV(46, 0);
3971 sv_setsv(*dst++, *src++);
3973 MARK = ORIGMARK + 1;
3974 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3976 Copy(tmparyval, MARK, length, SV*);
3978 EXTEND_MORTAL(length);
3979 for (i = length, dst = MARK; i; i--) {
3980 sv_2mortal(*dst); /* free them eventualy */
3984 Safefree(tmparyval);
3988 else if (length--) {
3989 *MARK = tmparyval[length];
3992 while (length-- > 0)
3993 SvREFCNT_dec(tmparyval[length]);
3995 Safefree(tmparyval);
3998 *MARK = &PL_sv_undef;
4006 dSP; dMARK; dORIGMARK; dTARGET;
4007 register AV *ary = (AV*)*++MARK;
4008 register SV *sv = &PL_sv_undef;
4011 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4012 *MARK-- = SvTIED_obj((SV*)ary, mg);
4016 call_method("PUSH",G_SCALAR|G_DISCARD);
4021 /* Why no pre-extend of ary here ? */
4022 for (++MARK; MARK <= SP; MARK++) {
4025 sv_setsv(sv, *MARK);
4030 PUSHi( AvFILL(ary) + 1 );
4038 SV *sv = av_pop(av);
4040 (void)sv_2mortal(sv);
4049 SV *sv = av_shift(av);
4054 (void)sv_2mortal(sv);
4061 dSP; dMARK; dORIGMARK; dTARGET;
4062 register AV *ary = (AV*)*++MARK;
4067 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4068 *MARK-- = SvTIED_obj((SV*)ary, mg);
4072 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4077 av_unshift(ary, SP - MARK);
4080 sv_setsv(sv, *++MARK);
4081 (void)av_store(ary, i++, sv);
4085 PUSHi( AvFILL(ary) + 1 );
4095 if (GIMME == G_ARRAY) {
4102 /* safe as long as stack cannot get extended in the above */
4107 register char *down;
4112 SvUTF8_off(TARG); /* decontaminate */
4114 do_join(TARG, &PL_sv_no, MARK, SP);
4116 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4117 up = SvPV_force(TARG, len);
4119 if (DO_UTF8(TARG)) { /* first reverse each character */
4120 U8* s = (U8*)SvPVX(TARG);
4121 U8* send = (U8*)(s + len);
4123 if (UTF8_IS_INVARIANT(*s)) {
4128 if (!utf8_to_uvchr(s, 0))
4132 down = (char*)(s - 1);
4133 /* reverse this character */
4143 down = SvPVX(TARG) + len - 1;
4149 (void)SvPOK_only_UTF8(TARG);
4161 register IV limit = POPi; /* note, negative is forever */
4164 register char *s = SvPV(sv, len);
4165 bool do_utf8 = DO_UTF8(sv);
4166 char *strend = s + len;
4168 register REGEXP *rx;
4172 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4173 I32 maxiters = slen + 10;
4176 I32 origlimit = limit;
4179 AV *oldstack = PL_curstack;
4180 I32 gimme = GIMME_V;
4181 I32 oldsave = PL_savestack_ix;
4182 I32 make_mortal = 1;
4183 MAGIC *mg = (MAGIC *) NULL;
4186 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4191 DIE(aTHX_ "panic: pp_split");
4194 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4195 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4197 PL_reg_match_utf8 = do_utf8;
4199 if (pm->op_pmreplroot) {
4201 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4203 ary = GvAVn((GV*)pm->op_pmreplroot);
4206 else if (gimme != G_ARRAY)
4207 #ifdef USE_5005THREADS
4208 ary = (AV*)PL_curpad[0];
4210 ary = GvAVn(PL_defgv);
4211 #endif /* USE_5005THREADS */
4214 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4220 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4222 XPUSHs(SvTIED_obj((SV*)ary, mg));
4228 for (i = AvFILLp(ary); i >= 0; i--)
4229 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4231 /* temporarily switch stacks */
4232 SWITCHSTACK(PL_curstack, ary);
4236 base = SP - PL_stack_base;
4238 if (pm->op_pmflags & PMf_SKIPWHITE) {
4239 if (pm->op_pmflags & PMf_LOCALE) {
4240 while (isSPACE_LC(*s))
4248 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4249 SAVEINT(PL_multiline);
4250 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4254 limit = maxiters + 2;
4255 if (pm->op_pmflags & PMf_WHITE) {
4258 while (m < strend &&
4259 !((pm->op_pmflags & PMf_LOCALE)
4260 ? isSPACE_LC(*m) : isSPACE(*m)))
4265 dstr = NEWSV(30, m-s);
4266 sv_setpvn(dstr, s, m-s);
4270 (void)SvUTF8_on(dstr);
4274 while (s < strend &&
4275 ((pm->op_pmflags & PMf_LOCALE)
4276 ? isSPACE_LC(*s) : isSPACE(*s)))
4280 else if (strEQ("^", rx->precomp)) {
4283 for (m = s; m < strend && *m != '\n'; m++) ;
4287 dstr = NEWSV(30, m-s);
4288 sv_setpvn(dstr, s, m-s);
4292 (void)SvUTF8_on(dstr);
4297 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4298 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4299 && (rx->reganch & ROPT_CHECK_ALL)
4300 && !(rx->reganch & ROPT_ANCH)) {
4301 int tail = (rx->reganch & RE_INTUIT_TAIL);
4302 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4305 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4307 char c = *SvPV(csv, n_a);
4310 for (m = s; m < strend && *m != c; m++) ;
4313 dstr = NEWSV(30, m-s);
4314 sv_setpvn(dstr, s, m-s);
4318 (void)SvUTF8_on(dstr);
4320 /* The rx->minlen is in characters but we want to step
4321 * s ahead by bytes. */
4323 s = (char*)utf8_hop((U8*)m, len);
4325 s = m + len; /* Fake \n at the end */
4330 while (s < strend && --limit &&
4331 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4332 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4335 dstr = NEWSV(31, m-s);
4336 sv_setpvn(dstr, s, m-s);
4340 (void)SvUTF8_on(dstr);
4342 /* The rx->minlen is in characters but we want to step
4343 * s ahead by bytes. */
4345 s = (char*)utf8_hop((U8*)m, len);
4347 s = m + len; /* Fake \n at the end */
4352 maxiters += slen * rx->nparens;
4353 while (s < strend && --limit
4354 /* && (!rx->check_substr
4355 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4357 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4358 1 /* minend */, sv, NULL, 0))
4360 TAINT_IF(RX_MATCH_TAINTED(rx));
4361 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4366 strend = s + (strend - m);
4368 m = rx->startp[0] + orig;
4369 dstr = NEWSV(32, m-s);
4370 sv_setpvn(dstr, s, m-s);
4374 (void)SvUTF8_on(dstr);
4377 for (i = 1; i <= rx->nparens; i++) {
4378 s = rx->startp[i] + orig;
4379 m = rx->endp[i] + orig;
4381 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4382 parens that didn't match -- they should be set to
4383 undef, not the empty string */
4384 if (m >= orig && s >= orig) {
4385 dstr = NEWSV(33, m-s);
4386 sv_setpvn(dstr, s, m-s);
4389 dstr = &PL_sv_undef; /* undef, not "" */
4393 (void)SvUTF8_on(dstr);
4397 s = rx->endp[0] + orig;
4401 LEAVE_SCOPE(oldsave);
4402 iters = (SP - PL_stack_base) - base;
4403 if (iters > maxiters)
4404 DIE(aTHX_ "Split loop");
4406 /* keep field after final delim? */
4407 if (s < strend || (iters && origlimit)) {
4408 STRLEN l = strend - s;
4409 dstr = NEWSV(34, l);
4410 sv_setpvn(dstr, s, l);
4414 (void)SvUTF8_on(dstr);
4418 else if (!origlimit) {
4419 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4425 SWITCHSTACK(ary, oldstack);
4426 if (SvSMAGICAL(ary)) {
4431 if (gimme == G_ARRAY) {
4433 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4441 call_method("PUSH",G_SCALAR|G_DISCARD);
4444 if (gimme == G_ARRAY) {
4445 /* EXTEND should not be needed - we just popped them */
4447 for (i=0; i < iters; i++) {
4448 SV **svp = av_fetch(ary, i, FALSE);
4449 PUSHs((svp) ? *svp : &PL_sv_undef);
4456 if (gimme == G_ARRAY)
4459 if (iters || !pm->op_pmreplroot) {
4467 #ifdef USE_5005THREADS
4469 Perl_unlock_condpair(pTHX_ void *svv)
4471 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4474 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4475 MUTEX_LOCK(MgMUTEXP(mg));
4476 if (MgOWNER(mg) != thr)
4477 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4479 COND_SIGNAL(MgOWNERCONDP(mg));
4480 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4481 PTR2UV(thr), PTR2UV(svv)));
4482 MUTEX_UNLOCK(MgMUTEXP(mg));
4484 #endif /* USE_5005THREADS */
4491 #ifdef USE_5005THREADS
4493 #endif /* USE_5005THREADS */
4495 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4497 Perl_sharedsv_lock(aTHX_ ssv);
4498 #endif /* USE_ITHREADS */
4499 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4500 || SvTYPE(retsv) == SVt_PVCV) {
4501 retsv = refto(retsv);
4509 #ifdef USE_5005THREADS
4512 if (PL_op->op_private & OPpLVAL_INTRO)
4513 PUSHs(*save_threadsv(PL_op->op_targ));
4515 PUSHs(THREADSV(PL_op->op_targ));
4518 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4519 #endif /* USE_5005THREADS */