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))
474 (void)SvREFCNT_inc(sv);
477 sv_upgrade(rv, SVt_RV);
491 if (sv && SvGMAGICAL(sv))
494 if (!sv || !SvROK(sv))
498 pv = sv_reftype(sv,TRUE);
499 PUSHp(pv, strlen(pv));
509 stash = CopSTASH(PL_curcop);
515 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
516 Perl_croak(aTHX_ "Attempt to bless into a reference");
518 if (ckWARN(WARN_MISC) && len == 0)
519 Perl_warner(aTHX_ WARN_MISC,
520 "Explicit blessing to '' (assuming package main)");
521 stash = gv_stashpvn(ptr, len, TRUE);
524 (void)sv_bless(TOPs, stash);
538 elem = SvPV(sv, n_a);
542 switch (elem ? *elem : '\0')
545 if (strEQ(elem, "ARRAY"))
546 tmpRef = (SV*)GvAV(gv);
549 if (strEQ(elem, "CODE"))
550 tmpRef = (SV*)GvCVu(gv);
553 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
554 tmpRef = (SV*)GvIOp(gv);
556 if (strEQ(elem, "FORMAT"))
557 tmpRef = (SV*)GvFORM(gv);
560 if (strEQ(elem, "GLOB"))
564 if (strEQ(elem, "HASH"))
565 tmpRef = (SV*)GvHV(gv);
568 if (strEQ(elem, "IO"))
569 tmpRef = (SV*)GvIOp(gv);
572 if (strEQ(elem, "NAME"))
573 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
576 if (strEQ(elem, "PACKAGE"))
577 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
580 if (strEQ(elem, "SCALAR"))
594 /* Pattern matching */
599 register unsigned char *s;
602 register I32 *sfirst;
606 if (sv == PL_lastscream) {
612 SvSCREAM_off(PL_lastscream);
613 SvREFCNT_dec(PL_lastscream);
615 PL_lastscream = SvREFCNT_inc(sv);
618 s = (unsigned char*)(SvPV(sv, len));
622 if (pos > PL_maxscream) {
623 if (PL_maxscream < 0) {
624 PL_maxscream = pos + 80;
625 New(301, PL_screamfirst, 256, I32);
626 New(302, PL_screamnext, PL_maxscream, I32);
629 PL_maxscream = pos + pos / 4;
630 Renew(PL_screamnext, PL_maxscream, I32);
634 sfirst = PL_screamfirst;
635 snext = PL_screamnext;
637 if (!sfirst || !snext)
638 DIE(aTHX_ "do_study: out of memory");
640 for (ch = 256; ch; --ch)
647 snext[pos] = sfirst[ch] - pos;
654 /* piggyback on m//g magic */
655 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
664 if (PL_op->op_flags & OPf_STACKED)
670 TARG = sv_newmortal();
675 /* Lvalue operators. */
687 dSP; dMARK; dTARGET; dORIGMARK;
689 do_chop(TARG, *++MARK);
698 SETi(do_chomp(TOPs));
705 register I32 count = 0;
708 count += do_chomp(POPs);
719 if (!sv || !SvANY(sv))
721 switch (SvTYPE(sv)) {
723 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
724 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
728 if (HvARRAY(sv) || SvGMAGICAL(sv)
729 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
733 if (CvROOT(sv) || CvXSUB(sv))
750 if (!PL_op->op_private) {
759 if (SvTHINKFIRST(sv))
762 switch (SvTYPE(sv)) {
772 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
773 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
774 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
778 /* let user-undef'd sub keep its identity */
779 GV* gv = CvGV((CV*)sv);
786 SvSetMagicSV(sv, &PL_sv_undef);
790 Newz(602, gp, 1, GP);
791 GvGP(sv) = gp_ref(gp);
792 GvSV(sv) = NEWSV(72,0);
793 GvLINE(sv) = CopLINE(PL_curcop);
799 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
802 SvPV_set(sv, Nullch);
815 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
816 DIE(aTHX_ PL_no_modify);
817 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
818 SvIVX(TOPs) != IV_MIN)
821 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
832 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
833 DIE(aTHX_ PL_no_modify);
834 sv_setsv(TARG, TOPs);
835 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
836 SvIVX(TOPs) != IV_MAX)
839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
853 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
854 DIE(aTHX_ PL_no_modify);
855 sv_setsv(TARG, TOPs);
856 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
857 SvIVX(TOPs) != IV_MIN)
860 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
869 /* Ordinary operators. */
873 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
876 SETn( Perl_pow( left, right) );
883 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
884 #ifdef PERL_PRESERVE_IVUV
887 /* Unless the left argument is integer in range we are going to have to
888 use NV maths. Hence only attempt to coerce the right argument if
889 we know the left is integer. */
890 /* Left operand is defined, so is it IV? */
893 bool auvok = SvUOK(TOPm1s);
894 bool buvok = SvUOK(TOPs);
895 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
896 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
903 alow = SvUVX(TOPm1s);
905 IV aiv = SvIVX(TOPm1s);
908 auvok = TRUE; /* effectively it's a UV now */
910 alow = -aiv; /* abs, auvok == false records sign */
916 IV biv = SvIVX(TOPs);
919 buvok = TRUE; /* effectively it's a UV now */
921 blow = -biv; /* abs, buvok == false records sign */
925 /* If this does sign extension on unsigned it's time for plan B */
926 ahigh = alow >> (4 * sizeof (UV));
928 bhigh = blow >> (4 * sizeof (UV));
930 if (ahigh && bhigh) {
931 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
932 which is overflow. Drop to NVs below. */
933 } else if (!ahigh && !bhigh) {
934 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
935 so the unsigned multiply cannot overflow. */
936 UV product = alow * blow;
937 if (auvok == buvok) {
938 /* -ve * -ve or +ve * +ve gives a +ve result. */
942 } else if (product <= (UV)IV_MIN) {
943 /* 2s complement assumption that (UV)-IV_MIN is correct. */
944 /* -ve result, which could overflow an IV */
946 SETi( -(IV)product );
948 } /* else drop to NVs below. */
950 /* One operand is large, 1 small */
953 /* swap the operands */
955 bhigh = blow; /* bhigh now the temp var for the swap */
959 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
960 multiplies can't overflow. shift can, add can, -ve can. */
961 product_middle = ahigh * blow;
962 if (!(product_middle & topmask)) {
963 /* OK, (ahigh * blow) won't lose bits when we shift it. */
965 product_middle <<= (4 * sizeof (UV));
966 product_low = alow * blow;
968 /* as for pp_add, UV + something mustn't get smaller.
969 IIRC ANSI mandates this wrapping *behaviour* for
970 unsigned whatever the actual representation*/
971 product_low += product_middle;
972 if (product_low >= product_middle) {
973 /* didn't overflow */
974 if (auvok == buvok) {
975 /* -ve * -ve or +ve * +ve gives a +ve result. */
979 } else if (product_low <= (UV)IV_MIN) {
980 /* 2s complement assumption again */
981 /* -ve result, which could overflow an IV */
983 SETi( -(IV)product_low );
985 } /* else drop to NVs below. */
987 } /* product_middle too large */
988 } /* ahigh && bhigh */
989 } /* SvIOK(TOPm1s) */
994 SETn( left * right );
1001 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1006 DIE(aTHX_ "Illegal division by zero");
1008 /* insure that 20./5. == 4. */
1011 if ((NV)I_V(left) == left &&
1012 (NV)I_V(right) == right &&
1013 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1017 value = left / right;
1021 value = left / right;
1030 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1036 bool use_double = 0;
1040 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1042 right = (right_neg = (i < 0)) ? -i : i;
1047 right_neg = dright < 0;
1052 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1054 left = (left_neg = (i < 0)) ? -i : i;
1062 left_neg = dleft < 0;
1071 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1073 # define CAST_D2UV(d) U_V(d)
1075 # define CAST_D2UV(d) ((UV)(d))
1077 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1078 * or, in other words, precision of UV more than of NV.
1079 * But in fact the approach below turned out to be an
1080 * optimization - floor() may be slow */
1081 if (dright <= UV_MAX && dleft <= UV_MAX) {
1082 right = CAST_D2UV(dright);
1083 left = CAST_D2UV(dleft);
1088 /* Backward-compatibility clause: */
1089 dright = Perl_floor(dright + 0.5);
1090 dleft = Perl_floor(dleft + 0.5);
1093 DIE(aTHX_ "Illegal modulus zero");
1095 dans = Perl_fmod(dleft, dright);
1096 if ((left_neg != right_neg) && dans)
1097 dans = dright - dans;
1100 sv_setnv(TARG, dans);
1107 DIE(aTHX_ "Illegal modulus zero");
1110 if ((left_neg != right_neg) && ans)
1113 /* XXX may warn: unary minus operator applied to unsigned type */
1114 /* could change -foo to be (~foo)+1 instead */
1115 if (ans <= ~((UV)IV_MAX)+1)
1116 sv_setiv(TARG, ~ans+1);
1118 sv_setnv(TARG, -(NV)ans);
1121 sv_setuv(TARG, ans);
1130 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1132 register IV count = POPi;
1133 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1135 I32 items = SP - MARK;
1138 max = items * count;
1147 repeatcpy((char*)(MARK + items), (char*)MARK,
1148 items * sizeof(SV*), count - 1);
1151 else if (count <= 0)
1154 else { /* Note: mark already snarfed by pp_list */
1159 SvSetSV(TARG, tmpstr);
1160 SvPV_force(TARG, len);
1161 isutf = DO_UTF8(TARG);
1166 SvGROW(TARG, (count * len) + 1);
1167 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1168 SvCUR(TARG) *= count;
1170 *SvEND(TARG) = '\0';
1173 (void)SvPOK_only_UTF8(TARG);
1175 (void)SvPOK_only(TARG);
1177 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1178 /* The parser saw this as a list repeat, and there
1179 are probably several items on the stack. But we're
1180 in scalar context, and there's no pp_list to save us
1181 now. So drop the rest of the items -- robin@kitsite.com
1194 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1195 useleft = USE_LEFT(TOPm1s);
1196 #ifdef PERL_PRESERVE_IVUV
1197 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1198 "bad things" happen if you rely on signed integers wrapping. */
1201 /* Unless the left argument is integer in range we are going to have to
1202 use NV maths. Hence only attempt to coerce the right argument if
1203 we know the left is integer. */
1204 register UV auv = 0;
1210 a_valid = auvok = 1;
1211 /* left operand is undef, treat as zero. */
1213 /* Left operand is defined, so is it IV? */
1214 SvIV_please(TOPm1s);
1215 if (SvIOK(TOPm1s)) {
1216 if ((auvok = SvUOK(TOPm1s)))
1217 auv = SvUVX(TOPm1s);
1219 register IV aiv = SvIVX(TOPm1s);
1222 auvok = 1; /* Now acting as a sign flag. */
1223 } else { /* 2s complement assumption for IV_MIN */
1231 bool result_good = 0;
1234 bool buvok = SvUOK(TOPs);
1239 register IV biv = SvIVX(TOPs);
1246 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1247 else "IV" now, independant of how it came in.
1248 if a, b represents positive, A, B negative, a maps to -A etc
1253 all UV maths. negate result if A negative.
1254 subtract if signs same, add if signs differ. */
1256 if (auvok ^ buvok) {
1265 /* Must get smaller */
1270 if (result <= buv) {
1271 /* result really should be -(auv-buv). as its negation
1272 of true value, need to swap our result flag */
1284 if (result <= (UV)IV_MIN)
1285 SETi( -(IV)result );
1287 /* result valid, but out of range for IV. */
1288 SETn( -(NV)result );
1292 } /* Overflow, drop through to NVs. */
1296 useleft = USE_LEFT(TOPm1s);
1300 /* left operand is undef, treat as zero - value */
1304 SETn( TOPn - value );
1311 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1314 if (PL_op->op_private & HINT_INTEGER) {
1328 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1331 if (PL_op->op_private & HINT_INTEGER) {
1345 dSP; tryAMAGICbinSET(lt,0);
1346 #ifdef PERL_PRESERVE_IVUV
1349 SvIV_please(TOPm1s);
1350 if (SvIOK(TOPm1s)) {
1351 bool auvok = SvUOK(TOPm1s);
1352 bool buvok = SvUOK(TOPs);
1354 if (!auvok && !buvok) { /* ## IV < IV ## */
1355 IV aiv = SvIVX(TOPm1s);
1356 IV biv = SvIVX(TOPs);
1359 SETs(boolSV(aiv < biv));
1362 if (auvok && buvok) { /* ## UV < UV ## */
1363 UV auv = SvUVX(TOPm1s);
1364 UV buv = SvUVX(TOPs);
1367 SETs(boolSV(auv < buv));
1370 if (auvok) { /* ## UV < IV ## */
1377 /* As (a) is a UV, it's >=0, so it cannot be < */
1382 if (auv >= (UV) IV_MAX) {
1383 /* As (b) is an IV, it cannot be > IV_MAX */
1387 SETs(boolSV(auv < (UV)biv));
1390 { /* ## IV < UV ## */
1394 aiv = SvIVX(TOPm1s);
1396 /* As (b) is a UV, it's >=0, so it must be < */
1403 if (buv > (UV) IV_MAX) {
1404 /* As (a) is an IV, it cannot be > IV_MAX */
1408 SETs(boolSV((UV)aiv < buv));
1416 SETs(boolSV(TOPn < value));
1423 dSP; tryAMAGICbinSET(gt,0);
1424 #ifdef PERL_PRESERVE_IVUV
1427 SvIV_please(TOPm1s);
1428 if (SvIOK(TOPm1s)) {
1429 bool auvok = SvUOK(TOPm1s);
1430 bool buvok = SvUOK(TOPs);
1432 if (!auvok && !buvok) { /* ## IV > IV ## */
1433 IV aiv = SvIVX(TOPm1s);
1434 IV biv = SvIVX(TOPs);
1437 SETs(boolSV(aiv > biv));
1440 if (auvok && buvok) { /* ## UV > UV ## */
1441 UV auv = SvUVX(TOPm1s);
1442 UV buv = SvUVX(TOPs);
1445 SETs(boolSV(auv > buv));
1448 if (auvok) { /* ## UV > IV ## */
1455 /* As (a) is a UV, it's >=0, so it must be > */
1460 if (auv > (UV) IV_MAX) {
1461 /* As (b) is an IV, it cannot be > IV_MAX */
1465 SETs(boolSV(auv > (UV)biv));
1468 { /* ## IV > UV ## */
1472 aiv = SvIVX(TOPm1s);
1474 /* As (b) is a UV, it's >=0, so it cannot be > */
1481 if (buv >= (UV) IV_MAX) {
1482 /* As (a) is an IV, it cannot be > IV_MAX */
1486 SETs(boolSV((UV)aiv > buv));
1494 SETs(boolSV(TOPn > value));
1501 dSP; tryAMAGICbinSET(le,0);
1502 #ifdef PERL_PRESERVE_IVUV
1505 SvIV_please(TOPm1s);
1506 if (SvIOK(TOPm1s)) {
1507 bool auvok = SvUOK(TOPm1s);
1508 bool buvok = SvUOK(TOPs);
1510 if (!auvok && !buvok) { /* ## IV <= IV ## */
1511 IV aiv = SvIVX(TOPm1s);
1512 IV biv = SvIVX(TOPs);
1515 SETs(boolSV(aiv <= biv));
1518 if (auvok && buvok) { /* ## UV <= UV ## */
1519 UV auv = SvUVX(TOPm1s);
1520 UV buv = SvUVX(TOPs);
1523 SETs(boolSV(auv <= buv));
1526 if (auvok) { /* ## UV <= IV ## */
1533 /* As (a) is a UV, it's >=0, so a cannot be <= */
1538 if (auv > (UV) IV_MAX) {
1539 /* As (b) is an IV, it cannot be > IV_MAX */
1543 SETs(boolSV(auv <= (UV)biv));
1546 { /* ## IV <= UV ## */
1550 aiv = SvIVX(TOPm1s);
1552 /* As (b) is a UV, it's >=0, so a must be <= */
1559 if (buv >= (UV) IV_MAX) {
1560 /* As (a) is an IV, it cannot be > IV_MAX */
1564 SETs(boolSV((UV)aiv <= buv));
1572 SETs(boolSV(TOPn <= value));
1579 dSP; tryAMAGICbinSET(ge,0);
1580 #ifdef PERL_PRESERVE_IVUV
1583 SvIV_please(TOPm1s);
1584 if (SvIOK(TOPm1s)) {
1585 bool auvok = SvUOK(TOPm1s);
1586 bool buvok = SvUOK(TOPs);
1588 if (!auvok && !buvok) { /* ## IV >= IV ## */
1589 IV aiv = SvIVX(TOPm1s);
1590 IV biv = SvIVX(TOPs);
1593 SETs(boolSV(aiv >= biv));
1596 if (auvok && buvok) { /* ## UV >= UV ## */
1597 UV auv = SvUVX(TOPm1s);
1598 UV buv = SvUVX(TOPs);
1601 SETs(boolSV(auv >= buv));
1604 if (auvok) { /* ## UV >= IV ## */
1611 /* As (a) is a UV, it's >=0, so it must be >= */
1616 if (auv >= (UV) IV_MAX) {
1617 /* As (b) is an IV, it cannot be > IV_MAX */
1621 SETs(boolSV(auv >= (UV)biv));
1624 { /* ## IV >= UV ## */
1628 aiv = SvIVX(TOPm1s);
1630 /* As (b) is a UV, it's >=0, so a cannot be >= */
1637 if (buv > (UV) IV_MAX) {
1638 /* As (a) is an IV, it cannot be > IV_MAX */
1642 SETs(boolSV((UV)aiv >= buv));
1650 SETs(boolSV(TOPn >= value));
1657 dSP; tryAMAGICbinSET(ne,0);
1658 #ifndef NV_PRESERVES_UV
1659 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1660 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1664 #ifdef PERL_PRESERVE_IVUV
1667 SvIV_please(TOPm1s);
1668 if (SvIOK(TOPm1s)) {
1669 bool auvok = SvUOK(TOPm1s);
1670 bool buvok = SvUOK(TOPs);
1672 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1673 IV aiv = SvIVX(TOPm1s);
1674 IV biv = SvIVX(TOPs);
1677 SETs(boolSV(aiv != biv));
1680 if (auvok && buvok) { /* ## UV != UV ## */
1681 UV auv = SvUVX(TOPm1s);
1682 UV buv = SvUVX(TOPs);
1685 SETs(boolSV(auv != buv));
1688 { /* ## Mixed IV,UV ## */
1692 /* != is commutative so swap if needed (save code) */
1694 /* swap. top of stack (b) is the iv */
1698 /* As (a) is a UV, it's >0, so it cannot be == */
1707 /* As (b) is a UV, it's >0, so it cannot be == */
1711 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1713 /* we know iv is >= 0 */
1714 if (uv > (UV) IV_MAX) {
1718 SETs(boolSV((UV)iv != uv));
1726 SETs(boolSV(TOPn != value));
1733 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1734 #ifndef NV_PRESERVES_UV
1735 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1736 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1740 #ifdef PERL_PRESERVE_IVUV
1741 /* Fortunately it seems NaN isn't IOK */
1744 SvIV_please(TOPm1s);
1745 if (SvIOK(TOPm1s)) {
1746 bool leftuvok = SvUOK(TOPm1s);
1747 bool rightuvok = SvUOK(TOPs);
1749 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1750 IV leftiv = SvIVX(TOPm1s);
1751 IV rightiv = SvIVX(TOPs);
1753 if (leftiv > rightiv)
1755 else if (leftiv < rightiv)
1759 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1760 UV leftuv = SvUVX(TOPm1s);
1761 UV rightuv = SvUVX(TOPs);
1763 if (leftuv > rightuv)
1765 else if (leftuv < rightuv)
1769 } else if (leftuvok) { /* ## UV <=> IV ## */
1773 rightiv = SvIVX(TOPs);
1775 /* As (a) is a UV, it's >=0, so it cannot be < */
1778 leftuv = SvUVX(TOPm1s);
1779 if (leftuv > (UV) IV_MAX) {
1780 /* As (b) is an IV, it cannot be > IV_MAX */
1782 } else if (leftuv > (UV)rightiv) {
1784 } else if (leftuv < (UV)rightiv) {
1790 } else { /* ## IV <=> UV ## */
1794 leftiv = SvIVX(TOPm1s);
1796 /* As (b) is a UV, it's >=0, so it must be < */
1799 rightuv = SvUVX(TOPs);
1800 if (rightuv > (UV) IV_MAX) {
1801 /* As (a) is an IV, it cannot be > IV_MAX */
1803 } else if (leftiv > (UV)rightuv) {
1805 } else if (leftiv < (UV)rightuv) {
1823 if (Perl_isnan(left) || Perl_isnan(right)) {
1827 value = (left > right) - (left < right);
1831 else if (left < right)
1833 else if (left > right)
1847 dSP; tryAMAGICbinSET(slt,0);
1850 int cmp = (IN_LOCALE_RUNTIME
1851 ? sv_cmp_locale(left, right)
1852 : sv_cmp(left, right));
1853 SETs(boolSV(cmp < 0));
1860 dSP; tryAMAGICbinSET(sgt,0);
1863 int cmp = (IN_LOCALE_RUNTIME
1864 ? sv_cmp_locale(left, right)
1865 : sv_cmp(left, right));
1866 SETs(boolSV(cmp > 0));
1873 dSP; tryAMAGICbinSET(sle,0);
1876 int cmp = (IN_LOCALE_RUNTIME
1877 ? sv_cmp_locale(left, right)
1878 : sv_cmp(left, right));
1879 SETs(boolSV(cmp <= 0));
1886 dSP; tryAMAGICbinSET(sge,0);
1889 int cmp = (IN_LOCALE_RUNTIME
1890 ? sv_cmp_locale(left, right)
1891 : sv_cmp(left, right));
1892 SETs(boolSV(cmp >= 0));
1899 dSP; tryAMAGICbinSET(seq,0);
1902 SETs(boolSV(sv_eq(left, right)));
1909 dSP; tryAMAGICbinSET(sne,0);
1912 SETs(boolSV(!sv_eq(left, right)));
1919 dSP; dTARGET; tryAMAGICbin(scmp,0);
1922 int cmp = (IN_LOCALE_RUNTIME
1923 ? sv_cmp_locale(left, right)
1924 : sv_cmp(left, right));
1932 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1935 if (SvNIOKp(left) || SvNIOKp(right)) {
1936 if (PL_op->op_private & HINT_INTEGER) {
1937 IV i = SvIV(left) & SvIV(right);
1941 UV u = SvUV(left) & SvUV(right);
1946 do_vop(PL_op->op_type, TARG, left, right);
1955 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1958 if (SvNIOKp(left) || SvNIOKp(right)) {
1959 if (PL_op->op_private & HINT_INTEGER) {
1960 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1964 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1969 do_vop(PL_op->op_type, TARG, left, right);
1978 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1981 if (SvNIOKp(left) || SvNIOKp(right)) {
1982 if (PL_op->op_private & HINT_INTEGER) {
1983 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1987 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1992 do_vop(PL_op->op_type, TARG, left, right);
2001 dSP; dTARGET; tryAMAGICun(neg);
2004 int flags = SvFLAGS(sv);
2007 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2008 /* It's publicly an integer, or privately an integer-not-float */
2011 if (SvIVX(sv) == IV_MIN) {
2012 /* 2s complement assumption. */
2013 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2016 else if (SvUVX(sv) <= IV_MAX) {
2021 else if (SvIVX(sv) != IV_MIN) {
2025 #ifdef PERL_PRESERVE_IVUV
2034 else if (SvPOKp(sv)) {
2036 char *s = SvPV(sv, len);
2037 if (isIDFIRST(*s)) {
2038 sv_setpvn(TARG, "-", 1);
2041 else if (*s == '+' || *s == '-') {
2043 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2045 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2046 sv_setpvn(TARG, "-", 1);
2052 goto oops_its_an_int;
2053 sv_setnv(TARG, -SvNV(sv));
2065 dSP; tryAMAGICunSET(not);
2066 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2072 dSP; dTARGET; tryAMAGICun(compl);
2076 if (PL_op->op_private & HINT_INTEGER) {
2091 tmps = (U8*)SvPV_force(TARG, len);
2094 /* Calculate exact length, let's not estimate. */
2103 while (tmps < send) {
2104 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2105 tmps += UTF8SKIP(tmps);
2106 targlen += UNISKIP(~c);
2112 /* Now rewind strings and write them. */
2116 Newz(0, result, targlen + 1, U8);
2117 while (tmps < send) {
2118 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2119 tmps += UTF8SKIP(tmps);
2120 result = uvchr_to_utf8(result, ~c);
2124 sv_setpvn(TARG, (char*)result, targlen);
2128 Newz(0, result, nchar + 1, U8);
2129 while (tmps < send) {
2130 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2131 tmps += UTF8SKIP(tmps);
2136 sv_setpvn(TARG, (char*)result, nchar);
2144 register long *tmpl;
2145 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2148 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2153 for ( ; anum > 0; anum--, tmps++)
2162 /* integer versions of some of the above */
2166 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2169 SETi( left * right );
2176 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2180 DIE(aTHX_ "Illegal division by zero");
2181 value = POPi / value;
2189 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2193 DIE(aTHX_ "Illegal modulus zero");
2194 SETi( left % right );
2201 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2204 SETi( left + right );
2211 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2214 SETi( left - right );
2221 dSP; tryAMAGICbinSET(lt,0);
2224 SETs(boolSV(left < right));
2231 dSP; tryAMAGICbinSET(gt,0);
2234 SETs(boolSV(left > right));
2241 dSP; tryAMAGICbinSET(le,0);
2244 SETs(boolSV(left <= right));
2251 dSP; tryAMAGICbinSET(ge,0);
2254 SETs(boolSV(left >= right));
2261 dSP; tryAMAGICbinSET(eq,0);
2264 SETs(boolSV(left == right));
2271 dSP; tryAMAGICbinSET(ne,0);
2274 SETs(boolSV(left != right));
2281 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2288 else if (left < right)
2299 dSP; dTARGET; tryAMAGICun(neg);
2304 /* High falutin' math. */
2308 dSP; dTARGET; tryAMAGICbin(atan2,0);
2311 SETn(Perl_atan2(left, right));
2318 dSP; dTARGET; tryAMAGICun(sin);
2322 value = Perl_sin(value);
2330 dSP; dTARGET; tryAMAGICun(cos);
2334 value = Perl_cos(value);
2340 /* Support Configure command-line overrides for rand() functions.
2341 After 5.005, perhaps we should replace this by Configure support
2342 for drand48(), random(), or rand(). For 5.005, though, maintain
2343 compatibility by calling rand() but allow the user to override it.
2344 See INSTALL for details. --Andy Dougherty 15 July 1998
2346 /* Now it's after 5.005, and Configure supports drand48() and random(),
2347 in addition to rand(). So the overrides should not be needed any more.
2348 --Jarkko Hietaniemi 27 September 1998
2351 #ifndef HAS_DRAND48_PROTO
2352 extern double drand48 (void);
2365 if (!PL_srand_called) {
2366 (void)seedDrand01((Rand_seed_t)seed());
2367 PL_srand_called = TRUE;
2382 (void)seedDrand01((Rand_seed_t)anum);
2383 PL_srand_called = TRUE;
2392 * This is really just a quick hack which grabs various garbage
2393 * values. It really should be a real hash algorithm which
2394 * spreads the effect of every input bit onto every output bit,
2395 * if someone who knows about such things would bother to write it.
2396 * Might be a good idea to add that function to CORE as well.
2397 * No numbers below come from careful analysis or anything here,
2398 * except they are primes and SEED_C1 > 1E6 to get a full-width
2399 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2400 * probably be bigger too.
2403 # define SEED_C1 1000003
2404 #define SEED_C4 73819
2406 # define SEED_C1 25747
2407 #define SEED_C4 20639
2411 #define SEED_C5 26107
2413 #ifndef PERL_NO_DEV_RANDOM
2418 # include <starlet.h>
2419 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2420 * in 100-ns units, typically incremented ever 10 ms. */
2421 unsigned int when[2];
2423 # ifdef HAS_GETTIMEOFDAY
2424 struct timeval when;
2430 /* This test is an escape hatch, this symbol isn't set by Configure. */
2431 #ifndef PERL_NO_DEV_RANDOM
2432 #ifndef PERL_RANDOM_DEVICE
2433 /* /dev/random isn't used by default because reads from it will block
2434 * if there isn't enough entropy available. You can compile with
2435 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2436 * is enough real entropy to fill the seed. */
2437 # define PERL_RANDOM_DEVICE "/dev/urandom"
2439 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2441 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2450 _ckvmssts(sys$gettim(when));
2451 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2453 # ifdef HAS_GETTIMEOFDAY
2454 gettimeofday(&when,(struct timezone *) 0);
2455 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2458 u = (U32)SEED_C1 * when;
2461 u += SEED_C3 * (U32)PerlProc_getpid();
2462 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2463 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2464 u += SEED_C5 * (U32)PTR2UV(&when);
2471 dSP; dTARGET; tryAMAGICun(exp);
2475 value = Perl_exp(value);
2483 dSP; dTARGET; tryAMAGICun(log);
2488 SET_NUMERIC_STANDARD();
2489 DIE(aTHX_ "Can't take log of %g", value);
2491 value = Perl_log(value);
2499 dSP; dTARGET; tryAMAGICun(sqrt);
2504 SET_NUMERIC_STANDARD();
2505 DIE(aTHX_ "Can't take sqrt of %g", value);
2507 value = Perl_sqrt(value);
2515 dSP; dTARGET; tryAMAGICun(int);
2518 IV iv = TOPi; /* attempt to convert to IV if possible. */
2519 /* XXX it's arguable that compiler casting to IV might be subtly
2520 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2521 else preferring IV has introduced a subtle behaviour change bug. OTOH
2522 relying on floating point to be accurate is a bug. */
2533 if (value < (NV)UV_MAX + 0.5) {
2536 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2537 # ifdef HAS_MODFL_POW32_BUG
2538 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2540 NV offset = Perl_modf(value, &value);
2541 (void)Perl_modf(offset, &offset);
2545 (void)Perl_modf(value, &value);
2548 double tmp = (double)value;
2549 (void)Perl_modf(tmp, &tmp);
2556 if (value > (NV)IV_MIN - 0.5) {
2559 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2560 # ifdef HAS_MODFL_POW32_BUG
2561 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2563 NV offset = Perl_modf(-value, &value);
2564 (void)Perl_modf(offset, &offset);
2568 (void)Perl_modf(-value, &value);
2572 double tmp = (double)value;
2573 (void)Perl_modf(-tmp, &tmp);
2586 dSP; dTARGET; tryAMAGICun(abs);
2588 /* This will cache the NV value if string isn't actually integer */
2592 /* IVX is precise */
2594 SETu(TOPu); /* force it to be numeric only */
2602 /* 2s complement assumption. Also, not really needed as
2603 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2625 tmps = (SvPVx(POPs, len));
2626 argtype = 1; /* allow underscores */
2627 XPUSHn(scan_hex(tmps, len, &argtype));
2639 tmps = (SvPVx(POPs, len));
2640 while (*tmps && len && isSPACE(*tmps))
2644 argtype = 1; /* allow underscores */
2646 value = scan_hex(++tmps, --len, &argtype);
2647 else if (*tmps == 'b')
2648 value = scan_bin(++tmps, --len, &argtype);
2650 value = scan_oct(tmps, len, &argtype);
2663 SETi(sv_len_utf8(sv));
2679 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2681 I32 arybase = PL_curcop->cop_arybase;
2685 int num_args = PL_op->op_private & 7;
2686 bool repl_need_utf8_upgrade = FALSE;
2687 bool repl_is_utf8 = FALSE;
2689 SvTAINTED_off(TARG); /* decontaminate */
2690 SvUTF8_off(TARG); /* decontaminate */
2694 repl = SvPV(repl_sv, repl_len);
2695 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2705 sv_utf8_upgrade(sv);
2707 else if (DO_UTF8(sv))
2708 repl_need_utf8_upgrade = TRUE;
2710 tmps = SvPV(sv, curlen);
2712 utf8_curlen = sv_len_utf8(sv);
2713 if (utf8_curlen == curlen)
2716 curlen = utf8_curlen;
2721 if (pos >= arybase) {
2739 else if (len >= 0) {
2741 if (rem > (I32)curlen)
2756 Perl_croak(aTHX_ "substr outside of string");
2757 if (ckWARN(WARN_SUBSTR))
2758 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2765 sv_pos_u2b(sv, &pos, &rem);
2767 sv_setpvn(TARG, tmps, rem);
2768 #ifdef USE_LOCALE_COLLATE
2769 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2774 SV* repl_sv_copy = NULL;
2776 if (repl_need_utf8_upgrade) {
2777 repl_sv_copy = newSVsv(repl_sv);
2778 sv_utf8_upgrade(repl_sv_copy);
2779 repl = SvPV(repl_sv_copy, repl_len);
2780 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2782 sv_insert(sv, pos, rem, repl, repl_len);
2786 SvREFCNT_dec(repl_sv_copy);
2788 else if (lvalue) { /* it's an lvalue! */
2789 if (!SvGMAGICAL(sv)) {
2793 if (ckWARN(WARN_SUBSTR))
2794 Perl_warner(aTHX_ WARN_SUBSTR,
2795 "Attempt to use reference as lvalue in substr");
2797 if (SvOK(sv)) /* is it defined ? */
2798 (void)SvPOK_only_UTF8(sv);
2800 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2803 if (SvTYPE(TARG) < SVt_PVLV) {
2804 sv_upgrade(TARG, SVt_PVLV);
2805 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2809 if (LvTARG(TARG) != sv) {
2811 SvREFCNT_dec(LvTARG(TARG));
2812 LvTARG(TARG) = SvREFCNT_inc(sv);
2814 LvTARGOFF(TARG) = upos;
2815 LvTARGLEN(TARG) = urem;
2819 PUSHs(TARG); /* avoid SvSETMAGIC here */
2826 register IV size = POPi;
2827 register IV offset = POPi;
2828 register SV *src = POPs;
2829 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2831 SvTAINTED_off(TARG); /* decontaminate */
2832 if (lvalue) { /* it's an lvalue! */
2833 if (SvTYPE(TARG) < SVt_PVLV) {
2834 sv_upgrade(TARG, SVt_PVLV);
2835 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2838 if (LvTARG(TARG) != src) {
2840 SvREFCNT_dec(LvTARG(TARG));
2841 LvTARG(TARG) = SvREFCNT_inc(src);
2843 LvTARGOFF(TARG) = offset;
2844 LvTARGLEN(TARG) = size;
2847 sv_setuv(TARG, do_vecget(src, offset, size));
2862 I32 arybase = PL_curcop->cop_arybase;
2867 offset = POPi - arybase;
2870 tmps = SvPV(big, biglen);
2871 if (offset > 0 && DO_UTF8(big))
2872 sv_pos_u2b(big, &offset, 0);
2875 else if (offset > biglen)
2877 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2878 (unsigned char*)tmps + biglen, little, 0)))
2881 retval = tmps2 - tmps;
2882 if (retval > 0 && DO_UTF8(big))
2883 sv_pos_b2u(big, &retval);
2884 PUSHi(retval + arybase);
2899 I32 arybase = PL_curcop->cop_arybase;
2905 tmps2 = SvPV(little, llen);
2906 tmps = SvPV(big, blen);
2910 if (offset > 0 && DO_UTF8(big))
2911 sv_pos_u2b(big, &offset, 0);
2912 offset = offset - arybase + llen;
2916 else if (offset > blen)
2918 if (!(tmps2 = rninstr(tmps, tmps + offset,
2919 tmps2, tmps2 + llen)))
2922 retval = tmps2 - tmps;
2923 if (retval > 0 && DO_UTF8(big))
2924 sv_pos_b2u(big, &retval);
2925 PUSHi(retval + arybase);
2931 dSP; dMARK; dORIGMARK; dTARGET;
2932 do_sprintf(TARG, SP-MARK, MARK+1);
2933 TAINT_IF(SvTAINTED(TARG));
2944 U8 *s = (U8*)SvPVx(argsv, len);
2946 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2956 (void)SvUPGRADE(TARG,SVt_PV);
2958 if (value > 255 && !IN_BYTES) {
2959 SvGROW(TARG, UNISKIP(value)+1);
2960 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
2961 SvCUR_set(TARG, tmps - SvPVX(TARG));
2963 (void)SvPOK_only(TARG);
2974 (void)SvPOK_only(TARG);
2981 dSP; dTARGET; dPOPTOPssrl;
2984 char *tmps = SvPV(left, n_a);
2986 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2988 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2992 "The crypt() function is unimplemented due to excessive paranoia.");
3005 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3007 U8 tmpbuf[UTF8_MAXLEN+1];
3011 if (IN_LOCALE_RUNTIME) {
3014 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3017 uv = toTITLE_utf8(s);
3019 tend = uvchr_to_utf8(tmpbuf, uv);
3021 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3023 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3024 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3029 s = (U8*)SvPV_force(sv, slen);
3030 Copy(tmpbuf, s, ulen, U8);
3034 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3036 SvUTF8_off(TARG); /* decontaminate */
3041 s = (U8*)SvPV_force(sv, slen);
3043 if (IN_LOCALE_RUNTIME) {
3046 *s = toUPPER_LC(*s);
3064 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3066 U8 tmpbuf[UTF8_MAXLEN+1];
3070 if (IN_LOCALE_RUNTIME) {
3073 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3076 uv = toLOWER_utf8(s);
3078 tend = uvchr_to_utf8(tmpbuf, uv);
3080 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3082 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3083 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3088 s = (U8*)SvPV_force(sv, slen);
3089 Copy(tmpbuf, s, ulen, U8);
3093 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3095 SvUTF8_off(TARG); /* decontaminate */
3100 s = (U8*)SvPV_force(sv, slen);
3102 if (IN_LOCALE_RUNTIME) {
3105 *s = toLOWER_LC(*s);
3129 s = (U8*)SvPV(sv,len);
3131 SvUTF8_off(TARG); /* decontaminate */
3132 sv_setpvn(TARG, "", 0);
3136 (void)SvUPGRADE(TARG, SVt_PV);
3137 SvGROW(TARG, (len * 2) + 1);
3138 (void)SvPOK_only(TARG);
3139 d = (U8*)SvPVX(TARG);
3141 if (IN_LOCALE_RUNTIME) {
3145 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3151 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3157 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3162 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3164 SvUTF8_off(TARG); /* decontaminate */
3169 s = (U8*)SvPV_force(sv, len);
3171 register U8 *send = s + len;
3173 if (IN_LOCALE_RUNTIME) {
3176 for (; s < send; s++)
3177 *s = toUPPER_LC(*s);
3180 for (; s < send; s++)
3203 s = (U8*)SvPV(sv,len);
3205 SvUTF8_off(TARG); /* decontaminate */
3206 sv_setpvn(TARG, "", 0);
3210 (void)SvUPGRADE(TARG, SVt_PV);
3211 SvGROW(TARG, (len * 2) + 1);
3212 (void)SvPOK_only(TARG);
3213 d = (U8*)SvPVX(TARG);
3215 if (IN_LOCALE_RUNTIME) {
3219 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3225 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3231 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3236 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3238 SvUTF8_off(TARG); /* decontaminate */
3244 s = (U8*)SvPV_force(sv, len);
3246 register U8 *send = s + len;
3248 if (IN_LOCALE_RUNTIME) {
3251 for (; s < send; s++)
3252 *s = toLOWER_LC(*s);
3255 for (; s < send; s++)
3270 register char *s = SvPV(sv,len);
3273 SvUTF8_off(TARG); /* decontaminate */
3275 (void)SvUPGRADE(TARG, SVt_PV);
3276 SvGROW(TARG, (len * 2) + 1);
3280 if (UTF8_IS_CONTINUED(*s)) {
3281 STRLEN ulen = UTF8SKIP(s);
3305 SvCUR_set(TARG, d - SvPVX(TARG));
3306 (void)SvPOK_only_UTF8(TARG);
3309 sv_setpvn(TARG, s, len);
3311 if (SvSMAGICAL(TARG))
3320 dSP; dMARK; dORIGMARK;
3322 register AV* av = (AV*)POPs;
3323 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3324 I32 arybase = PL_curcop->cop_arybase;
3327 if (SvTYPE(av) == SVt_PVAV) {
3328 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3330 for (svp = MARK + 1; svp <= SP; svp++) {
3335 if (max > AvMAX(av))
3338 while (++MARK <= SP) {
3339 elem = SvIVx(*MARK);
3343 svp = av_fetch(av, elem, lval);
3345 if (!svp || *svp == &PL_sv_undef)
3346 DIE(aTHX_ PL_no_aelem, elem);
3347 if (PL_op->op_private & OPpLVAL_INTRO)
3348 save_aelem(av, elem, svp);
3350 *MARK = svp ? *svp : &PL_sv_undef;
3353 if (GIMME != G_ARRAY) {
3361 /* Associative arrays. */
3366 HV *hash = (HV*)POPs;
3368 I32 gimme = GIMME_V;
3369 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3372 /* might clobber stack_sp */
3373 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3378 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3379 if (gimme == G_ARRAY) {
3382 /* might clobber stack_sp */
3384 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3389 else if (gimme == G_SCALAR)
3408 I32 gimme = GIMME_V;
3409 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3413 if (PL_op->op_private & OPpSLICE) {
3417 hvtype = SvTYPE(hv);
3418 if (hvtype == SVt_PVHV) { /* hash element */
3419 while (++MARK <= SP) {
3420 sv = hv_delete_ent(hv, *MARK, discard, 0);
3421 *MARK = sv ? sv : &PL_sv_undef;
3424 else if (hvtype == SVt_PVAV) {
3425 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3426 while (++MARK <= SP) {
3427 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3428 *MARK = sv ? sv : &PL_sv_undef;
3431 else { /* pseudo-hash element */
3432 while (++MARK <= SP) {
3433 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3434 *MARK = sv ? sv : &PL_sv_undef;
3439 DIE(aTHX_ "Not a HASH reference");
3442 else if (gimme == G_SCALAR) {
3451 if (SvTYPE(hv) == SVt_PVHV)
3452 sv = hv_delete_ent(hv, keysv, discard, 0);
3453 else if (SvTYPE(hv) == SVt_PVAV) {
3454 if (PL_op->op_flags & OPf_SPECIAL)
3455 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3457 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3460 DIE(aTHX_ "Not a HASH reference");
3475 if (PL_op->op_private & OPpEXISTS_SUB) {
3479 cv = sv_2cv(sv, &hv, &gv, FALSE);
3482 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3488 if (SvTYPE(hv) == SVt_PVHV) {
3489 if (hv_exists_ent(hv, tmpsv, 0))
3492 else if (SvTYPE(hv) == SVt_PVAV) {
3493 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3494 if (av_exists((AV*)hv, SvIV(tmpsv)))
3497 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3501 DIE(aTHX_ "Not a HASH reference");
3508 dSP; dMARK; dORIGMARK;
3509 register HV *hv = (HV*)POPs;
3510 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3511 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3513 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3514 DIE(aTHX_ "Can't localize pseudo-hash element");
3516 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3517 while (++MARK <= SP) {
3520 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3521 realhv ? hv_exists_ent(hv, keysv, 0)
3522 : avhv_exists_ent((AV*)hv, keysv, 0);
3524 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3525 svp = he ? &HeVAL(he) : 0;
3528 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3531 if (!svp || *svp == &PL_sv_undef) {
3533 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3535 if (PL_op->op_private & OPpLVAL_INTRO) {
3537 save_helem(hv, keysv, svp);
3540 char *key = SvPV(keysv, keylen);
3541 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3545 *MARK = svp ? *svp : &PL_sv_undef;
3548 if (GIMME != G_ARRAY) {
3556 /* List operators. */
3561 if (GIMME != G_ARRAY) {
3563 *MARK = *SP; /* unwanted list, return last item */
3565 *MARK = &PL_sv_undef;
3574 SV **lastrelem = PL_stack_sp;
3575 SV **lastlelem = PL_stack_base + POPMARK;
3576 SV **firstlelem = PL_stack_base + POPMARK + 1;
3577 register SV **firstrelem = lastlelem + 1;
3578 I32 arybase = PL_curcop->cop_arybase;
3579 I32 lval = PL_op->op_flags & OPf_MOD;
3580 I32 is_something_there = lval;
3582 register I32 max = lastrelem - lastlelem;
3583 register SV **lelem;
3586 if (GIMME != G_ARRAY) {
3587 ix = SvIVx(*lastlelem);
3592 if (ix < 0 || ix >= max)
3593 *firstlelem = &PL_sv_undef;
3595 *firstlelem = firstrelem[ix];
3601 SP = firstlelem - 1;
3605 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3611 if (ix < 0 || ix >= max)
3612 *lelem = &PL_sv_undef;
3614 is_something_there = TRUE;
3615 if (!(*lelem = firstrelem[ix]))
3616 *lelem = &PL_sv_undef;
3619 if (is_something_there)
3622 SP = firstlelem - 1;
3628 dSP; dMARK; dORIGMARK;
3629 I32 items = SP - MARK;
3630 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3631 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3638 dSP; dMARK; dORIGMARK;
3639 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3643 SV *val = NEWSV(46, 0);
3645 sv_setsv(val, *++MARK);
3646 else if (ckWARN(WARN_MISC))
3647 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3648 (void)hv_store_ent(hv,key,val,0);
3657 dSP; dMARK; dORIGMARK;
3658 register AV *ary = (AV*)*++MARK;
3662 register I32 offset;
3663 register I32 length;
3670 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3671 *MARK-- = SvTIED_obj((SV*)ary, mg);
3675 call_method("SPLICE",GIMME_V);
3684 offset = i = SvIVx(*MARK);
3686 offset += AvFILLp(ary) + 1;
3688 offset -= PL_curcop->cop_arybase;
3690 DIE(aTHX_ PL_no_aelem, i);
3692 length = SvIVx(*MARK++);
3694 length += AvFILLp(ary) - offset + 1;
3700 length = AvMAX(ary) + 1; /* close enough to infinity */
3704 length = AvMAX(ary) + 1;
3706 if (offset > AvFILLp(ary) + 1)
3707 offset = AvFILLp(ary) + 1;
3708 after = AvFILLp(ary) + 1 - (offset + length);
3709 if (after < 0) { /* not that much array */
3710 length += after; /* offset+length now in array */
3716 /* At this point, MARK .. SP-1 is our new LIST */
3719 diff = newlen - length;
3720 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3723 if (diff < 0) { /* shrinking the area */
3725 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3726 Copy(MARK, tmparyval, newlen, SV*);
3729 MARK = ORIGMARK + 1;
3730 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3731 MEXTEND(MARK, length);
3732 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3734 EXTEND_MORTAL(length);
3735 for (i = length, dst = MARK; i; i--) {
3736 sv_2mortal(*dst); /* free them eventualy */
3743 *MARK = AvARRAY(ary)[offset+length-1];
3746 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3747 SvREFCNT_dec(*dst++); /* free them now */
3750 AvFILLp(ary) += diff;
3752 /* pull up or down? */
3754 if (offset < after) { /* easier to pull up */
3755 if (offset) { /* esp. if nothing to pull */
3756 src = &AvARRAY(ary)[offset-1];
3757 dst = src - diff; /* diff is negative */
3758 for (i = offset; i > 0; i--) /* can't trust Copy */
3762 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3766 if (after) { /* anything to pull down? */
3767 src = AvARRAY(ary) + offset + length;
3768 dst = src + diff; /* diff is negative */
3769 Move(src, dst, after, SV*);
3771 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3772 /* avoid later double free */
3776 dst[--i] = &PL_sv_undef;
3779 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3781 *dst = NEWSV(46, 0);
3782 sv_setsv(*dst++, *src++);
3784 Safefree(tmparyval);
3787 else { /* no, expanding (or same) */
3789 New(452, tmparyval, length, SV*); /* so remember deletion */
3790 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3793 if (diff > 0) { /* expanding */
3795 /* push up or down? */
3797 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3801 Move(src, dst, offset, SV*);
3803 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3805 AvFILLp(ary) += diff;
3808 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3809 av_extend(ary, AvFILLp(ary) + diff);
3810 AvFILLp(ary) += diff;
3813 dst = AvARRAY(ary) + AvFILLp(ary);
3815 for (i = after; i; i--) {
3822 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3823 *dst = NEWSV(46, 0);
3824 sv_setsv(*dst++, *src++);
3826 MARK = ORIGMARK + 1;
3827 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3829 Copy(tmparyval, MARK, length, SV*);
3831 EXTEND_MORTAL(length);
3832 for (i = length, dst = MARK; i; i--) {
3833 sv_2mortal(*dst); /* free them eventualy */
3837 Safefree(tmparyval);
3841 else if (length--) {
3842 *MARK = tmparyval[length];
3845 while (length-- > 0)
3846 SvREFCNT_dec(tmparyval[length]);
3848 Safefree(tmparyval);
3851 *MARK = &PL_sv_undef;
3859 dSP; dMARK; dORIGMARK; dTARGET;
3860 register AV *ary = (AV*)*++MARK;
3861 register SV *sv = &PL_sv_undef;
3864 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3865 *MARK-- = SvTIED_obj((SV*)ary, mg);
3869 call_method("PUSH",G_SCALAR|G_DISCARD);
3874 /* Why no pre-extend of ary here ? */
3875 for (++MARK; MARK <= SP; MARK++) {
3878 sv_setsv(sv, *MARK);
3883 PUSHi( AvFILL(ary) + 1 );
3891 SV *sv = av_pop(av);
3893 (void)sv_2mortal(sv);
3902 SV *sv = av_shift(av);
3907 (void)sv_2mortal(sv);
3914 dSP; dMARK; dORIGMARK; dTARGET;
3915 register AV *ary = (AV*)*++MARK;
3920 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3921 *MARK-- = SvTIED_obj((SV*)ary, mg);
3925 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3930 av_unshift(ary, SP - MARK);
3933 sv_setsv(sv, *++MARK);
3934 (void)av_store(ary, i++, sv);
3938 PUSHi( AvFILL(ary) + 1 );
3948 if (GIMME == G_ARRAY) {
3955 /* safe as long as stack cannot get extended in the above */
3960 register char *down;
3965 SvUTF8_off(TARG); /* decontaminate */
3967 do_join(TARG, &PL_sv_no, MARK, SP);
3969 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3970 up = SvPV_force(TARG, len);
3972 if (DO_UTF8(TARG)) { /* first reverse each character */
3973 U8* s = (U8*)SvPVX(TARG);
3974 U8* send = (U8*)(s + len);
3976 if (UTF8_IS_INVARIANT(*s)) {
3981 if (!utf8_to_uvchr(s, 0))
3985 down = (char*)(s - 1);
3986 /* reverse this character */
3996 down = SvPVX(TARG) + len - 1;
4002 (void)SvPOK_only_UTF8(TARG);
4014 register IV limit = POPi; /* note, negative is forever */
4017 register char *s = SvPV(sv, len);
4018 bool do_utf8 = DO_UTF8(sv);
4019 char *strend = s + len;
4021 register REGEXP *rx;
4025 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4026 I32 maxiters = slen + 10;
4029 I32 origlimit = limit;
4032 AV *oldstack = PL_curstack;
4033 I32 gimme = GIMME_V;
4034 I32 oldsave = PL_savestack_ix;
4035 I32 make_mortal = 1;
4036 MAGIC *mg = (MAGIC *) NULL;
4039 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4044 DIE(aTHX_ "panic: pp_split");
4047 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4048 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4050 if (pm->op_pmreplroot) {
4052 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4054 ary = GvAVn((GV*)pm->op_pmreplroot);
4057 else if (gimme != G_ARRAY)
4059 ary = (AV*)PL_curpad[0];
4061 ary = GvAVn(PL_defgv);
4062 #endif /* USE_THREADS */
4065 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4071 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4073 XPUSHs(SvTIED_obj((SV*)ary, mg));
4079 for (i = AvFILLp(ary); i >= 0; i--)
4080 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4082 /* temporarily switch stacks */
4083 SWITCHSTACK(PL_curstack, ary);
4087 base = SP - PL_stack_base;
4089 if (pm->op_pmflags & PMf_SKIPWHITE) {
4090 if (pm->op_pmflags & PMf_LOCALE) {
4091 while (isSPACE_LC(*s))
4099 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4100 SAVEINT(PL_multiline);
4101 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4105 limit = maxiters + 2;
4106 if (pm->op_pmflags & PMf_WHITE) {
4109 while (m < strend &&
4110 !((pm->op_pmflags & PMf_LOCALE)
4111 ? isSPACE_LC(*m) : isSPACE(*m)))
4116 dstr = NEWSV(30, m-s);
4117 sv_setpvn(dstr, s, m-s);
4121 (void)SvUTF8_on(dstr);
4125 while (s < strend &&
4126 ((pm->op_pmflags & PMf_LOCALE)
4127 ? isSPACE_LC(*s) : isSPACE(*s)))
4131 else if (strEQ("^", rx->precomp)) {
4134 for (m = s; m < strend && *m != '\n'; m++) ;
4138 dstr = NEWSV(30, m-s);
4139 sv_setpvn(dstr, s, m-s);
4143 (void)SvUTF8_on(dstr);
4148 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4149 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4150 && (rx->reganch & ROPT_CHECK_ALL)
4151 && !(rx->reganch & ROPT_ANCH)) {
4152 int tail = (rx->reganch & RE_INTUIT_TAIL);
4153 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4156 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4158 char c = *SvPV(csv, n_a);
4161 for (m = s; m < strend && *m != c; m++) ;
4164 dstr = NEWSV(30, m-s);
4165 sv_setpvn(dstr, s, m-s);
4169 (void)SvUTF8_on(dstr);
4171 /* The rx->minlen is in characters but we want to step
4172 * s ahead by bytes. */
4174 s = (char*)utf8_hop((U8*)m, len);
4176 s = m + len; /* Fake \n at the end */
4181 while (s < strend && --limit &&
4182 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4183 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4186 dstr = NEWSV(31, m-s);
4187 sv_setpvn(dstr, s, m-s);
4191 (void)SvUTF8_on(dstr);
4193 /* The rx->minlen is in characters but we want to step
4194 * s ahead by bytes. */
4196 s = (char*)utf8_hop((U8*)m, len);
4198 s = m + len; /* Fake \n at the end */
4203 maxiters += slen * rx->nparens;
4204 while (s < strend && --limit
4205 /* && (!rx->check_substr
4206 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4208 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4209 1 /* minend */, sv, NULL, 0))
4211 TAINT_IF(RX_MATCH_TAINTED(rx));
4212 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4217 strend = s + (strend - m);
4219 m = rx->startp[0] + orig;
4220 dstr = NEWSV(32, m-s);
4221 sv_setpvn(dstr, s, m-s);
4225 (void)SvUTF8_on(dstr);
4228 for (i = 1; i <= rx->nparens; i++) {
4229 s = rx->startp[i] + orig;
4230 m = rx->endp[i] + orig;
4232 dstr = NEWSV(33, m-s);
4233 sv_setpvn(dstr, s, m-s);
4236 dstr = NEWSV(33, 0);
4240 (void)SvUTF8_on(dstr);
4244 s = rx->endp[0] + orig;
4248 LEAVE_SCOPE(oldsave);
4249 iters = (SP - PL_stack_base) - base;
4250 if (iters > maxiters)
4251 DIE(aTHX_ "Split loop");
4253 /* keep field after final delim? */
4254 if (s < strend || (iters && origlimit)) {
4255 STRLEN l = strend - s;
4256 dstr = NEWSV(34, l);
4257 sv_setpvn(dstr, s, l);
4261 (void)SvUTF8_on(dstr);
4265 else if (!origlimit) {
4266 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4272 SWITCHSTACK(ary, oldstack);
4273 if (SvSMAGICAL(ary)) {
4278 if (gimme == G_ARRAY) {
4280 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4288 call_method("PUSH",G_SCALAR|G_DISCARD);
4291 if (gimme == G_ARRAY) {
4292 /* EXTEND should not be needed - we just popped them */
4294 for (i=0; i < iters; i++) {
4295 SV **svp = av_fetch(ary, i, FALSE);
4296 PUSHs((svp) ? *svp : &PL_sv_undef);
4303 if (gimme == G_ARRAY)
4306 if (iters || !pm->op_pmreplroot) {
4316 Perl_unlock_condpair(pTHX_ void *svv)
4318 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4321 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4322 MUTEX_LOCK(MgMUTEXP(mg));
4323 if (MgOWNER(mg) != thr)
4324 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4326 COND_SIGNAL(MgOWNERCONDP(mg));
4327 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4328 PTR2UV(thr), PTR2UV(svv)));
4329 MUTEX_UNLOCK(MgMUTEXP(mg));
4331 #endif /* USE_THREADS */
4340 #endif /* USE_THREADS */
4341 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4342 || SvTYPE(retsv) == SVt_PVCV) {
4343 retsv = refto(retsv);
4354 if (PL_op->op_private & OPpLVAL_INTRO)
4355 PUSHs(*save_threadsv(PL_op->op_targ));
4357 PUSHs(THREADSV(PL_op->op_targ));
4360 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4361 #endif /* USE_THREADS */