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. However,
1078 as left >= right to ensure integer result here, we know that
1079 we can skip the test on the right operand - right big
1080 enough not to be preserved can't get here unless left is
1083 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1086 /* Integer division can't overflow, but it can be imprecise. */
1087 UV result = left / right;
1088 if (result * right == left) {
1089 SP--; /* result is valid */
1090 if (left_non_neg == right_non_neg) {
1091 /* signs identical, result is positive. */
1095 /* 2s complement assumption */
1096 if (result <= (UV)IV_MIN)
1099 /* It's exact but too negative for IV. */
1100 SETn( -(NV)result );
1103 } /* tried integer divide but it was not an integer result */
1104 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1105 } /* left wasn't SvIOK */
1106 } /* right wasn't SvIOK */
1107 #endif /* PERL_TRY_UV_DIVIDE */
1111 DIE(aTHX_ "Illegal division by zero");
1112 PUSHn( left / right );
1119 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1125 bool use_double = FALSE;
1126 bool dright_valid = FALSE;
1132 right_neg = !SvUOK(TOPs);
1134 right = SvUVX(POPs);
1136 IV biv = SvIVX(POPs);
1139 right_neg = FALSE; /* effectively it's a UV now */
1147 right_neg = dright < 0;
1150 if (dright < UV_MAX_P1) {
1151 right = U_V(dright);
1152 dright_valid = TRUE; /* In case we need to use double below. */
1158 /* At this point use_double is only true if right is out of range for
1159 a UV. In range NV has been rounded down to nearest UV and
1160 use_double false. */
1162 if (!use_double && SvIOK(TOPs)) {
1164 left_neg = !SvUOK(TOPs);
1168 IV aiv = SvIVX(POPs);
1171 left_neg = FALSE; /* effectively it's a UV now */
1180 left_neg = dleft < 0;
1184 /* This should be exactly the 5.6 behaviour - if left and right are
1185 both in range for UV then use U_V() rather than floor. */
1187 if (dleft < UV_MAX_P1) {
1188 /* right was in range, so is dleft, so use UVs not double.
1192 /* left is out of range for UV, right was in range, so promote
1193 right (back) to double. */
1195 /* The +0.5 is used in 5.6 even though it is not strictly
1196 consistent with the implicit +0 floor in the U_V()
1197 inside the #if 1. */
1198 dleft = Perl_floor(dleft + 0.5);
1201 dright = Perl_floor(dright + 0.5);
1211 DIE(aTHX_ "Illegal modulus zero");
1213 dans = Perl_fmod(dleft, dright);
1214 if ((left_neg != right_neg) && dans)
1215 dans = dright - dans;
1218 sv_setnv(TARG, dans);
1224 DIE(aTHX_ "Illegal modulus zero");
1227 if ((left_neg != right_neg) && ans)
1230 /* XXX may warn: unary minus operator applied to unsigned type */
1231 /* could change -foo to be (~foo)+1 instead */
1232 if (ans <= ~((UV)IV_MAX)+1)
1233 sv_setiv(TARG, ~ans+1);
1235 sv_setnv(TARG, -(NV)ans);
1238 sv_setuv(TARG, ans);
1247 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1249 register IV count = POPi;
1250 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1252 I32 items = SP - MARK;
1255 max = items * count;
1260 /* This code was intended to fix 20010809.028:
1263 for (($x =~ /./g) x 2) {
1264 print chop; # "abcdabcd" expected as output.
1267 * but that change (#11635) broke this code:
1269 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1271 * I can't think of a better fix that doesn't introduce
1272 * an efficiency hit by copying the SVs. The stack isn't
1273 * refcounted, and mortalisation obviously doesn't
1274 * Do The Right Thing when the stack has more than
1275 * one pointer to the same mortal value.
1279 *SP = sv_2mortal(newSVsv(*SP));
1289 repeatcpy((char*)(MARK + items), (char*)MARK,
1290 items * sizeof(SV*), count - 1);
1293 else if (count <= 0)
1296 else { /* Note: mark already snarfed by pp_list */
1301 SvSetSV(TARG, tmpstr);
1302 SvPV_force(TARG, len);
1303 isutf = DO_UTF8(TARG);
1308 SvGROW(TARG, (count * len) + 1);
1309 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1310 SvCUR(TARG) *= count;
1312 *SvEND(TARG) = '\0';
1315 (void)SvPOK_only_UTF8(TARG);
1317 (void)SvPOK_only(TARG);
1319 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1320 /* The parser saw this as a list repeat, and there
1321 are probably several items on the stack. But we're
1322 in scalar context, and there's no pp_list to save us
1323 now. So drop the rest of the items -- robin@kitsite.com
1336 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1337 useleft = USE_LEFT(TOPm1s);
1338 #ifdef PERL_PRESERVE_IVUV
1339 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1340 "bad things" happen if you rely on signed integers wrapping. */
1343 /* Unless the left argument is integer in range we are going to have to
1344 use NV maths. Hence only attempt to coerce the right argument if
1345 we know the left is integer. */
1346 register UV auv = 0;
1352 a_valid = auvok = 1;
1353 /* left operand is undef, treat as zero. */
1355 /* Left operand is defined, so is it IV? */
1356 SvIV_please(TOPm1s);
1357 if (SvIOK(TOPm1s)) {
1358 if ((auvok = SvUOK(TOPm1s)))
1359 auv = SvUVX(TOPm1s);
1361 register IV aiv = SvIVX(TOPm1s);
1364 auvok = 1; /* Now acting as a sign flag. */
1365 } else { /* 2s complement assumption for IV_MIN */
1373 bool result_good = 0;
1376 bool buvok = SvUOK(TOPs);
1381 register IV biv = SvIVX(TOPs);
1388 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1389 else "IV" now, independant of how it came in.
1390 if a, b represents positive, A, B negative, a maps to -A etc
1395 all UV maths. negate result if A negative.
1396 subtract if signs same, add if signs differ. */
1398 if (auvok ^ buvok) {
1407 /* Must get smaller */
1412 if (result <= buv) {
1413 /* result really should be -(auv-buv). as its negation
1414 of true value, need to swap our result flag */
1426 if (result <= (UV)IV_MIN)
1427 SETi( -(IV)result );
1429 /* result valid, but out of range for IV. */
1430 SETn( -(NV)result );
1434 } /* Overflow, drop through to NVs. */
1438 useleft = USE_LEFT(TOPm1s);
1442 /* left operand is undef, treat as zero - value */
1446 SETn( TOPn - value );
1453 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1456 if (PL_op->op_private & HINT_INTEGER) {
1470 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1473 if (PL_op->op_private & HINT_INTEGER) {
1487 dSP; tryAMAGICbinSET(lt,0);
1488 #ifdef PERL_PRESERVE_IVUV
1491 SvIV_please(TOPm1s);
1492 if (SvIOK(TOPm1s)) {
1493 bool auvok = SvUOK(TOPm1s);
1494 bool buvok = SvUOK(TOPs);
1496 if (!auvok && !buvok) { /* ## IV < IV ## */
1497 IV aiv = SvIVX(TOPm1s);
1498 IV biv = SvIVX(TOPs);
1501 SETs(boolSV(aiv < biv));
1504 if (auvok && buvok) { /* ## UV < UV ## */
1505 UV auv = SvUVX(TOPm1s);
1506 UV buv = SvUVX(TOPs);
1509 SETs(boolSV(auv < buv));
1512 if (auvok) { /* ## UV < IV ## */
1519 /* As (a) is a UV, it's >=0, so it cannot be < */
1524 SETs(boolSV(auv < (UV)biv));
1527 { /* ## IV < UV ## */
1531 aiv = SvIVX(TOPm1s);
1533 /* As (b) is a UV, it's >=0, so it must be < */
1540 SETs(boolSV((UV)aiv < buv));
1546 #ifndef NV_PRESERVES_UV
1547 #ifdef PERL_PRESERVE_IVUV
1550 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1552 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1558 SETs(boolSV(TOPn < value));
1565 dSP; tryAMAGICbinSET(gt,0);
1566 #ifdef PERL_PRESERVE_IVUV
1569 SvIV_please(TOPm1s);
1570 if (SvIOK(TOPm1s)) {
1571 bool auvok = SvUOK(TOPm1s);
1572 bool buvok = SvUOK(TOPs);
1574 if (!auvok && !buvok) { /* ## IV > IV ## */
1575 IV aiv = SvIVX(TOPm1s);
1576 IV biv = SvIVX(TOPs);
1579 SETs(boolSV(aiv > biv));
1582 if (auvok && buvok) { /* ## UV > UV ## */
1583 UV auv = SvUVX(TOPm1s);
1584 UV buv = SvUVX(TOPs);
1587 SETs(boolSV(auv > buv));
1590 if (auvok) { /* ## UV > IV ## */
1597 /* As (a) is a UV, it's >=0, so it must be > */
1602 SETs(boolSV(auv > (UV)biv));
1605 { /* ## IV > UV ## */
1609 aiv = SvIVX(TOPm1s);
1611 /* As (b) is a UV, it's >=0, so it cannot be > */
1618 SETs(boolSV((UV)aiv > buv));
1624 #ifndef NV_PRESERVES_UV
1625 #ifdef PERL_PRESERVE_IVUV
1628 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1630 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1636 SETs(boolSV(TOPn > value));
1643 dSP; tryAMAGICbinSET(le,0);
1644 #ifdef PERL_PRESERVE_IVUV
1647 SvIV_please(TOPm1s);
1648 if (SvIOK(TOPm1s)) {
1649 bool auvok = SvUOK(TOPm1s);
1650 bool buvok = SvUOK(TOPs);
1652 if (!auvok && !buvok) { /* ## IV <= IV ## */
1653 IV aiv = SvIVX(TOPm1s);
1654 IV biv = SvIVX(TOPs);
1657 SETs(boolSV(aiv <= biv));
1660 if (auvok && buvok) { /* ## UV <= UV ## */
1661 UV auv = SvUVX(TOPm1s);
1662 UV buv = SvUVX(TOPs);
1665 SETs(boolSV(auv <= buv));
1668 if (auvok) { /* ## UV <= IV ## */
1675 /* As (a) is a UV, it's >=0, so a cannot be <= */
1680 SETs(boolSV(auv <= (UV)biv));
1683 { /* ## IV <= UV ## */
1687 aiv = SvIVX(TOPm1s);
1689 /* As (b) is a UV, it's >=0, so a must be <= */
1696 SETs(boolSV((UV)aiv <= buv));
1702 #ifndef NV_PRESERVES_UV
1703 #ifdef PERL_PRESERVE_IVUV
1706 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1708 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1714 SETs(boolSV(TOPn <= value));
1721 dSP; tryAMAGICbinSET(ge,0);
1722 #ifdef PERL_PRESERVE_IVUV
1725 SvIV_please(TOPm1s);
1726 if (SvIOK(TOPm1s)) {
1727 bool auvok = SvUOK(TOPm1s);
1728 bool buvok = SvUOK(TOPs);
1730 if (!auvok && !buvok) { /* ## IV >= IV ## */
1731 IV aiv = SvIVX(TOPm1s);
1732 IV biv = SvIVX(TOPs);
1735 SETs(boolSV(aiv >= biv));
1738 if (auvok && buvok) { /* ## UV >= UV ## */
1739 UV auv = SvUVX(TOPm1s);
1740 UV buv = SvUVX(TOPs);
1743 SETs(boolSV(auv >= buv));
1746 if (auvok) { /* ## UV >= IV ## */
1753 /* As (a) is a UV, it's >=0, so it must be >= */
1758 SETs(boolSV(auv >= (UV)biv));
1761 { /* ## IV >= UV ## */
1765 aiv = SvIVX(TOPm1s);
1767 /* As (b) is a UV, it's >=0, so a cannot be >= */
1774 SETs(boolSV((UV)aiv >= buv));
1780 #ifndef NV_PRESERVES_UV
1781 #ifdef PERL_PRESERVE_IVUV
1784 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1786 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1792 SETs(boolSV(TOPn >= value));
1799 dSP; tryAMAGICbinSET(ne,0);
1800 #ifndef NV_PRESERVES_UV
1801 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1803 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1807 #ifdef PERL_PRESERVE_IVUV
1810 SvIV_please(TOPm1s);
1811 if (SvIOK(TOPm1s)) {
1812 bool auvok = SvUOK(TOPm1s);
1813 bool buvok = SvUOK(TOPs);
1815 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1816 /* Casting IV to UV before comparison isn't going to matter
1817 on 2s complement. On 1s complement or sign&magnitude
1818 (if we have any of them) it could make negative zero
1819 differ from normal zero. As I understand it. (Need to
1820 check - is negative zero implementation defined behaviour
1822 UV buv = SvUVX(POPs);
1823 UV auv = SvUVX(TOPs);
1825 SETs(boolSV(auv != buv));
1828 { /* ## Mixed IV,UV ## */
1832 /* != is commutative so swap if needed (save code) */
1834 /* swap. top of stack (b) is the iv */
1838 /* As (a) is a UV, it's >0, so it cannot be == */
1847 /* As (b) is a UV, it's >0, so it cannot be == */
1851 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1853 SETs(boolSV((UV)iv != uv));
1861 SETs(boolSV(TOPn != value));
1868 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1869 #ifndef NV_PRESERVES_UV
1870 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1871 UV right = PTR2UV(SvRV(POPs));
1872 UV left = PTR2UV(SvRV(TOPs));
1873 SETi((left > right) - (left < right));
1877 #ifdef PERL_PRESERVE_IVUV
1878 /* Fortunately it seems NaN isn't IOK */
1881 SvIV_please(TOPm1s);
1882 if (SvIOK(TOPm1s)) {
1883 bool leftuvok = SvUOK(TOPm1s);
1884 bool rightuvok = SvUOK(TOPs);
1886 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1887 IV leftiv = SvIVX(TOPm1s);
1888 IV rightiv = SvIVX(TOPs);
1890 if (leftiv > rightiv)
1892 else if (leftiv < rightiv)
1896 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1897 UV leftuv = SvUVX(TOPm1s);
1898 UV rightuv = SvUVX(TOPs);
1900 if (leftuv > rightuv)
1902 else if (leftuv < rightuv)
1906 } else if (leftuvok) { /* ## UV <=> IV ## */
1910 rightiv = SvIVX(TOPs);
1912 /* As (a) is a UV, it's >=0, so it cannot be < */
1915 leftuv = SvUVX(TOPm1s);
1916 if (leftuv > (UV)rightiv) {
1918 } else if (leftuv < (UV)rightiv) {
1924 } else { /* ## IV <=> UV ## */
1928 leftiv = SvIVX(TOPm1s);
1930 /* As (b) is a UV, it's >=0, so it must be < */
1933 rightuv = SvUVX(TOPs);
1934 if ((UV)leftiv > rightuv) {
1936 } else if ((UV)leftiv < rightuv) {
1954 if (Perl_isnan(left) || Perl_isnan(right)) {
1958 value = (left > right) - (left < right);
1962 else if (left < right)
1964 else if (left > right)
1978 dSP; tryAMAGICbinSET(slt,0);
1981 int cmp = (IN_LOCALE_RUNTIME
1982 ? sv_cmp_locale(left, right)
1983 : sv_cmp(left, right));
1984 SETs(boolSV(cmp < 0));
1991 dSP; tryAMAGICbinSET(sgt,0);
1994 int cmp = (IN_LOCALE_RUNTIME
1995 ? sv_cmp_locale(left, right)
1996 : sv_cmp(left, right));
1997 SETs(boolSV(cmp > 0));
2004 dSP; tryAMAGICbinSET(sle,0);
2007 int cmp = (IN_LOCALE_RUNTIME
2008 ? sv_cmp_locale(left, right)
2009 : sv_cmp(left, right));
2010 SETs(boolSV(cmp <= 0));
2017 dSP; tryAMAGICbinSET(sge,0);
2020 int cmp = (IN_LOCALE_RUNTIME
2021 ? sv_cmp_locale(left, right)
2022 : sv_cmp(left, right));
2023 SETs(boolSV(cmp >= 0));
2030 dSP; tryAMAGICbinSET(seq,0);
2033 SETs(boolSV(sv_eq(left, right)));
2040 dSP; tryAMAGICbinSET(sne,0);
2043 SETs(boolSV(!sv_eq(left, right)));
2050 dSP; dTARGET; tryAMAGICbin(scmp,0);
2053 int cmp = (IN_LOCALE_RUNTIME
2054 ? sv_cmp_locale(left, right)
2055 : sv_cmp(left, right));
2063 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2066 if (SvNIOKp(left) || SvNIOKp(right)) {
2067 if (PL_op->op_private & HINT_INTEGER) {
2068 IV i = SvIV(left) & SvIV(right);
2072 UV u = SvUV(left) & SvUV(right);
2077 do_vop(PL_op->op_type, TARG, left, right);
2086 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2089 if (SvNIOKp(left) || SvNIOKp(right)) {
2090 if (PL_op->op_private & HINT_INTEGER) {
2091 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2095 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2100 do_vop(PL_op->op_type, TARG, left, right);
2109 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2112 if (SvNIOKp(left) || SvNIOKp(right)) {
2113 if (PL_op->op_private & HINT_INTEGER) {
2114 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2118 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2123 do_vop(PL_op->op_type, TARG, left, right);
2132 dSP; dTARGET; tryAMAGICun(neg);
2135 int flags = SvFLAGS(sv);
2138 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2139 /* It's publicly an integer, or privately an integer-not-float */
2142 if (SvIVX(sv) == IV_MIN) {
2143 /* 2s complement assumption. */
2144 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2147 else if (SvUVX(sv) <= IV_MAX) {
2152 else if (SvIVX(sv) != IV_MIN) {
2156 #ifdef PERL_PRESERVE_IVUV
2165 else if (SvPOKp(sv)) {
2167 char *s = SvPV(sv, len);
2168 if (isIDFIRST(*s)) {
2169 sv_setpvn(TARG, "-", 1);
2172 else if (*s == '+' || *s == '-') {
2174 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2176 else if (DO_UTF8(sv)) {
2179 goto oops_its_an_int;
2181 sv_setnv(TARG, -SvNV(sv));
2183 sv_setpvn(TARG, "-", 1);
2190 goto oops_its_an_int;
2191 sv_setnv(TARG, -SvNV(sv));
2203 dSP; tryAMAGICunSET(not);
2204 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2210 dSP; dTARGET; tryAMAGICun(compl);
2214 if (PL_op->op_private & HINT_INTEGER) {
2229 tmps = (U8*)SvPV_force(TARG, len);
2232 /* Calculate exact length, let's not estimate. */
2241 while (tmps < send) {
2242 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2243 tmps += UTF8SKIP(tmps);
2244 targlen += UNISKIP(~c);
2250 /* Now rewind strings and write them. */
2254 Newz(0, result, targlen + 1, U8);
2255 while (tmps < send) {
2256 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2257 tmps += UTF8SKIP(tmps);
2258 result = uvchr_to_utf8(result, ~c);
2262 sv_setpvn(TARG, (char*)result, targlen);
2266 Newz(0, result, nchar + 1, U8);
2267 while (tmps < send) {
2268 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2269 tmps += UTF8SKIP(tmps);
2274 sv_setpvn(TARG, (char*)result, nchar);
2282 register long *tmpl;
2283 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2286 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2291 for ( ; anum > 0; anum--, tmps++)
2300 /* integer versions of some of the above */
2304 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2307 SETi( left * right );
2314 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2318 DIE(aTHX_ "Illegal division by zero");
2319 value = POPi / value;
2327 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2331 DIE(aTHX_ "Illegal modulus zero");
2332 SETi( left % right );
2339 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2342 SETi( left + right );
2349 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2352 SETi( left - right );
2359 dSP; tryAMAGICbinSET(lt,0);
2362 SETs(boolSV(left < right));
2369 dSP; tryAMAGICbinSET(gt,0);
2372 SETs(boolSV(left > right));
2379 dSP; tryAMAGICbinSET(le,0);
2382 SETs(boolSV(left <= right));
2389 dSP; tryAMAGICbinSET(ge,0);
2392 SETs(boolSV(left >= right));
2399 dSP; tryAMAGICbinSET(eq,0);
2402 SETs(boolSV(left == right));
2409 dSP; tryAMAGICbinSET(ne,0);
2412 SETs(boolSV(left != right));
2419 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2426 else if (left < right)
2437 dSP; dTARGET; tryAMAGICun(neg);
2442 /* High falutin' math. */
2446 dSP; dTARGET; tryAMAGICbin(atan2,0);
2449 SETn(Perl_atan2(left, right));
2456 dSP; dTARGET; tryAMAGICun(sin);
2460 value = Perl_sin(value);
2468 dSP; dTARGET; tryAMAGICun(cos);
2472 value = Perl_cos(value);
2478 /* Support Configure command-line overrides for rand() functions.
2479 After 5.005, perhaps we should replace this by Configure support
2480 for drand48(), random(), or rand(). For 5.005, though, maintain
2481 compatibility by calling rand() but allow the user to override it.
2482 See INSTALL for details. --Andy Dougherty 15 July 1998
2484 /* Now it's after 5.005, and Configure supports drand48() and random(),
2485 in addition to rand(). So the overrides should not be needed any more.
2486 --Jarkko Hietaniemi 27 September 1998
2489 #ifndef HAS_DRAND48_PROTO
2490 extern double drand48 (void);
2503 if (!PL_srand_called) {
2504 (void)seedDrand01((Rand_seed_t)seed());
2505 PL_srand_called = TRUE;
2520 (void)seedDrand01((Rand_seed_t)anum);
2521 PL_srand_called = TRUE;
2530 * This is really just a quick hack which grabs various garbage
2531 * values. It really should be a real hash algorithm which
2532 * spreads the effect of every input bit onto every output bit,
2533 * if someone who knows about such things would bother to write it.
2534 * Might be a good idea to add that function to CORE as well.
2535 * No numbers below come from careful analysis or anything here,
2536 * except they are primes and SEED_C1 > 1E6 to get a full-width
2537 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2538 * probably be bigger too.
2541 # define SEED_C1 1000003
2542 #define SEED_C4 73819
2544 # define SEED_C1 25747
2545 #define SEED_C4 20639
2549 #define SEED_C5 26107
2551 #ifndef PERL_NO_DEV_RANDOM
2556 # include <starlet.h>
2557 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2558 * in 100-ns units, typically incremented ever 10 ms. */
2559 unsigned int when[2];
2561 # ifdef HAS_GETTIMEOFDAY
2562 struct timeval when;
2568 /* This test is an escape hatch, this symbol isn't set by Configure. */
2569 #ifndef PERL_NO_DEV_RANDOM
2570 #ifndef PERL_RANDOM_DEVICE
2571 /* /dev/random isn't used by default because reads from it will block
2572 * if there isn't enough entropy available. You can compile with
2573 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2574 * is enough real entropy to fill the seed. */
2575 # define PERL_RANDOM_DEVICE "/dev/urandom"
2577 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2579 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2588 _ckvmssts(sys$gettim(when));
2589 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2591 # ifdef HAS_GETTIMEOFDAY
2592 gettimeofday(&when,(struct timezone *) 0);
2593 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2596 u = (U32)SEED_C1 * when;
2599 u += SEED_C3 * (U32)PerlProc_getpid();
2600 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2601 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2602 u += SEED_C5 * (U32)PTR2UV(&when);
2609 dSP; dTARGET; tryAMAGICun(exp);
2613 value = Perl_exp(value);
2621 dSP; dTARGET; tryAMAGICun(log);
2626 SET_NUMERIC_STANDARD();
2627 DIE(aTHX_ "Can't take log of %g", value);
2629 value = Perl_log(value);
2637 dSP; dTARGET; tryAMAGICun(sqrt);
2642 SET_NUMERIC_STANDARD();
2643 DIE(aTHX_ "Can't take sqrt of %g", value);
2645 value = Perl_sqrt(value);
2653 dSP; dTARGET; tryAMAGICun(int);
2656 IV iv = TOPi; /* attempt to convert to IV if possible. */
2657 /* XXX it's arguable that compiler casting to IV might be subtly
2658 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2659 else preferring IV has introduced a subtle behaviour change bug. OTOH
2660 relying on floating point to be accurate is a bug. */
2671 if (value < (NV)UV_MAX + 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);
2686 double tmp = (double)value;
2687 (void)Perl_modf(tmp, &tmp);
2694 if (value > (NV)IV_MIN - 0.5) {
2697 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2698 # ifdef HAS_MODFL_POW32_BUG
2699 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2701 NV offset = Perl_modf(-value, &value);
2702 (void)Perl_modf(offset, &offset);
2706 (void)Perl_modf(-value, &value);
2710 double tmp = (double)value;
2711 (void)Perl_modf(-tmp, &tmp);
2724 dSP; dTARGET; tryAMAGICun(abs);
2726 /* This will cache the NV value if string isn't actually integer */
2730 /* IVX is precise */
2732 SETu(TOPu); /* force it to be numeric only */
2740 /* 2s complement assumption. Also, not really needed as
2741 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2761 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2766 tmps = (SvPVx(POPs, len));
2767 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2768 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2781 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2786 tmps = (SvPVx(POPs, len));
2787 while (*tmps && len && isSPACE(*tmps))
2792 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2793 else if (*tmps == 'b')
2794 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2796 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2798 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2815 SETi(sv_len_utf8(sv));
2831 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2833 I32 arybase = PL_curcop->cop_arybase;
2837 int num_args = PL_op->op_private & 7;
2838 bool repl_need_utf8_upgrade = FALSE;
2839 bool repl_is_utf8 = FALSE;
2841 SvTAINTED_off(TARG); /* decontaminate */
2842 SvUTF8_off(TARG); /* decontaminate */
2846 repl = SvPV(repl_sv, repl_len);
2847 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2857 sv_utf8_upgrade(sv);
2859 else if (DO_UTF8(sv))
2860 repl_need_utf8_upgrade = TRUE;
2862 tmps = SvPV(sv, curlen);
2864 utf8_curlen = sv_len_utf8(sv);
2865 if (utf8_curlen == curlen)
2868 curlen = utf8_curlen;
2873 if (pos >= arybase) {
2891 else if (len >= 0) {
2893 if (rem > (I32)curlen)
2908 Perl_croak(aTHX_ "substr outside of string");
2909 if (ckWARN(WARN_SUBSTR))
2910 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2917 sv_pos_u2b(sv, &pos, &rem);
2919 sv_setpvn(TARG, tmps, rem);
2920 #ifdef USE_LOCALE_COLLATE
2921 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2926 SV* repl_sv_copy = NULL;
2928 if (repl_need_utf8_upgrade) {
2929 repl_sv_copy = newSVsv(repl_sv);
2930 sv_utf8_upgrade(repl_sv_copy);
2931 repl = SvPV(repl_sv_copy, repl_len);
2932 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2934 sv_insert(sv, pos, rem, repl, repl_len);
2938 SvREFCNT_dec(repl_sv_copy);
2940 else if (lvalue) { /* it's an lvalue! */
2941 if (!SvGMAGICAL(sv)) {
2945 if (ckWARN(WARN_SUBSTR))
2946 Perl_warner(aTHX_ WARN_SUBSTR,
2947 "Attempt to use reference as lvalue in substr");
2949 if (SvOK(sv)) /* is it defined ? */
2950 (void)SvPOK_only_UTF8(sv);
2952 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2955 if (SvTYPE(TARG) < SVt_PVLV) {
2956 sv_upgrade(TARG, SVt_PVLV);
2957 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2961 if (LvTARG(TARG) != sv) {
2963 SvREFCNT_dec(LvTARG(TARG));
2964 LvTARG(TARG) = SvREFCNT_inc(sv);
2966 LvTARGOFF(TARG) = upos;
2967 LvTARGLEN(TARG) = urem;
2971 PUSHs(TARG); /* avoid SvSETMAGIC here */
2978 register IV size = POPi;
2979 register IV offset = POPi;
2980 register SV *src = POPs;
2981 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2983 SvTAINTED_off(TARG); /* decontaminate */
2984 if (lvalue) { /* it's an lvalue! */
2985 if (SvTYPE(TARG) < SVt_PVLV) {
2986 sv_upgrade(TARG, SVt_PVLV);
2987 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2990 if (LvTARG(TARG) != src) {
2992 SvREFCNT_dec(LvTARG(TARG));
2993 LvTARG(TARG) = SvREFCNT_inc(src);
2995 LvTARGOFF(TARG) = offset;
2996 LvTARGLEN(TARG) = size;
2999 sv_setuv(TARG, do_vecget(src, offset, size));
3014 I32 arybase = PL_curcop->cop_arybase;
3019 offset = POPi - arybase;
3022 tmps = SvPV(big, biglen);
3023 if (offset > 0 && DO_UTF8(big))
3024 sv_pos_u2b(big, &offset, 0);
3027 else if (offset > biglen)
3029 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3030 (unsigned char*)tmps + biglen, little, 0)))
3033 retval = tmps2 - tmps;
3034 if (retval > 0 && DO_UTF8(big))
3035 sv_pos_b2u(big, &retval);
3036 PUSHi(retval + arybase);
3051 I32 arybase = PL_curcop->cop_arybase;
3057 tmps2 = SvPV(little, llen);
3058 tmps = SvPV(big, blen);
3062 if (offset > 0 && DO_UTF8(big))
3063 sv_pos_u2b(big, &offset, 0);
3064 offset = offset - arybase + llen;
3068 else if (offset > blen)
3070 if (!(tmps2 = rninstr(tmps, tmps + offset,
3071 tmps2, tmps2 + llen)))
3074 retval = tmps2 - tmps;
3075 if (retval > 0 && DO_UTF8(big))
3076 sv_pos_b2u(big, &retval);
3077 PUSHi(retval + arybase);
3083 dSP; dMARK; dORIGMARK; dTARGET;
3084 do_sprintf(TARG, SP-MARK, MARK+1);
3085 TAINT_IF(SvTAINTED(TARG));
3086 if (DO_UTF8(*(MARK+1)))
3098 U8 *s = (U8*)SvPVx(argsv, len);
3101 if (PL_encoding && !DO_UTF8(argsv)) {
3102 tmpsv = sv_2mortal(newSVsv(argsv));
3103 s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
3107 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3118 (void)SvUPGRADE(TARG,SVt_PV);
3120 if (value > 255 && !IN_BYTES) {
3121 SvGROW(TARG, UNISKIP(value)+1);
3122 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3123 SvCUR_set(TARG, tmps - SvPVX(TARG));
3125 (void)SvPOK_only(TARG);
3136 (void)SvPOK_only(TARG);
3138 Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
3150 char *tmps = SvPV(left, len);
3152 if (DO_UTF8(left)) {
3153 /* If Unicode take the crypt() of the low 8 bits
3154 * of the characters of the string. */
3156 char *send = tmps + len;
3158 Newz(688, t, len, char);
3160 t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
3166 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3168 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3173 "The crypt() function is unimplemented due to excessive paranoia.");
3187 U8 tmpbuf[UTF8_MAXLEN*2+1];
3191 s = (U8*)SvPV(sv, slen);
3192 utf8_to_uvchr(s, &ulen);
3194 toTITLE_utf8(s, tmpbuf, &tculen);
3195 utf8_to_uvchr(tmpbuf, 0);
3197 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3199 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3200 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3205 s = (U8*)SvPV_force(sv, slen);
3206 Copy(tmpbuf, s, tculen, U8);
3210 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3212 SvUTF8_off(TARG); /* decontaminate */
3217 s = (U8*)SvPV_force(sv, slen);
3219 if (IN_LOCALE_RUNTIME) {
3222 *s = toUPPER_LC(*s);
3240 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3242 U8 tmpbuf[UTF8_MAXLEN*2+1];
3246 toLOWER_utf8(s, tmpbuf, &ulen);
3247 uv = utf8_to_uvchr(tmpbuf, 0);
3249 tend = uvchr_to_utf8(tmpbuf, uv);
3251 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3253 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3254 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3259 s = (U8*)SvPV_force(sv, slen);
3260 Copy(tmpbuf, s, ulen, U8);
3264 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3266 SvUTF8_off(TARG); /* decontaminate */
3271 s = (U8*)SvPV_force(sv, slen);
3273 if (IN_LOCALE_RUNTIME) {
3276 *s = toLOWER_LC(*s);
3299 U8 tmpbuf[UTF8_MAXLEN*2+1];
3301 s = (U8*)SvPV(sv,len);
3303 SvUTF8_off(TARG); /* decontaminate */
3304 sv_setpvn(TARG, "", 0);
3308 (void)SvUPGRADE(TARG, SVt_PV);
3309 SvGROW(TARG, (len * 2) + 1);
3310 (void)SvPOK_only(TARG);
3311 d = (U8*)SvPVX(TARG);
3314 toUPPER_utf8(s, tmpbuf, &ulen);
3315 Copy(tmpbuf, d, ulen, U8);
3321 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3326 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3328 SvUTF8_off(TARG); /* decontaminate */
3333 s = (U8*)SvPV_force(sv, len);
3335 register U8 *send = s + len;
3337 if (IN_LOCALE_RUNTIME) {
3340 for (; s < send; s++)
3341 *s = toUPPER_LC(*s);
3344 for (; s < send; s++)
3366 U8 tmpbuf[UTF8_MAXLEN*2+1];
3368 s = (U8*)SvPV(sv,len);
3370 SvUTF8_off(TARG); /* decontaminate */
3371 sv_setpvn(TARG, "", 0);
3375 (void)SvUPGRADE(TARG, SVt_PV);
3376 SvGROW(TARG, (len * 2) + 1);
3377 (void)SvPOK_only(TARG);
3378 d = (U8*)SvPVX(TARG);
3381 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3382 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3383 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3385 * Now if the sigma is NOT followed by
3386 * /$ignorable_sequence$cased_letter/;
3387 * and it IS preceded by
3388 * /$cased_letter$ignorable_sequence/;
3389 * where $ignorable_sequence is
3390 * [\x{2010}\x{AD}\p{Mn}]*
3391 * and $cased_letter is
3392 * [\p{Ll}\p{Lo}\p{Lt}]
3393 * then it should be mapped to 0x03C2,
3394 * (GREEK SMALL LETTER FINAL SIGMA),
3395 * instead of staying 0x03A3.
3396 * See lib/unicore/SpecCase.txt.
3399 Copy(tmpbuf, d, ulen, U8);
3405 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3410 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3412 SvUTF8_off(TARG); /* decontaminate */
3418 s = (U8*)SvPV_force(sv, len);
3420 register U8 *send = s + len;
3422 if (IN_LOCALE_RUNTIME) {
3425 for (; s < send; s++)
3426 *s = toLOWER_LC(*s);
3429 for (; s < send; s++)
3444 register char *s = SvPV(sv,len);
3447 SvUTF8_off(TARG); /* decontaminate */
3449 (void)SvUPGRADE(TARG, SVt_PV);
3450 SvGROW(TARG, (len * 2) + 1);
3454 if (UTF8_IS_CONTINUED(*s)) {
3455 STRLEN ulen = UTF8SKIP(s);
3479 SvCUR_set(TARG, d - SvPVX(TARG));
3480 (void)SvPOK_only_UTF8(TARG);
3483 sv_setpvn(TARG, s, len);
3485 if (SvSMAGICAL(TARG))
3494 dSP; dMARK; dORIGMARK;
3496 register AV* av = (AV*)POPs;
3497 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3498 I32 arybase = PL_curcop->cop_arybase;
3501 if (SvTYPE(av) == SVt_PVAV) {
3502 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3504 for (svp = MARK + 1; svp <= SP; svp++) {
3509 if (max > AvMAX(av))
3512 while (++MARK <= SP) {
3513 elem = SvIVx(*MARK);
3517 svp = av_fetch(av, elem, lval);
3519 if (!svp || *svp == &PL_sv_undef)
3520 DIE(aTHX_ PL_no_aelem, elem);
3521 if (PL_op->op_private & OPpLVAL_INTRO)
3522 save_aelem(av, elem, svp);
3524 *MARK = svp ? *svp : &PL_sv_undef;
3527 if (GIMME != G_ARRAY) {
3535 /* Associative arrays. */
3540 HV *hash = (HV*)POPs;
3542 I32 gimme = GIMME_V;
3543 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3546 /* might clobber stack_sp */
3547 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3552 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3553 if (gimme == G_ARRAY) {
3556 /* might clobber stack_sp */
3558 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3563 else if (gimme == G_SCALAR)
3582 I32 gimme = GIMME_V;
3583 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3587 if (PL_op->op_private & OPpSLICE) {
3591 hvtype = SvTYPE(hv);
3592 if (hvtype == SVt_PVHV) { /* hash element */
3593 while (++MARK <= SP) {
3594 sv = hv_delete_ent(hv, *MARK, discard, 0);
3595 *MARK = sv ? sv : &PL_sv_undef;
3598 else if (hvtype == SVt_PVAV) {
3599 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3600 while (++MARK <= SP) {
3601 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3602 *MARK = sv ? sv : &PL_sv_undef;
3605 else { /* pseudo-hash element */
3606 while (++MARK <= SP) {
3607 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3608 *MARK = sv ? sv : &PL_sv_undef;
3613 DIE(aTHX_ "Not a HASH reference");
3616 else if (gimme == G_SCALAR) {
3625 if (SvTYPE(hv) == SVt_PVHV)
3626 sv = hv_delete_ent(hv, keysv, discard, 0);
3627 else if (SvTYPE(hv) == SVt_PVAV) {
3628 if (PL_op->op_flags & OPf_SPECIAL)
3629 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3631 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3634 DIE(aTHX_ "Not a HASH reference");
3649 if (PL_op->op_private & OPpEXISTS_SUB) {
3653 cv = sv_2cv(sv, &hv, &gv, FALSE);
3656 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3662 if (SvTYPE(hv) == SVt_PVHV) {
3663 if (hv_exists_ent(hv, tmpsv, 0))
3666 else if (SvTYPE(hv) == SVt_PVAV) {
3667 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3668 if (av_exists((AV*)hv, SvIV(tmpsv)))
3671 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3675 DIE(aTHX_ "Not a HASH reference");
3682 dSP; dMARK; dORIGMARK;
3683 register HV *hv = (HV*)POPs;
3684 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3685 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3687 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3688 DIE(aTHX_ "Can't localize pseudo-hash element");
3690 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3691 while (++MARK <= SP) {
3694 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3695 realhv ? hv_exists_ent(hv, keysv, 0)
3696 : avhv_exists_ent((AV*)hv, keysv, 0);
3698 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3699 svp = he ? &HeVAL(he) : 0;
3702 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3705 if (!svp || *svp == &PL_sv_undef) {
3707 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3709 if (PL_op->op_private & OPpLVAL_INTRO) {
3711 save_helem(hv, keysv, svp);
3714 char *key = SvPV(keysv, keylen);
3715 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3719 *MARK = svp ? *svp : &PL_sv_undef;
3722 if (GIMME != G_ARRAY) {
3730 /* List operators. */
3735 if (GIMME != G_ARRAY) {
3737 *MARK = *SP; /* unwanted list, return last item */
3739 *MARK = &PL_sv_undef;
3748 SV **lastrelem = PL_stack_sp;
3749 SV **lastlelem = PL_stack_base + POPMARK;
3750 SV **firstlelem = PL_stack_base + POPMARK + 1;
3751 register SV **firstrelem = lastlelem + 1;
3752 I32 arybase = PL_curcop->cop_arybase;
3753 I32 lval = PL_op->op_flags & OPf_MOD;
3754 I32 is_something_there = lval;
3756 register I32 max = lastrelem - lastlelem;
3757 register SV **lelem;
3760 if (GIMME != G_ARRAY) {
3761 ix = SvIVx(*lastlelem);
3766 if (ix < 0 || ix >= max)
3767 *firstlelem = &PL_sv_undef;
3769 *firstlelem = firstrelem[ix];
3775 SP = firstlelem - 1;
3779 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3785 if (ix < 0 || ix >= max)
3786 *lelem = &PL_sv_undef;
3788 is_something_there = TRUE;
3789 if (!(*lelem = firstrelem[ix]))
3790 *lelem = &PL_sv_undef;
3793 if (is_something_there)
3796 SP = firstlelem - 1;
3802 dSP; dMARK; dORIGMARK;
3803 I32 items = SP - MARK;
3804 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3805 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3812 dSP; dMARK; dORIGMARK;
3813 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3817 SV *val = NEWSV(46, 0);
3819 sv_setsv(val, *++MARK);
3820 else if (ckWARN(WARN_MISC))
3821 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3822 (void)hv_store_ent(hv,key,val,0);
3831 dSP; dMARK; dORIGMARK;
3832 register AV *ary = (AV*)*++MARK;
3836 register I32 offset;
3837 register I32 length;
3844 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3845 *MARK-- = SvTIED_obj((SV*)ary, mg);
3849 call_method("SPLICE",GIMME_V);
3858 offset = i = SvIVx(*MARK);
3860 offset += AvFILLp(ary) + 1;
3862 offset -= PL_curcop->cop_arybase;
3864 DIE(aTHX_ PL_no_aelem, i);
3866 length = SvIVx(*MARK++);
3868 length += AvFILLp(ary) - offset + 1;
3874 length = AvMAX(ary) + 1; /* close enough to infinity */
3878 length = AvMAX(ary) + 1;
3880 if (offset > AvFILLp(ary) + 1)
3881 offset = AvFILLp(ary) + 1;
3882 after = AvFILLp(ary) + 1 - (offset + length);
3883 if (after < 0) { /* not that much array */
3884 length += after; /* offset+length now in array */
3890 /* At this point, MARK .. SP-1 is our new LIST */
3893 diff = newlen - length;
3894 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3897 if (diff < 0) { /* shrinking the area */
3899 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3900 Copy(MARK, tmparyval, newlen, SV*);
3903 MARK = ORIGMARK + 1;
3904 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3905 MEXTEND(MARK, length);
3906 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3908 EXTEND_MORTAL(length);
3909 for (i = length, dst = MARK; i; i--) {
3910 sv_2mortal(*dst); /* free them eventualy */
3917 *MARK = AvARRAY(ary)[offset+length-1];
3920 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3921 SvREFCNT_dec(*dst++); /* free them now */
3924 AvFILLp(ary) += diff;
3926 /* pull up or down? */
3928 if (offset < after) { /* easier to pull up */
3929 if (offset) { /* esp. if nothing to pull */
3930 src = &AvARRAY(ary)[offset-1];
3931 dst = src - diff; /* diff is negative */
3932 for (i = offset; i > 0; i--) /* can't trust Copy */
3936 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3940 if (after) { /* anything to pull down? */
3941 src = AvARRAY(ary) + offset + length;
3942 dst = src + diff; /* diff is negative */
3943 Move(src, dst, after, SV*);
3945 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3946 /* avoid later double free */
3950 dst[--i] = &PL_sv_undef;
3953 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3955 *dst = NEWSV(46, 0);
3956 sv_setsv(*dst++, *src++);
3958 Safefree(tmparyval);
3961 else { /* no, expanding (or same) */
3963 New(452, tmparyval, length, SV*); /* so remember deletion */
3964 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3967 if (diff > 0) { /* expanding */
3969 /* push up or down? */
3971 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3975 Move(src, dst, offset, SV*);
3977 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3979 AvFILLp(ary) += diff;
3982 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3983 av_extend(ary, AvFILLp(ary) + diff);
3984 AvFILLp(ary) += diff;
3987 dst = AvARRAY(ary) + AvFILLp(ary);
3989 for (i = after; i; i--) {
3996 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3997 *dst = NEWSV(46, 0);
3998 sv_setsv(*dst++, *src++);
4000 MARK = ORIGMARK + 1;
4001 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4003 Copy(tmparyval, MARK, length, SV*);
4005 EXTEND_MORTAL(length);
4006 for (i = length, dst = MARK; i; i--) {
4007 sv_2mortal(*dst); /* free them eventualy */
4011 Safefree(tmparyval);
4015 else if (length--) {
4016 *MARK = tmparyval[length];
4019 while (length-- > 0)
4020 SvREFCNT_dec(tmparyval[length]);
4022 Safefree(tmparyval);
4025 *MARK = &PL_sv_undef;
4033 dSP; dMARK; dORIGMARK; dTARGET;
4034 register AV *ary = (AV*)*++MARK;
4035 register SV *sv = &PL_sv_undef;
4038 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4039 *MARK-- = SvTIED_obj((SV*)ary, mg);
4043 call_method("PUSH",G_SCALAR|G_DISCARD);
4048 /* Why no pre-extend of ary here ? */
4049 for (++MARK; MARK <= SP; MARK++) {
4052 sv_setsv(sv, *MARK);
4057 PUSHi( AvFILL(ary) + 1 );
4065 SV *sv = av_pop(av);
4067 (void)sv_2mortal(sv);
4076 SV *sv = av_shift(av);
4081 (void)sv_2mortal(sv);
4088 dSP; dMARK; dORIGMARK; dTARGET;
4089 register AV *ary = (AV*)*++MARK;
4094 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4095 *MARK-- = SvTIED_obj((SV*)ary, mg);
4099 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4104 av_unshift(ary, SP - MARK);
4107 sv_setsv(sv, *++MARK);
4108 (void)av_store(ary, i++, sv);
4112 PUSHi( AvFILL(ary) + 1 );
4122 if (GIMME == G_ARRAY) {
4129 /* safe as long as stack cannot get extended in the above */
4134 register char *down;
4139 SvUTF8_off(TARG); /* decontaminate */
4141 do_join(TARG, &PL_sv_no, MARK, SP);
4143 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4144 up = SvPV_force(TARG, len);
4146 if (DO_UTF8(TARG)) { /* first reverse each character */
4147 U8* s = (U8*)SvPVX(TARG);
4148 U8* send = (U8*)(s + len);
4150 if (UTF8_IS_INVARIANT(*s)) {
4155 if (!utf8_to_uvchr(s, 0))
4159 down = (char*)(s - 1);
4160 /* reverse this character */
4170 down = SvPVX(TARG) + len - 1;
4176 (void)SvPOK_only_UTF8(TARG);
4188 register IV limit = POPi; /* note, negative is forever */
4191 register char *s = SvPV(sv, len);
4192 bool do_utf8 = DO_UTF8(sv);
4193 char *strend = s + len;
4195 register REGEXP *rx;
4199 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4200 I32 maxiters = slen + 10;
4203 I32 origlimit = limit;
4206 AV *oldstack = PL_curstack;
4207 I32 gimme = GIMME_V;
4208 I32 oldsave = PL_savestack_ix;
4209 I32 make_mortal = 1;
4210 MAGIC *mg = (MAGIC *) NULL;
4213 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4218 DIE(aTHX_ "panic: pp_split");
4221 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4222 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4224 PL_reg_match_utf8 = do_utf8;
4226 if (pm->op_pmreplroot) {
4228 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4230 ary = GvAVn((GV*)pm->op_pmreplroot);
4233 else if (gimme != G_ARRAY)
4234 #ifdef USE_5005THREADS
4235 ary = (AV*)PL_curpad[0];
4237 ary = GvAVn(PL_defgv);
4238 #endif /* USE_5005THREADS */
4241 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4247 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4249 XPUSHs(SvTIED_obj((SV*)ary, mg));
4255 for (i = AvFILLp(ary); i >= 0; i--)
4256 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4258 /* temporarily switch stacks */
4259 SWITCHSTACK(PL_curstack, ary);
4263 base = SP - PL_stack_base;
4265 if (pm->op_pmflags & PMf_SKIPWHITE) {
4266 if (pm->op_pmflags & PMf_LOCALE) {
4267 while (isSPACE_LC(*s))
4275 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4276 SAVEINT(PL_multiline);
4277 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4281 limit = maxiters + 2;
4282 if (pm->op_pmflags & PMf_WHITE) {
4285 while (m < strend &&
4286 !((pm->op_pmflags & PMf_LOCALE)
4287 ? isSPACE_LC(*m) : isSPACE(*m)))
4292 dstr = NEWSV(30, m-s);
4293 sv_setpvn(dstr, s, m-s);
4297 (void)SvUTF8_on(dstr);
4301 while (s < strend &&
4302 ((pm->op_pmflags & PMf_LOCALE)
4303 ? isSPACE_LC(*s) : isSPACE(*s)))
4307 else if (strEQ("^", rx->precomp)) {
4310 for (m = s; m < strend && *m != '\n'; m++) ;
4314 dstr = NEWSV(30, m-s);
4315 sv_setpvn(dstr, s, m-s);
4319 (void)SvUTF8_on(dstr);
4324 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4325 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4326 && (rx->reganch & ROPT_CHECK_ALL)
4327 && !(rx->reganch & ROPT_ANCH)) {
4328 int tail = (rx->reganch & RE_INTUIT_TAIL);
4329 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4332 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4334 char c = *SvPV(csv, n_a);
4337 for (m = s; m < strend && *m != c; m++) ;
4340 dstr = NEWSV(30, m-s);
4341 sv_setpvn(dstr, s, m-s);
4345 (void)SvUTF8_on(dstr);
4347 /* The rx->minlen is in characters but we want to step
4348 * s ahead by bytes. */
4350 s = (char*)utf8_hop((U8*)m, len);
4352 s = m + len; /* Fake \n at the end */
4357 while (s < strend && --limit &&
4358 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4359 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4362 dstr = NEWSV(31, m-s);
4363 sv_setpvn(dstr, s, m-s);
4367 (void)SvUTF8_on(dstr);
4369 /* The rx->minlen is in characters but we want to step
4370 * s ahead by bytes. */
4372 s = (char*)utf8_hop((U8*)m, len);
4374 s = m + len; /* Fake \n at the end */
4379 maxiters += slen * rx->nparens;
4380 while (s < strend && --limit
4381 /* && (!rx->check_substr
4382 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4384 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4385 1 /* minend */, sv, NULL, 0))
4387 TAINT_IF(RX_MATCH_TAINTED(rx));
4388 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4393 strend = s + (strend - m);
4395 m = rx->startp[0] + orig;
4396 dstr = NEWSV(32, m-s);
4397 sv_setpvn(dstr, s, m-s);
4401 (void)SvUTF8_on(dstr);
4404 for (i = 1; i <= rx->nparens; i++) {
4405 s = rx->startp[i] + orig;
4406 m = rx->endp[i] + orig;
4408 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4409 parens that didn't match -- they should be set to
4410 undef, not the empty string */
4411 if (m >= orig && s >= orig) {
4412 dstr = NEWSV(33, m-s);
4413 sv_setpvn(dstr, s, m-s);
4416 dstr = &PL_sv_undef; /* undef, not "" */
4420 (void)SvUTF8_on(dstr);
4424 s = rx->endp[0] + orig;
4428 LEAVE_SCOPE(oldsave);
4429 iters = (SP - PL_stack_base) - base;
4430 if (iters > maxiters)
4431 DIE(aTHX_ "Split loop");
4433 /* keep field after final delim? */
4434 if (s < strend || (iters && origlimit)) {
4435 STRLEN l = strend - s;
4436 dstr = NEWSV(34, l);
4437 sv_setpvn(dstr, s, l);
4441 (void)SvUTF8_on(dstr);
4445 else if (!origlimit) {
4446 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4452 SWITCHSTACK(ary, oldstack);
4453 if (SvSMAGICAL(ary)) {
4458 if (gimme == G_ARRAY) {
4460 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4468 call_method("PUSH",G_SCALAR|G_DISCARD);
4471 if (gimme == G_ARRAY) {
4472 /* EXTEND should not be needed - we just popped them */
4474 for (i=0; i < iters; i++) {
4475 SV **svp = av_fetch(ary, i, FALSE);
4476 PUSHs((svp) ? *svp : &PL_sv_undef);
4483 if (gimme == G_ARRAY)
4486 if (iters || !pm->op_pmreplroot) {
4494 #ifdef USE_5005THREADS
4496 Perl_unlock_condpair(pTHX_ void *svv)
4498 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4501 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4502 MUTEX_LOCK(MgMUTEXP(mg));
4503 if (MgOWNER(mg) != thr)
4504 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4506 COND_SIGNAL(MgOWNERCONDP(mg));
4507 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4508 PTR2UV(thr), PTR2UV(svv)));
4509 MUTEX_UNLOCK(MgMUTEXP(mg));
4511 #endif /* USE_5005THREADS */
4518 #ifdef USE_5005THREADS
4520 #endif /* USE_5005THREADS */
4522 shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
4524 Perl_sharedsv_lock(aTHX_ ssv);
4525 #endif /* USE_ITHREADS */
4526 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4527 || SvTYPE(retsv) == SVt_PVCV) {
4528 retsv = refto(retsv);
4536 #ifdef USE_5005THREADS
4539 if (PL_op->op_private & OPpLVAL_INTRO)
4540 PUSHs(*save_threadsv(PL_op->op_targ));
4542 PUSHs(THREADSV(PL_op->op_targ));
4545 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4546 #endif /* USE_5005THREADS */