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);
3023 tend = uvchr_to_utf8(tmpbuf, uv);
3025 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3027 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3028 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3033 s = (U8*)SvPV_force(sv, slen);
3034 Copy(tmpbuf, s, ulen, U8);
3038 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3040 SvUTF8_off(TARG); /* decontaminate */
3045 s = (U8*)SvPV_force(sv, slen);
3047 if (IN_LOCALE_RUNTIME) {
3050 *s = toUPPER_LC(*s);
3068 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3070 U8 tmpbuf[UTF8_MAXLEN+1];
3074 if (IN_LOCALE_RUNTIME) {
3077 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3080 uv = toLOWER_utf8(s);
3084 tend = uvchr_to_utf8(tmpbuf, uv);
3086 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3088 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3089 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3094 s = (U8*)SvPV_force(sv, slen);
3095 Copy(tmpbuf, s, ulen, U8);
3099 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3101 SvUTF8_off(TARG); /* decontaminate */
3106 s = (U8*)SvPV_force(sv, slen);
3108 if (IN_LOCALE_RUNTIME) {
3111 *s = toLOWER_LC(*s);
3135 s = (U8*)SvPV(sv,len);
3137 SvUTF8_off(TARG); /* decontaminate */
3138 sv_setpvn(TARG, "", 0);
3142 (void)SvUPGRADE(TARG, SVt_PV);
3143 SvGROW(TARG, (len * 2) + 1);
3144 (void)SvPOK_only(TARG);
3145 d = (U8*)SvPVX(TARG);
3147 if (IN_LOCALE_RUNTIME) {
3151 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3157 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3163 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3168 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3170 SvUTF8_off(TARG); /* decontaminate */
3175 s = (U8*)SvPV_force(sv, len);
3177 register U8 *send = s + len;
3179 if (IN_LOCALE_RUNTIME) {
3182 for (; s < send; s++)
3183 *s = toUPPER_LC(*s);
3186 for (; s < send; s++)
3209 s = (U8*)SvPV(sv,len);
3211 SvUTF8_off(TARG); /* decontaminate */
3212 sv_setpvn(TARG, "", 0);
3216 (void)SvUPGRADE(TARG, SVt_PV);
3217 SvGROW(TARG, (len * 2) + 1);
3218 (void)SvPOK_only(TARG);
3219 d = (U8*)SvPVX(TARG);
3221 if (IN_LOCALE_RUNTIME) {
3225 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3231 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3237 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3242 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3244 SvUTF8_off(TARG); /* decontaminate */
3250 s = (U8*)SvPV_force(sv, len);
3252 register U8 *send = s + len;
3254 if (IN_LOCALE_RUNTIME) {
3257 for (; s < send; s++)
3258 *s = toLOWER_LC(*s);
3261 for (; s < send; s++)
3276 register char *s = SvPV(sv,len);
3279 SvUTF8_off(TARG); /* decontaminate */
3281 (void)SvUPGRADE(TARG, SVt_PV);
3282 SvGROW(TARG, (len * 2) + 1);
3286 if (UTF8_IS_CONTINUED(*s)) {
3287 STRLEN ulen = UTF8SKIP(s);
3311 SvCUR_set(TARG, d - SvPVX(TARG));
3312 (void)SvPOK_only_UTF8(TARG);
3315 sv_setpvn(TARG, s, len);
3317 if (SvSMAGICAL(TARG))
3326 dSP; dMARK; dORIGMARK;
3328 register AV* av = (AV*)POPs;
3329 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3330 I32 arybase = PL_curcop->cop_arybase;
3333 if (SvTYPE(av) == SVt_PVAV) {
3334 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3336 for (svp = MARK + 1; svp <= SP; svp++) {
3341 if (max > AvMAX(av))
3344 while (++MARK <= SP) {
3345 elem = SvIVx(*MARK);
3349 svp = av_fetch(av, elem, lval);
3351 if (!svp || *svp == &PL_sv_undef)
3352 DIE(aTHX_ PL_no_aelem, elem);
3353 if (PL_op->op_private & OPpLVAL_INTRO)
3354 save_aelem(av, elem, svp);
3356 *MARK = svp ? *svp : &PL_sv_undef;
3359 if (GIMME != G_ARRAY) {
3367 /* Associative arrays. */
3372 HV *hash = (HV*)POPs;
3374 I32 gimme = GIMME_V;
3375 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3378 /* might clobber stack_sp */
3379 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3384 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3385 if (gimme == G_ARRAY) {
3388 /* might clobber stack_sp */
3390 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3395 else if (gimme == G_SCALAR)
3414 I32 gimme = GIMME_V;
3415 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3419 if (PL_op->op_private & OPpSLICE) {
3423 hvtype = SvTYPE(hv);
3424 if (hvtype == SVt_PVHV) { /* hash element */
3425 while (++MARK <= SP) {
3426 sv = hv_delete_ent(hv, *MARK, discard, 0);
3427 *MARK = sv ? sv : &PL_sv_undef;
3430 else if (hvtype == SVt_PVAV) {
3431 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3432 while (++MARK <= SP) {
3433 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3434 *MARK = sv ? sv : &PL_sv_undef;
3437 else { /* pseudo-hash element */
3438 while (++MARK <= SP) {
3439 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3440 *MARK = sv ? sv : &PL_sv_undef;
3445 DIE(aTHX_ "Not a HASH reference");
3448 else if (gimme == G_SCALAR) {
3457 if (SvTYPE(hv) == SVt_PVHV)
3458 sv = hv_delete_ent(hv, keysv, discard, 0);
3459 else if (SvTYPE(hv) == SVt_PVAV) {
3460 if (PL_op->op_flags & OPf_SPECIAL)
3461 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3463 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3466 DIE(aTHX_ "Not a HASH reference");
3481 if (PL_op->op_private & OPpEXISTS_SUB) {
3485 cv = sv_2cv(sv, &hv, &gv, FALSE);
3488 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3494 if (SvTYPE(hv) == SVt_PVHV) {
3495 if (hv_exists_ent(hv, tmpsv, 0))
3498 else if (SvTYPE(hv) == SVt_PVAV) {
3499 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3500 if (av_exists((AV*)hv, SvIV(tmpsv)))
3503 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3507 DIE(aTHX_ "Not a HASH reference");
3514 dSP; dMARK; dORIGMARK;
3515 register HV *hv = (HV*)POPs;
3516 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3517 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3519 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3520 DIE(aTHX_ "Can't localize pseudo-hash element");
3522 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3523 while (++MARK <= SP) {
3526 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3527 realhv ? hv_exists_ent(hv, keysv, 0)
3528 : avhv_exists_ent((AV*)hv, keysv, 0);
3530 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3531 svp = he ? &HeVAL(he) : 0;
3534 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3537 if (!svp || *svp == &PL_sv_undef) {
3539 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3541 if (PL_op->op_private & OPpLVAL_INTRO) {
3543 save_helem(hv, keysv, svp);
3546 char *key = SvPV(keysv, keylen);
3547 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3551 *MARK = svp ? *svp : &PL_sv_undef;
3554 if (GIMME != G_ARRAY) {
3562 /* List operators. */
3567 if (GIMME != G_ARRAY) {
3569 *MARK = *SP; /* unwanted list, return last item */
3571 *MARK = &PL_sv_undef;
3580 SV **lastrelem = PL_stack_sp;
3581 SV **lastlelem = PL_stack_base + POPMARK;
3582 SV **firstlelem = PL_stack_base + POPMARK + 1;
3583 register SV **firstrelem = lastlelem + 1;
3584 I32 arybase = PL_curcop->cop_arybase;
3585 I32 lval = PL_op->op_flags & OPf_MOD;
3586 I32 is_something_there = lval;
3588 register I32 max = lastrelem - lastlelem;
3589 register SV **lelem;
3592 if (GIMME != G_ARRAY) {
3593 ix = SvIVx(*lastlelem);
3598 if (ix < 0 || ix >= max)
3599 *firstlelem = &PL_sv_undef;
3601 *firstlelem = firstrelem[ix];
3607 SP = firstlelem - 1;
3611 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3617 if (ix < 0 || ix >= max)
3618 *lelem = &PL_sv_undef;
3620 is_something_there = TRUE;
3621 if (!(*lelem = firstrelem[ix]))
3622 *lelem = &PL_sv_undef;
3625 if (is_something_there)
3628 SP = firstlelem - 1;
3634 dSP; dMARK; dORIGMARK;
3635 I32 items = SP - MARK;
3636 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3637 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3644 dSP; dMARK; dORIGMARK;
3645 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3649 SV *val = NEWSV(46, 0);
3651 sv_setsv(val, *++MARK);
3652 else if (ckWARN(WARN_MISC))
3653 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3654 (void)hv_store_ent(hv,key,val,0);
3663 dSP; dMARK; dORIGMARK;
3664 register AV *ary = (AV*)*++MARK;
3668 register I32 offset;
3669 register I32 length;
3676 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3677 *MARK-- = SvTIED_obj((SV*)ary, mg);
3681 call_method("SPLICE",GIMME_V);
3690 offset = i = SvIVx(*MARK);
3692 offset += AvFILLp(ary) + 1;
3694 offset -= PL_curcop->cop_arybase;
3696 DIE(aTHX_ PL_no_aelem, i);
3698 length = SvIVx(*MARK++);
3700 length += AvFILLp(ary) - offset + 1;
3706 length = AvMAX(ary) + 1; /* close enough to infinity */
3710 length = AvMAX(ary) + 1;
3712 if (offset > AvFILLp(ary) + 1)
3713 offset = AvFILLp(ary) + 1;
3714 after = AvFILLp(ary) + 1 - (offset + length);
3715 if (after < 0) { /* not that much array */
3716 length += after; /* offset+length now in array */
3722 /* At this point, MARK .. SP-1 is our new LIST */
3725 diff = newlen - length;
3726 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3729 if (diff < 0) { /* shrinking the area */
3731 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3732 Copy(MARK, tmparyval, newlen, SV*);
3735 MARK = ORIGMARK + 1;
3736 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3737 MEXTEND(MARK, length);
3738 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3740 EXTEND_MORTAL(length);
3741 for (i = length, dst = MARK; i; i--) {
3742 sv_2mortal(*dst); /* free them eventualy */
3749 *MARK = AvARRAY(ary)[offset+length-1];
3752 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3753 SvREFCNT_dec(*dst++); /* free them now */
3756 AvFILLp(ary) += diff;
3758 /* pull up or down? */
3760 if (offset < after) { /* easier to pull up */
3761 if (offset) { /* esp. if nothing to pull */
3762 src = &AvARRAY(ary)[offset-1];
3763 dst = src - diff; /* diff is negative */
3764 for (i = offset; i > 0; i--) /* can't trust Copy */
3768 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3772 if (after) { /* anything to pull down? */
3773 src = AvARRAY(ary) + offset + length;
3774 dst = src + diff; /* diff is negative */
3775 Move(src, dst, after, SV*);
3777 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3778 /* avoid later double free */
3782 dst[--i] = &PL_sv_undef;
3785 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3787 *dst = NEWSV(46, 0);
3788 sv_setsv(*dst++, *src++);
3790 Safefree(tmparyval);
3793 else { /* no, expanding (or same) */
3795 New(452, tmparyval, length, SV*); /* so remember deletion */
3796 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3799 if (diff > 0) { /* expanding */
3801 /* push up or down? */
3803 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3807 Move(src, dst, offset, SV*);
3809 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3811 AvFILLp(ary) += diff;
3814 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3815 av_extend(ary, AvFILLp(ary) + diff);
3816 AvFILLp(ary) += diff;
3819 dst = AvARRAY(ary) + AvFILLp(ary);
3821 for (i = after; i; i--) {
3828 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3829 *dst = NEWSV(46, 0);
3830 sv_setsv(*dst++, *src++);
3832 MARK = ORIGMARK + 1;
3833 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3835 Copy(tmparyval, MARK, length, SV*);
3837 EXTEND_MORTAL(length);
3838 for (i = length, dst = MARK; i; i--) {
3839 sv_2mortal(*dst); /* free them eventualy */
3843 Safefree(tmparyval);
3847 else if (length--) {
3848 *MARK = tmparyval[length];
3851 while (length-- > 0)
3852 SvREFCNT_dec(tmparyval[length]);
3854 Safefree(tmparyval);
3857 *MARK = &PL_sv_undef;
3865 dSP; dMARK; dORIGMARK; dTARGET;
3866 register AV *ary = (AV*)*++MARK;
3867 register SV *sv = &PL_sv_undef;
3870 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3871 *MARK-- = SvTIED_obj((SV*)ary, mg);
3875 call_method("PUSH",G_SCALAR|G_DISCARD);
3880 /* Why no pre-extend of ary here ? */
3881 for (++MARK; MARK <= SP; MARK++) {
3884 sv_setsv(sv, *MARK);
3889 PUSHi( AvFILL(ary) + 1 );
3897 SV *sv = av_pop(av);
3899 (void)sv_2mortal(sv);
3908 SV *sv = av_shift(av);
3913 (void)sv_2mortal(sv);
3920 dSP; dMARK; dORIGMARK; dTARGET;
3921 register AV *ary = (AV*)*++MARK;
3926 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3927 *MARK-- = SvTIED_obj((SV*)ary, mg);
3931 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3936 av_unshift(ary, SP - MARK);
3939 sv_setsv(sv, *++MARK);
3940 (void)av_store(ary, i++, sv);
3944 PUSHi( AvFILL(ary) + 1 );
3954 if (GIMME == G_ARRAY) {
3961 /* safe as long as stack cannot get extended in the above */
3966 register char *down;
3971 SvUTF8_off(TARG); /* decontaminate */
3973 do_join(TARG, &PL_sv_no, MARK, SP);
3975 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3976 up = SvPV_force(TARG, len);
3978 if (DO_UTF8(TARG)) { /* first reverse each character */
3979 U8* s = (U8*)SvPVX(TARG);
3980 U8* send = (U8*)(s + len);
3982 if (UTF8_IS_INVARIANT(*s)) {
3987 if (!utf8_to_uvchr(s, 0))
3991 down = (char*)(s - 1);
3992 /* reverse this character */
4002 down = SvPVX(TARG) + len - 1;
4008 (void)SvPOK_only_UTF8(TARG);
4020 register IV limit = POPi; /* note, negative is forever */
4023 register char *s = SvPV(sv, len);
4024 bool do_utf8 = DO_UTF8(sv);
4025 char *strend = s + len;
4027 register REGEXP *rx;
4031 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4032 I32 maxiters = slen + 10;
4035 I32 origlimit = limit;
4038 AV *oldstack = PL_curstack;
4039 I32 gimme = GIMME_V;
4040 I32 oldsave = PL_savestack_ix;
4041 I32 make_mortal = 1;
4042 MAGIC *mg = (MAGIC *) NULL;
4045 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4050 DIE(aTHX_ "panic: pp_split");
4053 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4054 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4056 if (pm->op_pmreplroot) {
4058 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4060 ary = GvAVn((GV*)pm->op_pmreplroot);
4063 else if (gimme != G_ARRAY)
4065 ary = (AV*)PL_curpad[0];
4067 ary = GvAVn(PL_defgv);
4068 #endif /* USE_THREADS */
4071 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4077 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4079 XPUSHs(SvTIED_obj((SV*)ary, mg));
4085 for (i = AvFILLp(ary); i >= 0; i--)
4086 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4088 /* temporarily switch stacks */
4089 SWITCHSTACK(PL_curstack, ary);
4093 base = SP - PL_stack_base;
4095 if (pm->op_pmflags & PMf_SKIPWHITE) {
4096 if (pm->op_pmflags & PMf_LOCALE) {
4097 while (isSPACE_LC(*s))
4105 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4106 SAVEINT(PL_multiline);
4107 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4111 limit = maxiters + 2;
4112 if (pm->op_pmflags & PMf_WHITE) {
4115 while (m < strend &&
4116 !((pm->op_pmflags & PMf_LOCALE)
4117 ? isSPACE_LC(*m) : isSPACE(*m)))
4122 dstr = NEWSV(30, m-s);
4123 sv_setpvn(dstr, s, m-s);
4127 (void)SvUTF8_on(dstr);
4131 while (s < strend &&
4132 ((pm->op_pmflags & PMf_LOCALE)
4133 ? isSPACE_LC(*s) : isSPACE(*s)))
4137 else if (strEQ("^", rx->precomp)) {
4140 for (m = s; m < strend && *m != '\n'; m++) ;
4144 dstr = NEWSV(30, m-s);
4145 sv_setpvn(dstr, s, m-s);
4149 (void)SvUTF8_on(dstr);
4154 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4155 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4156 && (rx->reganch & ROPT_CHECK_ALL)
4157 && !(rx->reganch & ROPT_ANCH)) {
4158 int tail = (rx->reganch & RE_INTUIT_TAIL);
4159 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4162 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4164 char c = *SvPV(csv, n_a);
4167 for (m = s; m < strend && *m != c; m++) ;
4170 dstr = NEWSV(30, m-s);
4171 sv_setpvn(dstr, s, m-s);
4175 (void)SvUTF8_on(dstr);
4177 /* The rx->minlen is in characters but we want to step
4178 * s ahead by bytes. */
4180 s = (char*)utf8_hop((U8*)m, len);
4182 s = m + len; /* Fake \n at the end */
4187 while (s < strend && --limit &&
4188 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4189 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4192 dstr = NEWSV(31, m-s);
4193 sv_setpvn(dstr, s, m-s);
4197 (void)SvUTF8_on(dstr);
4199 /* The rx->minlen is in characters but we want to step
4200 * s ahead by bytes. */
4202 s = (char*)utf8_hop((U8*)m, len);
4204 s = m + len; /* Fake \n at the end */
4209 maxiters += slen * rx->nparens;
4210 while (s < strend && --limit
4211 /* && (!rx->check_substr
4212 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4214 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4215 1 /* minend */, sv, NULL, 0))
4217 TAINT_IF(RX_MATCH_TAINTED(rx));
4218 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4223 strend = s + (strend - m);
4225 m = rx->startp[0] + orig;
4226 dstr = NEWSV(32, m-s);
4227 sv_setpvn(dstr, s, m-s);
4231 (void)SvUTF8_on(dstr);
4234 for (i = 1; i <= rx->nparens; i++) {
4235 s = rx->startp[i] + orig;
4236 m = rx->endp[i] + orig;
4238 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4239 parens that didn't match -- they should be set to
4240 undef, not the empty string */
4241 if (m >= orig && s >= orig) {
4242 dstr = NEWSV(33, m-s);
4243 sv_setpvn(dstr, s, m-s);
4246 dstr = &PL_sv_undef; /* undef, not "" */
4250 (void)SvUTF8_on(dstr);
4254 s = rx->endp[0] + orig;
4258 LEAVE_SCOPE(oldsave);
4259 iters = (SP - PL_stack_base) - base;
4260 if (iters > maxiters)
4261 DIE(aTHX_ "Split loop");
4263 /* keep field after final delim? */
4264 if (s < strend || (iters && origlimit)) {
4265 STRLEN l = strend - s;
4266 dstr = NEWSV(34, l);
4267 sv_setpvn(dstr, s, l);
4271 (void)SvUTF8_on(dstr);
4275 else if (!origlimit) {
4276 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4282 SWITCHSTACK(ary, oldstack);
4283 if (SvSMAGICAL(ary)) {
4288 if (gimme == G_ARRAY) {
4290 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4298 call_method("PUSH",G_SCALAR|G_DISCARD);
4301 if (gimme == G_ARRAY) {
4302 /* EXTEND should not be needed - we just popped them */
4304 for (i=0; i < iters; i++) {
4305 SV **svp = av_fetch(ary, i, FALSE);
4306 PUSHs((svp) ? *svp : &PL_sv_undef);
4313 if (gimme == G_ARRAY)
4316 if (iters || !pm->op_pmreplroot) {
4326 Perl_unlock_condpair(pTHX_ void *svv)
4328 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4331 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4332 MUTEX_LOCK(MgMUTEXP(mg));
4333 if (MgOWNER(mg) != thr)
4334 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4336 COND_SIGNAL(MgOWNERCONDP(mg));
4337 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4338 PTR2UV(thr), PTR2UV(svv)));
4339 MUTEX_UNLOCK(MgMUTEXP(mg));
4341 #endif /* USE_THREADS */
4350 #endif /* USE_THREADS */
4351 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4352 || SvTYPE(retsv) == SVt_PVCV) {
4353 retsv = refto(retsv);
4364 if (PL_op->op_private & OPpLVAL_INTRO)
4365 PUSHs(*save_threadsv(PL_op->op_targ));
4367 PUSHs(THREADSV(PL_op->op_targ));
4370 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4371 #endif /* USE_THREADS */