3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
19 /* variations on pp_null */
21 /* XXX I can't imagine anyone who doesn't have this actually _needs_
22 it, since pid_t is an integral type.
25 #ifdef NEED_GETPID_PROTO
26 extern Pid_t getpid (void);
32 if (GIMME_V == G_SCALAR)
47 if (PL_op->op_private & OPpLVAL_INTRO)
48 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
50 if (PL_op->op_flags & OPf_REF) {
54 if (GIMME == G_SCALAR)
55 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
59 if (GIMME == G_ARRAY) {
60 I32 maxarg = AvFILL((AV*)TARG) + 1;
62 if (SvMAGICAL(TARG)) {
64 for (i=0; i < maxarg; i++) {
65 SV **svp = av_fetch((AV*)TARG, i, FALSE);
66 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
70 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
75 SV* sv = sv_newmortal();
76 I32 maxarg = AvFILL((AV*)TARG) + 1;
89 if (PL_op->op_private & OPpLVAL_INTRO)
90 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
91 if (PL_op->op_flags & OPf_REF)
94 if (GIMME == G_SCALAR)
95 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
99 if (gimme == G_ARRAY) {
102 else if (gimme == G_SCALAR) {
103 SV* sv = sv_newmortal();
104 if (HvFILL((HV*)TARG))
105 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
106 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
116 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
127 tryAMAGICunDEREF(to_gv);
130 if (SvTYPE(sv) == SVt_PVIO) {
131 GV *gv = (GV*) sv_newmortal();
132 gv_init(gv, 0, "", 0, 0);
133 GvIOp(gv) = (IO *)sv;
134 (void)SvREFCNT_inc(sv);
137 else if (SvTYPE(sv) != SVt_PVGV)
138 DIE(aTHX_ "Not a GLOB reference");
141 if (SvTYPE(sv) != SVt_PVGV) {
145 if (SvGMAGICAL(sv)) {
150 if (!SvOK(sv) && sv != &PL_sv_undef) {
151 /* If this is a 'my' scalar and flag is set then vivify
154 if (PL_op->op_private & OPpDEREF) {
157 if (cUNOP->op_targ) {
159 SV *namesv = PL_curpad[cUNOP->op_targ];
160 name = SvPV(namesv, len);
161 gv = (GV*)NEWSV(0,0);
162 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
165 name = CopSTASHPV(PL_curcop);
168 if (SvTYPE(sv) < SVt_RV)
169 sv_upgrade(sv, SVt_RV);
175 if (PL_op->op_flags & OPf_REF ||
176 PL_op->op_private & HINT_STRICT_REFS)
177 DIE(aTHX_ PL_no_usym, "a symbol");
178 if (ckWARN(WARN_UNINITIALIZED))
183 if ((PL_op->op_flags & OPf_SPECIAL) &&
184 !(PL_op->op_flags & OPf_MOD))
186 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
188 && (!is_gv_magical(sym,len,0)
189 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
195 if (PL_op->op_private & HINT_STRICT_REFS)
196 DIE(aTHX_ PL_no_symref, sym, "a symbol");
197 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
201 if (PL_op->op_private & OPpLVAL_INTRO)
202 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
213 tryAMAGICunDEREF(to_sv);
216 switch (SvTYPE(sv)) {
220 DIE(aTHX_ "Not a SCALAR reference");
228 if (SvTYPE(gv) != SVt_PVGV) {
229 if (SvGMAGICAL(sv)) {
235 if (PL_op->op_flags & OPf_REF ||
236 PL_op->op_private & HINT_STRICT_REFS)
237 DIE(aTHX_ PL_no_usym, "a SCALAR");
238 if (ckWARN(WARN_UNINITIALIZED))
243 if ((PL_op->op_flags & OPf_SPECIAL) &&
244 !(PL_op->op_flags & OPf_MOD))
246 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
248 && (!is_gv_magical(sym,len,0)
249 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
255 if (PL_op->op_private & HINT_STRICT_REFS)
256 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
257 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
262 if (PL_op->op_flags & OPf_MOD) {
263 if (PL_op->op_private & OPpLVAL_INTRO)
264 sv = save_scalar((GV*)TOPs);
265 else if (PL_op->op_private & OPpDEREF)
266 vivify_ref(sv, PL_op->op_private & OPpDEREF);
276 SV *sv = AvARYLEN(av);
278 AvARYLEN(av) = sv = NEWSV(0,0);
279 sv_upgrade(sv, SVt_IV);
280 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
288 dSP; dTARGET; dPOPss;
290 if (PL_op->op_flags & OPf_MOD || LVRET) {
291 if (SvTYPE(TARG) < SVt_PVLV) {
292 sv_upgrade(TARG, SVt_PVLV);
293 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
297 if (LvTARG(TARG) != sv) {
299 SvREFCNT_dec(LvTARG(TARG));
300 LvTARG(TARG) = SvREFCNT_inc(sv);
302 PUSHs(TARG); /* no SvSETMAGIC */
308 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
309 mg = mg_find(sv, PERL_MAGIC_regex_global);
310 if (mg && mg->mg_len >= 0) {
314 PUSHi(i + PL_curcop->cop_arybase);
328 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
329 /* (But not in defined().) */
330 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
333 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
334 if ((PL_op->op_private & OPpLVAL_INTRO)) {
335 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
338 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
342 cv = (CV*)&PL_sv_undef;
356 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
357 char *s = SvPVX(TOPs);
358 if (strnEQ(s, "CORE::", 6)) {
361 code = keyword(s + 6, SvCUR(TOPs) - 6);
362 if (code < 0) { /* Overridable. */
363 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
364 int i = 0, n = 0, seen_question = 0;
366 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
368 while (i < MAXO) { /* The slow way. */
369 if (strEQ(s + 6, PL_op_name[i])
370 || strEQ(s + 6, PL_op_desc[i]))
376 goto nonesuch; /* Should not happen... */
378 oa = PL_opargs[i] >> OASHIFT;
380 if (oa & OA_OPTIONAL && !seen_question) {
384 else if (n && str[0] == ';' && seen_question)
385 goto set; /* XXXX system, exec */
386 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
387 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
388 /* But globs are already references (kinda) */
389 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
393 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
397 ret = sv_2mortal(newSVpvn(str, n - 1));
399 else if (code) /* Non-Overridable */
401 else { /* None such */
403 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
407 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
409 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
418 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
420 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
436 if (GIMME != G_ARRAY) {
440 *MARK = &PL_sv_undef;
441 *MARK = refto(*MARK);
445 EXTEND_MORTAL(SP - MARK);
447 *MARK = refto(*MARK);
452 S_refto(pTHX_ SV *sv)
456 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
459 if (!(sv = LvTARG(sv)))
462 (void)SvREFCNT_inc(sv);
464 else if (SvTYPE(sv) == SVt_PVAV) {
465 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
468 (void)SvREFCNT_inc(sv);
470 else if (SvPADTMP(sv) && !IS_PADGV(sv))
474 (void)SvREFCNT_inc(sv);
477 sv_upgrade(rv, SVt_RV);
491 if (sv && SvGMAGICAL(sv))
494 if (!sv || !SvROK(sv))
498 pv = sv_reftype(sv,TRUE);
499 PUSHp(pv, strlen(pv));
509 stash = CopSTASH(PL_curcop);
515 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
516 Perl_croak(aTHX_ "Attempt to bless into a reference");
518 if (ckWARN(WARN_MISC) && len == 0)
519 Perl_warner(aTHX_ WARN_MISC,
520 "Explicit blessing to '' (assuming package main)");
521 stash = gv_stashpvn(ptr, len, TRUE);
524 (void)sv_bless(TOPs, stash);
538 elem = SvPV(sv, n_a);
542 switch (elem ? *elem : '\0')
545 if (strEQ(elem, "ARRAY"))
546 tmpRef = (SV*)GvAV(gv);
549 if (strEQ(elem, "CODE"))
550 tmpRef = (SV*)GvCVu(gv);
553 if (strEQ(elem, "FILEHANDLE")) {
554 /* finally deprecated in 5.8.0 */
555 deprecate("*glob{FILEHANDLE}");
556 tmpRef = (SV*)GvIOp(gv);
559 if (strEQ(elem, "FORMAT"))
560 tmpRef = (SV*)GvFORM(gv);
563 if (strEQ(elem, "GLOB"))
567 if (strEQ(elem, "HASH"))
568 tmpRef = (SV*)GvHV(gv);
571 if (strEQ(elem, "IO"))
572 tmpRef = (SV*)GvIOp(gv);
575 if (strEQ(elem, "NAME"))
576 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
579 if (strEQ(elem, "PACKAGE"))
580 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
583 if (strEQ(elem, "SCALAR"))
597 /* Pattern matching */
602 register unsigned char *s;
605 register I32 *sfirst;
609 if (sv == PL_lastscream) {
615 SvSCREAM_off(PL_lastscream);
616 SvREFCNT_dec(PL_lastscream);
618 PL_lastscream = SvREFCNT_inc(sv);
621 s = (unsigned char*)(SvPV(sv, len));
625 if (pos > PL_maxscream) {
626 if (PL_maxscream < 0) {
627 PL_maxscream = pos + 80;
628 New(301, PL_screamfirst, 256, I32);
629 New(302, PL_screamnext, PL_maxscream, I32);
632 PL_maxscream = pos + pos / 4;
633 Renew(PL_screamnext, PL_maxscream, I32);
637 sfirst = PL_screamfirst;
638 snext = PL_screamnext;
640 if (!sfirst || !snext)
641 DIE(aTHX_ "do_study: out of memory");
643 for (ch = 256; ch; --ch)
650 snext[pos] = sfirst[ch] - pos;
657 /* piggyback on m//g magic */
658 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
667 if (PL_op->op_flags & OPf_STACKED)
673 TARG = sv_newmortal();
678 /* Lvalue operators. */
690 dSP; dMARK; dTARGET; dORIGMARK;
692 do_chop(TARG, *++MARK);
701 SETi(do_chomp(TOPs));
708 register I32 count = 0;
711 count += do_chomp(POPs);
722 if (!sv || !SvANY(sv))
724 switch (SvTYPE(sv)) {
726 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
727 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
731 if (HvARRAY(sv) || SvGMAGICAL(sv)
732 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
736 if (CvROOT(sv) || CvXSUB(sv))
753 if (!PL_op->op_private) {
762 if (SvTHINKFIRST(sv))
765 switch (SvTYPE(sv)) {
775 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
776 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
777 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
781 /* let user-undef'd sub keep its identity */
782 GV* gv = CvGV((CV*)sv);
789 SvSetMagicSV(sv, &PL_sv_undef);
793 Newz(602, gp, 1, GP);
794 GvGP(sv) = gp_ref(gp);
795 GvSV(sv) = NEWSV(72,0);
796 GvLINE(sv) = CopLINE(PL_curcop);
802 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
805 SvPV_set(sv, Nullch);
818 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
819 DIE(aTHX_ PL_no_modify);
820 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
821 SvIVX(TOPs) != IV_MIN)
824 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
835 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
836 DIE(aTHX_ PL_no_modify);
837 sv_setsv(TARG, TOPs);
838 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
839 SvIVX(TOPs) != IV_MAX)
842 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
856 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
857 DIE(aTHX_ PL_no_modify);
858 sv_setsv(TARG, TOPs);
859 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
860 SvIVX(TOPs) != IV_MIN)
863 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 /* Ordinary operators. */
876 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
879 SETn( Perl_pow( left, right) );
886 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
887 #ifdef PERL_PRESERVE_IVUV
890 /* Unless the left argument is integer in range we are going to have to
891 use NV maths. Hence only attempt to coerce the right argument if
892 we know the left is integer. */
893 /* Left operand is defined, so is it IV? */
896 bool auvok = SvUOK(TOPm1s);
897 bool buvok = SvUOK(TOPs);
898 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
899 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
906 alow = SvUVX(TOPm1s);
908 IV aiv = SvIVX(TOPm1s);
911 auvok = TRUE; /* effectively it's a UV now */
913 alow = -aiv; /* abs, auvok == false records sign */
919 IV biv = SvIVX(TOPs);
922 buvok = TRUE; /* effectively it's a UV now */
924 blow = -biv; /* abs, buvok == false records sign */
928 /* If this does sign extension on unsigned it's time for plan B */
929 ahigh = alow >> (4 * sizeof (UV));
931 bhigh = blow >> (4 * sizeof (UV));
933 if (ahigh && bhigh) {
934 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
935 which is overflow. Drop to NVs below. */
936 } else if (!ahigh && !bhigh) {
937 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
938 so the unsigned multiply cannot overflow. */
939 UV product = alow * blow;
940 if (auvok == buvok) {
941 /* -ve * -ve or +ve * +ve gives a +ve result. */
945 } else if (product <= (UV)IV_MIN) {
946 /* 2s complement assumption that (UV)-IV_MIN is correct. */
947 /* -ve result, which could overflow an IV */
949 SETi( -(IV)product );
951 } /* else drop to NVs below. */
953 /* One operand is large, 1 small */
956 /* swap the operands */
958 bhigh = blow; /* bhigh now the temp var for the swap */
962 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
963 multiplies can't overflow. shift can, add can, -ve can. */
964 product_middle = ahigh * blow;
965 if (!(product_middle & topmask)) {
966 /* OK, (ahigh * blow) won't lose bits when we shift it. */
968 product_middle <<= (4 * sizeof (UV));
969 product_low = alow * blow;
971 /* as for pp_add, UV + something mustn't get smaller.
972 IIRC ANSI mandates this wrapping *behaviour* for
973 unsigned whatever the actual representation*/
974 product_low += product_middle;
975 if (product_low >= product_middle) {
976 /* didn't overflow */
977 if (auvok == buvok) {
978 /* -ve * -ve or +ve * +ve gives a +ve result. */
982 } else if (product_low <= (UV)IV_MIN) {
983 /* 2s complement assumption again */
984 /* -ve result, which could overflow an IV */
986 SETi( -(IV)product_low );
988 } /* else drop to NVs below. */
990 } /* product_middle too large */
991 } /* ahigh && bhigh */
992 } /* SvIOK(TOPm1s) */
997 SETn( left * right );
1004 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1005 /* Only try to do UV divide first
1006 if ((SLOPPYDIVIDE is true) or
1007 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1009 The assumption is that it is better to use floating point divide
1010 whenever possible, only doing integer divide first if we can't be sure.
1011 If NV_PRESERVES_UV is true then we know at compile time that no UV
1012 can be too large to preserve, so don't need to compile the code to
1013 test the size of UVs. */
1016 # define PERL_TRY_UV_DIVIDE
1017 /* ensure that 20./5. == 4. */
1019 # ifdef PERL_PRESERVE_IVUV
1020 # ifndef NV_PRESERVES_UV
1021 # define PERL_TRY_UV_DIVIDE
1026 #ifdef PERL_TRY_UV_DIVIDE
1029 SvIV_please(TOPm1s);
1030 if (SvIOK(TOPm1s)) {
1031 bool left_non_neg = SvUOK(TOPm1s);
1032 bool right_non_neg = SvUOK(TOPs);
1036 if (right_non_neg) {
1037 right = SvUVX(TOPs);
1040 IV biv = SvIVX(TOPs);
1043 right_non_neg = TRUE; /* effectively it's a UV now */
1049 /* historically undef()/0 gives a "Use of uninitialized value"
1050 warning before dieing, hence this test goes here.
1051 If it were immediately before the second SvIV_please, then
1052 DIE() would be invoked before left was even inspected, so
1053 no inpsection would give no warning. */
1055 DIE(aTHX_ "Illegal division by zero");
1058 left = SvUVX(TOPm1s);
1061 IV aiv = SvIVX(TOPm1s);
1064 left_non_neg = TRUE; /* effectively it's a UV now */
1073 /* For sloppy divide we always attempt integer division. */
1075 /* Otherwise we only attempt it if either or both operands
1076 would not be preserved by an NV. If both fit in NVs
1077 we fall through to the NV divide code below. */
1078 && ((left > ((UV)1 << NV_PRESERVES_UV_BITS))
1079 || (right > ((UV)1 << NV_PRESERVES_UV_BITS)))
1082 /* Integer division can't overflow, but it can be imprecise. */
1083 UV result = left / right;
1084 if (result * right == left) {
1085 SP--; /* result is valid */
1086 if (left_non_neg == right_non_neg) {
1087 /* signs identical, result is positive. */
1091 /* 2s complement assumption */
1092 if (result <= (UV)IV_MIN)
1095 /* It's exact but too negative for IV. */
1096 SETn( -(NV)result );
1099 } /* tried integer divide but it was not an integer result */
1100 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1101 } /* left wasn't SvIOK */
1102 } /* right wasn't SvIOK */
1103 #endif /* PERL_TRY_UV_DIVIDE */
1107 DIE(aTHX_ "Illegal division by zero");
1108 PUSHn( left / right );
1115 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1121 bool use_double = FALSE;
1122 bool dright_valid = FALSE;
1128 right_neg = !SvUOK(TOPs);
1130 right = SvUVX(POPs);
1132 IV biv = SvIVX(POPs);
1135 right_neg = FALSE; /* effectively it's a UV now */
1143 right_neg = dright < 0;
1146 if (dright < UV_MAX_P1) {
1147 right = U_V(dright);
1148 dright_valid = TRUE; /* In case we need to use double below. */
1154 /* At this point use_double is only true if right is out of range for
1155 a UV. In range NV has been rounded down to nearest UV and
1156 use_double false. */
1158 if (!use_double && SvIOK(TOPs)) {
1160 left_neg = !SvUOK(TOPs);
1164 IV aiv = SvIVX(POPs);
1167 left_neg = FALSE; /* effectively it's a UV now */
1176 left_neg = dleft < 0;
1180 /* This should be exactly the 5.6 behaviour - if left and right are
1181 both in range for UV then use U_V() rather than floor. */
1183 if (dleft < UV_MAX_P1) {
1184 /* right was in range, so is dleft, so use UVs not double.
1188 /* left is out of range for UV, right was in range, so promote
1189 right (back) to double. */
1191 /* The +0.5 is used in 5.6 even though it is not strictly
1192 consistent with the implicit +0 floor in the U_V()
1193 inside the #if 1. */
1194 dleft = Perl_floor(dleft + 0.5);
1197 dright = Perl_floor(dright + 0.5);
1207 DIE(aTHX_ "Illegal modulus zero");
1209 dans = Perl_fmod(dleft, dright);
1210 if ((left_neg != right_neg) && dans)
1211 dans = dright - dans;
1214 sv_setnv(TARG, dans);
1220 DIE(aTHX_ "Illegal modulus zero");
1223 if ((left_neg != right_neg) && ans)
1226 /* XXX may warn: unary minus operator applied to unsigned type */
1227 /* could change -foo to be (~foo)+1 instead */
1228 if (ans <= ~((UV)IV_MAX)+1)
1229 sv_setiv(TARG, ~ans+1);
1231 sv_setnv(TARG, -(NV)ans);
1234 sv_setuv(TARG, ans);
1243 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1245 register IV count = POPi;
1246 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1248 I32 items = SP - MARK;
1251 max = items * count;
1256 *SP = sv_2mortal(newSVsv(*SP));
1262 repeatcpy((char*)(MARK + items), (char*)MARK,
1263 items * sizeof(SV*), count - 1);
1266 else if (count <= 0)
1269 else { /* Note: mark already snarfed by pp_list */
1274 SvSetSV(TARG, tmpstr);
1275 SvPV_force(TARG, len);
1276 isutf = DO_UTF8(TARG);
1281 SvGROW(TARG, (count * len) + 1);
1282 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1283 SvCUR(TARG) *= count;
1285 *SvEND(TARG) = '\0';
1288 (void)SvPOK_only_UTF8(TARG);
1290 (void)SvPOK_only(TARG);
1292 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1293 /* The parser saw this as a list repeat, and there
1294 are probably several items on the stack. But we're
1295 in scalar context, and there's no pp_list to save us
1296 now. So drop the rest of the items -- robin@kitsite.com
1309 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1310 useleft = USE_LEFT(TOPm1s);
1311 #ifdef PERL_PRESERVE_IVUV
1312 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1313 "bad things" happen if you rely on signed integers wrapping. */
1316 /* Unless the left argument is integer in range we are going to have to
1317 use NV maths. Hence only attempt to coerce the right argument if
1318 we know the left is integer. */
1319 register UV auv = 0;
1325 a_valid = auvok = 1;
1326 /* left operand is undef, treat as zero. */
1328 /* Left operand is defined, so is it IV? */
1329 SvIV_please(TOPm1s);
1330 if (SvIOK(TOPm1s)) {
1331 if ((auvok = SvUOK(TOPm1s)))
1332 auv = SvUVX(TOPm1s);
1334 register IV aiv = SvIVX(TOPm1s);
1337 auvok = 1; /* Now acting as a sign flag. */
1338 } else { /* 2s complement assumption for IV_MIN */
1346 bool result_good = 0;
1349 bool buvok = SvUOK(TOPs);
1354 register IV biv = SvIVX(TOPs);
1361 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1362 else "IV" now, independant of how it came in.
1363 if a, b represents positive, A, B negative, a maps to -A etc
1368 all UV maths. negate result if A negative.
1369 subtract if signs same, add if signs differ. */
1371 if (auvok ^ buvok) {
1380 /* Must get smaller */
1385 if (result <= buv) {
1386 /* result really should be -(auv-buv). as its negation
1387 of true value, need to swap our result flag */
1399 if (result <= (UV)IV_MIN)
1400 SETi( -(IV)result );
1402 /* result valid, but out of range for IV. */
1403 SETn( -(NV)result );
1407 } /* Overflow, drop through to NVs. */
1411 useleft = USE_LEFT(TOPm1s);
1415 /* left operand is undef, treat as zero - value */
1419 SETn( TOPn - value );
1426 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1429 if (PL_op->op_private & HINT_INTEGER) {
1443 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1446 if (PL_op->op_private & HINT_INTEGER) {
1460 dSP; tryAMAGICbinSET(lt,0);
1461 #ifdef PERL_PRESERVE_IVUV
1464 SvIV_please(TOPm1s);
1465 if (SvIOK(TOPm1s)) {
1466 bool auvok = SvUOK(TOPm1s);
1467 bool buvok = SvUOK(TOPs);
1469 if (!auvok && !buvok) { /* ## IV < IV ## */
1470 IV aiv = SvIVX(TOPm1s);
1471 IV biv = SvIVX(TOPs);
1474 SETs(boolSV(aiv < biv));
1477 if (auvok && buvok) { /* ## UV < UV ## */
1478 UV auv = SvUVX(TOPm1s);
1479 UV buv = SvUVX(TOPs);
1482 SETs(boolSV(auv < buv));
1485 if (auvok) { /* ## UV < IV ## */
1492 /* As (a) is a UV, it's >=0, so it cannot be < */
1497 if (auv >= (UV) IV_MAX) {
1498 /* As (b) is an IV, it cannot be > IV_MAX */
1502 SETs(boolSV(auv < (UV)biv));
1505 { /* ## IV < UV ## */
1509 aiv = SvIVX(TOPm1s);
1511 /* As (b) is a UV, it's >=0, so it must be < */
1518 if (buv > (UV) IV_MAX) {
1519 /* As (a) is an IV, it cannot be > IV_MAX */
1523 SETs(boolSV((UV)aiv < buv));
1531 SETs(boolSV(TOPn < value));
1538 dSP; tryAMAGICbinSET(gt,0);
1539 #ifdef PERL_PRESERVE_IVUV
1542 SvIV_please(TOPm1s);
1543 if (SvIOK(TOPm1s)) {
1544 bool auvok = SvUOK(TOPm1s);
1545 bool buvok = SvUOK(TOPs);
1547 if (!auvok && !buvok) { /* ## IV > IV ## */
1548 IV aiv = SvIVX(TOPm1s);
1549 IV biv = SvIVX(TOPs);
1552 SETs(boolSV(aiv > biv));
1555 if (auvok && buvok) { /* ## UV > UV ## */
1556 UV auv = SvUVX(TOPm1s);
1557 UV buv = SvUVX(TOPs);
1560 SETs(boolSV(auv > buv));
1563 if (auvok) { /* ## UV > IV ## */
1570 /* As (a) is a UV, it's >=0, so it must be > */
1575 if (auv > (UV) IV_MAX) {
1576 /* As (b) is an IV, it cannot be > IV_MAX */
1580 SETs(boolSV(auv > (UV)biv));
1583 { /* ## IV > UV ## */
1587 aiv = SvIVX(TOPm1s);
1589 /* As (b) is a UV, it's >=0, so it cannot be > */
1596 if (buv >= (UV) IV_MAX) {
1597 /* As (a) is an IV, it cannot be > IV_MAX */
1601 SETs(boolSV((UV)aiv > buv));
1609 SETs(boolSV(TOPn > value));
1616 dSP; tryAMAGICbinSET(le,0);
1617 #ifdef PERL_PRESERVE_IVUV
1620 SvIV_please(TOPm1s);
1621 if (SvIOK(TOPm1s)) {
1622 bool auvok = SvUOK(TOPm1s);
1623 bool buvok = SvUOK(TOPs);
1625 if (!auvok && !buvok) { /* ## IV <= IV ## */
1626 IV aiv = SvIVX(TOPm1s);
1627 IV biv = SvIVX(TOPs);
1630 SETs(boolSV(aiv <= biv));
1633 if (auvok && buvok) { /* ## UV <= UV ## */
1634 UV auv = SvUVX(TOPm1s);
1635 UV buv = SvUVX(TOPs);
1638 SETs(boolSV(auv <= buv));
1641 if (auvok) { /* ## UV <= IV ## */
1648 /* As (a) is a UV, it's >=0, so a cannot be <= */
1653 if (auv > (UV) IV_MAX) {
1654 /* As (b) is an IV, it cannot be > IV_MAX */
1658 SETs(boolSV(auv <= (UV)biv));
1661 { /* ## IV <= UV ## */
1665 aiv = SvIVX(TOPm1s);
1667 /* As (b) is a UV, it's >=0, so a must be <= */
1674 if (buv >= (UV) IV_MAX) {
1675 /* As (a) is an IV, it cannot be > IV_MAX */
1679 SETs(boolSV((UV)aiv <= buv));
1687 SETs(boolSV(TOPn <= value));
1694 dSP; tryAMAGICbinSET(ge,0);
1695 #ifdef PERL_PRESERVE_IVUV
1698 SvIV_please(TOPm1s);
1699 if (SvIOK(TOPm1s)) {
1700 bool auvok = SvUOK(TOPm1s);
1701 bool buvok = SvUOK(TOPs);
1703 if (!auvok && !buvok) { /* ## IV >= IV ## */
1704 IV aiv = SvIVX(TOPm1s);
1705 IV biv = SvIVX(TOPs);
1708 SETs(boolSV(aiv >= biv));
1711 if (auvok && buvok) { /* ## UV >= UV ## */
1712 UV auv = SvUVX(TOPm1s);
1713 UV buv = SvUVX(TOPs);
1716 SETs(boolSV(auv >= buv));
1719 if (auvok) { /* ## UV >= IV ## */
1726 /* As (a) is a UV, it's >=0, so it must be >= */
1731 if (auv >= (UV) IV_MAX) {
1732 /* As (b) is an IV, it cannot be > IV_MAX */
1736 SETs(boolSV(auv >= (UV)biv));
1739 { /* ## IV >= UV ## */
1743 aiv = SvIVX(TOPm1s);
1745 /* As (b) is a UV, it's >=0, so a cannot be >= */
1752 if (buv > (UV) IV_MAX) {
1753 /* As (a) is an IV, it cannot be > IV_MAX */
1757 SETs(boolSV((UV)aiv >= buv));
1765 SETs(boolSV(TOPn >= value));
1772 dSP; tryAMAGICbinSET(ne,0);
1773 #ifndef NV_PRESERVES_UV
1774 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1775 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1779 #ifdef PERL_PRESERVE_IVUV
1782 SvIV_please(TOPm1s);
1783 if (SvIOK(TOPm1s)) {
1784 bool auvok = SvUOK(TOPm1s);
1785 bool buvok = SvUOK(TOPs);
1787 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1788 IV aiv = SvIVX(TOPm1s);
1789 IV biv = SvIVX(TOPs);
1792 SETs(boolSV(aiv != biv));
1795 if (auvok && buvok) { /* ## UV != UV ## */
1796 UV auv = SvUVX(TOPm1s);
1797 UV buv = SvUVX(TOPs);
1800 SETs(boolSV(auv != buv));
1803 { /* ## Mixed IV,UV ## */
1807 /* != is commutative so swap if needed (save code) */
1809 /* swap. top of stack (b) is the iv */
1813 /* As (a) is a UV, it's >0, so it cannot be == */
1822 /* As (b) is a UV, it's >0, so it cannot be == */
1826 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1828 /* we know iv is >= 0 */
1829 if (uv > (UV) IV_MAX) {
1833 SETs(boolSV((UV)iv != uv));
1841 SETs(boolSV(TOPn != value));
1848 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1849 #ifndef NV_PRESERVES_UV
1850 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1851 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1855 #ifdef PERL_PRESERVE_IVUV
1856 /* Fortunately it seems NaN isn't IOK */
1859 SvIV_please(TOPm1s);
1860 if (SvIOK(TOPm1s)) {
1861 bool leftuvok = SvUOK(TOPm1s);
1862 bool rightuvok = SvUOK(TOPs);
1864 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1865 IV leftiv = SvIVX(TOPm1s);
1866 IV rightiv = SvIVX(TOPs);
1868 if (leftiv > rightiv)
1870 else if (leftiv < rightiv)
1874 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1875 UV leftuv = SvUVX(TOPm1s);
1876 UV rightuv = SvUVX(TOPs);
1878 if (leftuv > rightuv)
1880 else if (leftuv < rightuv)
1884 } else if (leftuvok) { /* ## UV <=> IV ## */
1888 rightiv = SvIVX(TOPs);
1890 /* As (a) is a UV, it's >=0, so it cannot be < */
1893 leftuv = SvUVX(TOPm1s);
1894 if (leftuv > (UV) IV_MAX) {
1895 /* As (b) is an IV, it cannot be > IV_MAX */
1897 } else if (leftuv > (UV)rightiv) {
1899 } else if (leftuv < (UV)rightiv) {
1905 } else { /* ## IV <=> UV ## */
1909 leftiv = SvIVX(TOPm1s);
1911 /* As (b) is a UV, it's >=0, so it must be < */
1914 rightuv = SvUVX(TOPs);
1915 if (rightuv > (UV) IV_MAX) {
1916 /* As (a) is an IV, it cannot be > IV_MAX */
1918 } else if (leftiv > (UV)rightuv) {
1920 } else if (leftiv < (UV)rightuv) {
1938 if (Perl_isnan(left) || Perl_isnan(right)) {
1942 value = (left > right) - (left < right);
1946 else if (left < right)
1948 else if (left > right)
1962 dSP; tryAMAGICbinSET(slt,0);
1965 int cmp = (IN_LOCALE_RUNTIME
1966 ? sv_cmp_locale(left, right)
1967 : sv_cmp(left, right));
1968 SETs(boolSV(cmp < 0));
1975 dSP; tryAMAGICbinSET(sgt,0);
1978 int cmp = (IN_LOCALE_RUNTIME
1979 ? sv_cmp_locale(left, right)
1980 : sv_cmp(left, right));
1981 SETs(boolSV(cmp > 0));
1988 dSP; tryAMAGICbinSET(sle,0);
1991 int cmp = (IN_LOCALE_RUNTIME
1992 ? sv_cmp_locale(left, right)
1993 : sv_cmp(left, right));
1994 SETs(boolSV(cmp <= 0));
2001 dSP; tryAMAGICbinSET(sge,0);
2004 int cmp = (IN_LOCALE_RUNTIME
2005 ? sv_cmp_locale(left, right)
2006 : sv_cmp(left, right));
2007 SETs(boolSV(cmp >= 0));
2014 dSP; tryAMAGICbinSET(seq,0);
2017 SETs(boolSV(sv_eq(left, right)));
2024 dSP; tryAMAGICbinSET(sne,0);
2027 SETs(boolSV(!sv_eq(left, right)));
2034 dSP; dTARGET; tryAMAGICbin(scmp,0);
2037 int cmp = (IN_LOCALE_RUNTIME
2038 ? sv_cmp_locale(left, right)
2039 : sv_cmp(left, right));
2047 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2050 if (SvNIOKp(left) || SvNIOKp(right)) {
2051 if (PL_op->op_private & HINT_INTEGER) {
2052 IV i = SvIV(left) & SvIV(right);
2056 UV u = SvUV(left) & SvUV(right);
2061 do_vop(PL_op->op_type, TARG, left, right);
2070 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2073 if (SvNIOKp(left) || SvNIOKp(right)) {
2074 if (PL_op->op_private & HINT_INTEGER) {
2075 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2079 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2084 do_vop(PL_op->op_type, TARG, left, right);
2093 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2096 if (SvNIOKp(left) || SvNIOKp(right)) {
2097 if (PL_op->op_private & HINT_INTEGER) {
2098 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2102 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2107 do_vop(PL_op->op_type, TARG, left, right);
2116 dSP; dTARGET; tryAMAGICun(neg);
2119 int flags = SvFLAGS(sv);
2122 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2123 /* It's publicly an integer, or privately an integer-not-float */
2126 if (SvIVX(sv) == IV_MIN) {
2127 /* 2s complement assumption. */
2128 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2131 else if (SvUVX(sv) <= IV_MAX) {
2136 else if (SvIVX(sv) != IV_MIN) {
2140 #ifdef PERL_PRESERVE_IVUV
2149 else if (SvPOKp(sv)) {
2151 char *s = SvPV(sv, len);
2152 if (isIDFIRST(*s)) {
2153 sv_setpvn(TARG, "-", 1);
2156 else if (*s == '+' || *s == '-') {
2158 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2160 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2161 sv_setpvn(TARG, "-", 1);
2167 goto oops_its_an_int;
2168 sv_setnv(TARG, -SvNV(sv));
2180 dSP; tryAMAGICunSET(not);
2181 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2187 dSP; dTARGET; tryAMAGICun(compl);
2191 if (PL_op->op_private & HINT_INTEGER) {
2206 tmps = (U8*)SvPV_force(TARG, len);
2209 /* Calculate exact length, let's not estimate. */
2218 while (tmps < send) {
2219 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2220 tmps += UTF8SKIP(tmps);
2221 targlen += UNISKIP(~c);
2227 /* Now rewind strings and write them. */
2231 Newz(0, result, targlen + 1, U8);
2232 while (tmps < send) {
2233 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2234 tmps += UTF8SKIP(tmps);
2235 result = uvchr_to_utf8(result, ~c);
2239 sv_setpvn(TARG, (char*)result, targlen);
2243 Newz(0, result, nchar + 1, U8);
2244 while (tmps < send) {
2245 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2246 tmps += UTF8SKIP(tmps);
2251 sv_setpvn(TARG, (char*)result, nchar);
2259 register long *tmpl;
2260 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2263 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2268 for ( ; anum > 0; anum--, tmps++)
2277 /* integer versions of some of the above */
2281 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2284 SETi( left * right );
2291 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2295 DIE(aTHX_ "Illegal division by zero");
2296 value = POPi / value;
2304 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2308 DIE(aTHX_ "Illegal modulus zero");
2309 SETi( left % right );
2316 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2319 SETi( left + right );
2326 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2329 SETi( left - right );
2336 dSP; tryAMAGICbinSET(lt,0);
2339 SETs(boolSV(left < right));
2346 dSP; tryAMAGICbinSET(gt,0);
2349 SETs(boolSV(left > right));
2356 dSP; tryAMAGICbinSET(le,0);
2359 SETs(boolSV(left <= right));
2366 dSP; tryAMAGICbinSET(ge,0);
2369 SETs(boolSV(left >= right));
2376 dSP; tryAMAGICbinSET(eq,0);
2379 SETs(boolSV(left == right));
2386 dSP; tryAMAGICbinSET(ne,0);
2389 SETs(boolSV(left != right));
2396 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2403 else if (left < right)
2414 dSP; dTARGET; tryAMAGICun(neg);
2419 /* High falutin' math. */
2423 dSP; dTARGET; tryAMAGICbin(atan2,0);
2426 SETn(Perl_atan2(left, right));
2433 dSP; dTARGET; tryAMAGICun(sin);
2437 value = Perl_sin(value);
2445 dSP; dTARGET; tryAMAGICun(cos);
2449 value = Perl_cos(value);
2455 /* Support Configure command-line overrides for rand() functions.
2456 After 5.005, perhaps we should replace this by Configure support
2457 for drand48(), random(), or rand(). For 5.005, though, maintain
2458 compatibility by calling rand() but allow the user to override it.
2459 See INSTALL for details. --Andy Dougherty 15 July 1998
2461 /* Now it's after 5.005, and Configure supports drand48() and random(),
2462 in addition to rand(). So the overrides should not be needed any more.
2463 --Jarkko Hietaniemi 27 September 1998
2466 #ifndef HAS_DRAND48_PROTO
2467 extern double drand48 (void);
2480 if (!PL_srand_called) {
2481 (void)seedDrand01((Rand_seed_t)seed());
2482 PL_srand_called = TRUE;
2497 (void)seedDrand01((Rand_seed_t)anum);
2498 PL_srand_called = TRUE;
2507 * This is really just a quick hack which grabs various garbage
2508 * values. It really should be a real hash algorithm which
2509 * spreads the effect of every input bit onto every output bit,
2510 * if someone who knows about such things would bother to write it.
2511 * Might be a good idea to add that function to CORE as well.
2512 * No numbers below come from careful analysis or anything here,
2513 * except they are primes and SEED_C1 > 1E6 to get a full-width
2514 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2515 * probably be bigger too.
2518 # define SEED_C1 1000003
2519 #define SEED_C4 73819
2521 # define SEED_C1 25747
2522 #define SEED_C4 20639
2526 #define SEED_C5 26107
2528 #ifndef PERL_NO_DEV_RANDOM
2533 # include <starlet.h>
2534 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2535 * in 100-ns units, typically incremented ever 10 ms. */
2536 unsigned int when[2];
2538 # ifdef HAS_GETTIMEOFDAY
2539 struct timeval when;
2545 /* This test is an escape hatch, this symbol isn't set by Configure. */
2546 #ifndef PERL_NO_DEV_RANDOM
2547 #ifndef PERL_RANDOM_DEVICE
2548 /* /dev/random isn't used by default because reads from it will block
2549 * if there isn't enough entropy available. You can compile with
2550 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2551 * is enough real entropy to fill the seed. */
2552 # define PERL_RANDOM_DEVICE "/dev/urandom"
2554 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2556 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2565 _ckvmssts(sys$gettim(when));
2566 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2568 # ifdef HAS_GETTIMEOFDAY
2569 gettimeofday(&when,(struct timezone *) 0);
2570 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2573 u = (U32)SEED_C1 * when;
2576 u += SEED_C3 * (U32)PerlProc_getpid();
2577 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2578 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2579 u += SEED_C5 * (U32)PTR2UV(&when);
2586 dSP; dTARGET; tryAMAGICun(exp);
2590 value = Perl_exp(value);
2598 dSP; dTARGET; tryAMAGICun(log);
2603 SET_NUMERIC_STANDARD();
2604 DIE(aTHX_ "Can't take log of %g", value);
2606 value = Perl_log(value);
2614 dSP; dTARGET; tryAMAGICun(sqrt);
2619 SET_NUMERIC_STANDARD();
2620 DIE(aTHX_ "Can't take sqrt of %g", value);
2622 value = Perl_sqrt(value);
2630 dSP; dTARGET; tryAMAGICun(int);
2633 IV iv = TOPi; /* attempt to convert to IV if possible. */
2634 /* XXX it's arguable that compiler casting to IV might be subtly
2635 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2636 else preferring IV has introduced a subtle behaviour change bug. OTOH
2637 relying on floating point to be accurate is a bug. */
2648 if (value < (NV)UV_MAX + 0.5) {
2651 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2652 # ifdef HAS_MODFL_POW32_BUG
2653 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2655 NV offset = Perl_modf(value, &value);
2656 (void)Perl_modf(offset, &offset);
2660 (void)Perl_modf(value, &value);
2663 double tmp = (double)value;
2664 (void)Perl_modf(tmp, &tmp);
2671 if (value > (NV)IV_MIN - 0.5) {
2674 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2675 # ifdef HAS_MODFL_POW32_BUG
2676 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2678 NV offset = Perl_modf(-value, &value);
2679 (void)Perl_modf(offset, &offset);
2683 (void)Perl_modf(-value, &value);
2687 double tmp = (double)value;
2688 (void)Perl_modf(-tmp, &tmp);
2701 dSP; dTARGET; tryAMAGICun(abs);
2703 /* This will cache the NV value if string isn't actually integer */
2707 /* IVX is precise */
2709 SETu(TOPu); /* force it to be numeric only */
2717 /* 2s complement assumption. Also, not really needed as
2718 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2738 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2743 tmps = (SvPVx(POPs, len));
2744 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2745 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2758 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2763 tmps = (SvPVx(POPs, len));
2764 while (*tmps && len && isSPACE(*tmps))
2769 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2770 else if (*tmps == 'b')
2771 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2773 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2775 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2792 SETi(sv_len_utf8(sv));
2808 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2810 I32 arybase = PL_curcop->cop_arybase;
2814 int num_args = PL_op->op_private & 7;
2815 bool repl_need_utf8_upgrade = FALSE;
2816 bool repl_is_utf8 = FALSE;
2818 SvTAINTED_off(TARG); /* decontaminate */
2819 SvUTF8_off(TARG); /* decontaminate */
2823 repl = SvPV(repl_sv, repl_len);
2824 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2834 sv_utf8_upgrade(sv);
2836 else if (DO_UTF8(sv))
2837 repl_need_utf8_upgrade = TRUE;
2839 tmps = SvPV(sv, curlen);
2841 utf8_curlen = sv_len_utf8(sv);
2842 if (utf8_curlen == curlen)
2845 curlen = utf8_curlen;
2850 if (pos >= arybase) {
2868 else if (len >= 0) {
2870 if (rem > (I32)curlen)
2885 Perl_croak(aTHX_ "substr outside of string");
2886 if (ckWARN(WARN_SUBSTR))
2887 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2894 sv_pos_u2b(sv, &pos, &rem);
2896 sv_setpvn(TARG, tmps, rem);
2897 #ifdef USE_LOCALE_COLLATE
2898 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2903 SV* repl_sv_copy = NULL;
2905 if (repl_need_utf8_upgrade) {
2906 repl_sv_copy = newSVsv(repl_sv);
2907 sv_utf8_upgrade(repl_sv_copy);
2908 repl = SvPV(repl_sv_copy, repl_len);
2909 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2911 sv_insert(sv, pos, rem, repl, repl_len);
2915 SvREFCNT_dec(repl_sv_copy);
2917 else if (lvalue) { /* it's an lvalue! */
2918 if (!SvGMAGICAL(sv)) {
2922 if (ckWARN(WARN_SUBSTR))
2923 Perl_warner(aTHX_ WARN_SUBSTR,
2924 "Attempt to use reference as lvalue in substr");
2926 if (SvOK(sv)) /* is it defined ? */
2927 (void)SvPOK_only_UTF8(sv);
2929 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2932 if (SvTYPE(TARG) < SVt_PVLV) {
2933 sv_upgrade(TARG, SVt_PVLV);
2934 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2938 if (LvTARG(TARG) != sv) {
2940 SvREFCNT_dec(LvTARG(TARG));
2941 LvTARG(TARG) = SvREFCNT_inc(sv);
2943 LvTARGOFF(TARG) = upos;
2944 LvTARGLEN(TARG) = urem;
2948 PUSHs(TARG); /* avoid SvSETMAGIC here */
2955 register IV size = POPi;
2956 register IV offset = POPi;
2957 register SV *src = POPs;
2958 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2960 SvTAINTED_off(TARG); /* decontaminate */
2961 if (lvalue) { /* it's an lvalue! */
2962 if (SvTYPE(TARG) < SVt_PVLV) {
2963 sv_upgrade(TARG, SVt_PVLV);
2964 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2967 if (LvTARG(TARG) != src) {
2969 SvREFCNT_dec(LvTARG(TARG));
2970 LvTARG(TARG) = SvREFCNT_inc(src);
2972 LvTARGOFF(TARG) = offset;
2973 LvTARGLEN(TARG) = size;
2976 sv_setuv(TARG, do_vecget(src, offset, size));
2991 I32 arybase = PL_curcop->cop_arybase;
2996 offset = POPi - arybase;
2999 tmps = SvPV(big, biglen);
3000 if (offset > 0 && DO_UTF8(big))
3001 sv_pos_u2b(big, &offset, 0);
3004 else if (offset > biglen)
3006 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3007 (unsigned char*)tmps + biglen, little, 0)))
3010 retval = tmps2 - tmps;
3011 if (retval > 0 && DO_UTF8(big))
3012 sv_pos_b2u(big, &retval);
3013 PUSHi(retval + arybase);
3028 I32 arybase = PL_curcop->cop_arybase;
3034 tmps2 = SvPV(little, llen);
3035 tmps = SvPV(big, blen);
3039 if (offset > 0 && DO_UTF8(big))
3040 sv_pos_u2b(big, &offset, 0);
3041 offset = offset - arybase + llen;
3045 else if (offset > blen)
3047 if (!(tmps2 = rninstr(tmps, tmps + offset,
3048 tmps2, tmps2 + llen)))
3051 retval = tmps2 - tmps;
3052 if (retval > 0 && DO_UTF8(big))
3053 sv_pos_b2u(big, &retval);
3054 PUSHi(retval + arybase);
3060 dSP; dMARK; dORIGMARK; dTARGET;
3061 do_sprintf(TARG, SP-MARK, MARK+1);
3062 TAINT_IF(SvTAINTED(TARG));
3063 if (DO_UTF8(*(MARK+1)))
3075 U8 *s = (U8*)SvPVx(argsv, len);
3077 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3087 (void)SvUPGRADE(TARG,SVt_PV);
3089 if (value > 255 && !IN_BYTES) {
3090 SvGROW(TARG, UNISKIP(value)+1);
3091 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3092 SvCUR_set(TARG, tmps - SvPVX(TARG));
3094 (void)SvPOK_only(TARG);
3105 (void)SvPOK_only(TARG);
3112 dSP; dTARGET; dPOPTOPssrl;
3116 char *tmps = SvPV(left, len);
3118 if (DO_UTF8(left)) {
3119 /* If Unicode take the crypt() of the low 8 bits
3120 * of the characters of the string. */
3122 char *send = tmps + len;
3124 Newz(688, t, len, char);
3126 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3132 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3134 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3139 "The crypt() function is unimplemented due to excessive paranoia.");
3153 U8 tmpbuf[UTF8_MAXLEN*2+1];
3157 s = (U8*)SvPV(sv, slen);
3158 utf8_to_uvchr(s, &ulen);
3160 toTITLE_utf8(s, tmpbuf, &tculen);
3161 utf8_to_uvchr(tmpbuf, 0);
3163 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3165 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3166 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3171 s = (U8*)SvPV_force(sv, slen);
3172 Copy(tmpbuf, s, tculen, U8);
3176 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3178 SvUTF8_off(TARG); /* decontaminate */
3183 s = (U8*)SvPV_force(sv, slen);
3185 if (IN_LOCALE_RUNTIME) {
3188 *s = toUPPER_LC(*s);
3206 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3208 U8 tmpbuf[UTF8_MAXLEN*2+1];
3212 toLOWER_utf8(s, tmpbuf, &ulen);
3213 uv = utf8_to_uvchr(tmpbuf, 0);
3215 tend = uvchr_to_utf8(tmpbuf, uv);
3217 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3219 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3220 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3225 s = (U8*)SvPV_force(sv, slen);
3226 Copy(tmpbuf, s, ulen, U8);
3230 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3232 SvUTF8_off(TARG); /* decontaminate */
3237 s = (U8*)SvPV_force(sv, slen);
3239 if (IN_LOCALE_RUNTIME) {
3242 *s = toLOWER_LC(*s);
3265 U8 tmpbuf[UTF8_MAXLEN*2+1];
3267 s = (U8*)SvPV(sv,len);
3269 SvUTF8_off(TARG); /* decontaminate */
3270 sv_setpvn(TARG, "", 0);
3274 (void)SvUPGRADE(TARG, SVt_PV);
3275 SvGROW(TARG, (len * 2) + 1);
3276 (void)SvPOK_only(TARG);
3277 d = (U8*)SvPVX(TARG);
3280 toUPPER_utf8(s, tmpbuf, &ulen);
3281 Copy(tmpbuf, d, ulen, U8);
3287 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3292 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3294 SvUTF8_off(TARG); /* decontaminate */
3299 s = (U8*)SvPV_force(sv, len);
3301 register U8 *send = s + len;
3303 if (IN_LOCALE_RUNTIME) {
3306 for (; s < send; s++)
3307 *s = toUPPER_LC(*s);
3310 for (; s < send; s++)
3332 U8 tmpbuf[UTF8_MAXLEN*2+1];
3334 s = (U8*)SvPV(sv,len);
3336 SvUTF8_off(TARG); /* decontaminate */
3337 sv_setpvn(TARG, "", 0);
3341 (void)SvUPGRADE(TARG, SVt_PV);
3342 SvGROW(TARG, (len * 2) + 1);
3343 (void)SvPOK_only(TARG);
3344 d = (U8*)SvPVX(TARG);
3347 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3348 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3349 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3351 * Now if the sigma is NOT followed by
3352 * /$ignorable_sequence$cased_letter/;
3353 * and it IS preceded by
3354 * /$cased_letter$ignorable_sequence/;
3355 * where $ignorable_sequence is
3356 * [\x{2010}\x{AD}\p{Mn}]*
3357 * and $cased_letter is
3358 * [\p{Ll}\p{Lo}\p{Lt}]
3359 * then it should be mapped to 0x03C2,
3360 * (GREEK SMALL LETTER FINAL SIGMA),
3361 * instead of staying 0x03A3.
3362 * See lib/unicore/SpecCase.txt.
3365 Copy(tmpbuf, d, ulen, U8);
3371 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3376 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3378 SvUTF8_off(TARG); /* decontaminate */
3384 s = (U8*)SvPV_force(sv, len);
3386 register U8 *send = s + len;
3388 if (IN_LOCALE_RUNTIME) {
3391 for (; s < send; s++)
3392 *s = toLOWER_LC(*s);
3395 for (; s < send; s++)
3410 register char *s = SvPV(sv,len);
3413 SvUTF8_off(TARG); /* decontaminate */
3415 (void)SvUPGRADE(TARG, SVt_PV);
3416 SvGROW(TARG, (len * 2) + 1);
3420 if (UTF8_IS_CONTINUED(*s)) {
3421 STRLEN ulen = UTF8SKIP(s);
3445 SvCUR_set(TARG, d - SvPVX(TARG));
3446 (void)SvPOK_only_UTF8(TARG);
3449 sv_setpvn(TARG, s, len);
3451 if (SvSMAGICAL(TARG))
3460 dSP; dMARK; dORIGMARK;
3462 register AV* av = (AV*)POPs;
3463 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3464 I32 arybase = PL_curcop->cop_arybase;
3467 if (SvTYPE(av) == SVt_PVAV) {
3468 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3470 for (svp = MARK + 1; svp <= SP; svp++) {
3475 if (max > AvMAX(av))
3478 while (++MARK <= SP) {
3479 elem = SvIVx(*MARK);
3483 svp = av_fetch(av, elem, lval);
3485 if (!svp || *svp == &PL_sv_undef)
3486 DIE(aTHX_ PL_no_aelem, elem);
3487 if (PL_op->op_private & OPpLVAL_INTRO)
3488 save_aelem(av, elem, svp);
3490 *MARK = svp ? *svp : &PL_sv_undef;
3493 if (GIMME != G_ARRAY) {
3501 /* Associative arrays. */
3506 HV *hash = (HV*)POPs;
3508 I32 gimme = GIMME_V;
3509 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3512 /* might clobber stack_sp */
3513 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3518 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3519 if (gimme == G_ARRAY) {
3522 /* might clobber stack_sp */
3524 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3529 else if (gimme == G_SCALAR)
3548 I32 gimme = GIMME_V;
3549 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3553 if (PL_op->op_private & OPpSLICE) {
3557 hvtype = SvTYPE(hv);
3558 if (hvtype == SVt_PVHV) { /* hash element */
3559 while (++MARK <= SP) {
3560 sv = hv_delete_ent(hv, *MARK, discard, 0);
3561 *MARK = sv ? sv : &PL_sv_undef;
3564 else if (hvtype == SVt_PVAV) {
3565 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3566 while (++MARK <= SP) {
3567 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3568 *MARK = sv ? sv : &PL_sv_undef;
3571 else { /* pseudo-hash element */
3572 while (++MARK <= SP) {
3573 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3574 *MARK = sv ? sv : &PL_sv_undef;
3579 DIE(aTHX_ "Not a HASH reference");
3582 else if (gimme == G_SCALAR) {
3591 if (SvTYPE(hv) == SVt_PVHV)
3592 sv = hv_delete_ent(hv, keysv, discard, 0);
3593 else if (SvTYPE(hv) == SVt_PVAV) {
3594 if (PL_op->op_flags & OPf_SPECIAL)
3595 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3597 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3600 DIE(aTHX_ "Not a HASH reference");
3615 if (PL_op->op_private & OPpEXISTS_SUB) {
3619 cv = sv_2cv(sv, &hv, &gv, FALSE);
3622 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3628 if (SvTYPE(hv) == SVt_PVHV) {
3629 if (hv_exists_ent(hv, tmpsv, 0))
3632 else if (SvTYPE(hv) == SVt_PVAV) {
3633 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3634 if (av_exists((AV*)hv, SvIV(tmpsv)))
3637 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3641 DIE(aTHX_ "Not a HASH reference");
3648 dSP; dMARK; dORIGMARK;
3649 register HV *hv = (HV*)POPs;
3650 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3651 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3653 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3654 DIE(aTHX_ "Can't localize pseudo-hash element");
3656 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3657 while (++MARK <= SP) {
3660 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3661 realhv ? hv_exists_ent(hv, keysv, 0)
3662 : avhv_exists_ent((AV*)hv, keysv, 0);
3664 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3665 svp = he ? &HeVAL(he) : 0;
3668 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3671 if (!svp || *svp == &PL_sv_undef) {
3673 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3675 if (PL_op->op_private & OPpLVAL_INTRO) {
3677 save_helem(hv, keysv, svp);
3680 char *key = SvPV(keysv, keylen);
3681 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3685 *MARK = svp ? *svp : &PL_sv_undef;
3688 if (GIMME != G_ARRAY) {
3696 /* List operators. */
3701 if (GIMME != G_ARRAY) {
3703 *MARK = *SP; /* unwanted list, return last item */
3705 *MARK = &PL_sv_undef;
3714 SV **lastrelem = PL_stack_sp;
3715 SV **lastlelem = PL_stack_base + POPMARK;
3716 SV **firstlelem = PL_stack_base + POPMARK + 1;
3717 register SV **firstrelem = lastlelem + 1;
3718 I32 arybase = PL_curcop->cop_arybase;
3719 I32 lval = PL_op->op_flags & OPf_MOD;
3720 I32 is_something_there = lval;
3722 register I32 max = lastrelem - lastlelem;
3723 register SV **lelem;
3726 if (GIMME != G_ARRAY) {
3727 ix = SvIVx(*lastlelem);
3732 if (ix < 0 || ix >= max)
3733 *firstlelem = &PL_sv_undef;
3735 *firstlelem = firstrelem[ix];
3741 SP = firstlelem - 1;
3745 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3751 if (ix < 0 || ix >= max)
3752 *lelem = &PL_sv_undef;
3754 is_something_there = TRUE;
3755 if (!(*lelem = firstrelem[ix]))
3756 *lelem = &PL_sv_undef;
3759 if (is_something_there)
3762 SP = firstlelem - 1;
3768 dSP; dMARK; dORIGMARK;
3769 I32 items = SP - MARK;
3770 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3771 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3778 dSP; dMARK; dORIGMARK;
3779 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3783 SV *val = NEWSV(46, 0);
3785 sv_setsv(val, *++MARK);
3786 else if (ckWARN(WARN_MISC))
3787 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3788 (void)hv_store_ent(hv,key,val,0);
3797 dSP; dMARK; dORIGMARK;
3798 register AV *ary = (AV*)*++MARK;
3802 register I32 offset;
3803 register I32 length;
3810 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3811 *MARK-- = SvTIED_obj((SV*)ary, mg);
3815 call_method("SPLICE",GIMME_V);
3824 offset = i = SvIVx(*MARK);
3826 offset += AvFILLp(ary) + 1;
3828 offset -= PL_curcop->cop_arybase;
3830 DIE(aTHX_ PL_no_aelem, i);
3832 length = SvIVx(*MARK++);
3834 length += AvFILLp(ary) - offset + 1;
3840 length = AvMAX(ary) + 1; /* close enough to infinity */
3844 length = AvMAX(ary) + 1;
3846 if (offset > AvFILLp(ary) + 1)
3847 offset = AvFILLp(ary) + 1;
3848 after = AvFILLp(ary) + 1 - (offset + length);
3849 if (after < 0) { /* not that much array */
3850 length += after; /* offset+length now in array */
3856 /* At this point, MARK .. SP-1 is our new LIST */
3859 diff = newlen - length;
3860 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3863 if (diff < 0) { /* shrinking the area */
3865 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3866 Copy(MARK, tmparyval, newlen, SV*);
3869 MARK = ORIGMARK + 1;
3870 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3871 MEXTEND(MARK, length);
3872 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3874 EXTEND_MORTAL(length);
3875 for (i = length, dst = MARK; i; i--) {
3876 sv_2mortal(*dst); /* free them eventualy */
3883 *MARK = AvARRAY(ary)[offset+length-1];
3886 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3887 SvREFCNT_dec(*dst++); /* free them now */
3890 AvFILLp(ary) += diff;
3892 /* pull up or down? */
3894 if (offset < after) { /* easier to pull up */
3895 if (offset) { /* esp. if nothing to pull */
3896 src = &AvARRAY(ary)[offset-1];
3897 dst = src - diff; /* diff is negative */
3898 for (i = offset; i > 0; i--) /* can't trust Copy */
3902 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3906 if (after) { /* anything to pull down? */
3907 src = AvARRAY(ary) + offset + length;
3908 dst = src + diff; /* diff is negative */
3909 Move(src, dst, after, SV*);
3911 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3912 /* avoid later double free */
3916 dst[--i] = &PL_sv_undef;
3919 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3921 *dst = NEWSV(46, 0);
3922 sv_setsv(*dst++, *src++);
3924 Safefree(tmparyval);
3927 else { /* no, expanding (or same) */
3929 New(452, tmparyval, length, SV*); /* so remember deletion */
3930 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3933 if (diff > 0) { /* expanding */
3935 /* push up or down? */
3937 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3941 Move(src, dst, offset, SV*);
3943 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3945 AvFILLp(ary) += diff;
3948 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3949 av_extend(ary, AvFILLp(ary) + diff);
3950 AvFILLp(ary) += diff;
3953 dst = AvARRAY(ary) + AvFILLp(ary);
3955 for (i = after; i; i--) {
3962 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3963 *dst = NEWSV(46, 0);
3964 sv_setsv(*dst++, *src++);
3966 MARK = ORIGMARK + 1;
3967 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3969 Copy(tmparyval, MARK, length, SV*);
3971 EXTEND_MORTAL(length);
3972 for (i = length, dst = MARK; i; i--) {
3973 sv_2mortal(*dst); /* free them eventualy */
3977 Safefree(tmparyval);
3981 else if (length--) {
3982 *MARK = tmparyval[length];
3985 while (length-- > 0)
3986 SvREFCNT_dec(tmparyval[length]);
3988 Safefree(tmparyval);
3991 *MARK = &PL_sv_undef;
3999 dSP; dMARK; dORIGMARK; dTARGET;
4000 register AV *ary = (AV*)*++MARK;
4001 register SV *sv = &PL_sv_undef;
4004 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4005 *MARK-- = SvTIED_obj((SV*)ary, mg);
4009 call_method("PUSH",G_SCALAR|G_DISCARD);
4014 /* Why no pre-extend of ary here ? */
4015 for (++MARK; MARK <= SP; MARK++) {
4018 sv_setsv(sv, *MARK);
4023 PUSHi( AvFILL(ary) + 1 );
4031 SV *sv = av_pop(av);
4033 (void)sv_2mortal(sv);
4042 SV *sv = av_shift(av);
4047 (void)sv_2mortal(sv);
4054 dSP; dMARK; dORIGMARK; dTARGET;
4055 register AV *ary = (AV*)*++MARK;
4060 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4061 *MARK-- = SvTIED_obj((SV*)ary, mg);
4065 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4070 av_unshift(ary, SP - MARK);
4073 sv_setsv(sv, *++MARK);
4074 (void)av_store(ary, i++, sv);
4078 PUSHi( AvFILL(ary) + 1 );
4088 if (GIMME == G_ARRAY) {
4095 /* safe as long as stack cannot get extended in the above */
4100 register char *down;
4105 SvUTF8_off(TARG); /* decontaminate */
4107 do_join(TARG, &PL_sv_no, MARK, SP);
4109 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4110 up = SvPV_force(TARG, len);
4112 if (DO_UTF8(TARG)) { /* first reverse each character */
4113 U8* s = (U8*)SvPVX(TARG);
4114 U8* send = (U8*)(s + len);
4116 if (UTF8_IS_INVARIANT(*s)) {
4121 if (!utf8_to_uvchr(s, 0))
4125 down = (char*)(s - 1);
4126 /* reverse this character */
4136 down = SvPVX(TARG) + len - 1;
4142 (void)SvPOK_only_UTF8(TARG);
4154 register IV limit = POPi; /* note, negative is forever */
4157 register char *s = SvPV(sv, len);
4158 bool do_utf8 = DO_UTF8(sv);
4159 char *strend = s + len;
4161 register REGEXP *rx;
4165 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4166 I32 maxiters = slen + 10;
4169 I32 origlimit = limit;
4172 AV *oldstack = PL_curstack;
4173 I32 gimme = GIMME_V;
4174 I32 oldsave = PL_savestack_ix;
4175 I32 make_mortal = 1;
4176 MAGIC *mg = (MAGIC *) NULL;
4179 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4184 DIE(aTHX_ "panic: pp_split");
4187 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4188 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4190 PL_reg_match_utf8 = do_utf8;
4192 if (pm->op_pmreplroot) {
4194 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4196 ary = GvAVn((GV*)pm->op_pmreplroot);
4199 else if (gimme != G_ARRAY)
4200 #ifdef USE_5005THREADS
4201 ary = (AV*)PL_curpad[0];
4203 ary = GvAVn(PL_defgv);
4204 #endif /* USE_5005THREADS */
4207 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4213 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4215 XPUSHs(SvTIED_obj((SV*)ary, mg));
4221 for (i = AvFILLp(ary); i >= 0; i--)
4222 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4224 /* temporarily switch stacks */
4225 SWITCHSTACK(PL_curstack, ary);
4229 base = SP - PL_stack_base;
4231 if (pm->op_pmflags & PMf_SKIPWHITE) {
4232 if (pm->op_pmflags & PMf_LOCALE) {
4233 while (isSPACE_LC(*s))
4241 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4242 SAVEINT(PL_multiline);
4243 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4247 limit = maxiters + 2;
4248 if (pm->op_pmflags & PMf_WHITE) {
4251 while (m < strend &&
4252 !((pm->op_pmflags & PMf_LOCALE)
4253 ? isSPACE_LC(*m) : isSPACE(*m)))
4258 dstr = NEWSV(30, m-s);
4259 sv_setpvn(dstr, s, m-s);
4263 (void)SvUTF8_on(dstr);
4267 while (s < strend &&
4268 ((pm->op_pmflags & PMf_LOCALE)
4269 ? isSPACE_LC(*s) : isSPACE(*s)))
4273 else if (strEQ("^", rx->precomp)) {
4276 for (m = s; m < strend && *m != '\n'; m++) ;
4280 dstr = NEWSV(30, m-s);
4281 sv_setpvn(dstr, s, m-s);
4285 (void)SvUTF8_on(dstr);
4290 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4291 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4292 && (rx->reganch & ROPT_CHECK_ALL)
4293 && !(rx->reganch & ROPT_ANCH)) {
4294 int tail = (rx->reganch & RE_INTUIT_TAIL);
4295 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4298 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4300 char c = *SvPV(csv, n_a);
4303 for (m = s; m < strend && *m != c; m++) ;
4306 dstr = NEWSV(30, 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 while (s < strend && --limit &&
4324 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4325 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4328 dstr = NEWSV(31, m-s);
4329 sv_setpvn(dstr, s, m-s);
4333 (void)SvUTF8_on(dstr);
4335 /* The rx->minlen is in characters but we want to step
4336 * s ahead by bytes. */
4338 s = (char*)utf8_hop((U8*)m, len);
4340 s = m + len; /* Fake \n at the end */
4345 maxiters += slen * rx->nparens;
4346 while (s < strend && --limit
4347 /* && (!rx->check_substr
4348 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4350 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4351 1 /* minend */, sv, NULL, 0))
4353 TAINT_IF(RX_MATCH_TAINTED(rx));
4354 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4359 strend = s + (strend - m);
4361 m = rx->startp[0] + orig;
4362 dstr = NEWSV(32, m-s);
4363 sv_setpvn(dstr, s, m-s);
4367 (void)SvUTF8_on(dstr);
4370 for (i = 1; i <= rx->nparens; i++) {
4371 s = rx->startp[i] + orig;
4372 m = rx->endp[i] + orig;
4374 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4375 parens that didn't match -- they should be set to
4376 undef, not the empty string */
4377 if (m >= orig && s >= orig) {
4378 dstr = NEWSV(33, m-s);
4379 sv_setpvn(dstr, s, m-s);
4382 dstr = &PL_sv_undef; /* undef, not "" */
4386 (void)SvUTF8_on(dstr);
4390 s = rx->endp[0] + orig;
4394 LEAVE_SCOPE(oldsave);
4395 iters = (SP - PL_stack_base) - base;
4396 if (iters > maxiters)
4397 DIE(aTHX_ "Split loop");
4399 /* keep field after final delim? */
4400 if (s < strend || (iters && origlimit)) {
4401 STRLEN l = strend - s;
4402 dstr = NEWSV(34, l);
4403 sv_setpvn(dstr, s, l);
4407 (void)SvUTF8_on(dstr);
4411 else if (!origlimit) {
4412 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4418 SWITCHSTACK(ary, oldstack);
4419 if (SvSMAGICAL(ary)) {
4424 if (gimme == G_ARRAY) {
4426 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4434 call_method("PUSH",G_SCALAR|G_DISCARD);
4437 if (gimme == G_ARRAY) {
4438 /* EXTEND should not be needed - we just popped them */
4440 for (i=0; i < iters; i++) {
4441 SV **svp = av_fetch(ary, i, FALSE);
4442 PUSHs((svp) ? *svp : &PL_sv_undef);
4449 if (gimme == G_ARRAY)
4452 if (iters || !pm->op_pmreplroot) {
4460 #ifdef USE_5005THREADS
4462 Perl_unlock_condpair(pTHX_ void *svv)
4464 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4467 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4468 MUTEX_LOCK(MgMUTEXP(mg));
4469 if (MgOWNER(mg) != thr)
4470 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4472 COND_SIGNAL(MgOWNERCONDP(mg));
4473 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4474 PTR2UV(thr), PTR2UV(svv)));
4475 MUTEX_UNLOCK(MgMUTEXP(mg));
4477 #endif /* USE_5005THREADS */
4484 #ifdef USE_5005THREADS
4486 #endif /* USE_5005THREADS */
4488 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4490 Perl_sharedsv_lock(aTHX_ ssv);
4491 #endif /* USE_ITHREADS */
4492 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4493 || SvTYPE(retsv) == SVt_PVCV) {
4494 retsv = refto(retsv);
4502 #ifdef USE_5005THREADS
4505 if (PL_op->op_private & OPpLVAL_INTRO)
4506 PUSHs(*save_threadsv(PL_op->op_targ));
4508 PUSHs(THREADSV(PL_op->op_targ));
4511 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4512 #endif /* USE_5005THREADS */