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 SETs(boolSV(auv < (UV)biv));
1500 { /* ## IV < UV ## */
1504 aiv = SvIVX(TOPm1s);
1506 /* As (b) is a UV, it's >=0, so it must be < */
1513 SETs(boolSV((UV)aiv < buv));
1521 SETs(boolSV(TOPn < value));
1528 dSP; tryAMAGICbinSET(gt,0);
1529 #ifdef PERL_PRESERVE_IVUV
1532 SvIV_please(TOPm1s);
1533 if (SvIOK(TOPm1s)) {
1534 bool auvok = SvUOK(TOPm1s);
1535 bool buvok = SvUOK(TOPs);
1537 if (!auvok && !buvok) { /* ## IV > IV ## */
1538 IV aiv = SvIVX(TOPm1s);
1539 IV biv = SvIVX(TOPs);
1542 SETs(boolSV(aiv > biv));
1545 if (auvok && buvok) { /* ## UV > UV ## */
1546 UV auv = SvUVX(TOPm1s);
1547 UV buv = SvUVX(TOPs);
1550 SETs(boolSV(auv > buv));
1553 if (auvok) { /* ## UV > IV ## */
1560 /* As (a) is a UV, it's >=0, so it must be > */
1565 SETs(boolSV(auv > (UV)biv));
1568 { /* ## IV > UV ## */
1572 aiv = SvIVX(TOPm1s);
1574 /* As (b) is a UV, it's >=0, so it cannot be > */
1581 SETs(boolSV((UV)aiv > buv));
1589 SETs(boolSV(TOPn > value));
1596 dSP; tryAMAGICbinSET(le,0);
1597 #ifdef PERL_PRESERVE_IVUV
1600 SvIV_please(TOPm1s);
1601 if (SvIOK(TOPm1s)) {
1602 bool auvok = SvUOK(TOPm1s);
1603 bool buvok = SvUOK(TOPs);
1605 if (!auvok && !buvok) { /* ## IV <= IV ## */
1606 IV aiv = SvIVX(TOPm1s);
1607 IV biv = SvIVX(TOPs);
1610 SETs(boolSV(aiv <= biv));
1613 if (auvok && buvok) { /* ## UV <= UV ## */
1614 UV auv = SvUVX(TOPm1s);
1615 UV buv = SvUVX(TOPs);
1618 SETs(boolSV(auv <= buv));
1621 if (auvok) { /* ## UV <= IV ## */
1628 /* As (a) is a UV, it's >=0, so a cannot be <= */
1633 SETs(boolSV(auv <= (UV)biv));
1636 { /* ## IV <= UV ## */
1640 aiv = SvIVX(TOPm1s);
1642 /* As (b) is a UV, it's >=0, so a must be <= */
1649 SETs(boolSV((UV)aiv <= buv));
1657 SETs(boolSV(TOPn <= value));
1664 dSP; tryAMAGICbinSET(ge,0);
1665 #ifdef PERL_PRESERVE_IVUV
1668 SvIV_please(TOPm1s);
1669 if (SvIOK(TOPm1s)) {
1670 bool auvok = SvUOK(TOPm1s);
1671 bool buvok = SvUOK(TOPs);
1673 if (!auvok && !buvok) { /* ## IV >= IV ## */
1674 IV aiv = SvIVX(TOPm1s);
1675 IV biv = SvIVX(TOPs);
1678 SETs(boolSV(aiv >= biv));
1681 if (auvok && buvok) { /* ## UV >= UV ## */
1682 UV auv = SvUVX(TOPm1s);
1683 UV buv = SvUVX(TOPs);
1686 SETs(boolSV(auv >= buv));
1689 if (auvok) { /* ## UV >= IV ## */
1696 /* As (a) is a UV, it's >=0, so it must be >= */
1701 SETs(boolSV(auv >= (UV)biv));
1704 { /* ## IV >= UV ## */
1708 aiv = SvIVX(TOPm1s);
1710 /* As (b) is a UV, it's >=0, so a cannot be >= */
1717 SETs(boolSV((UV)aiv >= buv));
1725 SETs(boolSV(TOPn >= value));
1732 dSP; tryAMAGICbinSET(ne,0);
1733 #ifndef NV_PRESERVES_UV
1734 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1735 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1739 #ifdef PERL_PRESERVE_IVUV
1742 SvIV_please(TOPm1s);
1743 if (SvIOK(TOPm1s)) {
1744 bool auvok = SvUOK(TOPm1s);
1745 bool buvok = SvUOK(TOPs);
1747 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1748 IV aiv = SvIVX(TOPm1s);
1749 IV biv = SvIVX(TOPs);
1752 SETs(boolSV(aiv != biv));
1755 if (auvok && buvok) { /* ## UV != UV ## */
1756 UV auv = SvUVX(TOPm1s);
1757 UV buv = SvUVX(TOPs);
1760 SETs(boolSV(auv != buv));
1763 { /* ## Mixed IV,UV ## */
1767 /* != is commutative so swap if needed (save code) */
1769 /* swap. top of stack (b) is the iv */
1773 /* As (a) is a UV, it's >0, so it cannot be == */
1782 /* As (b) is a UV, it's >0, so it cannot be == */
1786 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1788 SETs(boolSV((UV)iv != uv));
1796 SETs(boolSV(TOPn != value));
1803 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1804 #ifndef NV_PRESERVES_UV
1805 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1806 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1810 #ifdef PERL_PRESERVE_IVUV
1811 /* Fortunately it seems NaN isn't IOK */
1814 SvIV_please(TOPm1s);
1815 if (SvIOK(TOPm1s)) {
1816 bool leftuvok = SvUOK(TOPm1s);
1817 bool rightuvok = SvUOK(TOPs);
1819 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1820 IV leftiv = SvIVX(TOPm1s);
1821 IV rightiv = SvIVX(TOPs);
1823 if (leftiv > rightiv)
1825 else if (leftiv < rightiv)
1829 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1830 UV leftuv = SvUVX(TOPm1s);
1831 UV rightuv = SvUVX(TOPs);
1833 if (leftuv > rightuv)
1835 else if (leftuv < rightuv)
1839 } else if (leftuvok) { /* ## UV <=> IV ## */
1843 rightiv = SvIVX(TOPs);
1845 /* As (a) is a UV, it's >=0, so it cannot be < */
1848 leftuv = SvUVX(TOPm1s);
1849 if (leftuv > (UV)rightiv) {
1851 } else if (leftuv < (UV)rightiv) {
1857 } else { /* ## IV <=> UV ## */
1861 leftiv = SvIVX(TOPm1s);
1863 /* As (b) is a UV, it's >=0, so it must be < */
1866 rightuv = SvUVX(TOPs);
1867 if ((UV)leftiv > rightuv) {
1869 } else if ((UV)leftiv < rightuv) {
1887 if (Perl_isnan(left) || Perl_isnan(right)) {
1891 value = (left > right) - (left < right);
1895 else if (left < right)
1897 else if (left > right)
1911 dSP; tryAMAGICbinSET(slt,0);
1914 int cmp = (IN_LOCALE_RUNTIME
1915 ? sv_cmp_locale(left, right)
1916 : sv_cmp(left, right));
1917 SETs(boolSV(cmp < 0));
1924 dSP; tryAMAGICbinSET(sgt,0);
1927 int cmp = (IN_LOCALE_RUNTIME
1928 ? sv_cmp_locale(left, right)
1929 : sv_cmp(left, right));
1930 SETs(boolSV(cmp > 0));
1937 dSP; tryAMAGICbinSET(sle,0);
1940 int cmp = (IN_LOCALE_RUNTIME
1941 ? sv_cmp_locale(left, right)
1942 : sv_cmp(left, right));
1943 SETs(boolSV(cmp <= 0));
1950 dSP; tryAMAGICbinSET(sge,0);
1953 int cmp = (IN_LOCALE_RUNTIME
1954 ? sv_cmp_locale(left, right)
1955 : sv_cmp(left, right));
1956 SETs(boolSV(cmp >= 0));
1963 dSP; tryAMAGICbinSET(seq,0);
1966 SETs(boolSV(sv_eq(left, right)));
1973 dSP; tryAMAGICbinSET(sne,0);
1976 SETs(boolSV(!sv_eq(left, right)));
1983 dSP; dTARGET; tryAMAGICbin(scmp,0);
1986 int cmp = (IN_LOCALE_RUNTIME
1987 ? sv_cmp_locale(left, right)
1988 : sv_cmp(left, right));
1996 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1999 if (SvNIOKp(left) || SvNIOKp(right)) {
2000 if (PL_op->op_private & HINT_INTEGER) {
2001 IV i = SvIV(left) & SvIV(right);
2005 UV u = SvUV(left) & SvUV(right);
2010 do_vop(PL_op->op_type, TARG, left, right);
2019 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2022 if (SvNIOKp(left) || SvNIOKp(right)) {
2023 if (PL_op->op_private & HINT_INTEGER) {
2024 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2028 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2033 do_vop(PL_op->op_type, TARG, left, right);
2042 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2045 if (SvNIOKp(left) || SvNIOKp(right)) {
2046 if (PL_op->op_private & HINT_INTEGER) {
2047 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2051 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2056 do_vop(PL_op->op_type, TARG, left, right);
2065 dSP; dTARGET; tryAMAGICun(neg);
2068 int flags = SvFLAGS(sv);
2071 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2072 /* It's publicly an integer, or privately an integer-not-float */
2075 if (SvIVX(sv) == IV_MIN) {
2076 /* 2s complement assumption. */
2077 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2080 else if (SvUVX(sv) <= IV_MAX) {
2085 else if (SvIVX(sv) != IV_MIN) {
2089 #ifdef PERL_PRESERVE_IVUV
2098 else if (SvPOKp(sv)) {
2100 char *s = SvPV(sv, len);
2101 if (isIDFIRST(*s)) {
2102 sv_setpvn(TARG, "-", 1);
2105 else if (*s == '+' || *s == '-') {
2107 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2109 else if (DO_UTF8(sv)) {
2112 goto oops_its_an_int;
2114 sv_setnv(TARG, -SvNV(sv));
2116 sv_setpvn(TARG, "-", 1);
2123 goto oops_its_an_int;
2124 sv_setnv(TARG, -SvNV(sv));
2136 dSP; tryAMAGICunSET(not);
2137 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2143 dSP; dTARGET; tryAMAGICun(compl);
2147 if (PL_op->op_private & HINT_INTEGER) {
2162 tmps = (U8*)SvPV_force(TARG, len);
2165 /* Calculate exact length, let's not estimate. */
2174 while (tmps < send) {
2175 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2176 tmps += UTF8SKIP(tmps);
2177 targlen += UNISKIP(~c);
2183 /* Now rewind strings and write them. */
2187 Newz(0, result, targlen + 1, U8);
2188 while (tmps < send) {
2189 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2190 tmps += UTF8SKIP(tmps);
2191 result = uvchr_to_utf8(result, ~c);
2195 sv_setpvn(TARG, (char*)result, targlen);
2199 Newz(0, result, nchar + 1, U8);
2200 while (tmps < send) {
2201 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2202 tmps += UTF8SKIP(tmps);
2207 sv_setpvn(TARG, (char*)result, nchar);
2215 register long *tmpl;
2216 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2219 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2224 for ( ; anum > 0; anum--, tmps++)
2233 /* integer versions of some of the above */
2237 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2240 SETi( left * right );
2247 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2251 DIE(aTHX_ "Illegal division by zero");
2252 value = POPi / value;
2260 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2264 DIE(aTHX_ "Illegal modulus zero");
2265 SETi( left % right );
2272 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2275 SETi( left + right );
2282 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2285 SETi( left - right );
2292 dSP; tryAMAGICbinSET(lt,0);
2295 SETs(boolSV(left < right));
2302 dSP; tryAMAGICbinSET(gt,0);
2305 SETs(boolSV(left > right));
2312 dSP; tryAMAGICbinSET(le,0);
2315 SETs(boolSV(left <= right));
2322 dSP; tryAMAGICbinSET(ge,0);
2325 SETs(boolSV(left >= right));
2332 dSP; tryAMAGICbinSET(eq,0);
2335 SETs(boolSV(left == right));
2342 dSP; tryAMAGICbinSET(ne,0);
2345 SETs(boolSV(left != right));
2352 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2359 else if (left < right)
2370 dSP; dTARGET; tryAMAGICun(neg);
2375 /* High falutin' math. */
2379 dSP; dTARGET; tryAMAGICbin(atan2,0);
2382 SETn(Perl_atan2(left, right));
2389 dSP; dTARGET; tryAMAGICun(sin);
2393 value = Perl_sin(value);
2401 dSP; dTARGET; tryAMAGICun(cos);
2405 value = Perl_cos(value);
2411 /* Support Configure command-line overrides for rand() functions.
2412 After 5.005, perhaps we should replace this by Configure support
2413 for drand48(), random(), or rand(). For 5.005, though, maintain
2414 compatibility by calling rand() but allow the user to override it.
2415 See INSTALL for details. --Andy Dougherty 15 July 1998
2417 /* Now it's after 5.005, and Configure supports drand48() and random(),
2418 in addition to rand(). So the overrides should not be needed any more.
2419 --Jarkko Hietaniemi 27 September 1998
2422 #ifndef HAS_DRAND48_PROTO
2423 extern double drand48 (void);
2436 if (!PL_srand_called) {
2437 (void)seedDrand01((Rand_seed_t)seed());
2438 PL_srand_called = TRUE;
2453 (void)seedDrand01((Rand_seed_t)anum);
2454 PL_srand_called = TRUE;
2463 * This is really just a quick hack which grabs various garbage
2464 * values. It really should be a real hash algorithm which
2465 * spreads the effect of every input bit onto every output bit,
2466 * if someone who knows about such things would bother to write it.
2467 * Might be a good idea to add that function to CORE as well.
2468 * No numbers below come from careful analysis or anything here,
2469 * except they are primes and SEED_C1 > 1E6 to get a full-width
2470 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2471 * probably be bigger too.
2474 # define SEED_C1 1000003
2475 #define SEED_C4 73819
2477 # define SEED_C1 25747
2478 #define SEED_C4 20639
2482 #define SEED_C5 26107
2484 #ifndef PERL_NO_DEV_RANDOM
2489 # include <starlet.h>
2490 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2491 * in 100-ns units, typically incremented ever 10 ms. */
2492 unsigned int when[2];
2494 # ifdef HAS_GETTIMEOFDAY
2495 struct timeval when;
2501 /* This test is an escape hatch, this symbol isn't set by Configure. */
2502 #ifndef PERL_NO_DEV_RANDOM
2503 #ifndef PERL_RANDOM_DEVICE
2504 /* /dev/random isn't used by default because reads from it will block
2505 * if there isn't enough entropy available. You can compile with
2506 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2507 * is enough real entropy to fill the seed. */
2508 # define PERL_RANDOM_DEVICE "/dev/urandom"
2510 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2512 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2521 _ckvmssts(sys$gettim(when));
2522 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2524 # ifdef HAS_GETTIMEOFDAY
2525 gettimeofday(&when,(struct timezone *) 0);
2526 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2529 u = (U32)SEED_C1 * when;
2532 u += SEED_C3 * (U32)PerlProc_getpid();
2533 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2534 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2535 u += SEED_C5 * (U32)PTR2UV(&when);
2542 dSP; dTARGET; tryAMAGICun(exp);
2546 value = Perl_exp(value);
2554 dSP; dTARGET; tryAMAGICun(log);
2559 SET_NUMERIC_STANDARD();
2560 DIE(aTHX_ "Can't take log of %g", value);
2562 value = Perl_log(value);
2570 dSP; dTARGET; tryAMAGICun(sqrt);
2575 SET_NUMERIC_STANDARD();
2576 DIE(aTHX_ "Can't take sqrt of %g", value);
2578 value = Perl_sqrt(value);
2586 dSP; dTARGET; tryAMAGICun(int);
2589 IV iv = TOPi; /* attempt to convert to IV if possible. */
2590 /* XXX it's arguable that compiler casting to IV might be subtly
2591 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2592 else preferring IV has introduced a subtle behaviour change bug. OTOH
2593 relying on floating point to be accurate is a bug. */
2604 if (value < (NV)UV_MAX + 0.5) {
2607 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2608 # ifdef HAS_MODFL_POW32_BUG
2609 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2611 NV offset = Perl_modf(value, &value);
2612 (void)Perl_modf(offset, &offset);
2616 (void)Perl_modf(value, &value);
2619 double tmp = (double)value;
2620 (void)Perl_modf(tmp, &tmp);
2627 if (value > (NV)IV_MIN - 0.5) {
2630 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2631 # ifdef HAS_MODFL_POW32_BUG
2632 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2634 NV offset = Perl_modf(-value, &value);
2635 (void)Perl_modf(offset, &offset);
2639 (void)Perl_modf(-value, &value);
2643 double tmp = (double)value;
2644 (void)Perl_modf(-tmp, &tmp);
2657 dSP; dTARGET; tryAMAGICun(abs);
2659 /* This will cache the NV value if string isn't actually integer */
2663 /* IVX is precise */
2665 SETu(TOPu); /* force it to be numeric only */
2673 /* 2s complement assumption. Also, not really needed as
2674 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2694 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2699 tmps = (SvPVx(POPs, len));
2700 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2701 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2714 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2719 tmps = (SvPVx(POPs, len));
2720 while (*tmps && len && isSPACE(*tmps))
2725 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2726 else if (*tmps == 'b')
2727 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2729 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2731 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2748 SETi(sv_len_utf8(sv));
2764 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2766 I32 arybase = PL_curcop->cop_arybase;
2770 int num_args = PL_op->op_private & 7;
2771 bool repl_need_utf8_upgrade = FALSE;
2772 bool repl_is_utf8 = FALSE;
2774 SvTAINTED_off(TARG); /* decontaminate */
2775 SvUTF8_off(TARG); /* decontaminate */
2779 repl = SvPV(repl_sv, repl_len);
2780 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2790 sv_utf8_upgrade(sv);
2792 else if (DO_UTF8(sv))
2793 repl_need_utf8_upgrade = TRUE;
2795 tmps = SvPV(sv, curlen);
2797 utf8_curlen = sv_len_utf8(sv);
2798 if (utf8_curlen == curlen)
2801 curlen = utf8_curlen;
2806 if (pos >= arybase) {
2824 else if (len >= 0) {
2826 if (rem > (I32)curlen)
2841 Perl_croak(aTHX_ "substr outside of string");
2842 if (ckWARN(WARN_SUBSTR))
2843 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2850 sv_pos_u2b(sv, &pos, &rem);
2852 sv_setpvn(TARG, tmps, rem);
2853 #ifdef USE_LOCALE_COLLATE
2854 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2859 SV* repl_sv_copy = NULL;
2861 if (repl_need_utf8_upgrade) {
2862 repl_sv_copy = newSVsv(repl_sv);
2863 sv_utf8_upgrade(repl_sv_copy);
2864 repl = SvPV(repl_sv_copy, repl_len);
2865 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2867 sv_insert(sv, pos, rem, repl, repl_len);
2871 SvREFCNT_dec(repl_sv_copy);
2873 else if (lvalue) { /* it's an lvalue! */
2874 if (!SvGMAGICAL(sv)) {
2878 if (ckWARN(WARN_SUBSTR))
2879 Perl_warner(aTHX_ WARN_SUBSTR,
2880 "Attempt to use reference as lvalue in substr");
2882 if (SvOK(sv)) /* is it defined ? */
2883 (void)SvPOK_only_UTF8(sv);
2885 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2888 if (SvTYPE(TARG) < SVt_PVLV) {
2889 sv_upgrade(TARG, SVt_PVLV);
2890 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2894 if (LvTARG(TARG) != sv) {
2896 SvREFCNT_dec(LvTARG(TARG));
2897 LvTARG(TARG) = SvREFCNT_inc(sv);
2899 LvTARGOFF(TARG) = upos;
2900 LvTARGLEN(TARG) = urem;
2904 PUSHs(TARG); /* avoid SvSETMAGIC here */
2911 register IV size = POPi;
2912 register IV offset = POPi;
2913 register SV *src = POPs;
2914 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2916 SvTAINTED_off(TARG); /* decontaminate */
2917 if (lvalue) { /* it's an lvalue! */
2918 if (SvTYPE(TARG) < SVt_PVLV) {
2919 sv_upgrade(TARG, SVt_PVLV);
2920 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2923 if (LvTARG(TARG) != src) {
2925 SvREFCNT_dec(LvTARG(TARG));
2926 LvTARG(TARG) = SvREFCNT_inc(src);
2928 LvTARGOFF(TARG) = offset;
2929 LvTARGLEN(TARG) = size;
2932 sv_setuv(TARG, do_vecget(src, offset, size));
2947 I32 arybase = PL_curcop->cop_arybase;
2952 offset = POPi - arybase;
2955 tmps = SvPV(big, biglen);
2956 if (offset > 0 && DO_UTF8(big))
2957 sv_pos_u2b(big, &offset, 0);
2960 else if (offset > biglen)
2962 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2963 (unsigned char*)tmps + biglen, little, 0)))
2966 retval = tmps2 - tmps;
2967 if (retval > 0 && DO_UTF8(big))
2968 sv_pos_b2u(big, &retval);
2969 PUSHi(retval + arybase);
2984 I32 arybase = PL_curcop->cop_arybase;
2990 tmps2 = SvPV(little, llen);
2991 tmps = SvPV(big, blen);
2995 if (offset > 0 && DO_UTF8(big))
2996 sv_pos_u2b(big, &offset, 0);
2997 offset = offset - arybase + llen;
3001 else if (offset > blen)
3003 if (!(tmps2 = rninstr(tmps, tmps + offset,
3004 tmps2, tmps2 + llen)))
3007 retval = tmps2 - tmps;
3008 if (retval > 0 && DO_UTF8(big))
3009 sv_pos_b2u(big, &retval);
3010 PUSHi(retval + arybase);
3016 dSP; dMARK; dORIGMARK; dTARGET;
3017 do_sprintf(TARG, SP-MARK, MARK+1);
3018 TAINT_IF(SvTAINTED(TARG));
3019 if (DO_UTF8(*(MARK+1)))
3031 U8 *s = (U8*)SvPVx(argsv, len);
3033 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3043 (void)SvUPGRADE(TARG,SVt_PV);
3045 if (value > 255 && !IN_BYTES) {
3046 SvGROW(TARG, UNISKIP(value)+1);
3047 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3048 SvCUR_set(TARG, tmps - SvPVX(TARG));
3050 (void)SvPOK_only(TARG);
3061 (void)SvPOK_only(TARG);
3068 dSP; dTARGET; dPOPTOPssrl;
3072 char *tmps = SvPV(left, len);
3074 if (DO_UTF8(left)) {
3075 /* If Unicode take the crypt() of the low 8 bits
3076 * of the characters of the string. */
3078 char *send = tmps + len;
3080 Newz(688, t, len, char);
3082 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3088 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3090 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3095 "The crypt() function is unimplemented due to excessive paranoia.");
3109 U8 tmpbuf[UTF8_MAXLEN*2+1];
3113 s = (U8*)SvPV(sv, slen);
3114 utf8_to_uvchr(s, &ulen);
3116 toTITLE_utf8(s, tmpbuf, &tculen);
3117 utf8_to_uvchr(tmpbuf, 0);
3119 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3121 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3122 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3127 s = (U8*)SvPV_force(sv, slen);
3128 Copy(tmpbuf, s, tculen, U8);
3132 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3134 SvUTF8_off(TARG); /* decontaminate */
3139 s = (U8*)SvPV_force(sv, slen);
3141 if (IN_LOCALE_RUNTIME) {
3144 *s = toUPPER_LC(*s);
3162 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3164 U8 tmpbuf[UTF8_MAXLEN*2+1];
3168 toLOWER_utf8(s, tmpbuf, &ulen);
3169 uv = utf8_to_uvchr(tmpbuf, 0);
3171 tend = uvchr_to_utf8(tmpbuf, uv);
3173 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3175 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3176 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3181 s = (U8*)SvPV_force(sv, slen);
3182 Copy(tmpbuf, s, ulen, U8);
3186 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3188 SvUTF8_off(TARG); /* decontaminate */
3193 s = (U8*)SvPV_force(sv, slen);
3195 if (IN_LOCALE_RUNTIME) {
3198 *s = toLOWER_LC(*s);
3221 U8 tmpbuf[UTF8_MAXLEN*2+1];
3223 s = (U8*)SvPV(sv,len);
3225 SvUTF8_off(TARG); /* decontaminate */
3226 sv_setpvn(TARG, "", 0);
3230 (void)SvUPGRADE(TARG, SVt_PV);
3231 SvGROW(TARG, (len * 2) + 1);
3232 (void)SvPOK_only(TARG);
3233 d = (U8*)SvPVX(TARG);
3236 toUPPER_utf8(s, tmpbuf, &ulen);
3237 Copy(tmpbuf, d, ulen, U8);
3243 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3248 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3250 SvUTF8_off(TARG); /* decontaminate */
3255 s = (U8*)SvPV_force(sv, len);
3257 register U8 *send = s + len;
3259 if (IN_LOCALE_RUNTIME) {
3262 for (; s < send; s++)
3263 *s = toUPPER_LC(*s);
3266 for (; s < send; s++)
3288 U8 tmpbuf[UTF8_MAXLEN*2+1];
3290 s = (U8*)SvPV(sv,len);
3292 SvUTF8_off(TARG); /* decontaminate */
3293 sv_setpvn(TARG, "", 0);
3297 (void)SvUPGRADE(TARG, SVt_PV);
3298 SvGROW(TARG, (len * 2) + 1);
3299 (void)SvPOK_only(TARG);
3300 d = (U8*)SvPVX(TARG);
3303 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3304 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3305 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3307 * Now if the sigma is NOT followed by
3308 * /$ignorable_sequence$cased_letter/;
3309 * and it IS preceded by
3310 * /$cased_letter$ignorable_sequence/;
3311 * where $ignorable_sequence is
3312 * [\x{2010}\x{AD}\p{Mn}]*
3313 * and $cased_letter is
3314 * [\p{Ll}\p{Lo}\p{Lt}]
3315 * then it should be mapped to 0x03C2,
3316 * (GREEK SMALL LETTER FINAL SIGMA),
3317 * instead of staying 0x03A3.
3318 * See lib/unicore/SpecCase.txt.
3321 Copy(tmpbuf, d, ulen, U8);
3327 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3332 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3334 SvUTF8_off(TARG); /* decontaminate */
3340 s = (U8*)SvPV_force(sv, len);
3342 register U8 *send = s + len;
3344 if (IN_LOCALE_RUNTIME) {
3347 for (; s < send; s++)
3348 *s = toLOWER_LC(*s);
3351 for (; s < send; s++)
3366 register char *s = SvPV(sv,len);
3369 SvUTF8_off(TARG); /* decontaminate */
3371 (void)SvUPGRADE(TARG, SVt_PV);
3372 SvGROW(TARG, (len * 2) + 1);
3376 if (UTF8_IS_CONTINUED(*s)) {
3377 STRLEN ulen = UTF8SKIP(s);
3401 SvCUR_set(TARG, d - SvPVX(TARG));
3402 (void)SvPOK_only_UTF8(TARG);
3405 sv_setpvn(TARG, s, len);
3407 if (SvSMAGICAL(TARG))
3416 dSP; dMARK; dORIGMARK;
3418 register AV* av = (AV*)POPs;
3419 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3420 I32 arybase = PL_curcop->cop_arybase;
3423 if (SvTYPE(av) == SVt_PVAV) {
3424 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3426 for (svp = MARK + 1; svp <= SP; svp++) {
3431 if (max > AvMAX(av))
3434 while (++MARK <= SP) {
3435 elem = SvIVx(*MARK);
3439 svp = av_fetch(av, elem, lval);
3441 if (!svp || *svp == &PL_sv_undef)
3442 DIE(aTHX_ PL_no_aelem, elem);
3443 if (PL_op->op_private & OPpLVAL_INTRO)
3444 save_aelem(av, elem, svp);
3446 *MARK = svp ? *svp : &PL_sv_undef;
3449 if (GIMME != G_ARRAY) {
3457 /* Associative arrays. */
3462 HV *hash = (HV*)POPs;
3464 I32 gimme = GIMME_V;
3465 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3468 /* might clobber stack_sp */
3469 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3474 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3475 if (gimme == G_ARRAY) {
3478 /* might clobber stack_sp */
3480 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3485 else if (gimme == G_SCALAR)
3504 I32 gimme = GIMME_V;
3505 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3509 if (PL_op->op_private & OPpSLICE) {
3513 hvtype = SvTYPE(hv);
3514 if (hvtype == SVt_PVHV) { /* hash element */
3515 while (++MARK <= SP) {
3516 sv = hv_delete_ent(hv, *MARK, discard, 0);
3517 *MARK = sv ? sv : &PL_sv_undef;
3520 else if (hvtype == SVt_PVAV) {
3521 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3522 while (++MARK <= SP) {
3523 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3524 *MARK = sv ? sv : &PL_sv_undef;
3527 else { /* pseudo-hash element */
3528 while (++MARK <= SP) {
3529 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3530 *MARK = sv ? sv : &PL_sv_undef;
3535 DIE(aTHX_ "Not a HASH reference");
3538 else if (gimme == G_SCALAR) {
3547 if (SvTYPE(hv) == SVt_PVHV)
3548 sv = hv_delete_ent(hv, keysv, discard, 0);
3549 else if (SvTYPE(hv) == SVt_PVAV) {
3550 if (PL_op->op_flags & OPf_SPECIAL)
3551 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3553 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3556 DIE(aTHX_ "Not a HASH reference");
3571 if (PL_op->op_private & OPpEXISTS_SUB) {
3575 cv = sv_2cv(sv, &hv, &gv, FALSE);
3578 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3584 if (SvTYPE(hv) == SVt_PVHV) {
3585 if (hv_exists_ent(hv, tmpsv, 0))
3588 else if (SvTYPE(hv) == SVt_PVAV) {
3589 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3590 if (av_exists((AV*)hv, SvIV(tmpsv)))
3593 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3597 DIE(aTHX_ "Not a HASH reference");
3604 dSP; dMARK; dORIGMARK;
3605 register HV *hv = (HV*)POPs;
3606 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3607 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3609 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3610 DIE(aTHX_ "Can't localize pseudo-hash element");
3612 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3613 while (++MARK <= SP) {
3616 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3617 realhv ? hv_exists_ent(hv, keysv, 0)
3618 : avhv_exists_ent((AV*)hv, keysv, 0);
3620 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3621 svp = he ? &HeVAL(he) : 0;
3624 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3627 if (!svp || *svp == &PL_sv_undef) {
3629 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3631 if (PL_op->op_private & OPpLVAL_INTRO) {
3633 save_helem(hv, keysv, svp);
3636 char *key = SvPV(keysv, keylen);
3637 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3641 *MARK = svp ? *svp : &PL_sv_undef;
3644 if (GIMME != G_ARRAY) {
3652 /* List operators. */
3657 if (GIMME != G_ARRAY) {
3659 *MARK = *SP; /* unwanted list, return last item */
3661 *MARK = &PL_sv_undef;
3670 SV **lastrelem = PL_stack_sp;
3671 SV **lastlelem = PL_stack_base + POPMARK;
3672 SV **firstlelem = PL_stack_base + POPMARK + 1;
3673 register SV **firstrelem = lastlelem + 1;
3674 I32 arybase = PL_curcop->cop_arybase;
3675 I32 lval = PL_op->op_flags & OPf_MOD;
3676 I32 is_something_there = lval;
3678 register I32 max = lastrelem - lastlelem;
3679 register SV **lelem;
3682 if (GIMME != G_ARRAY) {
3683 ix = SvIVx(*lastlelem);
3688 if (ix < 0 || ix >= max)
3689 *firstlelem = &PL_sv_undef;
3691 *firstlelem = firstrelem[ix];
3697 SP = firstlelem - 1;
3701 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3707 if (ix < 0 || ix >= max)
3708 *lelem = &PL_sv_undef;
3710 is_something_there = TRUE;
3711 if (!(*lelem = firstrelem[ix]))
3712 *lelem = &PL_sv_undef;
3715 if (is_something_there)
3718 SP = firstlelem - 1;
3724 dSP; dMARK; dORIGMARK;
3725 I32 items = SP - MARK;
3726 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3727 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3734 dSP; dMARK; dORIGMARK;
3735 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3739 SV *val = NEWSV(46, 0);
3741 sv_setsv(val, *++MARK);
3742 else if (ckWARN(WARN_MISC))
3743 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3744 (void)hv_store_ent(hv,key,val,0);
3753 dSP; dMARK; dORIGMARK;
3754 register AV *ary = (AV*)*++MARK;
3758 register I32 offset;
3759 register I32 length;
3766 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3767 *MARK-- = SvTIED_obj((SV*)ary, mg);
3771 call_method("SPLICE",GIMME_V);
3780 offset = i = SvIVx(*MARK);
3782 offset += AvFILLp(ary) + 1;
3784 offset -= PL_curcop->cop_arybase;
3786 DIE(aTHX_ PL_no_aelem, i);
3788 length = SvIVx(*MARK++);
3790 length += AvFILLp(ary) - offset + 1;
3796 length = AvMAX(ary) + 1; /* close enough to infinity */
3800 length = AvMAX(ary) + 1;
3802 if (offset > AvFILLp(ary) + 1)
3803 offset = AvFILLp(ary) + 1;
3804 after = AvFILLp(ary) + 1 - (offset + length);
3805 if (after < 0) { /* not that much array */
3806 length += after; /* offset+length now in array */
3812 /* At this point, MARK .. SP-1 is our new LIST */
3815 diff = newlen - length;
3816 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3819 if (diff < 0) { /* shrinking the area */
3821 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3822 Copy(MARK, tmparyval, newlen, SV*);
3825 MARK = ORIGMARK + 1;
3826 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3827 MEXTEND(MARK, length);
3828 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3830 EXTEND_MORTAL(length);
3831 for (i = length, dst = MARK; i; i--) {
3832 sv_2mortal(*dst); /* free them eventualy */
3839 *MARK = AvARRAY(ary)[offset+length-1];
3842 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3843 SvREFCNT_dec(*dst++); /* free them now */
3846 AvFILLp(ary) += diff;
3848 /* pull up or down? */
3850 if (offset < after) { /* easier to pull up */
3851 if (offset) { /* esp. if nothing to pull */
3852 src = &AvARRAY(ary)[offset-1];
3853 dst = src - diff; /* diff is negative */
3854 for (i = offset; i > 0; i--) /* can't trust Copy */
3858 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3862 if (after) { /* anything to pull down? */
3863 src = AvARRAY(ary) + offset + length;
3864 dst = src + diff; /* diff is negative */
3865 Move(src, dst, after, SV*);
3867 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3868 /* avoid later double free */
3872 dst[--i] = &PL_sv_undef;
3875 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3877 *dst = NEWSV(46, 0);
3878 sv_setsv(*dst++, *src++);
3880 Safefree(tmparyval);
3883 else { /* no, expanding (or same) */
3885 New(452, tmparyval, length, SV*); /* so remember deletion */
3886 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3889 if (diff > 0) { /* expanding */
3891 /* push up or down? */
3893 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3897 Move(src, dst, offset, SV*);
3899 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3901 AvFILLp(ary) += diff;
3904 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3905 av_extend(ary, AvFILLp(ary) + diff);
3906 AvFILLp(ary) += diff;
3909 dst = AvARRAY(ary) + AvFILLp(ary);
3911 for (i = after; i; i--) {
3918 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3919 *dst = NEWSV(46, 0);
3920 sv_setsv(*dst++, *src++);
3922 MARK = ORIGMARK + 1;
3923 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3925 Copy(tmparyval, MARK, length, SV*);
3927 EXTEND_MORTAL(length);
3928 for (i = length, dst = MARK; i; i--) {
3929 sv_2mortal(*dst); /* free them eventualy */
3933 Safefree(tmparyval);
3937 else if (length--) {
3938 *MARK = tmparyval[length];
3941 while (length-- > 0)
3942 SvREFCNT_dec(tmparyval[length]);
3944 Safefree(tmparyval);
3947 *MARK = &PL_sv_undef;
3955 dSP; dMARK; dORIGMARK; dTARGET;
3956 register AV *ary = (AV*)*++MARK;
3957 register SV *sv = &PL_sv_undef;
3960 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3961 *MARK-- = SvTIED_obj((SV*)ary, mg);
3965 call_method("PUSH",G_SCALAR|G_DISCARD);
3970 /* Why no pre-extend of ary here ? */
3971 for (++MARK; MARK <= SP; MARK++) {
3974 sv_setsv(sv, *MARK);
3979 PUSHi( AvFILL(ary) + 1 );
3987 SV *sv = av_pop(av);
3989 (void)sv_2mortal(sv);
3998 SV *sv = av_shift(av);
4003 (void)sv_2mortal(sv);
4010 dSP; dMARK; dORIGMARK; dTARGET;
4011 register AV *ary = (AV*)*++MARK;
4016 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4017 *MARK-- = SvTIED_obj((SV*)ary, mg);
4021 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4026 av_unshift(ary, SP - MARK);
4029 sv_setsv(sv, *++MARK);
4030 (void)av_store(ary, i++, sv);
4034 PUSHi( AvFILL(ary) + 1 );
4044 if (GIMME == G_ARRAY) {
4051 /* safe as long as stack cannot get extended in the above */
4056 register char *down;
4061 SvUTF8_off(TARG); /* decontaminate */
4063 do_join(TARG, &PL_sv_no, MARK, SP);
4065 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4066 up = SvPV_force(TARG, len);
4068 if (DO_UTF8(TARG)) { /* first reverse each character */
4069 U8* s = (U8*)SvPVX(TARG);
4070 U8* send = (U8*)(s + len);
4072 if (UTF8_IS_INVARIANT(*s)) {
4077 if (!utf8_to_uvchr(s, 0))
4081 down = (char*)(s - 1);
4082 /* reverse this character */
4092 down = SvPVX(TARG) + len - 1;
4098 (void)SvPOK_only_UTF8(TARG);
4110 register IV limit = POPi; /* note, negative is forever */
4113 register char *s = SvPV(sv, len);
4114 bool do_utf8 = DO_UTF8(sv);
4115 char *strend = s + len;
4117 register REGEXP *rx;
4121 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4122 I32 maxiters = slen + 10;
4125 I32 origlimit = limit;
4128 AV *oldstack = PL_curstack;
4129 I32 gimme = GIMME_V;
4130 I32 oldsave = PL_savestack_ix;
4131 I32 make_mortal = 1;
4132 MAGIC *mg = (MAGIC *) NULL;
4135 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4140 DIE(aTHX_ "panic: pp_split");
4143 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4144 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4146 PL_reg_match_utf8 = do_utf8;
4148 if (pm->op_pmreplroot) {
4150 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4152 ary = GvAVn((GV*)pm->op_pmreplroot);
4155 else if (gimme != G_ARRAY)
4156 #ifdef USE_5005THREADS
4157 ary = (AV*)PL_curpad[0];
4159 ary = GvAVn(PL_defgv);
4160 #endif /* USE_5005THREADS */
4163 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4169 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4171 XPUSHs(SvTIED_obj((SV*)ary, mg));
4177 for (i = AvFILLp(ary); i >= 0; i--)
4178 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4180 /* temporarily switch stacks */
4181 SWITCHSTACK(PL_curstack, ary);
4185 base = SP - PL_stack_base;
4187 if (pm->op_pmflags & PMf_SKIPWHITE) {
4188 if (pm->op_pmflags & PMf_LOCALE) {
4189 while (isSPACE_LC(*s))
4197 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4198 SAVEINT(PL_multiline);
4199 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4203 limit = maxiters + 2;
4204 if (pm->op_pmflags & PMf_WHITE) {
4207 while (m < strend &&
4208 !((pm->op_pmflags & PMf_LOCALE)
4209 ? isSPACE_LC(*m) : isSPACE(*m)))
4214 dstr = NEWSV(30, m-s);
4215 sv_setpvn(dstr, s, m-s);
4219 (void)SvUTF8_on(dstr);
4223 while (s < strend &&
4224 ((pm->op_pmflags & PMf_LOCALE)
4225 ? isSPACE_LC(*s) : isSPACE(*s)))
4229 else if (strEQ("^", rx->precomp)) {
4232 for (m = s; m < strend && *m != '\n'; m++) ;
4236 dstr = NEWSV(30, m-s);
4237 sv_setpvn(dstr, s, m-s);
4241 (void)SvUTF8_on(dstr);
4246 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4247 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4248 && (rx->reganch & ROPT_CHECK_ALL)
4249 && !(rx->reganch & ROPT_ANCH)) {
4250 int tail = (rx->reganch & RE_INTUIT_TAIL);
4251 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4254 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4256 char c = *SvPV(csv, n_a);
4259 for (m = s; m < strend && *m != c; m++) ;
4262 dstr = NEWSV(30, m-s);
4263 sv_setpvn(dstr, s, m-s);
4267 (void)SvUTF8_on(dstr);
4269 /* The rx->minlen is in characters but we want to step
4270 * s ahead by bytes. */
4272 s = (char*)utf8_hop((U8*)m, len);
4274 s = m + len; /* Fake \n at the end */
4279 while (s < strend && --limit &&
4280 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4281 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4284 dstr = NEWSV(31, m-s);
4285 sv_setpvn(dstr, s, m-s);
4289 (void)SvUTF8_on(dstr);
4291 /* The rx->minlen is in characters but we want to step
4292 * s ahead by bytes. */
4294 s = (char*)utf8_hop((U8*)m, len);
4296 s = m + len; /* Fake \n at the end */
4301 maxiters += slen * rx->nparens;
4302 while (s < strend && --limit
4303 /* && (!rx->check_substr
4304 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4306 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4307 1 /* minend */, sv, NULL, 0))
4309 TAINT_IF(RX_MATCH_TAINTED(rx));
4310 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4315 strend = s + (strend - m);
4317 m = rx->startp[0] + orig;
4318 dstr = NEWSV(32, m-s);
4319 sv_setpvn(dstr, s, m-s);
4323 (void)SvUTF8_on(dstr);
4326 for (i = 1; i <= rx->nparens; i++) {
4327 s = rx->startp[i] + orig;
4328 m = rx->endp[i] + orig;
4330 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4331 parens that didn't match -- they should be set to
4332 undef, not the empty string */
4333 if (m >= orig && s >= orig) {
4334 dstr = NEWSV(33, m-s);
4335 sv_setpvn(dstr, s, m-s);
4338 dstr = &PL_sv_undef; /* undef, not "" */
4342 (void)SvUTF8_on(dstr);
4346 s = rx->endp[0] + orig;
4350 LEAVE_SCOPE(oldsave);
4351 iters = (SP - PL_stack_base) - base;
4352 if (iters > maxiters)
4353 DIE(aTHX_ "Split loop");
4355 /* keep field after final delim? */
4356 if (s < strend || (iters && origlimit)) {
4357 STRLEN l = strend - s;
4358 dstr = NEWSV(34, l);
4359 sv_setpvn(dstr, s, l);
4363 (void)SvUTF8_on(dstr);
4367 else if (!origlimit) {
4368 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4374 SWITCHSTACK(ary, oldstack);
4375 if (SvSMAGICAL(ary)) {
4380 if (gimme == G_ARRAY) {
4382 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4390 call_method("PUSH",G_SCALAR|G_DISCARD);
4393 if (gimme == G_ARRAY) {
4394 /* EXTEND should not be needed - we just popped them */
4396 for (i=0; i < iters; i++) {
4397 SV **svp = av_fetch(ary, i, FALSE);
4398 PUSHs((svp) ? *svp : &PL_sv_undef);
4405 if (gimme == G_ARRAY)
4408 if (iters || !pm->op_pmreplroot) {
4416 #ifdef USE_5005THREADS
4418 Perl_unlock_condpair(pTHX_ void *svv)
4420 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4423 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4424 MUTEX_LOCK(MgMUTEXP(mg));
4425 if (MgOWNER(mg) != thr)
4426 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4428 COND_SIGNAL(MgOWNERCONDP(mg));
4429 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4430 PTR2UV(thr), PTR2UV(svv)));
4431 MUTEX_UNLOCK(MgMUTEXP(mg));
4433 #endif /* USE_5005THREADS */
4440 #ifdef USE_5005THREADS
4442 #endif /* USE_5005THREADS */
4444 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4446 Perl_sharedsv_lock(aTHX_ ssv);
4447 #endif /* USE_ITHREADS */
4448 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4449 || SvTYPE(retsv) == SVt_PVCV) {
4450 retsv = refto(retsv);
4458 #ifdef USE_5005THREADS
4461 if (PL_op->op_private & OPpLVAL_INTRO)
4462 PUSHs(*save_threadsv(PL_op->op_targ));
4464 PUSHs(THREADSV(PL_op->op_targ));
4467 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4468 #endif /* USE_5005THREADS */