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")) /* 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;
1143 *SP = sv_2mortal(newSVsv(*SP));
1149 repeatcpy((char*)(MARK + items), (char*)MARK,
1150 items * sizeof(SV*), count - 1);
1153 else if (count <= 0)
1156 else { /* Note: mark already snarfed by pp_list */
1161 SvSetSV(TARG, tmpstr);
1162 SvPV_force(TARG, len);
1163 isutf = DO_UTF8(TARG);
1168 SvGROW(TARG, (count * len) + 1);
1169 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1170 SvCUR(TARG) *= count;
1172 *SvEND(TARG) = '\0';
1175 (void)SvPOK_only_UTF8(TARG);
1177 (void)SvPOK_only(TARG);
1179 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1180 /* The parser saw this as a list repeat, and there
1181 are probably several items on the stack. But we're
1182 in scalar context, and there's no pp_list to save us
1183 now. So drop the rest of the items -- robin@kitsite.com
1196 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1197 useleft = USE_LEFT(TOPm1s);
1198 #ifdef PERL_PRESERVE_IVUV
1199 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1200 "bad things" happen if you rely on signed integers wrapping. */
1203 /* Unless the left argument is integer in range we are going to have to
1204 use NV maths. Hence only attempt to coerce the right argument if
1205 we know the left is integer. */
1206 register UV auv = 0;
1212 a_valid = auvok = 1;
1213 /* left operand is undef, treat as zero. */
1215 /* Left operand is defined, so is it IV? */
1216 SvIV_please(TOPm1s);
1217 if (SvIOK(TOPm1s)) {
1218 if ((auvok = SvUOK(TOPm1s)))
1219 auv = SvUVX(TOPm1s);
1221 register IV aiv = SvIVX(TOPm1s);
1224 auvok = 1; /* Now acting as a sign flag. */
1225 } else { /* 2s complement assumption for IV_MIN */
1233 bool result_good = 0;
1236 bool buvok = SvUOK(TOPs);
1241 register IV biv = SvIVX(TOPs);
1248 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1249 else "IV" now, independant of how it came in.
1250 if a, b represents positive, A, B negative, a maps to -A etc
1255 all UV maths. negate result if A negative.
1256 subtract if signs same, add if signs differ. */
1258 if (auvok ^ buvok) {
1267 /* Must get smaller */
1272 if (result <= buv) {
1273 /* result really should be -(auv-buv). as its negation
1274 of true value, need to swap our result flag */
1286 if (result <= (UV)IV_MIN)
1287 SETi( -(IV)result );
1289 /* result valid, but out of range for IV. */
1290 SETn( -(NV)result );
1294 } /* Overflow, drop through to NVs. */
1298 useleft = USE_LEFT(TOPm1s);
1302 /* left operand is undef, treat as zero - value */
1306 SETn( TOPn - value );
1313 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1316 if (PL_op->op_private & HINT_INTEGER) {
1330 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1333 if (PL_op->op_private & HINT_INTEGER) {
1347 dSP; tryAMAGICbinSET(lt,0);
1348 #ifdef PERL_PRESERVE_IVUV
1351 SvIV_please(TOPm1s);
1352 if (SvIOK(TOPm1s)) {
1353 bool auvok = SvUOK(TOPm1s);
1354 bool buvok = SvUOK(TOPs);
1356 if (!auvok && !buvok) { /* ## IV < IV ## */
1357 IV aiv = SvIVX(TOPm1s);
1358 IV biv = SvIVX(TOPs);
1361 SETs(boolSV(aiv < biv));
1364 if (auvok && buvok) { /* ## UV < UV ## */
1365 UV auv = SvUVX(TOPm1s);
1366 UV buv = SvUVX(TOPs);
1369 SETs(boolSV(auv < buv));
1372 if (auvok) { /* ## UV < IV ## */
1379 /* As (a) is a UV, it's >=0, so it cannot be < */
1384 if (auv >= (UV) IV_MAX) {
1385 /* As (b) is an IV, it cannot be > IV_MAX */
1389 SETs(boolSV(auv < (UV)biv));
1392 { /* ## IV < UV ## */
1396 aiv = SvIVX(TOPm1s);
1398 /* As (b) is a UV, it's >=0, so it must be < */
1405 if (buv > (UV) IV_MAX) {
1406 /* As (a) is an IV, it cannot be > IV_MAX */
1410 SETs(boolSV((UV)aiv < buv));
1418 SETs(boolSV(TOPn < value));
1425 dSP; tryAMAGICbinSET(gt,0);
1426 #ifdef PERL_PRESERVE_IVUV
1429 SvIV_please(TOPm1s);
1430 if (SvIOK(TOPm1s)) {
1431 bool auvok = SvUOK(TOPm1s);
1432 bool buvok = SvUOK(TOPs);
1434 if (!auvok && !buvok) { /* ## IV > IV ## */
1435 IV aiv = SvIVX(TOPm1s);
1436 IV biv = SvIVX(TOPs);
1439 SETs(boolSV(aiv > biv));
1442 if (auvok && buvok) { /* ## UV > UV ## */
1443 UV auv = SvUVX(TOPm1s);
1444 UV buv = SvUVX(TOPs);
1447 SETs(boolSV(auv > buv));
1450 if (auvok) { /* ## UV > IV ## */
1457 /* As (a) is a UV, it's >=0, so it must be > */
1462 if (auv > (UV) IV_MAX) {
1463 /* As (b) is an IV, it cannot be > IV_MAX */
1467 SETs(boolSV(auv > (UV)biv));
1470 { /* ## IV > UV ## */
1474 aiv = SvIVX(TOPm1s);
1476 /* As (b) is a UV, it's >=0, so it cannot be > */
1483 if (buv >= (UV) IV_MAX) {
1484 /* As (a) is an IV, it cannot be > IV_MAX */
1488 SETs(boolSV((UV)aiv > buv));
1496 SETs(boolSV(TOPn > value));
1503 dSP; tryAMAGICbinSET(le,0);
1504 #ifdef PERL_PRESERVE_IVUV
1507 SvIV_please(TOPm1s);
1508 if (SvIOK(TOPm1s)) {
1509 bool auvok = SvUOK(TOPm1s);
1510 bool buvok = SvUOK(TOPs);
1512 if (!auvok && !buvok) { /* ## IV <= IV ## */
1513 IV aiv = SvIVX(TOPm1s);
1514 IV biv = SvIVX(TOPs);
1517 SETs(boolSV(aiv <= biv));
1520 if (auvok && buvok) { /* ## UV <= UV ## */
1521 UV auv = SvUVX(TOPm1s);
1522 UV buv = SvUVX(TOPs);
1525 SETs(boolSV(auv <= buv));
1528 if (auvok) { /* ## UV <= IV ## */
1535 /* As (a) is a UV, it's >=0, so a cannot be <= */
1540 if (auv > (UV) IV_MAX) {
1541 /* As (b) is an IV, it cannot be > IV_MAX */
1545 SETs(boolSV(auv <= (UV)biv));
1548 { /* ## IV <= UV ## */
1552 aiv = SvIVX(TOPm1s);
1554 /* As (b) is a UV, it's >=0, so a must be <= */
1561 if (buv >= (UV) IV_MAX) {
1562 /* As (a) is an IV, it cannot be > IV_MAX */
1566 SETs(boolSV((UV)aiv <= buv));
1574 SETs(boolSV(TOPn <= value));
1581 dSP; tryAMAGICbinSET(ge,0);
1582 #ifdef PERL_PRESERVE_IVUV
1585 SvIV_please(TOPm1s);
1586 if (SvIOK(TOPm1s)) {
1587 bool auvok = SvUOK(TOPm1s);
1588 bool buvok = SvUOK(TOPs);
1590 if (!auvok && !buvok) { /* ## IV >= IV ## */
1591 IV aiv = SvIVX(TOPm1s);
1592 IV biv = SvIVX(TOPs);
1595 SETs(boolSV(aiv >= biv));
1598 if (auvok && buvok) { /* ## UV >= UV ## */
1599 UV auv = SvUVX(TOPm1s);
1600 UV buv = SvUVX(TOPs);
1603 SETs(boolSV(auv >= buv));
1606 if (auvok) { /* ## UV >= IV ## */
1613 /* As (a) is a UV, it's >=0, so it must be >= */
1618 if (auv >= (UV) IV_MAX) {
1619 /* As (b) is an IV, it cannot be > IV_MAX */
1623 SETs(boolSV(auv >= (UV)biv));
1626 { /* ## IV >= UV ## */
1630 aiv = SvIVX(TOPm1s);
1632 /* As (b) is a UV, it's >=0, so a cannot be >= */
1639 if (buv > (UV) IV_MAX) {
1640 /* As (a) is an IV, it cannot be > IV_MAX */
1644 SETs(boolSV((UV)aiv >= buv));
1652 SETs(boolSV(TOPn >= value));
1659 dSP; tryAMAGICbinSET(ne,0);
1660 #ifndef NV_PRESERVES_UV
1661 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1662 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1666 #ifdef PERL_PRESERVE_IVUV
1669 SvIV_please(TOPm1s);
1670 if (SvIOK(TOPm1s)) {
1671 bool auvok = SvUOK(TOPm1s);
1672 bool buvok = SvUOK(TOPs);
1674 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1675 IV aiv = SvIVX(TOPm1s);
1676 IV biv = SvIVX(TOPs);
1679 SETs(boolSV(aiv != biv));
1682 if (auvok && buvok) { /* ## UV != UV ## */
1683 UV auv = SvUVX(TOPm1s);
1684 UV buv = SvUVX(TOPs);
1687 SETs(boolSV(auv != buv));
1690 { /* ## Mixed IV,UV ## */
1694 /* != is commutative so swap if needed (save code) */
1696 /* swap. top of stack (b) is the iv */
1700 /* As (a) is a UV, it's >0, so it cannot be == */
1709 /* As (b) is a UV, it's >0, so it cannot be == */
1713 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1715 /* we know iv is >= 0 */
1716 if (uv > (UV) IV_MAX) {
1720 SETs(boolSV((UV)iv != uv));
1728 SETs(boolSV(TOPn != value));
1735 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1736 #ifndef NV_PRESERVES_UV
1737 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1738 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1742 #ifdef PERL_PRESERVE_IVUV
1743 /* Fortunately it seems NaN isn't IOK */
1746 SvIV_please(TOPm1s);
1747 if (SvIOK(TOPm1s)) {
1748 bool leftuvok = SvUOK(TOPm1s);
1749 bool rightuvok = SvUOK(TOPs);
1751 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1752 IV leftiv = SvIVX(TOPm1s);
1753 IV rightiv = SvIVX(TOPs);
1755 if (leftiv > rightiv)
1757 else if (leftiv < rightiv)
1761 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1762 UV leftuv = SvUVX(TOPm1s);
1763 UV rightuv = SvUVX(TOPs);
1765 if (leftuv > rightuv)
1767 else if (leftuv < rightuv)
1771 } else if (leftuvok) { /* ## UV <=> IV ## */
1775 rightiv = SvIVX(TOPs);
1777 /* As (a) is a UV, it's >=0, so it cannot be < */
1780 leftuv = SvUVX(TOPm1s);
1781 if (leftuv > (UV) IV_MAX) {
1782 /* As (b) is an IV, it cannot be > IV_MAX */
1784 } else if (leftuv > (UV)rightiv) {
1786 } else if (leftuv < (UV)rightiv) {
1792 } else { /* ## IV <=> UV ## */
1796 leftiv = SvIVX(TOPm1s);
1798 /* As (b) is a UV, it's >=0, so it must be < */
1801 rightuv = SvUVX(TOPs);
1802 if (rightuv > (UV) IV_MAX) {
1803 /* As (a) is an IV, it cannot be > IV_MAX */
1805 } else if (leftiv > (UV)rightuv) {
1807 } else if (leftiv < (UV)rightuv) {
1825 if (Perl_isnan(left) || Perl_isnan(right)) {
1829 value = (left > right) - (left < right);
1833 else if (left < right)
1835 else if (left > right)
1849 dSP; tryAMAGICbinSET(slt,0);
1852 int cmp = (IN_LOCALE_RUNTIME
1853 ? sv_cmp_locale(left, right)
1854 : sv_cmp(left, right));
1855 SETs(boolSV(cmp < 0));
1862 dSP; tryAMAGICbinSET(sgt,0);
1865 int cmp = (IN_LOCALE_RUNTIME
1866 ? sv_cmp_locale(left, right)
1867 : sv_cmp(left, right));
1868 SETs(boolSV(cmp > 0));
1875 dSP; tryAMAGICbinSET(sle,0);
1878 int cmp = (IN_LOCALE_RUNTIME
1879 ? sv_cmp_locale(left, right)
1880 : sv_cmp(left, right));
1881 SETs(boolSV(cmp <= 0));
1888 dSP; tryAMAGICbinSET(sge,0);
1891 int cmp = (IN_LOCALE_RUNTIME
1892 ? sv_cmp_locale(left, right)
1893 : sv_cmp(left, right));
1894 SETs(boolSV(cmp >= 0));
1901 dSP; tryAMAGICbinSET(seq,0);
1904 SETs(boolSV(sv_eq(left, right)));
1911 dSP; tryAMAGICbinSET(sne,0);
1914 SETs(boolSV(!sv_eq(left, right)));
1921 dSP; dTARGET; tryAMAGICbin(scmp,0);
1924 int cmp = (IN_LOCALE_RUNTIME
1925 ? sv_cmp_locale(left, right)
1926 : sv_cmp(left, right));
1934 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1937 if (SvNIOKp(left) || SvNIOKp(right)) {
1938 if (PL_op->op_private & HINT_INTEGER) {
1939 IV i = SvIV(left) & SvIV(right);
1943 UV u = SvUV(left) & SvUV(right);
1948 do_vop(PL_op->op_type, TARG, left, right);
1957 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1960 if (SvNIOKp(left) || SvNIOKp(right)) {
1961 if (PL_op->op_private & HINT_INTEGER) {
1962 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1966 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1971 do_vop(PL_op->op_type, TARG, left, right);
1980 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1983 if (SvNIOKp(left) || SvNIOKp(right)) {
1984 if (PL_op->op_private & HINT_INTEGER) {
1985 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1989 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1994 do_vop(PL_op->op_type, TARG, left, right);
2003 dSP; dTARGET; tryAMAGICun(neg);
2006 int flags = SvFLAGS(sv);
2009 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2010 /* It's publicly an integer, or privately an integer-not-float */
2013 if (SvIVX(sv) == IV_MIN) {
2014 /* 2s complement assumption. */
2015 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2018 else if (SvUVX(sv) <= IV_MAX) {
2023 else if (SvIVX(sv) != IV_MIN) {
2027 #ifdef PERL_PRESERVE_IVUV
2036 else if (SvPOKp(sv)) {
2038 char *s = SvPV(sv, len);
2039 if (isIDFIRST(*s)) {
2040 sv_setpvn(TARG, "-", 1);
2043 else if (*s == '+' || *s == '-') {
2045 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2047 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2048 sv_setpvn(TARG, "-", 1);
2054 goto oops_its_an_int;
2055 sv_setnv(TARG, -SvNV(sv));
2067 dSP; tryAMAGICunSET(not);
2068 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2074 dSP; dTARGET; tryAMAGICun(compl);
2078 if (PL_op->op_private & HINT_INTEGER) {
2093 tmps = (U8*)SvPV_force(TARG, len);
2096 /* Calculate exact length, let's not estimate. */
2105 while (tmps < send) {
2106 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2107 tmps += UTF8SKIP(tmps);
2108 targlen += UNISKIP(~c);
2114 /* Now rewind strings and write them. */
2118 Newz(0, result, targlen + 1, U8);
2119 while (tmps < send) {
2120 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2121 tmps += UTF8SKIP(tmps);
2122 result = uvchr_to_utf8(result, ~c);
2126 sv_setpvn(TARG, (char*)result, targlen);
2130 Newz(0, result, nchar + 1, U8);
2131 while (tmps < send) {
2132 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2133 tmps += UTF8SKIP(tmps);
2138 sv_setpvn(TARG, (char*)result, nchar);
2146 register long *tmpl;
2147 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2150 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2155 for ( ; anum > 0; anum--, tmps++)
2164 /* integer versions of some of the above */
2168 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2171 SETi( left * right );
2178 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2182 DIE(aTHX_ "Illegal division by zero");
2183 value = POPi / value;
2191 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2195 DIE(aTHX_ "Illegal modulus zero");
2196 SETi( left % right );
2203 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2206 SETi( left + right );
2213 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2216 SETi( left - right );
2223 dSP; tryAMAGICbinSET(lt,0);
2226 SETs(boolSV(left < right));
2233 dSP; tryAMAGICbinSET(gt,0);
2236 SETs(boolSV(left > right));
2243 dSP; tryAMAGICbinSET(le,0);
2246 SETs(boolSV(left <= right));
2253 dSP; tryAMAGICbinSET(ge,0);
2256 SETs(boolSV(left >= right));
2263 dSP; tryAMAGICbinSET(eq,0);
2266 SETs(boolSV(left == right));
2273 dSP; tryAMAGICbinSET(ne,0);
2276 SETs(boolSV(left != right));
2283 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2290 else if (left < right)
2301 dSP; dTARGET; tryAMAGICun(neg);
2306 /* High falutin' math. */
2310 dSP; dTARGET; tryAMAGICbin(atan2,0);
2313 SETn(Perl_atan2(left, right));
2320 dSP; dTARGET; tryAMAGICun(sin);
2324 value = Perl_sin(value);
2332 dSP; dTARGET; tryAMAGICun(cos);
2336 value = Perl_cos(value);
2342 /* Support Configure command-line overrides for rand() functions.
2343 After 5.005, perhaps we should replace this by Configure support
2344 for drand48(), random(), or rand(). For 5.005, though, maintain
2345 compatibility by calling rand() but allow the user to override it.
2346 See INSTALL for details. --Andy Dougherty 15 July 1998
2348 /* Now it's after 5.005, and Configure supports drand48() and random(),
2349 in addition to rand(). So the overrides should not be needed any more.
2350 --Jarkko Hietaniemi 27 September 1998
2353 #ifndef HAS_DRAND48_PROTO
2354 extern double drand48 (void);
2367 if (!PL_srand_called) {
2368 (void)seedDrand01((Rand_seed_t)seed());
2369 PL_srand_called = TRUE;
2384 (void)seedDrand01((Rand_seed_t)anum);
2385 PL_srand_called = TRUE;
2394 * This is really just a quick hack which grabs various garbage
2395 * values. It really should be a real hash algorithm which
2396 * spreads the effect of every input bit onto every output bit,
2397 * if someone who knows about such things would bother to write it.
2398 * Might be a good idea to add that function to CORE as well.
2399 * No numbers below come from careful analysis or anything here,
2400 * except they are primes and SEED_C1 > 1E6 to get a full-width
2401 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2402 * probably be bigger too.
2405 # define SEED_C1 1000003
2406 #define SEED_C4 73819
2408 # define SEED_C1 25747
2409 #define SEED_C4 20639
2413 #define SEED_C5 26107
2415 #ifndef PERL_NO_DEV_RANDOM
2420 # include <starlet.h>
2421 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2422 * in 100-ns units, typically incremented ever 10 ms. */
2423 unsigned int when[2];
2425 # ifdef HAS_GETTIMEOFDAY
2426 struct timeval when;
2432 /* This test is an escape hatch, this symbol isn't set by Configure. */
2433 #ifndef PERL_NO_DEV_RANDOM
2434 #ifndef PERL_RANDOM_DEVICE
2435 /* /dev/random isn't used by default because reads from it will block
2436 * if there isn't enough entropy available. You can compile with
2437 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2438 * is enough real entropy to fill the seed. */
2439 # define PERL_RANDOM_DEVICE "/dev/urandom"
2441 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2443 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2452 _ckvmssts(sys$gettim(when));
2453 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2455 # ifdef HAS_GETTIMEOFDAY
2456 gettimeofday(&when,(struct timezone *) 0);
2457 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2460 u = (U32)SEED_C1 * when;
2463 u += SEED_C3 * (U32)PerlProc_getpid();
2464 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2465 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2466 u += SEED_C5 * (U32)PTR2UV(&when);
2473 dSP; dTARGET; tryAMAGICun(exp);
2477 value = Perl_exp(value);
2485 dSP; dTARGET; tryAMAGICun(log);
2490 SET_NUMERIC_STANDARD();
2491 DIE(aTHX_ "Can't take log of %g", value);
2493 value = Perl_log(value);
2501 dSP; dTARGET; tryAMAGICun(sqrt);
2506 SET_NUMERIC_STANDARD();
2507 DIE(aTHX_ "Can't take sqrt of %g", value);
2509 value = Perl_sqrt(value);
2517 dSP; dTARGET; tryAMAGICun(int);
2520 IV iv = TOPi; /* attempt to convert to IV if possible. */
2521 /* XXX it's arguable that compiler casting to IV might be subtly
2522 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2523 else preferring IV has introduced a subtle behaviour change bug. OTOH
2524 relying on floating point to be accurate is a bug. */
2535 if (value < (NV)UV_MAX + 0.5) {
2538 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2539 # ifdef HAS_MODFL_POW32_BUG
2540 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2542 NV offset = Perl_modf(value, &value);
2543 (void)Perl_modf(offset, &offset);
2547 (void)Perl_modf(value, &value);
2550 double tmp = (double)value;
2551 (void)Perl_modf(tmp, &tmp);
2558 if (value > (NV)IV_MIN - 0.5) {
2561 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2562 # ifdef HAS_MODFL_POW32_BUG
2563 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2565 NV offset = Perl_modf(-value, &value);
2566 (void)Perl_modf(offset, &offset);
2570 (void)Perl_modf(-value, &value);
2574 double tmp = (double)value;
2575 (void)Perl_modf(-tmp, &tmp);
2588 dSP; dTARGET; tryAMAGICun(abs);
2590 /* This will cache the NV value if string isn't actually integer */
2594 /* IVX is precise */
2596 SETu(TOPu); /* force it to be numeric only */
2604 /* 2s complement assumption. Also, not really needed as
2605 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2627 tmps = (SvPVx(POPs, len));
2628 argtype = 1; /* allow underscores */
2629 XPUSHn(scan_hex(tmps, len, &argtype));
2641 tmps = (SvPVx(POPs, len));
2642 while (*tmps && len && isSPACE(*tmps))
2646 argtype = 1; /* allow underscores */
2648 value = scan_hex(++tmps, --len, &argtype);
2649 else if (*tmps == 'b')
2650 value = scan_bin(++tmps, --len, &argtype);
2652 value = scan_oct(tmps, len, &argtype);
2665 SETi(sv_len_utf8(sv));
2681 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2683 I32 arybase = PL_curcop->cop_arybase;
2687 int num_args = PL_op->op_private & 7;
2688 bool repl_need_utf8_upgrade = FALSE;
2689 bool repl_is_utf8 = FALSE;
2691 SvTAINTED_off(TARG); /* decontaminate */
2692 SvUTF8_off(TARG); /* decontaminate */
2696 repl = SvPV(repl_sv, repl_len);
2697 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2707 sv_utf8_upgrade(sv);
2709 else if (DO_UTF8(sv))
2710 repl_need_utf8_upgrade = TRUE;
2712 tmps = SvPV(sv, curlen);
2714 utf8_curlen = sv_len_utf8(sv);
2715 if (utf8_curlen == curlen)
2718 curlen = utf8_curlen;
2723 if (pos >= arybase) {
2741 else if (len >= 0) {
2743 if (rem > (I32)curlen)
2758 Perl_croak(aTHX_ "substr outside of string");
2759 if (ckWARN(WARN_SUBSTR))
2760 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2767 sv_pos_u2b(sv, &pos, &rem);
2769 sv_setpvn(TARG, tmps, rem);
2770 #ifdef USE_LOCALE_COLLATE
2771 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2776 SV* repl_sv_copy = NULL;
2778 if (repl_need_utf8_upgrade) {
2779 repl_sv_copy = newSVsv(repl_sv);
2780 sv_utf8_upgrade(repl_sv_copy);
2781 repl = SvPV(repl_sv_copy, repl_len);
2782 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2784 sv_insert(sv, pos, rem, repl, repl_len);
2788 SvREFCNT_dec(repl_sv_copy);
2790 else if (lvalue) { /* it's an lvalue! */
2791 if (!SvGMAGICAL(sv)) {
2795 if (ckWARN(WARN_SUBSTR))
2796 Perl_warner(aTHX_ WARN_SUBSTR,
2797 "Attempt to use reference as lvalue in substr");
2799 if (SvOK(sv)) /* is it defined ? */
2800 (void)SvPOK_only_UTF8(sv);
2802 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2805 if (SvTYPE(TARG) < SVt_PVLV) {
2806 sv_upgrade(TARG, SVt_PVLV);
2807 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2811 if (LvTARG(TARG) != sv) {
2813 SvREFCNT_dec(LvTARG(TARG));
2814 LvTARG(TARG) = SvREFCNT_inc(sv);
2816 LvTARGOFF(TARG) = upos;
2817 LvTARGLEN(TARG) = urem;
2821 PUSHs(TARG); /* avoid SvSETMAGIC here */
2828 register IV size = POPi;
2829 register IV offset = POPi;
2830 register SV *src = POPs;
2831 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2833 SvTAINTED_off(TARG); /* decontaminate */
2834 if (lvalue) { /* it's an lvalue! */
2835 if (SvTYPE(TARG) < SVt_PVLV) {
2836 sv_upgrade(TARG, SVt_PVLV);
2837 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2840 if (LvTARG(TARG) != src) {
2842 SvREFCNT_dec(LvTARG(TARG));
2843 LvTARG(TARG) = SvREFCNT_inc(src);
2845 LvTARGOFF(TARG) = offset;
2846 LvTARGLEN(TARG) = size;
2849 sv_setuv(TARG, do_vecget(src, offset, size));
2864 I32 arybase = PL_curcop->cop_arybase;
2869 offset = POPi - arybase;
2872 tmps = SvPV(big, biglen);
2873 if (offset > 0 && DO_UTF8(big))
2874 sv_pos_u2b(big, &offset, 0);
2877 else if (offset > biglen)
2879 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2880 (unsigned char*)tmps + biglen, little, 0)))
2883 retval = tmps2 - tmps;
2884 if (retval > 0 && DO_UTF8(big))
2885 sv_pos_b2u(big, &retval);
2886 PUSHi(retval + arybase);
2901 I32 arybase = PL_curcop->cop_arybase;
2907 tmps2 = SvPV(little, llen);
2908 tmps = SvPV(big, blen);
2912 if (offset > 0 && DO_UTF8(big))
2913 sv_pos_u2b(big, &offset, 0);
2914 offset = offset - arybase + llen;
2918 else if (offset > blen)
2920 if (!(tmps2 = rninstr(tmps, tmps + offset,
2921 tmps2, tmps2 + llen)))
2924 retval = tmps2 - tmps;
2925 if (retval > 0 && DO_UTF8(big))
2926 sv_pos_b2u(big, &retval);
2927 PUSHi(retval + arybase);
2933 dSP; dMARK; dORIGMARK; dTARGET;
2934 do_sprintf(TARG, SP-MARK, MARK+1);
2935 TAINT_IF(SvTAINTED(TARG));
2946 U8 *s = (U8*)SvPVx(argsv, len);
2948 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2958 (void)SvUPGRADE(TARG,SVt_PV);
2960 if (value > 255 && !IN_BYTES) {
2961 SvGROW(TARG, UNISKIP(value)+1);
2962 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
2963 SvCUR_set(TARG, tmps - SvPVX(TARG));
2965 (void)SvPOK_only(TARG);
2976 (void)SvPOK_only(TARG);
2983 dSP; dTARGET; dPOPTOPssrl;
2986 char *tmps = SvPV(left, n_a);
2988 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2990 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2994 "The crypt() function is unimplemented due to excessive paranoia.");
3007 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3009 U8 tmpbuf[UTF8_MAXLEN+1];
3013 if (IN_LOCALE_RUNTIME) {
3016 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3019 uv = toTITLE_utf8(s);
3021 tend = uvchr_to_utf8(tmpbuf, uv);
3023 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3025 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3026 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3031 s = (U8*)SvPV_force(sv, slen);
3032 Copy(tmpbuf, s, ulen, U8);
3036 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3038 SvUTF8_off(TARG); /* decontaminate */
3043 s = (U8*)SvPV_force(sv, slen);
3045 if (IN_LOCALE_RUNTIME) {
3048 *s = toUPPER_LC(*s);
3066 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3068 U8 tmpbuf[UTF8_MAXLEN+1];
3072 if (IN_LOCALE_RUNTIME) {
3075 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3078 uv = toLOWER_utf8(s);
3080 tend = uvchr_to_utf8(tmpbuf, uv);
3082 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3084 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3085 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3090 s = (U8*)SvPV_force(sv, slen);
3091 Copy(tmpbuf, s, ulen, U8);
3095 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3097 SvUTF8_off(TARG); /* decontaminate */
3102 s = (U8*)SvPV_force(sv, slen);
3104 if (IN_LOCALE_RUNTIME) {
3107 *s = toLOWER_LC(*s);
3131 s = (U8*)SvPV(sv,len);
3133 SvUTF8_off(TARG); /* decontaminate */
3134 sv_setpvn(TARG, "", 0);
3138 (void)SvUPGRADE(TARG, SVt_PV);
3139 SvGROW(TARG, (len * 2) + 1);
3140 (void)SvPOK_only(TARG);
3141 d = (U8*)SvPVX(TARG);
3143 if (IN_LOCALE_RUNTIME) {
3147 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3153 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3159 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3164 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3166 SvUTF8_off(TARG); /* decontaminate */
3171 s = (U8*)SvPV_force(sv, len);
3173 register U8 *send = s + len;
3175 if (IN_LOCALE_RUNTIME) {
3178 for (; s < send; s++)
3179 *s = toUPPER_LC(*s);
3182 for (; s < send; s++)
3205 s = (U8*)SvPV(sv,len);
3207 SvUTF8_off(TARG); /* decontaminate */
3208 sv_setpvn(TARG, "", 0);
3212 (void)SvUPGRADE(TARG, SVt_PV);
3213 SvGROW(TARG, (len * 2) + 1);
3214 (void)SvPOK_only(TARG);
3215 d = (U8*)SvPVX(TARG);
3217 if (IN_LOCALE_RUNTIME) {
3221 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3227 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3233 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3238 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3240 SvUTF8_off(TARG); /* decontaminate */
3246 s = (U8*)SvPV_force(sv, len);
3248 register U8 *send = s + len;
3250 if (IN_LOCALE_RUNTIME) {
3253 for (; s < send; s++)
3254 *s = toLOWER_LC(*s);
3257 for (; s < send; s++)
3272 register char *s = SvPV(sv,len);
3275 SvUTF8_off(TARG); /* decontaminate */
3277 (void)SvUPGRADE(TARG, SVt_PV);
3278 SvGROW(TARG, (len * 2) + 1);
3282 if (UTF8_IS_CONTINUED(*s)) {
3283 STRLEN ulen = UTF8SKIP(s);
3307 SvCUR_set(TARG, d - SvPVX(TARG));
3308 (void)SvPOK_only_UTF8(TARG);
3311 sv_setpvn(TARG, s, len);
3313 if (SvSMAGICAL(TARG))
3322 dSP; dMARK; dORIGMARK;
3324 register AV* av = (AV*)POPs;
3325 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3326 I32 arybase = PL_curcop->cop_arybase;
3329 if (SvTYPE(av) == SVt_PVAV) {
3330 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3332 for (svp = MARK + 1; svp <= SP; svp++) {
3337 if (max > AvMAX(av))
3340 while (++MARK <= SP) {
3341 elem = SvIVx(*MARK);
3345 svp = av_fetch(av, elem, lval);
3347 if (!svp || *svp == &PL_sv_undef)
3348 DIE(aTHX_ PL_no_aelem, elem);
3349 if (PL_op->op_private & OPpLVAL_INTRO)
3350 save_aelem(av, elem, svp);
3352 *MARK = svp ? *svp : &PL_sv_undef;
3355 if (GIMME != G_ARRAY) {
3363 /* Associative arrays. */
3368 HV *hash = (HV*)POPs;
3370 I32 gimme = GIMME_V;
3371 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3374 /* might clobber stack_sp */
3375 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3380 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3381 if (gimme == G_ARRAY) {
3384 /* might clobber stack_sp */
3386 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3391 else if (gimme == G_SCALAR)
3410 I32 gimme = GIMME_V;
3411 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3415 if (PL_op->op_private & OPpSLICE) {
3419 hvtype = SvTYPE(hv);
3420 if (hvtype == SVt_PVHV) { /* hash element */
3421 while (++MARK <= SP) {
3422 sv = hv_delete_ent(hv, *MARK, discard, 0);
3423 *MARK = sv ? sv : &PL_sv_undef;
3426 else if (hvtype == SVt_PVAV) {
3427 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3428 while (++MARK <= SP) {
3429 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3430 *MARK = sv ? sv : &PL_sv_undef;
3433 else { /* pseudo-hash element */
3434 while (++MARK <= SP) {
3435 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3436 *MARK = sv ? sv : &PL_sv_undef;
3441 DIE(aTHX_ "Not a HASH reference");
3444 else if (gimme == G_SCALAR) {
3453 if (SvTYPE(hv) == SVt_PVHV)
3454 sv = hv_delete_ent(hv, keysv, discard, 0);
3455 else if (SvTYPE(hv) == SVt_PVAV) {
3456 if (PL_op->op_flags & OPf_SPECIAL)
3457 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3459 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3462 DIE(aTHX_ "Not a HASH reference");
3477 if (PL_op->op_private & OPpEXISTS_SUB) {
3481 cv = sv_2cv(sv, &hv, &gv, FALSE);
3484 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3490 if (SvTYPE(hv) == SVt_PVHV) {
3491 if (hv_exists_ent(hv, tmpsv, 0))
3494 else if (SvTYPE(hv) == SVt_PVAV) {
3495 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3496 if (av_exists((AV*)hv, SvIV(tmpsv)))
3499 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3503 DIE(aTHX_ "Not a HASH reference");
3510 dSP; dMARK; dORIGMARK;
3511 register HV *hv = (HV*)POPs;
3512 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3513 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3515 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3516 DIE(aTHX_ "Can't localize pseudo-hash element");
3518 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3519 while (++MARK <= SP) {
3522 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3523 realhv ? hv_exists_ent(hv, keysv, 0)
3524 : avhv_exists_ent((AV*)hv, keysv, 0);
3526 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3527 svp = he ? &HeVAL(he) : 0;
3530 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3533 if (!svp || *svp == &PL_sv_undef) {
3535 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3537 if (PL_op->op_private & OPpLVAL_INTRO) {
3539 save_helem(hv, keysv, svp);
3542 char *key = SvPV(keysv, keylen);
3543 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3547 *MARK = svp ? *svp : &PL_sv_undef;
3550 if (GIMME != G_ARRAY) {
3558 /* List operators. */
3563 if (GIMME != G_ARRAY) {
3565 *MARK = *SP; /* unwanted list, return last item */
3567 *MARK = &PL_sv_undef;
3576 SV **lastrelem = PL_stack_sp;
3577 SV **lastlelem = PL_stack_base + POPMARK;
3578 SV **firstlelem = PL_stack_base + POPMARK + 1;
3579 register SV **firstrelem = lastlelem + 1;
3580 I32 arybase = PL_curcop->cop_arybase;
3581 I32 lval = PL_op->op_flags & OPf_MOD;
3582 I32 is_something_there = lval;
3584 register I32 max = lastrelem - lastlelem;
3585 register SV **lelem;
3588 if (GIMME != G_ARRAY) {
3589 ix = SvIVx(*lastlelem);
3594 if (ix < 0 || ix >= max)
3595 *firstlelem = &PL_sv_undef;
3597 *firstlelem = firstrelem[ix];
3603 SP = firstlelem - 1;
3607 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3613 if (ix < 0 || ix >= max)
3614 *lelem = &PL_sv_undef;
3616 is_something_there = TRUE;
3617 if (!(*lelem = firstrelem[ix]))
3618 *lelem = &PL_sv_undef;
3621 if (is_something_there)
3624 SP = firstlelem - 1;
3630 dSP; dMARK; dORIGMARK;
3631 I32 items = SP - MARK;
3632 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3633 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3640 dSP; dMARK; dORIGMARK;
3641 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3645 SV *val = NEWSV(46, 0);
3647 sv_setsv(val, *++MARK);
3648 else if (ckWARN(WARN_MISC))
3649 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3650 (void)hv_store_ent(hv,key,val,0);
3659 dSP; dMARK; dORIGMARK;
3660 register AV *ary = (AV*)*++MARK;
3664 register I32 offset;
3665 register I32 length;
3672 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3673 *MARK-- = SvTIED_obj((SV*)ary, mg);
3677 call_method("SPLICE",GIMME_V);
3686 offset = i = SvIVx(*MARK);
3688 offset += AvFILLp(ary) + 1;
3690 offset -= PL_curcop->cop_arybase;
3692 DIE(aTHX_ PL_no_aelem, i);
3694 length = SvIVx(*MARK++);
3696 length += AvFILLp(ary) - offset + 1;
3702 length = AvMAX(ary) + 1; /* close enough to infinity */
3706 length = AvMAX(ary) + 1;
3708 if (offset > AvFILLp(ary) + 1)
3709 offset = AvFILLp(ary) + 1;
3710 after = AvFILLp(ary) + 1 - (offset + length);
3711 if (after < 0) { /* not that much array */
3712 length += after; /* offset+length now in array */
3718 /* At this point, MARK .. SP-1 is our new LIST */
3721 diff = newlen - length;
3722 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3725 if (diff < 0) { /* shrinking the area */
3727 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3728 Copy(MARK, tmparyval, newlen, SV*);
3731 MARK = ORIGMARK + 1;
3732 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3733 MEXTEND(MARK, length);
3734 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3736 EXTEND_MORTAL(length);
3737 for (i = length, dst = MARK; i; i--) {
3738 sv_2mortal(*dst); /* free them eventualy */
3745 *MARK = AvARRAY(ary)[offset+length-1];
3748 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3749 SvREFCNT_dec(*dst++); /* free them now */
3752 AvFILLp(ary) += diff;
3754 /* pull up or down? */
3756 if (offset < after) { /* easier to pull up */
3757 if (offset) { /* esp. if nothing to pull */
3758 src = &AvARRAY(ary)[offset-1];
3759 dst = src - diff; /* diff is negative */
3760 for (i = offset; i > 0; i--) /* can't trust Copy */
3764 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3768 if (after) { /* anything to pull down? */
3769 src = AvARRAY(ary) + offset + length;
3770 dst = src + diff; /* diff is negative */
3771 Move(src, dst, after, SV*);
3773 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3774 /* avoid later double free */
3778 dst[--i] = &PL_sv_undef;
3781 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3783 *dst = NEWSV(46, 0);
3784 sv_setsv(*dst++, *src++);
3786 Safefree(tmparyval);
3789 else { /* no, expanding (or same) */
3791 New(452, tmparyval, length, SV*); /* so remember deletion */
3792 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3795 if (diff > 0) { /* expanding */
3797 /* push up or down? */
3799 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3803 Move(src, dst, offset, SV*);
3805 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3807 AvFILLp(ary) += diff;
3810 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3811 av_extend(ary, AvFILLp(ary) + diff);
3812 AvFILLp(ary) += diff;
3815 dst = AvARRAY(ary) + AvFILLp(ary);
3817 for (i = after; i; i--) {
3824 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3825 *dst = NEWSV(46, 0);
3826 sv_setsv(*dst++, *src++);
3828 MARK = ORIGMARK + 1;
3829 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3831 Copy(tmparyval, MARK, length, SV*);
3833 EXTEND_MORTAL(length);
3834 for (i = length, dst = MARK; i; i--) {
3835 sv_2mortal(*dst); /* free them eventualy */
3839 Safefree(tmparyval);
3843 else if (length--) {
3844 *MARK = tmparyval[length];
3847 while (length-- > 0)
3848 SvREFCNT_dec(tmparyval[length]);
3850 Safefree(tmparyval);
3853 *MARK = &PL_sv_undef;
3861 dSP; dMARK; dORIGMARK; dTARGET;
3862 register AV *ary = (AV*)*++MARK;
3863 register SV *sv = &PL_sv_undef;
3866 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3867 *MARK-- = SvTIED_obj((SV*)ary, mg);
3871 call_method("PUSH",G_SCALAR|G_DISCARD);
3876 /* Why no pre-extend of ary here ? */
3877 for (++MARK; MARK <= SP; MARK++) {
3880 sv_setsv(sv, *MARK);
3885 PUSHi( AvFILL(ary) + 1 );
3893 SV *sv = av_pop(av);
3895 (void)sv_2mortal(sv);
3904 SV *sv = av_shift(av);
3909 (void)sv_2mortal(sv);
3916 dSP; dMARK; dORIGMARK; dTARGET;
3917 register AV *ary = (AV*)*++MARK;
3922 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3923 *MARK-- = SvTIED_obj((SV*)ary, mg);
3927 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3932 av_unshift(ary, SP - MARK);
3935 sv_setsv(sv, *++MARK);
3936 (void)av_store(ary, i++, sv);
3940 PUSHi( AvFILL(ary) + 1 );
3950 if (GIMME == G_ARRAY) {
3957 /* safe as long as stack cannot get extended in the above */
3962 register char *down;
3967 SvUTF8_off(TARG); /* decontaminate */
3969 do_join(TARG, &PL_sv_no, MARK, SP);
3971 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3972 up = SvPV_force(TARG, len);
3974 if (DO_UTF8(TARG)) { /* first reverse each character */
3975 U8* s = (U8*)SvPVX(TARG);
3976 U8* send = (U8*)(s + len);
3978 if (UTF8_IS_INVARIANT(*s)) {
3983 if (!utf8_to_uvchr(s, 0))
3987 down = (char*)(s - 1);
3988 /* reverse this character */
3998 down = SvPVX(TARG) + len - 1;
4004 (void)SvPOK_only_UTF8(TARG);
4016 register IV limit = POPi; /* note, negative is forever */
4019 register char *s = SvPV(sv, len);
4020 bool do_utf8 = DO_UTF8(sv);
4021 char *strend = s + len;
4023 register REGEXP *rx;
4027 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4028 I32 maxiters = slen + 10;
4031 I32 origlimit = limit;
4034 AV *oldstack = PL_curstack;
4035 I32 gimme = GIMME_V;
4036 I32 oldsave = PL_savestack_ix;
4037 I32 make_mortal = 1;
4038 MAGIC *mg = (MAGIC *) NULL;
4041 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4046 DIE(aTHX_ "panic: pp_split");
4049 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4050 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4052 if (pm->op_pmreplroot) {
4054 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4056 ary = GvAVn((GV*)pm->op_pmreplroot);
4059 else if (gimme != G_ARRAY)
4061 ary = (AV*)PL_curpad[0];
4063 ary = GvAVn(PL_defgv);
4064 #endif /* USE_THREADS */
4067 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4073 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4075 XPUSHs(SvTIED_obj((SV*)ary, mg));
4081 for (i = AvFILLp(ary); i >= 0; i--)
4082 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4084 /* temporarily switch stacks */
4085 SWITCHSTACK(PL_curstack, ary);
4089 base = SP - PL_stack_base;
4091 if (pm->op_pmflags & PMf_SKIPWHITE) {
4092 if (pm->op_pmflags & PMf_LOCALE) {
4093 while (isSPACE_LC(*s))
4101 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4102 SAVEINT(PL_multiline);
4103 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4107 limit = maxiters + 2;
4108 if (pm->op_pmflags & PMf_WHITE) {
4111 while (m < strend &&
4112 !((pm->op_pmflags & PMf_LOCALE)
4113 ? isSPACE_LC(*m) : isSPACE(*m)))
4118 dstr = NEWSV(30, m-s);
4119 sv_setpvn(dstr, s, m-s);
4123 (void)SvUTF8_on(dstr);
4127 while (s < strend &&
4128 ((pm->op_pmflags & PMf_LOCALE)
4129 ? isSPACE_LC(*s) : isSPACE(*s)))
4133 else if (strEQ("^", rx->precomp)) {
4136 for (m = s; m < strend && *m != '\n'; m++) ;
4140 dstr = NEWSV(30, m-s);
4141 sv_setpvn(dstr, s, m-s);
4145 (void)SvUTF8_on(dstr);
4150 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4151 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4152 && (rx->reganch & ROPT_CHECK_ALL)
4153 && !(rx->reganch & ROPT_ANCH)) {
4154 int tail = (rx->reganch & RE_INTUIT_TAIL);
4155 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4158 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4160 char c = *SvPV(csv, n_a);
4163 for (m = s; m < strend && *m != c; m++) ;
4166 dstr = NEWSV(30, m-s);
4167 sv_setpvn(dstr, s, m-s);
4171 (void)SvUTF8_on(dstr);
4173 /* The rx->minlen is in characters but we want to step
4174 * s ahead by bytes. */
4176 s = (char*)utf8_hop((U8*)m, len);
4178 s = m + len; /* Fake \n at the end */
4183 while (s < strend && --limit &&
4184 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4185 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4188 dstr = NEWSV(31, m-s);
4189 sv_setpvn(dstr, s, m-s);
4193 (void)SvUTF8_on(dstr);
4195 /* The rx->minlen is in characters but we want to step
4196 * s ahead by bytes. */
4198 s = (char*)utf8_hop((U8*)m, len);
4200 s = m + len; /* Fake \n at the end */
4205 maxiters += slen * rx->nparens;
4206 while (s < strend && --limit
4207 /* && (!rx->check_substr
4208 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4210 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4211 1 /* minend */, sv, NULL, 0))
4213 TAINT_IF(RX_MATCH_TAINTED(rx));
4214 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4219 strend = s + (strend - m);
4221 m = rx->startp[0] + orig;
4222 dstr = NEWSV(32, m-s);
4223 sv_setpvn(dstr, s, m-s);
4227 (void)SvUTF8_on(dstr);
4230 for (i = 1; i <= rx->nparens; i++) {
4231 s = rx->startp[i] + orig;
4232 m = rx->endp[i] + orig;
4234 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4235 parens that didn't match -- they should be set to
4236 undef, not the empty string */
4237 if (m >= orig && s >= orig) {
4238 dstr = NEWSV(33, m-s);
4239 sv_setpvn(dstr, s, m-s);
4242 dstr = &PL_sv_undef; /* undef, not "" */
4246 (void)SvUTF8_on(dstr);
4250 s = rx->endp[0] + orig;
4254 LEAVE_SCOPE(oldsave);
4255 iters = (SP - PL_stack_base) - base;
4256 if (iters > maxiters)
4257 DIE(aTHX_ "Split loop");
4259 /* keep field after final delim? */
4260 if (s < strend || (iters && origlimit)) {
4261 STRLEN l = strend - s;
4262 dstr = NEWSV(34, l);
4263 sv_setpvn(dstr, s, l);
4267 (void)SvUTF8_on(dstr);
4271 else if (!origlimit) {
4272 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4278 SWITCHSTACK(ary, oldstack);
4279 if (SvSMAGICAL(ary)) {
4284 if (gimme == G_ARRAY) {
4286 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4294 call_method("PUSH",G_SCALAR|G_DISCARD);
4297 if (gimme == G_ARRAY) {
4298 /* EXTEND should not be needed - we just popped them */
4300 for (i=0; i < iters; i++) {
4301 SV **svp = av_fetch(ary, i, FALSE);
4302 PUSHs((svp) ? *svp : &PL_sv_undef);
4309 if (gimme == G_ARRAY)
4312 if (iters || !pm->op_pmreplroot) {
4322 Perl_unlock_condpair(pTHX_ void *svv)
4324 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4327 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4328 MUTEX_LOCK(MgMUTEXP(mg));
4329 if (MgOWNER(mg) != thr)
4330 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4332 COND_SIGNAL(MgOWNERCONDP(mg));
4333 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4334 PTR2UV(thr), PTR2UV(svv)));
4335 MUTEX_UNLOCK(MgMUTEXP(mg));
4337 #endif /* USE_THREADS */
4346 #endif /* USE_THREADS */
4347 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4348 || SvTYPE(retsv) == SVt_PVCV) {
4349 retsv = refto(retsv);
4360 if (PL_op->op_private & OPpLVAL_INTRO)
4361 PUSHs(*save_threadsv(PL_op->op_targ));
4363 PUSHs(THREADSV(PL_op->op_targ));
4366 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4367 #endif /* USE_THREADS */