3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
38 /* variations on pp_null */
43 if (GIMME_V == G_SCALAR)
59 if (PL_op->op_private & OPpLVAL_INTRO)
60 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
62 if (PL_op->op_flags & OPf_REF) {
66 if (GIMME == G_SCALAR)
67 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
72 if (gimme == G_ARRAY) {
73 I32 maxarg = AvFILL((AV*)TARG) + 1;
75 if (SvMAGICAL(TARG)) {
77 for (i=0; i < (U32)maxarg; i++) {
78 SV **svp = av_fetch((AV*)TARG, i, FALSE);
79 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
83 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
87 else if (gimme == G_SCALAR) {
88 SV* sv = sv_newmortal();
89 I32 maxarg = AvFILL((AV*)TARG) + 1;
102 if (PL_op->op_private & OPpLVAL_INTRO)
103 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
104 if (PL_op->op_flags & OPf_REF)
107 if (GIMME == G_SCALAR)
108 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
112 if (gimme == G_ARRAY) {
115 else if (gimme == G_SCALAR) {
116 SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
124 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
135 tryAMAGICunDEREF(to_gv);
138 if (SvTYPE(sv) == SVt_PVIO) {
139 GV *gv = (GV*) sv_newmortal();
140 gv_init(gv, 0, "", 0, 0);
141 GvIOp(gv) = (IO *)sv;
142 (void)SvREFCNT_inc(sv);
145 else if (SvTYPE(sv) != SVt_PVGV)
146 DIE(aTHX_ "Not a GLOB reference");
149 if (SvTYPE(sv) != SVt_PVGV) {
150 if (SvGMAGICAL(sv)) {
155 if (!SvOK(sv) && sv != &PL_sv_undef) {
156 /* If this is a 'my' scalar and flag is set then vivify
160 Perl_croak(aTHX_ PL_no_modify);
161 if (PL_op->op_private & OPpDEREF) {
164 if (cUNOP->op_targ) {
166 SV *namesv = PAD_SV(cUNOP->op_targ);
167 name = SvPV(namesv, len);
168 gv = (GV*)NEWSV(0,0);
169 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
172 name = CopSTASHPV(PL_curcop);
175 if (SvTYPE(sv) < SVt_RV)
176 sv_upgrade(sv, SVt_RV);
182 SvRV_set(sv, (SV*)gv);
187 if (PL_op->op_flags & OPf_REF ||
188 PL_op->op_private & HINT_STRICT_REFS)
189 DIE(aTHX_ PL_no_usym, "a symbol");
190 if (ckWARN(WARN_UNINITIALIZED))
194 if ((PL_op->op_flags & OPf_SPECIAL) &&
195 !(PL_op->op_flags & OPf_MOD))
197 SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
199 && (!is_gv_magical_sv(sv,0)
200 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
206 if (PL_op->op_private & HINT_STRICT_REFS)
207 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
208 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
212 if (PL_op->op_private & OPpLVAL_INTRO)
213 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
225 tryAMAGICunDEREF(to_sv);
228 switch (SvTYPE(sv)) {
232 DIE(aTHX_ "Not a SCALAR reference");
238 if (SvTYPE(gv) != SVt_PVGV) {
239 if (SvGMAGICAL(sv)) {
245 if (PL_op->op_flags & OPf_REF ||
246 PL_op->op_private & HINT_STRICT_REFS)
247 DIE(aTHX_ PL_no_usym, "a SCALAR");
248 if (ckWARN(WARN_UNINITIALIZED))
252 if ((PL_op->op_flags & OPf_SPECIAL) &&
253 !(PL_op->op_flags & OPf_MOD))
255 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
257 && (!is_gv_magical_sv(sv, 0)
258 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
264 if (PL_op->op_private & HINT_STRICT_REFS)
265 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
266 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
271 if (PL_op->op_flags & OPf_MOD) {
272 if (PL_op->op_private & OPpLVAL_INTRO) {
273 if (cUNOP->op_first->op_type == OP_NULL)
274 sv = save_scalar((GV*)TOPs);
276 sv = save_scalar(gv);
278 Perl_croak(aTHX_ PL_no_localize_ref);
280 else if (PL_op->op_private & OPpDEREF)
281 vivify_ref(sv, PL_op->op_private & OPpDEREF);
291 SV *sv = AvARYLEN(av);
293 AvARYLEN(av) = sv = NEWSV(0,0);
294 sv_upgrade(sv, SVt_IV);
295 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
303 dSP; dTARGET; dPOPss;
305 if (PL_op->op_flags & OPf_MOD || LVRET) {
306 if (SvTYPE(TARG) < SVt_PVLV) {
307 sv_upgrade(TARG, SVt_PVLV);
308 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
312 if (LvTARG(TARG) != sv) {
314 SvREFCNT_dec(LvTARG(TARG));
315 LvTARG(TARG) = SvREFCNT_inc(sv);
317 PUSHs(TARG); /* no SvSETMAGIC */
323 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
324 mg = mg_find(sv, PERL_MAGIC_regex_global);
325 if (mg && mg->mg_len >= 0) {
329 PUSHi(i + PL_curcop->cop_arybase);
343 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
344 /* (But not in defined().) */
345 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
348 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
349 if ((PL_op->op_private & OPpLVAL_INTRO)) {
350 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
353 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
357 cv = (CV*)&PL_sv_undef;
371 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
372 char *s = SvPVX(TOPs);
373 if (strnEQ(s, "CORE::", 6)) {
376 code = keyword(s + 6, SvCUR(TOPs) - 6);
377 if (code < 0) { /* Overridable. */
378 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
379 int i = 0, n = 0, seen_question = 0;
381 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
383 if (code == -KEY_chop || code == -KEY_chomp)
385 while (i < MAXO) { /* The slow way. */
386 if (strEQ(s + 6, PL_op_name[i])
387 || strEQ(s + 6, PL_op_desc[i]))
393 goto nonesuch; /* Should not happen... */
395 oa = PL_opargs[i] >> OASHIFT;
397 if (oa & OA_OPTIONAL && !seen_question) {
401 else if (n && str[0] == ';' && seen_question)
402 goto set; /* XXXX system, exec */
403 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
404 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
405 /* But globs are already references (kinda) */
406 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
410 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
414 ret = sv_2mortal(newSVpvn(str, n - 1));
416 else if (code) /* Non-Overridable */
418 else { /* None such */
420 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
424 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
426 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
435 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
437 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
453 if (GIMME != G_ARRAY) {
457 *MARK = &PL_sv_undef;
458 *MARK = refto(*MARK);
462 EXTEND_MORTAL(SP - MARK);
464 *MARK = refto(*MARK);
469 S_refto(pTHX_ SV *sv)
473 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
476 if (!(sv = LvTARG(sv)))
479 (void)SvREFCNT_inc(sv);
481 else if (SvTYPE(sv) == SVt_PVAV) {
482 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
485 (void)SvREFCNT_inc(sv);
487 else if (SvPADTMP(sv) && !IS_PADGV(sv))
491 (void)SvREFCNT_inc(sv);
494 sv_upgrade(rv, SVt_RV);
508 if (sv && SvGMAGICAL(sv))
511 if (!sv || !SvROK(sv))
515 pv = sv_reftype(sv,TRUE);
516 PUSHp(pv, strlen(pv));
526 stash = CopSTASH(PL_curcop);
532 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
533 Perl_croak(aTHX_ "Attempt to bless into a reference");
535 if (ckWARN(WARN_MISC) && len == 0)
536 Perl_warner(aTHX_ packWARN(WARN_MISC),
537 "Explicit blessing to '' (assuming package main)");
538 stash = gv_stashpvn(ptr, len, TRUE);
541 (void)sv_bless(TOPs, stash);
555 elem = SvPV(sv, n_a);
560 /* elem will always be NUL terminated. */
561 const char *elem2 = elem + 1;
564 if (strEQ(elem2, "RRAY"))
565 tmpRef = (SV*)GvAV(gv);
568 if (strEQ(elem2, "ODE"))
569 tmpRef = (SV*)GvCVu(gv);
572 if (strEQ(elem2, "ILEHANDLE")) {
573 /* finally deprecated in 5.8.0 */
574 deprecate("*glob{FILEHANDLE}");
575 tmpRef = (SV*)GvIOp(gv);
578 if (strEQ(elem2, "ORMAT"))
579 tmpRef = (SV*)GvFORM(gv);
582 if (strEQ(elem2, "LOB"))
586 if (strEQ(elem2, "ASH"))
587 tmpRef = (SV*)GvHV(gv);
590 if (*elem2 == 'O' && !elem[2])
591 tmpRef = (SV*)GvIOp(gv);
594 if (strEQ(elem2, "AME"))
595 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
598 if (strEQ(elem2, "ACKAGE")) {
599 const char *name = HvNAME(GvSTASH(gv));
600 sv = newSVpv(name ? name : "__ANON__", 0);
604 if (strEQ(elem2, "CALAR"))
619 /* Pattern matching */
624 register unsigned char *s;
627 register I32 *sfirst;
631 if (sv == PL_lastscream) {
637 SvSCREAM_off(PL_lastscream);
638 SvREFCNT_dec(PL_lastscream);
640 PL_lastscream = SvREFCNT_inc(sv);
643 s = (unsigned char*)(SvPV(sv, len));
647 if (pos > PL_maxscream) {
648 if (PL_maxscream < 0) {
649 PL_maxscream = pos + 80;
650 New(301, PL_screamfirst, 256, I32);
651 New(302, PL_screamnext, PL_maxscream, I32);
654 PL_maxscream = pos + pos / 4;
655 Renew(PL_screamnext, PL_maxscream, I32);
659 sfirst = PL_screamfirst;
660 snext = PL_screamnext;
662 if (!sfirst || !snext)
663 DIE(aTHX_ "do_study: out of memory");
665 for (ch = 256; ch; --ch)
672 snext[pos] = sfirst[ch] - pos;
679 /* piggyback on m//g magic */
680 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
689 if (PL_op->op_flags & OPf_STACKED)
691 else if (PL_op->op_private & OPpTARGET_MY)
697 TARG = sv_newmortal();
702 /* Lvalue operators. */
714 dSP; dMARK; dTARGET; dORIGMARK;
716 do_chop(TARG, *++MARK);
725 SETi(do_chomp(TOPs));
732 register I32 count = 0;
735 count += do_chomp(POPs);
746 if (!sv || !SvANY(sv))
748 switch (SvTYPE(sv)) {
750 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
751 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
755 if (HvARRAY(sv) || SvGMAGICAL(sv)
756 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
760 if (CvROOT(sv) || CvXSUB(sv))
777 if (!PL_op->op_private) {
786 SV_CHECK_THINKFIRST_COW_DROP(sv);
788 switch (SvTYPE(sv)) {
798 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
799 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
800 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
804 /* let user-undef'd sub keep its identity */
805 GV* gv = CvGV((CV*)sv);
812 SvSetMagicSV(sv, &PL_sv_undef);
816 Newz(602, gp, 1, GP);
817 GvGP(sv) = gp_ref(gp);
818 GvSV(sv) = NEWSV(72,0);
819 GvLINE(sv) = CopLINE(PL_curcop);
825 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
827 SvPV_set(sv, Nullch);
840 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
841 DIE(aTHX_ PL_no_modify);
842 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
843 && SvIVX(TOPs) != IV_MIN)
845 SvIV_set(TOPs, SvIVX(TOPs) - 1);
846 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
857 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
858 DIE(aTHX_ PL_no_modify);
859 sv_setsv(TARG, TOPs);
860 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
861 && SvIVX(TOPs) != IV_MAX)
863 SvIV_set(TOPs, SvIVX(TOPs) + 1);
864 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
869 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
879 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
880 DIE(aTHX_ PL_no_modify);
881 sv_setsv(TARG, TOPs);
882 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
883 && SvIVX(TOPs) != IV_MIN)
885 SvIV_set(TOPs, SvIVX(TOPs) - 1);
886 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
895 /* Ordinary operators. */
900 #ifdef PERL_PRESERVE_IVUV
903 tryAMAGICbin(pow,opASSIGN);
904 #ifdef PERL_PRESERVE_IVUV
905 /* For integer to integer power, we do the calculation by hand wherever
906 we're sure it is safe; otherwise we call pow() and try to convert to
907 integer afterwards. */
911 bool baseuok = SvUOK(TOPm1s);
915 baseuv = SvUVX(TOPm1s);
917 IV iv = SvIVX(TOPm1s);
920 baseuok = TRUE; /* effectively it's a UV now */
922 baseuv = -iv; /* abs, baseuok == false records sign */
936 goto float_it; /* Can't do negative powers this way. */
939 /* now we have integer ** positive integer. */
942 /* foo & (foo - 1) is zero only for a power of 2. */
943 if (!(baseuv & (baseuv - 1))) {
944 /* We are raising power-of-2 to a positive integer.
945 The logic here will work for any base (even non-integer
946 bases) but it can be less accurate than
947 pow (base,power) or exp (power * log (base)) when the
948 intermediate values start to spill out of the mantissa.
949 With powers of 2 we know this can't happen.
950 And powers of 2 are the favourite thing for perl
951 programmers to notice ** not doing what they mean. */
953 NV base = baseuok ? baseuv : -(NV)baseuv;
956 for (; power; base *= base, n++) {
957 /* Do I look like I trust gcc with long longs here?
959 UV bit = (UV)1 << (UV)n;
962 /* Only bother to clear the bit if it is set. */
964 /* Avoid squaring base again if we're done. */
965 if (power == 0) break;
973 register unsigned int highbit = 8 * sizeof(UV);
974 register unsigned int lowbit = 0;
975 register unsigned int diff;
976 bool odd_power = (bool)(power & 1);
977 while ((diff = (highbit - lowbit) >> 1)) {
978 if (baseuv & ~((1 << (lowbit + diff)) - 1))
983 /* we now have baseuv < 2 ** highbit */
984 if (power * highbit <= 8 * sizeof(UV)) {
985 /* result will definitely fit in UV, so use UV math
986 on same algorithm as above */
987 register UV result = 1;
988 register UV base = baseuv;
990 for (; power; base *= base, n++) {
991 register UV bit = (UV)1 << (UV)n;
995 if (power == 0) break;
999 if (baseuok || !odd_power)
1000 /* answer is positive */
1002 else if (result <= (UV)IV_MAX)
1003 /* answer negative, fits in IV */
1004 SETi( -(IV)result );
1005 else if (result == (UV)IV_MIN)
1006 /* 2's complement assumption: special case IV_MIN */
1009 /* answer negative, doesn't fit */
1010 SETn( -(NV)result );
1021 SETn( Perl_pow( left, right) );
1022 #ifdef PERL_PRESERVE_IVUV
1032 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1033 #ifdef PERL_PRESERVE_IVUV
1036 /* Unless the left argument is integer in range we are going to have to
1037 use NV maths. Hence only attempt to coerce the right argument if
1038 we know the left is integer. */
1039 /* Left operand is defined, so is it IV? */
1040 SvIV_please(TOPm1s);
1041 if (SvIOK(TOPm1s)) {
1042 bool auvok = SvUOK(TOPm1s);
1043 bool buvok = SvUOK(TOPs);
1044 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1045 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1052 alow = SvUVX(TOPm1s);
1054 IV aiv = SvIVX(TOPm1s);
1057 auvok = TRUE; /* effectively it's a UV now */
1059 alow = -aiv; /* abs, auvok == false records sign */
1065 IV biv = SvIVX(TOPs);
1068 buvok = TRUE; /* effectively it's a UV now */
1070 blow = -biv; /* abs, buvok == false records sign */
1074 /* If this does sign extension on unsigned it's time for plan B */
1075 ahigh = alow >> (4 * sizeof (UV));
1077 bhigh = blow >> (4 * sizeof (UV));
1079 if (ahigh && bhigh) {
1080 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1081 which is overflow. Drop to NVs below. */
1082 } else if (!ahigh && !bhigh) {
1083 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1084 so the unsigned multiply cannot overflow. */
1085 UV product = alow * blow;
1086 if (auvok == buvok) {
1087 /* -ve * -ve or +ve * +ve gives a +ve result. */
1091 } else if (product <= (UV)IV_MIN) {
1092 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1093 /* -ve result, which could overflow an IV */
1095 SETi( -(IV)product );
1097 } /* else drop to NVs below. */
1099 /* One operand is large, 1 small */
1102 /* swap the operands */
1104 bhigh = blow; /* bhigh now the temp var for the swap */
1108 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1109 multiplies can't overflow. shift can, add can, -ve can. */
1110 product_middle = ahigh * blow;
1111 if (!(product_middle & topmask)) {
1112 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1114 product_middle <<= (4 * sizeof (UV));
1115 product_low = alow * blow;
1117 /* as for pp_add, UV + something mustn't get smaller.
1118 IIRC ANSI mandates this wrapping *behaviour* for
1119 unsigned whatever the actual representation*/
1120 product_low += product_middle;
1121 if (product_low >= product_middle) {
1122 /* didn't overflow */
1123 if (auvok == buvok) {
1124 /* -ve * -ve or +ve * +ve gives a +ve result. */
1126 SETu( product_low );
1128 } else if (product_low <= (UV)IV_MIN) {
1129 /* 2s complement assumption again */
1130 /* -ve result, which could overflow an IV */
1132 SETi( -(IV)product_low );
1134 } /* else drop to NVs below. */
1136 } /* product_middle too large */
1137 } /* ahigh && bhigh */
1138 } /* SvIOK(TOPm1s) */
1143 SETn( left * right );
1150 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1151 /* Only try to do UV divide first
1152 if ((SLOPPYDIVIDE is true) or
1153 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1155 The assumption is that it is better to use floating point divide
1156 whenever possible, only doing integer divide first if we can't be sure.
1157 If NV_PRESERVES_UV is true then we know at compile time that no UV
1158 can be too large to preserve, so don't need to compile the code to
1159 test the size of UVs. */
1162 # define PERL_TRY_UV_DIVIDE
1163 /* ensure that 20./5. == 4. */
1165 # ifdef PERL_PRESERVE_IVUV
1166 # ifndef NV_PRESERVES_UV
1167 # define PERL_TRY_UV_DIVIDE
1172 #ifdef PERL_TRY_UV_DIVIDE
1175 SvIV_please(TOPm1s);
1176 if (SvIOK(TOPm1s)) {
1177 bool left_non_neg = SvUOK(TOPm1s);
1178 bool right_non_neg = SvUOK(TOPs);
1182 if (right_non_neg) {
1183 right = SvUVX(TOPs);
1186 IV biv = SvIVX(TOPs);
1189 right_non_neg = TRUE; /* effectively it's a UV now */
1195 /* historically undef()/0 gives a "Use of uninitialized value"
1196 warning before dieing, hence this test goes here.
1197 If it were immediately before the second SvIV_please, then
1198 DIE() would be invoked before left was even inspected, so
1199 no inpsection would give no warning. */
1201 DIE(aTHX_ "Illegal division by zero");
1204 left = SvUVX(TOPm1s);
1207 IV aiv = SvIVX(TOPm1s);
1210 left_non_neg = TRUE; /* effectively it's a UV now */
1219 /* For sloppy divide we always attempt integer division. */
1221 /* Otherwise we only attempt it if either or both operands
1222 would not be preserved by an NV. If both fit in NVs
1223 we fall through to the NV divide code below. However,
1224 as left >= right to ensure integer result here, we know that
1225 we can skip the test on the right operand - right big
1226 enough not to be preserved can't get here unless left is
1229 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1232 /* Integer division can't overflow, but it can be imprecise. */
1233 UV result = left / right;
1234 if (result * right == left) {
1235 SP--; /* result is valid */
1236 if (left_non_neg == right_non_neg) {
1237 /* signs identical, result is positive. */
1241 /* 2s complement assumption */
1242 if (result <= (UV)IV_MIN)
1243 SETi( -(IV)result );
1245 /* It's exact but too negative for IV. */
1246 SETn( -(NV)result );
1249 } /* tried integer divide but it was not an integer result */
1250 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1251 } /* left wasn't SvIOK */
1252 } /* right wasn't SvIOK */
1253 #endif /* PERL_TRY_UV_DIVIDE */
1257 DIE(aTHX_ "Illegal division by zero");
1258 PUSHn( left / right );
1265 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1269 bool left_neg = FALSE;
1270 bool right_neg = FALSE;
1271 bool use_double = FALSE;
1272 bool dright_valid = FALSE;
1278 right_neg = !SvUOK(TOPs);
1280 right = SvUVX(POPs);
1282 IV biv = SvIVX(POPs);
1285 right_neg = FALSE; /* effectively it's a UV now */
1293 right_neg = dright < 0;
1296 if (dright < UV_MAX_P1) {
1297 right = U_V(dright);
1298 dright_valid = TRUE; /* In case we need to use double below. */
1304 /* At this point use_double is only true if right is out of range for
1305 a UV. In range NV has been rounded down to nearest UV and
1306 use_double false. */
1308 if (!use_double && SvIOK(TOPs)) {
1310 left_neg = !SvUOK(TOPs);
1314 IV aiv = SvIVX(POPs);
1317 left_neg = FALSE; /* effectively it's a UV now */
1326 left_neg = dleft < 0;
1330 /* This should be exactly the 5.6 behaviour - if left and right are
1331 both in range for UV then use U_V() rather than floor. */
1333 if (dleft < UV_MAX_P1) {
1334 /* right was in range, so is dleft, so use UVs not double.
1338 /* left is out of range for UV, right was in range, so promote
1339 right (back) to double. */
1341 /* The +0.5 is used in 5.6 even though it is not strictly
1342 consistent with the implicit +0 floor in the U_V()
1343 inside the #if 1. */
1344 dleft = Perl_floor(dleft + 0.5);
1347 dright = Perl_floor(dright + 0.5);
1357 DIE(aTHX_ "Illegal modulus zero");
1359 dans = Perl_fmod(dleft, dright);
1360 if ((left_neg != right_neg) && dans)
1361 dans = dright - dans;
1364 sv_setnv(TARG, dans);
1370 DIE(aTHX_ "Illegal modulus zero");
1373 if ((left_neg != right_neg) && ans)
1376 /* XXX may warn: unary minus operator applied to unsigned type */
1377 /* could change -foo to be (~foo)+1 instead */
1378 if (ans <= ~((UV)IV_MAX)+1)
1379 sv_setiv(TARG, ~ans+1);
1381 sv_setnv(TARG, -(NV)ans);
1384 sv_setuv(TARG, ans);
1393 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1403 count = IV_MAX; /* The best we can do? */
1414 else if (SvNOKp(sv)) {
1423 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1425 I32 items = SP - MARK;
1427 static const char oom_list_extend[] =
1428 "Out of memory during list extend";
1430 max = items * count;
1431 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1432 /* Did the max computation overflow? */
1433 if (items > 0 && max > 0 && (max < items || max < count))
1434 Perl_croak(aTHX_ oom_list_extend);
1439 /* This code was intended to fix 20010809.028:
1442 for (($x =~ /./g) x 2) {
1443 print chop; # "abcdabcd" expected as output.
1446 * but that change (#11635) broke this code:
1448 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1450 * I can't think of a better fix that doesn't introduce
1451 * an efficiency hit by copying the SVs. The stack isn't
1452 * refcounted, and mortalisation obviously doesn't
1453 * Do The Right Thing when the stack has more than
1454 * one pointer to the same mortal value.
1458 *SP = sv_2mortal(newSVsv(*SP));
1468 repeatcpy((char*)(MARK + items), (char*)MARK,
1469 items * sizeof(SV*), count - 1);
1472 else if (count <= 0)
1475 else { /* Note: mark already snarfed by pp_list */
1479 static const char oom_string_extend[] =
1480 "Out of memory during string extend";
1482 SvSetSV(TARG, tmpstr);
1483 SvPV_force(TARG, len);
1484 isutf = DO_UTF8(TARG);
1489 STRLEN max = (UV)count * len;
1490 if (len > ((MEM_SIZE)~0)/count)
1491 Perl_croak(aTHX_ oom_string_extend);
1492 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1493 SvGROW(TARG, max + 1);
1494 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1495 SvCUR_set(TARG, SvCUR(TARG) * count);
1497 *SvEND(TARG) = '\0';
1500 (void)SvPOK_only_UTF8(TARG);
1502 (void)SvPOK_only(TARG);
1504 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1505 /* The parser saw this as a list repeat, and there
1506 are probably several items on the stack. But we're
1507 in scalar context, and there's no pp_list to save us
1508 now. So drop the rest of the items -- robin@kitsite.com
1521 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1522 useleft = USE_LEFT(TOPm1s);
1523 #ifdef PERL_PRESERVE_IVUV
1524 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1525 "bad things" happen if you rely on signed integers wrapping. */
1528 /* Unless the left argument is integer in range we are going to have to
1529 use NV maths. Hence only attempt to coerce the right argument if
1530 we know the left is integer. */
1531 register UV auv = 0;
1537 a_valid = auvok = 1;
1538 /* left operand is undef, treat as zero. */
1540 /* Left operand is defined, so is it IV? */
1541 SvIV_please(TOPm1s);
1542 if (SvIOK(TOPm1s)) {
1543 if ((auvok = SvUOK(TOPm1s)))
1544 auv = SvUVX(TOPm1s);
1546 register IV aiv = SvIVX(TOPm1s);
1549 auvok = 1; /* Now acting as a sign flag. */
1550 } else { /* 2s complement assumption for IV_MIN */
1558 bool result_good = 0;
1561 bool buvok = SvUOK(TOPs);
1566 register IV biv = SvIVX(TOPs);
1573 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1574 else "IV" now, independent of how it came in.
1575 if a, b represents positive, A, B negative, a maps to -A etc
1580 all UV maths. negate result if A negative.
1581 subtract if signs same, add if signs differ. */
1583 if (auvok ^ buvok) {
1592 /* Must get smaller */
1597 if (result <= buv) {
1598 /* result really should be -(auv-buv). as its negation
1599 of true value, need to swap our result flag */
1611 if (result <= (UV)IV_MIN)
1612 SETi( -(IV)result );
1614 /* result valid, but out of range for IV. */
1615 SETn( -(NV)result );
1619 } /* Overflow, drop through to NVs. */
1623 useleft = USE_LEFT(TOPm1s);
1627 /* left operand is undef, treat as zero - value */
1631 SETn( TOPn - value );
1638 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1641 if (PL_op->op_private & HINT_INTEGER) {
1655 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1658 if (PL_op->op_private & HINT_INTEGER) {
1672 dSP; tryAMAGICbinSET(lt,0);
1673 #ifdef PERL_PRESERVE_IVUV
1676 SvIV_please(TOPm1s);
1677 if (SvIOK(TOPm1s)) {
1678 bool auvok = SvUOK(TOPm1s);
1679 bool buvok = SvUOK(TOPs);
1681 if (!auvok && !buvok) { /* ## IV < IV ## */
1682 IV aiv = SvIVX(TOPm1s);
1683 IV biv = SvIVX(TOPs);
1686 SETs(boolSV(aiv < biv));
1689 if (auvok && buvok) { /* ## UV < UV ## */
1690 UV auv = SvUVX(TOPm1s);
1691 UV buv = SvUVX(TOPs);
1694 SETs(boolSV(auv < buv));
1697 if (auvok) { /* ## UV < IV ## */
1704 /* As (a) is a UV, it's >=0, so it cannot be < */
1709 SETs(boolSV(auv < (UV)biv));
1712 { /* ## IV < UV ## */
1716 aiv = SvIVX(TOPm1s);
1718 /* As (b) is a UV, it's >=0, so it must be < */
1725 SETs(boolSV((UV)aiv < buv));
1731 #ifndef NV_PRESERVES_UV
1732 #ifdef PERL_PRESERVE_IVUV
1735 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1737 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1743 SETs(boolSV(TOPn < value));
1750 dSP; tryAMAGICbinSET(gt,0);
1751 #ifdef PERL_PRESERVE_IVUV
1754 SvIV_please(TOPm1s);
1755 if (SvIOK(TOPm1s)) {
1756 bool auvok = SvUOK(TOPm1s);
1757 bool buvok = SvUOK(TOPs);
1759 if (!auvok && !buvok) { /* ## IV > IV ## */
1760 IV aiv = SvIVX(TOPm1s);
1761 IV biv = SvIVX(TOPs);
1764 SETs(boolSV(aiv > biv));
1767 if (auvok && buvok) { /* ## UV > UV ## */
1768 UV auv = SvUVX(TOPm1s);
1769 UV buv = SvUVX(TOPs);
1772 SETs(boolSV(auv > buv));
1775 if (auvok) { /* ## UV > IV ## */
1782 /* As (a) is a UV, it's >=0, so it must be > */
1787 SETs(boolSV(auv > (UV)biv));
1790 { /* ## IV > UV ## */
1794 aiv = SvIVX(TOPm1s);
1796 /* As (b) is a UV, it's >=0, so it cannot be > */
1803 SETs(boolSV((UV)aiv > buv));
1809 #ifndef NV_PRESERVES_UV
1810 #ifdef PERL_PRESERVE_IVUV
1813 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1815 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1821 SETs(boolSV(TOPn > value));
1828 dSP; tryAMAGICbinSET(le,0);
1829 #ifdef PERL_PRESERVE_IVUV
1832 SvIV_please(TOPm1s);
1833 if (SvIOK(TOPm1s)) {
1834 bool auvok = SvUOK(TOPm1s);
1835 bool buvok = SvUOK(TOPs);
1837 if (!auvok && !buvok) { /* ## IV <= IV ## */
1838 IV aiv = SvIVX(TOPm1s);
1839 IV biv = SvIVX(TOPs);
1842 SETs(boolSV(aiv <= biv));
1845 if (auvok && buvok) { /* ## UV <= UV ## */
1846 UV auv = SvUVX(TOPm1s);
1847 UV buv = SvUVX(TOPs);
1850 SETs(boolSV(auv <= buv));
1853 if (auvok) { /* ## UV <= IV ## */
1860 /* As (a) is a UV, it's >=0, so a cannot be <= */
1865 SETs(boolSV(auv <= (UV)biv));
1868 { /* ## IV <= UV ## */
1872 aiv = SvIVX(TOPm1s);
1874 /* As (b) is a UV, it's >=0, so a must be <= */
1881 SETs(boolSV((UV)aiv <= buv));
1887 #ifndef NV_PRESERVES_UV
1888 #ifdef PERL_PRESERVE_IVUV
1891 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1893 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1899 SETs(boolSV(TOPn <= value));
1906 dSP; tryAMAGICbinSET(ge,0);
1907 #ifdef PERL_PRESERVE_IVUV
1910 SvIV_please(TOPm1s);
1911 if (SvIOK(TOPm1s)) {
1912 bool auvok = SvUOK(TOPm1s);
1913 bool buvok = SvUOK(TOPs);
1915 if (!auvok && !buvok) { /* ## IV >= IV ## */
1916 IV aiv = SvIVX(TOPm1s);
1917 IV biv = SvIVX(TOPs);
1920 SETs(boolSV(aiv >= biv));
1923 if (auvok && buvok) { /* ## UV >= UV ## */
1924 UV auv = SvUVX(TOPm1s);
1925 UV buv = SvUVX(TOPs);
1928 SETs(boolSV(auv >= buv));
1931 if (auvok) { /* ## UV >= IV ## */
1938 /* As (a) is a UV, it's >=0, so it must be >= */
1943 SETs(boolSV(auv >= (UV)biv));
1946 { /* ## IV >= UV ## */
1950 aiv = SvIVX(TOPm1s);
1952 /* As (b) is a UV, it's >=0, so a cannot be >= */
1959 SETs(boolSV((UV)aiv >= buv));
1965 #ifndef NV_PRESERVES_UV
1966 #ifdef PERL_PRESERVE_IVUV
1969 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1971 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1977 SETs(boolSV(TOPn >= value));
1984 dSP; tryAMAGICbinSET(ne,0);
1985 #ifndef NV_PRESERVES_UV
1986 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1988 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1992 #ifdef PERL_PRESERVE_IVUV
1995 SvIV_please(TOPm1s);
1996 if (SvIOK(TOPm1s)) {
1997 bool auvok = SvUOK(TOPm1s);
1998 bool buvok = SvUOK(TOPs);
2000 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2001 /* Casting IV to UV before comparison isn't going to matter
2002 on 2s complement. On 1s complement or sign&magnitude
2003 (if we have any of them) it could make negative zero
2004 differ from normal zero. As I understand it. (Need to
2005 check - is negative zero implementation defined behaviour
2007 UV buv = SvUVX(POPs);
2008 UV auv = SvUVX(TOPs);
2010 SETs(boolSV(auv != buv));
2013 { /* ## Mixed IV,UV ## */
2017 /* != is commutative so swap if needed (save code) */
2019 /* swap. top of stack (b) is the iv */
2023 /* As (a) is a UV, it's >0, so it cannot be == */
2032 /* As (b) is a UV, it's >0, so it cannot be == */
2036 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2038 SETs(boolSV((UV)iv != uv));
2046 SETs(boolSV(TOPn != value));
2053 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2054 #ifndef NV_PRESERVES_UV
2055 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2056 UV right = PTR2UV(SvRV(POPs));
2057 UV left = PTR2UV(SvRV(TOPs));
2058 SETi((left > right) - (left < right));
2062 #ifdef PERL_PRESERVE_IVUV
2063 /* Fortunately it seems NaN isn't IOK */
2066 SvIV_please(TOPm1s);
2067 if (SvIOK(TOPm1s)) {
2068 bool leftuvok = SvUOK(TOPm1s);
2069 bool rightuvok = SvUOK(TOPs);
2071 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2072 IV leftiv = SvIVX(TOPm1s);
2073 IV rightiv = SvIVX(TOPs);
2075 if (leftiv > rightiv)
2077 else if (leftiv < rightiv)
2081 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2082 UV leftuv = SvUVX(TOPm1s);
2083 UV rightuv = SvUVX(TOPs);
2085 if (leftuv > rightuv)
2087 else if (leftuv < rightuv)
2091 } else if (leftuvok) { /* ## UV <=> IV ## */
2095 rightiv = SvIVX(TOPs);
2097 /* As (a) is a UV, it's >=0, so it cannot be < */
2100 leftuv = SvUVX(TOPm1s);
2101 if (leftuv > (UV)rightiv) {
2103 } else if (leftuv < (UV)rightiv) {
2109 } else { /* ## IV <=> UV ## */
2113 leftiv = SvIVX(TOPm1s);
2115 /* As (b) is a UV, it's >=0, so it must be < */
2118 rightuv = SvUVX(TOPs);
2119 if ((UV)leftiv > rightuv) {
2121 } else if ((UV)leftiv < rightuv) {
2139 if (Perl_isnan(left) || Perl_isnan(right)) {
2143 value = (left > right) - (left < right);
2147 else if (left < right)
2149 else if (left > right)
2163 dSP; tryAMAGICbinSET(slt,0);
2166 int cmp = (IN_LOCALE_RUNTIME
2167 ? sv_cmp_locale(left, right)
2168 : sv_cmp(left, right));
2169 SETs(boolSV(cmp < 0));
2176 dSP; tryAMAGICbinSET(sgt,0);
2179 int cmp = (IN_LOCALE_RUNTIME
2180 ? sv_cmp_locale(left, right)
2181 : sv_cmp(left, right));
2182 SETs(boolSV(cmp > 0));
2189 dSP; tryAMAGICbinSET(sle,0);
2192 int cmp = (IN_LOCALE_RUNTIME
2193 ? sv_cmp_locale(left, right)
2194 : sv_cmp(left, right));
2195 SETs(boolSV(cmp <= 0));
2202 dSP; tryAMAGICbinSET(sge,0);
2205 int cmp = (IN_LOCALE_RUNTIME
2206 ? sv_cmp_locale(left, right)
2207 : sv_cmp(left, right));
2208 SETs(boolSV(cmp >= 0));
2215 dSP; tryAMAGICbinSET(seq,0);
2218 SETs(boolSV(sv_eq(left, right)));
2225 dSP; tryAMAGICbinSET(sne,0);
2228 SETs(boolSV(!sv_eq(left, right)));
2235 dSP; dTARGET; tryAMAGICbin(scmp,0);
2238 int cmp = (IN_LOCALE_RUNTIME
2239 ? sv_cmp_locale(left, right)
2240 : sv_cmp(left, right));
2248 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2251 if (SvGMAGICAL(left)) mg_get(left);
2252 if (SvGMAGICAL(right)) mg_get(right);
2253 if (SvNIOKp(left) || SvNIOKp(right)) {
2254 if (PL_op->op_private & HINT_INTEGER) {
2255 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2259 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2264 do_vop(PL_op->op_type, TARG, left, right);
2273 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2276 if (SvGMAGICAL(left)) mg_get(left);
2277 if (SvGMAGICAL(right)) mg_get(right);
2278 if (SvNIOKp(left) || SvNIOKp(right)) {
2279 if (PL_op->op_private & HINT_INTEGER) {
2280 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2284 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2289 do_vop(PL_op->op_type, TARG, left, right);
2298 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2301 if (SvGMAGICAL(left)) mg_get(left);
2302 if (SvGMAGICAL(right)) mg_get(right);
2303 if (SvNIOKp(left) || SvNIOKp(right)) {
2304 if (PL_op->op_private & HINT_INTEGER) {
2305 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2309 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2314 do_vop(PL_op->op_type, TARG, left, right);
2323 dSP; dTARGET; tryAMAGICun(neg);
2326 int flags = SvFLAGS(sv);
2329 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2330 /* It's publicly an integer, or privately an integer-not-float */
2333 if (SvIVX(sv) == IV_MIN) {
2334 /* 2s complement assumption. */
2335 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2338 else if (SvUVX(sv) <= IV_MAX) {
2343 else if (SvIVX(sv) != IV_MIN) {
2347 #ifdef PERL_PRESERVE_IVUV
2356 else if (SvPOKp(sv)) {
2358 char *s = SvPV(sv, len);
2359 if (isIDFIRST(*s)) {
2360 sv_setpvn(TARG, "-", 1);
2363 else if (*s == '+' || *s == '-') {
2365 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2367 else if (DO_UTF8(sv)) {
2370 goto oops_its_an_int;
2372 sv_setnv(TARG, -SvNV(sv));
2374 sv_setpvn(TARG, "-", 1);
2381 goto oops_its_an_int;
2382 sv_setnv(TARG, -SvNV(sv));
2394 dSP; tryAMAGICunSET(not);
2395 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2401 dSP; dTARGET; tryAMAGICun(compl);
2407 if (PL_op->op_private & HINT_INTEGER) {
2408 IV i = ~SvIV_nomg(sv);
2412 UV u = ~SvUV_nomg(sv);
2421 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2422 sv_setsv_nomg(TARG, sv);
2423 tmps = (U8*)SvPV_force(TARG, len);
2426 /* Calculate exact length, let's not estimate. */
2435 while (tmps < send) {
2436 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2437 tmps += UTF8SKIP(tmps);
2438 targlen += UNISKIP(~c);
2444 /* Now rewind strings and write them. */
2448 Newz(0, result, targlen + 1, U8);
2449 while (tmps < send) {
2450 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2451 tmps += UTF8SKIP(tmps);
2452 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2456 sv_setpvn(TARG, (char*)result, targlen);
2460 Newz(0, result, nchar + 1, U8);
2461 while (tmps < send) {
2462 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2463 tmps += UTF8SKIP(tmps);
2468 sv_setpvn(TARG, (char*)result, nchar);
2477 register long *tmpl;
2478 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2481 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2486 for ( ; anum > 0; anum--, tmps++)
2495 /* integer versions of some of the above */
2499 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2502 SETi( left * right );
2509 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2513 DIE(aTHX_ "Illegal division by zero");
2514 value = POPi / value;
2523 /* This is the vanilla old i_modulo. */
2524 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2528 DIE(aTHX_ "Illegal modulus zero");
2529 SETi( left % right );
2534 #if defined(__GLIBC__) && IVSIZE == 8
2538 /* This is the i_modulo with the workaround for the _moddi3 bug
2539 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2540 * See below for pp_i_modulo. */
2541 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2545 DIE(aTHX_ "Illegal modulus zero");
2546 SETi( left % PERL_ABS(right) );
2554 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2558 DIE(aTHX_ "Illegal modulus zero");
2559 /* The assumption is to use hereafter the old vanilla version... */
2561 PL_ppaddr[OP_I_MODULO] =
2562 &Perl_pp_i_modulo_0;
2563 /* .. but if we have glibc, we might have a buggy _moddi3
2564 * (at least glicb 2.2.5 is known to have this bug), in other
2565 * words our integer modulus with negative quad as the second
2566 * argument might be broken. Test for this and re-patch the
2567 * opcode dispatch table if that is the case, remembering to
2568 * also apply the workaround so that this first round works
2569 * right, too. See [perl #9402] for more information. */
2570 #if defined(__GLIBC__) && IVSIZE == 8
2574 /* Cannot do this check with inlined IV constants since
2575 * that seems to work correctly even with the buggy glibc. */
2577 /* Yikes, we have the bug.
2578 * Patch in the workaround version. */
2580 PL_ppaddr[OP_I_MODULO] =
2581 &Perl_pp_i_modulo_1;
2582 /* Make certain we work right this time, too. */
2583 right = PERL_ABS(right);
2587 SETi( left % right );
2594 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2597 SETi( left + right );
2604 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2607 SETi( left - right );
2614 dSP; tryAMAGICbinSET(lt,0);
2617 SETs(boolSV(left < right));
2624 dSP; tryAMAGICbinSET(gt,0);
2627 SETs(boolSV(left > right));
2634 dSP; tryAMAGICbinSET(le,0);
2637 SETs(boolSV(left <= right));
2644 dSP; tryAMAGICbinSET(ge,0);
2647 SETs(boolSV(left >= right));
2654 dSP; tryAMAGICbinSET(eq,0);
2657 SETs(boolSV(left == right));
2664 dSP; tryAMAGICbinSET(ne,0);
2667 SETs(boolSV(left != right));
2674 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2681 else if (left < right)
2692 dSP; dTARGET; tryAMAGICun(neg);
2697 /* High falutin' math. */
2701 dSP; dTARGET; tryAMAGICbin(atan2,0);
2704 SETn(Perl_atan2(left, right));
2711 dSP; dTARGET; tryAMAGICun(sin);
2715 value = Perl_sin(value);
2723 dSP; dTARGET; tryAMAGICun(cos);
2727 value = Perl_cos(value);
2733 /* Support Configure command-line overrides for rand() functions.
2734 After 5.005, perhaps we should replace this by Configure support
2735 for drand48(), random(), or rand(). For 5.005, though, maintain
2736 compatibility by calling rand() but allow the user to override it.
2737 See INSTALL for details. --Andy Dougherty 15 July 1998
2739 /* Now it's after 5.005, and Configure supports drand48() and random(),
2740 in addition to rand(). So the overrides should not be needed any more.
2741 --Jarkko Hietaniemi 27 September 1998
2744 #ifndef HAS_DRAND48_PROTO
2745 extern double drand48 (void);
2758 if (!PL_srand_called) {
2759 (void)seedDrand01((Rand_seed_t)seed());
2760 PL_srand_called = TRUE;
2775 (void)seedDrand01((Rand_seed_t)anum);
2776 PL_srand_called = TRUE;
2783 dSP; dTARGET; tryAMAGICun(exp);
2787 value = Perl_exp(value);
2795 dSP; dTARGET; tryAMAGICun(log);
2800 SET_NUMERIC_STANDARD();
2801 DIE(aTHX_ "Can't take log of %"NVgf, value);
2803 value = Perl_log(value);
2811 dSP; dTARGET; tryAMAGICun(sqrt);
2816 SET_NUMERIC_STANDARD();
2817 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2819 value = Perl_sqrt(value);
2827 dSP; dTARGET; tryAMAGICun(int);
2830 IV iv = TOPi; /* attempt to convert to IV if possible. */
2831 /* XXX it's arguable that compiler casting to IV might be subtly
2832 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2833 else preferring IV has introduced a subtle behaviour change bug. OTOH
2834 relying on floating point to be accurate is a bug. */
2838 else if (SvIOK(TOPs)) {
2847 if (value < (NV)UV_MAX + 0.5) {
2850 SETn(Perl_floor(value));
2854 if (value > (NV)IV_MIN - 0.5) {
2857 SETn(Perl_ceil(value));
2867 dSP; dTARGET; tryAMAGICun(abs);
2869 /* This will cache the NV value if string isn't actually integer */
2874 else if (SvIOK(TOPs)) {
2875 /* IVX is precise */
2877 SETu(TOPu); /* force it to be numeric only */
2885 /* 2s complement assumption. Also, not really needed as
2886 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2906 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2912 tmps = (SvPVx(sv, len));
2914 /* If Unicode, try to downgrade
2915 * If not possible, croak. */
2916 SV* tsv = sv_2mortal(newSVsv(sv));
2919 sv_utf8_downgrade(tsv, FALSE);
2922 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2923 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2936 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2942 tmps = (SvPVx(sv, len));
2944 /* If Unicode, try to downgrade
2945 * If not possible, croak. */
2946 SV* tsv = sv_2mortal(newSVsv(sv));
2949 sv_utf8_downgrade(tsv, FALSE);
2952 while (*tmps && len && isSPACE(*tmps))
2957 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2958 else if (*tmps == 'b')
2959 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2961 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2963 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2980 SETi(sv_len_utf8(sv));
2996 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2998 const I32 arybase = PL_curcop->cop_arybase;
3000 const char *repl = 0;
3002 int num_args = PL_op->op_private & 7;
3003 bool repl_need_utf8_upgrade = FALSE;
3004 bool repl_is_utf8 = FALSE;
3006 SvTAINTED_off(TARG); /* decontaminate */
3007 SvUTF8_off(TARG); /* decontaminate */
3011 repl = SvPV(repl_sv, repl_len);
3012 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3022 sv_utf8_upgrade(sv);
3024 else if (DO_UTF8(sv))
3025 repl_need_utf8_upgrade = TRUE;
3027 tmps = SvPV(sv, curlen);
3029 utf8_curlen = sv_len_utf8(sv);
3030 if (utf8_curlen == curlen)
3033 curlen = utf8_curlen;
3038 if (pos >= arybase) {
3056 else if (len >= 0) {
3058 if (rem > (I32)curlen)
3073 Perl_croak(aTHX_ "substr outside of string");
3074 if (ckWARN(WARN_SUBSTR))
3075 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3082 sv_pos_u2b(sv, &pos, &rem);
3084 /* we either return a PV or an LV. If the TARG hasn't been used
3085 * before, or is of that type, reuse it; otherwise use a mortal
3086 * instead. Note that LVs can have an extended lifetime, so also
3087 * dont reuse if refcount > 1 (bug #20933) */
3088 if (SvTYPE(TARG) > SVt_NULL) {
3089 if ( (SvTYPE(TARG) == SVt_PVLV)
3090 ? (!lvalue || SvREFCNT(TARG) > 1)
3093 TARG = sv_newmortal();
3097 sv_setpvn(TARG, tmps, rem);
3098 #ifdef USE_LOCALE_COLLATE
3099 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3104 SV* repl_sv_copy = NULL;
3106 if (repl_need_utf8_upgrade) {
3107 repl_sv_copy = newSVsv(repl_sv);
3108 sv_utf8_upgrade(repl_sv_copy);
3109 repl = SvPV(repl_sv_copy, repl_len);
3110 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3112 sv_insert(sv, pos, rem, repl, repl_len);
3116 SvREFCNT_dec(repl_sv_copy);
3118 else if (lvalue) { /* it's an lvalue! */
3119 if (!SvGMAGICAL(sv)) {
3123 if (ckWARN(WARN_SUBSTR))
3124 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3125 "Attempt to use reference as lvalue in substr");
3127 if (SvOK(sv)) /* is it defined ? */
3128 (void)SvPOK_only_UTF8(sv);
3130 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3133 if (SvTYPE(TARG) < SVt_PVLV) {
3134 sv_upgrade(TARG, SVt_PVLV);
3135 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3141 if (LvTARG(TARG) != sv) {
3143 SvREFCNT_dec(LvTARG(TARG));
3144 LvTARG(TARG) = SvREFCNT_inc(sv);
3146 LvTARGOFF(TARG) = upos;
3147 LvTARGLEN(TARG) = urem;
3151 PUSHs(TARG); /* avoid SvSETMAGIC here */
3158 register IV size = POPi;
3159 register IV offset = POPi;
3160 register SV *src = POPs;
3161 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3163 SvTAINTED_off(TARG); /* decontaminate */
3164 if (lvalue) { /* it's an lvalue! */
3165 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3166 TARG = sv_newmortal();
3167 if (SvTYPE(TARG) < SVt_PVLV) {
3168 sv_upgrade(TARG, SVt_PVLV);
3169 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3172 if (LvTARG(TARG) != src) {
3174 SvREFCNT_dec(LvTARG(TARG));
3175 LvTARG(TARG) = SvREFCNT_inc(src);
3177 LvTARGOFF(TARG) = offset;
3178 LvTARGLEN(TARG) = size;
3181 sv_setuv(TARG, do_vecget(src, offset, size));
3197 I32 arybase = PL_curcop->cop_arybase;
3204 offset = POPi - arybase;
3207 big_utf8 = DO_UTF8(big);
3208 little_utf8 = DO_UTF8(little);
3209 if (big_utf8 ^ little_utf8) {
3210 /* One needs to be upgraded. */
3211 SV *bytes = little_utf8 ? big : little;
3213 char *p = SvPV(bytes, len);
3215 temp = newSVpvn(p, len);
3218 sv_recode_to_utf8(temp, PL_encoding);
3220 sv_utf8_upgrade(temp);
3229 if (big_utf8 && offset > 0)
3230 sv_pos_u2b(big, &offset, 0);
3231 tmps = SvPV(big, biglen);
3234 else if (offset > (I32)biglen)
3236 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3237 (unsigned char*)tmps + biglen, little, 0)))
3240 retval = tmps2 - tmps;
3241 if (retval > 0 && big_utf8)
3242 sv_pos_b2u(big, &retval);
3245 PUSHi(retval + arybase);
3261 I32 arybase = PL_curcop->cop_arybase;
3269 big_utf8 = DO_UTF8(big);
3270 little_utf8 = DO_UTF8(little);
3271 if (big_utf8 ^ little_utf8) {
3272 /* One needs to be upgraded. */
3273 SV *bytes = little_utf8 ? big : little;
3275 char *p = SvPV(bytes, len);
3277 temp = newSVpvn(p, len);
3280 sv_recode_to_utf8(temp, PL_encoding);
3282 sv_utf8_upgrade(temp);
3291 tmps2 = SvPV(little, llen);
3292 tmps = SvPV(big, blen);
3297 if (offset > 0 && big_utf8)
3298 sv_pos_u2b(big, &offset, 0);
3299 offset = offset - arybase + llen;
3303 else if (offset > (I32)blen)
3305 if (!(tmps2 = rninstr(tmps, tmps + offset,
3306 tmps2, tmps2 + llen)))
3309 retval = tmps2 - tmps;
3310 if (retval > 0 && big_utf8)
3311 sv_pos_b2u(big, &retval);
3314 PUSHi(retval + arybase);
3320 dSP; dMARK; dORIGMARK; dTARGET;
3321 do_sprintf(TARG, SP-MARK, MARK+1);
3322 TAINT_IF(SvTAINTED(TARG));
3323 if (DO_UTF8(*(MARK+1)))
3335 U8 *s = (U8*)SvPVx(argsv, len);
3338 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3339 tmpsv = sv_2mortal(newSVsv(argsv));
3340 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3344 XPUSHu(DO_UTF8(argsv) ?
3345 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3357 (void)SvUPGRADE(TARG,SVt_PV);
3359 if (value > 255 && !IN_BYTES) {
3360 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3361 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3362 SvCUR_set(TARG, tmps - SvPVX(TARG));
3364 (void)SvPOK_only(TARG);
3373 *tmps++ = (char)value;
3375 (void)SvPOK_only(TARG);
3376 if (PL_encoding && !IN_BYTES) {
3377 sv_recode_to_utf8(TARG, PL_encoding);
3379 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3380 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3384 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3385 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3401 char *tmps = SvPV(left, len);
3403 if (DO_UTF8(left)) {
3404 /* If Unicode, try to downgrade.
3405 * If not possible, croak.
3406 * Yes, we made this up. */
3407 SV* tsv = sv_2mortal(newSVsv(left));
3410 sv_utf8_downgrade(tsv, FALSE);
3413 # ifdef USE_ITHREADS
3415 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3416 /* This should be threadsafe because in ithreads there is only
3417 * one thread per interpreter. If this would not be true,
3418 * we would need a mutex to protect this malloc. */
3419 PL_reentrant_buffer->_crypt_struct_buffer =
3420 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3421 #if defined(__GLIBC__) || defined(__EMX__)
3422 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3423 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3424 /* work around glibc-2.2.5 bug */
3425 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3429 # endif /* HAS_CRYPT_R */
3430 # endif /* USE_ITHREADS */
3432 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3434 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3440 "The crypt() function is unimplemented due to excessive paranoia.");
3453 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3454 UTF8_IS_START(*s)) {
3455 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3459 utf8_to_uvchr(s, &ulen);
3460 toTITLE_utf8(s, tmpbuf, &tculen);
3461 utf8_to_uvchr(tmpbuf, 0);
3463 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3465 /* slen is the byte length of the whole SV.
3466 * ulen is the byte length of the original Unicode character
3467 * stored as UTF-8 at s.
3468 * tculen is the byte length of the freshly titlecased
3469 * Unicode character stored as UTF-8 at tmpbuf.
3470 * We first set the result to be the titlecased character,
3471 * and then append the rest of the SV data. */
3472 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3474 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3479 s = (U8*)SvPV_force_nomg(sv, slen);
3480 Copy(tmpbuf, s, tculen, U8);
3484 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3486 SvUTF8_off(TARG); /* decontaminate */
3487 sv_setsv_nomg(TARG, sv);
3491 s = (U8*)SvPV_force_nomg(sv, slen);
3493 if (IN_LOCALE_RUNTIME) {
3496 *s = toUPPER_LC(*s);
3515 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3516 UTF8_IS_START(*s)) {
3518 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3522 toLOWER_utf8(s, tmpbuf, &ulen);
3523 uv = utf8_to_uvchr(tmpbuf, 0);
3524 tend = uvchr_to_utf8(tmpbuf, uv);
3526 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3528 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3530 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3535 s = (U8*)SvPV_force_nomg(sv, slen);
3536 Copy(tmpbuf, s, ulen, U8);
3540 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3542 SvUTF8_off(TARG); /* decontaminate */
3543 sv_setsv_nomg(TARG, sv);
3547 s = (U8*)SvPV_force_nomg(sv, slen);
3549 if (IN_LOCALE_RUNTIME) {
3552 *s = toLOWER_LC(*s);
3575 U8 tmpbuf[UTF8_MAXBYTES+1];
3577 s = (U8*)SvPV_nomg(sv,len);
3579 SvUTF8_off(TARG); /* decontaminate */
3580 sv_setpvn(TARG, "", 0);
3584 STRLEN min = len + 1;
3586 (void)SvUPGRADE(TARG, SVt_PV);
3588 (void)SvPOK_only(TARG);
3589 d = (U8*)SvPVX(TARG);
3592 STRLEN u = UTF8SKIP(s);
3594 toUPPER_utf8(s, tmpbuf, &ulen);
3595 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3596 /* If the eventually required minimum size outgrows
3597 * the available space, we need to grow. */
3598 UV o = d - (U8*)SvPVX(TARG);
3600 /* If someone uppercases one million U+03B0s we
3601 * SvGROW() one million times. Or we could try
3602 * guessing how much to allocate without allocating
3603 * too much. Such is life. */
3605 d = (U8*)SvPVX(TARG) + o;
3607 Copy(tmpbuf, d, ulen, U8);
3613 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3618 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3620 SvUTF8_off(TARG); /* decontaminate */
3621 sv_setsv_nomg(TARG, sv);
3625 s = (U8*)SvPV_force_nomg(sv, len);
3627 register U8 *send = s + len;
3629 if (IN_LOCALE_RUNTIME) {
3632 for (; s < send; s++)
3633 *s = toUPPER_LC(*s);
3636 for (; s < send; s++)
3658 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3660 s = (U8*)SvPV_nomg(sv,len);
3662 SvUTF8_off(TARG); /* decontaminate */
3663 sv_setpvn(TARG, "", 0);
3667 STRLEN min = len + 1;
3669 (void)SvUPGRADE(TARG, SVt_PV);
3671 (void)SvPOK_only(TARG);
3672 d = (U8*)SvPVX(TARG);
3675 STRLEN u = UTF8SKIP(s);
3676 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3678 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3679 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3681 * Now if the sigma is NOT followed by
3682 * /$ignorable_sequence$cased_letter/;
3683 * and it IS preceded by
3684 * /$cased_letter$ignorable_sequence/;
3685 * where $ignorable_sequence is
3686 * [\x{2010}\x{AD}\p{Mn}]*
3687 * and $cased_letter is
3688 * [\p{Ll}\p{Lo}\p{Lt}]
3689 * then it should be mapped to 0x03C2,
3690 * (GREEK SMALL LETTER FINAL SIGMA),
3691 * instead of staying 0x03A3.
3692 * "should be": in other words,
3693 * this is not implemented yet.
3694 * See lib/unicore/SpecialCasing.txt.
3697 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3698 /* If the eventually required minimum size outgrows
3699 * the available space, we need to grow. */
3700 UV o = d - (U8*)SvPVX(TARG);
3702 /* If someone lowercases one million U+0130s we
3703 * SvGROW() one million times. Or we could try
3704 * guessing how much to allocate without allocating.
3705 * too much. Such is life. */
3707 d = (U8*)SvPVX(TARG) + o;
3709 Copy(tmpbuf, d, ulen, U8);
3715 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3720 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3722 SvUTF8_off(TARG); /* decontaminate */
3723 sv_setsv_nomg(TARG, sv);
3728 s = (U8*)SvPV_force_nomg(sv, len);
3730 register U8 *send = s + len;
3732 if (IN_LOCALE_RUNTIME) {
3735 for (; s < send; s++)
3736 *s = toLOWER_LC(*s);
3739 for (; s < send; s++)
3753 register char *s = SvPV(sv,len);
3756 SvUTF8_off(TARG); /* decontaminate */
3758 (void)SvUPGRADE(TARG, SVt_PV);
3759 SvGROW(TARG, (len * 2) + 1);
3763 if (UTF8_IS_CONTINUED(*s)) {
3764 STRLEN ulen = UTF8SKIP(s);
3788 SvCUR_set(TARG, d - SvPVX(TARG));
3789 (void)SvPOK_only_UTF8(TARG);
3792 sv_setpvn(TARG, s, len);
3794 if (SvSMAGICAL(TARG))
3803 dSP; dMARK; dORIGMARK;
3805 register AV* av = (AV*)POPs;
3806 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3807 I32 arybase = PL_curcop->cop_arybase;
3810 if (SvTYPE(av) == SVt_PVAV) {
3811 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3813 for (svp = MARK + 1; svp <= SP; svp++) {
3818 if (max > AvMAX(av))
3821 while (++MARK <= SP) {
3822 elem = SvIVx(*MARK);
3826 svp = av_fetch(av, elem, lval);
3828 if (!svp || *svp == &PL_sv_undef)
3829 DIE(aTHX_ PL_no_aelem, elem);
3830 if (PL_op->op_private & OPpLVAL_INTRO)
3831 save_aelem(av, elem, svp);
3833 *MARK = svp ? *svp : &PL_sv_undef;
3836 if (GIMME != G_ARRAY) {
3838 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3844 /* Associative arrays. */
3849 HV *hash = (HV*)POPs;
3851 I32 gimme = GIMME_V;
3854 /* might clobber stack_sp */
3855 entry = hv_iternext(hash);
3860 SV* sv = hv_iterkeysv(entry);
3861 PUSHs(sv); /* won't clobber stack_sp */
3862 if (gimme == G_ARRAY) {
3865 /* might clobber stack_sp */
3866 val = hv_iterval(hash, entry);
3871 else if (gimme == G_SCALAR)
3890 I32 gimme = GIMME_V;
3891 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3895 if (PL_op->op_private & OPpSLICE) {
3899 hvtype = SvTYPE(hv);
3900 if (hvtype == SVt_PVHV) { /* hash element */
3901 while (++MARK <= SP) {
3902 sv = hv_delete_ent(hv, *MARK, discard, 0);
3903 *MARK = sv ? sv : &PL_sv_undef;
3906 else if (hvtype == SVt_PVAV) { /* array element */
3907 if (PL_op->op_flags & OPf_SPECIAL) {
3908 while (++MARK <= SP) {
3909 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3910 *MARK = sv ? sv : &PL_sv_undef;
3915 DIE(aTHX_ "Not a HASH reference");
3918 else if (gimme == G_SCALAR) {
3923 *++MARK = &PL_sv_undef;
3930 if (SvTYPE(hv) == SVt_PVHV)
3931 sv = hv_delete_ent(hv, keysv, discard, 0);
3932 else if (SvTYPE(hv) == SVt_PVAV) {
3933 if (PL_op->op_flags & OPf_SPECIAL)
3934 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3936 DIE(aTHX_ "panic: avhv_delete no longer supported");
3939 DIE(aTHX_ "Not a HASH reference");
3954 if (PL_op->op_private & OPpEXISTS_SUB) {
3958 cv = sv_2cv(sv, &hv, &gv, FALSE);
3961 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3967 if (SvTYPE(hv) == SVt_PVHV) {
3968 if (hv_exists_ent(hv, tmpsv, 0))
3971 else if (SvTYPE(hv) == SVt_PVAV) {
3972 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3973 if (av_exists((AV*)hv, SvIV(tmpsv)))
3978 DIE(aTHX_ "Not a HASH reference");
3985 dSP; dMARK; dORIGMARK;
3986 register HV *hv = (HV*)POPs;
3987 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3988 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3989 bool other_magic = FALSE;
3995 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3996 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3997 /* Try to preserve the existenceness of a tied hash
3998 * element by using EXISTS and DELETE if possible.
3999 * Fallback to FETCH and STORE otherwise */
4000 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4001 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4002 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4005 while (++MARK <= SP) {
4009 bool preeminent = FALSE;
4012 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4013 hv_exists_ent(hv, keysv, 0);
4016 he = hv_fetch_ent(hv, keysv, lval, 0);
4017 svp = he ? &HeVAL(he) : 0;
4020 if (!svp || *svp == &PL_sv_undef) {
4022 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
4026 save_helem(hv, keysv, svp);
4029 char *key = SvPV(keysv, keylen);
4030 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4034 *MARK = svp ? *svp : &PL_sv_undef;
4036 if (GIMME != G_ARRAY) {
4038 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4044 /* List operators. */
4049 if (GIMME != G_ARRAY) {
4051 *MARK = *SP; /* unwanted list, return last item */
4053 *MARK = &PL_sv_undef;
4062 SV **lastrelem = PL_stack_sp;
4063 SV **lastlelem = PL_stack_base + POPMARK;
4064 SV **firstlelem = PL_stack_base + POPMARK + 1;
4065 register SV **firstrelem = lastlelem + 1;
4066 I32 arybase = PL_curcop->cop_arybase;
4067 I32 lval = PL_op->op_flags & OPf_MOD;
4068 I32 is_something_there = lval;
4070 register I32 max = lastrelem - lastlelem;
4071 register SV **lelem;
4074 if (GIMME != G_ARRAY) {
4075 ix = SvIVx(*lastlelem);
4080 if (ix < 0 || ix >= max)
4081 *firstlelem = &PL_sv_undef;
4083 *firstlelem = firstrelem[ix];
4089 SP = firstlelem - 1;
4093 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4099 if (ix < 0 || ix >= max)
4100 *lelem = &PL_sv_undef;
4102 is_something_there = TRUE;
4103 if (!(*lelem = firstrelem[ix]))
4104 *lelem = &PL_sv_undef;
4107 if (is_something_there)
4110 SP = firstlelem - 1;
4116 dSP; dMARK; dORIGMARK;
4117 I32 items = SP - MARK;
4118 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4119 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4126 dSP; dMARK; dORIGMARK;
4127 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4131 SV *val = NEWSV(46, 0);
4133 sv_setsv(val, *++MARK);
4134 else if (ckWARN(WARN_MISC))
4135 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4136 (void)hv_store_ent(hv,key,val,0);
4145 dVAR; dSP; dMARK; dORIGMARK;
4146 register AV *ary = (AV*)*++MARK;
4150 register I32 offset;
4151 register I32 length;
4158 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4159 *MARK-- = SvTIED_obj((SV*)ary, mg);
4163 call_method("SPLICE",GIMME_V);
4172 offset = i = SvIVx(*MARK);
4174 offset += AvFILLp(ary) + 1;
4176 offset -= PL_curcop->cop_arybase;
4178 DIE(aTHX_ PL_no_aelem, i);
4180 length = SvIVx(*MARK++);
4182 length += AvFILLp(ary) - offset + 1;
4188 length = AvMAX(ary) + 1; /* close enough to infinity */
4192 length = AvMAX(ary) + 1;
4194 if (offset > AvFILLp(ary) + 1) {
4195 if (ckWARN(WARN_MISC))
4196 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4197 offset = AvFILLp(ary) + 1;
4199 after = AvFILLp(ary) + 1 - (offset + length);
4200 if (after < 0) { /* not that much array */
4201 length += after; /* offset+length now in array */
4207 /* At this point, MARK .. SP-1 is our new LIST */
4210 diff = newlen - length;
4211 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4214 /* make new elements SVs now: avoid problems if they're from the array */
4215 for (dst = MARK, i = newlen; i; i--) {
4217 *dst++ = newSVsv(h);
4220 if (diff < 0) { /* shrinking the area */
4222 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4223 Copy(MARK, tmparyval, newlen, SV*);
4226 MARK = ORIGMARK + 1;
4227 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4228 MEXTEND(MARK, length);
4229 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4231 EXTEND_MORTAL(length);
4232 for (i = length, dst = MARK; i; i--) {
4233 sv_2mortal(*dst); /* free them eventualy */
4240 *MARK = AvARRAY(ary)[offset+length-1];
4243 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4244 SvREFCNT_dec(*dst++); /* free them now */
4247 AvFILLp(ary) += diff;
4249 /* pull up or down? */
4251 if (offset < after) { /* easier to pull up */
4252 if (offset) { /* esp. if nothing to pull */
4253 src = &AvARRAY(ary)[offset-1];
4254 dst = src - diff; /* diff is negative */
4255 for (i = offset; i > 0; i--) /* can't trust Copy */
4259 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4263 if (after) { /* anything to pull down? */
4264 src = AvARRAY(ary) + offset + length;
4265 dst = src + diff; /* diff is negative */
4266 Move(src, dst, after, SV*);
4268 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4269 /* avoid later double free */
4273 dst[--i] = &PL_sv_undef;
4276 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4277 Safefree(tmparyval);
4280 else { /* no, expanding (or same) */
4282 New(452, tmparyval, length, SV*); /* so remember deletion */
4283 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4286 if (diff > 0) { /* expanding */
4288 /* push up or down? */
4290 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4294 Move(src, dst, offset, SV*);
4296 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4298 AvFILLp(ary) += diff;
4301 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4302 av_extend(ary, AvFILLp(ary) + diff);
4303 AvFILLp(ary) += diff;
4306 dst = AvARRAY(ary) + AvFILLp(ary);
4308 for (i = after; i; i--) {
4316 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4319 MARK = ORIGMARK + 1;
4320 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4322 Copy(tmparyval, MARK, length, SV*);
4324 EXTEND_MORTAL(length);
4325 for (i = length, dst = MARK; i; i--) {
4326 sv_2mortal(*dst); /* free them eventualy */
4330 Safefree(tmparyval);
4334 else if (length--) {
4335 *MARK = tmparyval[length];
4338 while (length-- > 0)
4339 SvREFCNT_dec(tmparyval[length]);
4341 Safefree(tmparyval);
4344 *MARK = &PL_sv_undef;
4352 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4353 register AV *ary = (AV*)*++MARK;
4354 register SV *sv = &PL_sv_undef;
4357 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4358 *MARK-- = SvTIED_obj((SV*)ary, mg);
4362 call_method("PUSH",G_SCALAR|G_DISCARD);
4367 /* Why no pre-extend of ary here ? */
4368 for (++MARK; MARK <= SP; MARK++) {
4371 sv_setsv(sv, *MARK);
4376 PUSHi( AvFILL(ary) + 1 );
4384 SV *sv = av_pop(av);
4386 (void)sv_2mortal(sv);
4395 SV *sv = av_shift(av);
4400 (void)sv_2mortal(sv);
4407 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4408 register AV *ary = (AV*)*++MARK;
4413 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4414 *MARK-- = SvTIED_obj((SV*)ary, mg);
4418 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4423 av_unshift(ary, SP - MARK);
4425 sv = newSVsv(*++MARK);
4426 (void)av_store(ary, i++, sv);
4430 PUSHi( AvFILL(ary) + 1 );
4440 if (GIMME == G_ARRAY) {
4447 /* safe as long as stack cannot get extended in the above */
4452 register char *down;
4458 SvUTF8_off(TARG); /* decontaminate */
4460 do_join(TARG, &PL_sv_no, MARK, SP);
4462 sv_setsv(TARG, (SP > MARK)
4464 : (padoff_du = find_rundefsvoffset(),
4465 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4466 ? DEFSV : PAD_SVl(padoff_du)));
4467 up = SvPV_force(TARG, len);
4469 if (DO_UTF8(TARG)) { /* first reverse each character */
4470 U8* s = (U8*)SvPVX(TARG);
4471 U8* send = (U8*)(s + len);
4473 if (UTF8_IS_INVARIANT(*s)) {
4478 if (!utf8_to_uvchr(s, 0))
4482 down = (char*)(s - 1);
4483 /* reverse this character */
4487 *down-- = (char)tmp;
4493 down = SvPVX(TARG) + len - 1;
4497 *down-- = (char)tmp;
4499 (void)SvPOK_only_UTF8(TARG);
4511 register IV limit = POPi; /* note, negative is forever */
4514 register char *s = SvPV(sv, len);
4515 bool do_utf8 = DO_UTF8(sv);
4516 char *strend = s + len;
4518 register REGEXP *rx;
4522 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4523 I32 maxiters = slen + 10;
4526 I32 origlimit = limit;
4529 I32 gimme = GIMME_V;
4530 I32 oldsave = PL_savestack_ix;
4531 I32 make_mortal = 1;
4533 MAGIC *mg = (MAGIC *) NULL;
4536 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4541 DIE(aTHX_ "panic: pp_split");
4544 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4545 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4547 RX_MATCH_UTF8_set(rx, do_utf8);
4549 if (pm->op_pmreplroot) {
4551 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4553 ary = GvAVn((GV*)pm->op_pmreplroot);
4556 else if (gimme != G_ARRAY)
4557 ary = GvAVn(PL_defgv);
4560 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4566 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4568 XPUSHs(SvTIED_obj((SV*)ary, mg));
4574 for (i = AvFILLp(ary); i >= 0; i--)
4575 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4577 /* temporarily switch stacks */
4578 SAVESWITCHSTACK(PL_curstack, ary);
4582 base = SP - PL_stack_base;
4584 if (pm->op_pmflags & PMf_SKIPWHITE) {
4585 if (pm->op_pmflags & PMf_LOCALE) {
4586 while (isSPACE_LC(*s))
4594 if (pm->op_pmflags & PMf_MULTILINE) {
4599 limit = maxiters + 2;
4600 if (pm->op_pmflags & PMf_WHITE) {
4603 while (m < strend &&
4604 !((pm->op_pmflags & PMf_LOCALE)
4605 ? isSPACE_LC(*m) : isSPACE(*m)))
4610 dstr = newSVpvn(s, m-s);
4614 (void)SvUTF8_on(dstr);
4618 while (s < strend &&
4619 ((pm->op_pmflags & PMf_LOCALE)
4620 ? isSPACE_LC(*s) : isSPACE(*s)))
4624 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4627 for (m = s; m < strend && *m != '\n'; m++) ;
4631 dstr = newSVpvn(s, m-s);
4635 (void)SvUTF8_on(dstr);
4640 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4641 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4642 && (rx->reganch & ROPT_CHECK_ALL)
4643 && !(rx->reganch & ROPT_ANCH)) {
4644 int tail = (rx->reganch & RE_INTUIT_TAIL);
4645 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4648 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4650 char c = *SvPV(csv, n_a);
4653 for (m = s; m < strend && *m != c; m++) ;
4656 dstr = newSVpvn(s, m-s);
4660 (void)SvUTF8_on(dstr);
4662 /* The rx->minlen is in characters but we want to step
4663 * s ahead by bytes. */
4665 s = (char*)utf8_hop((U8*)m, len);
4667 s = m + len; /* Fake \n at the end */
4672 while (s < strend && --limit &&
4673 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4674 csv, multiline ? FBMrf_MULTILINE : 0)) )
4677 dstr = newSVpvn(s, m-s);
4681 (void)SvUTF8_on(dstr);
4683 /* The rx->minlen is in characters but we want to step
4684 * s ahead by bytes. */
4686 s = (char*)utf8_hop((U8*)m, len);
4688 s = m + len; /* Fake \n at the end */
4693 maxiters += slen * rx->nparens;
4694 while (s < strend && --limit)
4697 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4701 TAINT_IF(RX_MATCH_TAINTED(rx));
4702 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4707 strend = s + (strend - m);
4709 m = rx->startp[0] + orig;
4710 dstr = newSVpvn(s, m-s);
4714 (void)SvUTF8_on(dstr);
4717 for (i = 1; i <= (I32)rx->nparens; i++) {
4718 s = rx->startp[i] + orig;
4719 m = rx->endp[i] + orig;
4721 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4722 parens that didn't match -- they should be set to
4723 undef, not the empty string */
4724 if (m >= orig && s >= orig) {
4725 dstr = newSVpvn(s, m-s);
4728 dstr = &PL_sv_undef; /* undef, not "" */
4732 (void)SvUTF8_on(dstr);
4736 s = rx->endp[0] + orig;
4740 iters = (SP - PL_stack_base) - base;
4741 if (iters > maxiters)
4742 DIE(aTHX_ "Split loop");
4744 /* keep field after final delim? */
4745 if (s < strend || (iters && origlimit)) {
4746 STRLEN l = strend - s;
4747 dstr = newSVpvn(s, l);
4751 (void)SvUTF8_on(dstr);
4755 else if (!origlimit) {
4756 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4757 if (TOPs && !make_mortal)
4760 *SP-- = &PL_sv_undef;
4765 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4769 if (SvSMAGICAL(ary)) {
4774 if (gimme == G_ARRAY) {
4776 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4784 call_method("PUSH",G_SCALAR|G_DISCARD);
4787 if (gimme == G_ARRAY) {
4788 /* EXTEND should not be needed - we just popped them */
4790 for (i=0; i < iters; i++) {
4791 SV **svp = av_fetch(ary, i, FALSE);
4792 PUSHs((svp) ? *svp : &PL_sv_undef);
4799 if (gimme == G_ARRAY)
4814 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4815 || SvTYPE(retsv) == SVt_PVCV) {
4816 retsv = refto(retsv);
4824 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4829 * c-indentation-style: bsd
4831 * indent-tabs-mode: t
4834 * vim: shiftwidth=4: