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);
178 SvOOK_off(sv); /* backoff */
184 SvRV_set(sv, (SV*)gv);
189 if (PL_op->op_flags & OPf_REF ||
190 PL_op->op_private & HINT_STRICT_REFS)
191 DIE(aTHX_ PL_no_usym, "a symbol");
192 if (ckWARN(WARN_UNINITIALIZED))
196 if ((PL_op->op_flags & OPf_SPECIAL) &&
197 !(PL_op->op_flags & OPf_MOD))
199 SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
201 && (!is_gv_magical_sv(sv,0)
202 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
208 if (PL_op->op_private & HINT_STRICT_REFS)
209 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
210 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
214 if (PL_op->op_private & OPpLVAL_INTRO)
215 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
227 tryAMAGICunDEREF(to_sv);
230 switch (SvTYPE(sv)) {
234 DIE(aTHX_ "Not a SCALAR reference");
240 if (SvTYPE(gv) != SVt_PVGV) {
241 if (SvGMAGICAL(sv)) {
247 if (PL_op->op_flags & OPf_REF ||
248 PL_op->op_private & HINT_STRICT_REFS)
249 DIE(aTHX_ PL_no_usym, "a SCALAR");
250 if (ckWARN(WARN_UNINITIALIZED))
254 if ((PL_op->op_flags & OPf_SPECIAL) &&
255 !(PL_op->op_flags & OPf_MOD))
257 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
259 && (!is_gv_magical_sv(sv, 0)
260 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
266 if (PL_op->op_private & HINT_STRICT_REFS)
267 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
268 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
273 if (PL_op->op_flags & OPf_MOD) {
274 if (PL_op->op_private & OPpLVAL_INTRO) {
275 if (cUNOP->op_first->op_type == OP_NULL)
276 sv = save_scalar((GV*)TOPs);
278 sv = save_scalar(gv);
280 Perl_croak(aTHX_ PL_no_localize_ref);
282 else if (PL_op->op_private & OPpDEREF)
283 vivify_ref(sv, PL_op->op_private & OPpDEREF);
293 SV *sv = AvARYLEN(av);
295 AvARYLEN(av) = sv = NEWSV(0,0);
296 sv_upgrade(sv, SVt_IV);
297 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
305 dSP; dTARGET; dPOPss;
307 if (PL_op->op_flags & OPf_MOD || LVRET) {
308 if (SvTYPE(TARG) < SVt_PVLV) {
309 sv_upgrade(TARG, SVt_PVLV);
310 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
314 if (LvTARG(TARG) != sv) {
316 SvREFCNT_dec(LvTARG(TARG));
317 LvTARG(TARG) = SvREFCNT_inc(sv);
319 PUSHs(TARG); /* no SvSETMAGIC */
325 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
326 mg = mg_find(sv, PERL_MAGIC_regex_global);
327 if (mg && mg->mg_len >= 0) {
331 PUSHi(i + PL_curcop->cop_arybase);
345 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
346 /* (But not in defined().) */
347 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
350 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
351 if ((PL_op->op_private & OPpLVAL_INTRO)) {
352 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
355 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
359 cv = (CV*)&PL_sv_undef;
373 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
374 char *s = SvPVX(TOPs);
375 if (strnEQ(s, "CORE::", 6)) {
378 code = keyword(s + 6, SvCUR(TOPs) - 6);
379 if (code < 0) { /* Overridable. */
380 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
381 int i = 0, n = 0, seen_question = 0;
383 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
385 if (code == -KEY_chop || code == -KEY_chomp)
387 while (i < MAXO) { /* The slow way. */
388 if (strEQ(s + 6, PL_op_name[i])
389 || strEQ(s + 6, PL_op_desc[i]))
395 goto nonesuch; /* Should not happen... */
397 oa = PL_opargs[i] >> OASHIFT;
399 if (oa & OA_OPTIONAL && !seen_question) {
403 else if (n && str[0] == ';' && seen_question)
404 goto set; /* XXXX system, exec */
405 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
406 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
407 /* But globs are already references (kinda) */
408 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
412 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
416 ret = sv_2mortal(newSVpvn(str, n - 1));
418 else if (code) /* Non-Overridable */
420 else { /* None such */
422 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
426 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
428 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
437 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
439 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
455 if (GIMME != G_ARRAY) {
459 *MARK = &PL_sv_undef;
460 *MARK = refto(*MARK);
464 EXTEND_MORTAL(SP - MARK);
466 *MARK = refto(*MARK);
471 S_refto(pTHX_ SV *sv)
475 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
478 if (!(sv = LvTARG(sv)))
481 (void)SvREFCNT_inc(sv);
483 else if (SvTYPE(sv) == SVt_PVAV) {
484 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
487 (void)SvREFCNT_inc(sv);
489 else if (SvPADTMP(sv) && !IS_PADGV(sv))
493 (void)SvREFCNT_inc(sv);
496 sv_upgrade(rv, SVt_RV);
510 if (sv && SvGMAGICAL(sv))
513 if (!sv || !SvROK(sv))
517 pv = sv_reftype(sv,TRUE);
518 PUSHp(pv, strlen(pv));
528 stash = CopSTASH(PL_curcop);
534 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
535 Perl_croak(aTHX_ "Attempt to bless into a reference");
537 if (ckWARN(WARN_MISC) && len == 0)
538 Perl_warner(aTHX_ packWARN(WARN_MISC),
539 "Explicit blessing to '' (assuming package main)");
540 stash = gv_stashpvn(ptr, len, TRUE);
543 (void)sv_bless(TOPs, stash);
557 elem = SvPV(sv, n_a);
562 /* elem will always be NUL terminated. */
563 const char *elem2 = elem + 1;
566 if (strEQ(elem2, "RRAY"))
567 tmpRef = (SV*)GvAV(gv);
570 if (strEQ(elem2, "ODE"))
571 tmpRef = (SV*)GvCVu(gv);
574 if (strEQ(elem2, "ILEHANDLE")) {
575 /* finally deprecated in 5.8.0 */
576 deprecate("*glob{FILEHANDLE}");
577 tmpRef = (SV*)GvIOp(gv);
580 if (strEQ(elem2, "ORMAT"))
581 tmpRef = (SV*)GvFORM(gv);
584 if (strEQ(elem2, "LOB"))
588 if (strEQ(elem2, "ASH"))
589 tmpRef = (SV*)GvHV(gv);
592 if (*elem2 == 'O' && !elem[2])
593 tmpRef = (SV*)GvIOp(gv);
596 if (strEQ(elem2, "AME"))
597 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
600 if (strEQ(elem2, "ACKAGE")) {
601 const char *name = HvNAME(GvSTASH(gv));
602 sv = newSVpv(name ? name : "__ANON__", 0);
606 if (strEQ(elem2, "CALAR"))
621 /* Pattern matching */
626 register unsigned char *s;
629 register I32 *sfirst;
633 if (sv == PL_lastscream) {
639 SvSCREAM_off(PL_lastscream);
640 SvREFCNT_dec(PL_lastscream);
642 PL_lastscream = SvREFCNT_inc(sv);
645 s = (unsigned char*)(SvPV(sv, len));
649 if (pos > PL_maxscream) {
650 if (PL_maxscream < 0) {
651 PL_maxscream = pos + 80;
652 New(301, PL_screamfirst, 256, I32);
653 New(302, PL_screamnext, PL_maxscream, I32);
656 PL_maxscream = pos + pos / 4;
657 Renew(PL_screamnext, PL_maxscream, I32);
661 sfirst = PL_screamfirst;
662 snext = PL_screamnext;
664 if (!sfirst || !snext)
665 DIE(aTHX_ "do_study: out of memory");
667 for (ch = 256; ch; --ch)
674 snext[pos] = sfirst[ch] - pos;
681 /* piggyback on m//g magic */
682 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
691 if (PL_op->op_flags & OPf_STACKED)
693 else if (PL_op->op_private & OPpTARGET_MY)
699 TARG = sv_newmortal();
704 /* Lvalue operators. */
716 dSP; dMARK; dTARGET; dORIGMARK;
718 do_chop(TARG, *++MARK);
727 SETi(do_chomp(TOPs));
734 register I32 count = 0;
737 count += do_chomp(POPs);
748 if (!sv || !SvANY(sv))
750 switch (SvTYPE(sv)) {
752 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
753 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
757 if (HvARRAY(sv) || SvGMAGICAL(sv)
758 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
762 if (CvROOT(sv) || CvXSUB(sv))
779 if (!PL_op->op_private) {
788 SV_CHECK_THINKFIRST_COW_DROP(sv);
790 switch (SvTYPE(sv)) {
800 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
801 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
802 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
806 /* let user-undef'd sub keep its identity */
807 GV* gv = CvGV((CV*)sv);
814 SvSetMagicSV(sv, &PL_sv_undef);
818 Newz(602, gp, 1, GP);
819 GvGP(sv) = gp_ref(gp);
820 GvSV(sv) = NEWSV(72,0);
821 GvLINE(sv) = CopLINE(PL_curcop);
827 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
830 SvPV_set(sv, Nullch);
843 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
844 DIE(aTHX_ PL_no_modify);
845 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
846 && SvIVX(TOPs) != IV_MIN)
848 SvIV_set(TOPs, SvIVX(TOPs) - 1);
849 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
860 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
861 DIE(aTHX_ PL_no_modify);
862 sv_setsv(TARG, TOPs);
863 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
864 && SvIVX(TOPs) != IV_MAX)
866 SvIV_set(TOPs, SvIVX(TOPs) + 1);
867 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
882 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
883 DIE(aTHX_ PL_no_modify);
884 sv_setsv(TARG, TOPs);
885 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
886 && SvIVX(TOPs) != IV_MIN)
888 SvIV_set(TOPs, SvIVX(TOPs) - 1);
889 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
898 /* Ordinary operators. */
903 #ifdef PERL_PRESERVE_IVUV
906 tryAMAGICbin(pow,opASSIGN);
907 #ifdef PERL_PRESERVE_IVUV
908 /* For integer to integer power, we do the calculation by hand wherever
909 we're sure it is safe; otherwise we call pow() and try to convert to
910 integer afterwards. */
914 bool baseuok = SvUOK(TOPm1s);
918 baseuv = SvUVX(TOPm1s);
920 IV iv = SvIVX(TOPm1s);
923 baseuok = TRUE; /* effectively it's a UV now */
925 baseuv = -iv; /* abs, baseuok == false records sign */
939 goto float_it; /* Can't do negative powers this way. */
942 /* now we have integer ** positive integer. */
945 /* foo & (foo - 1) is zero only for a power of 2. */
946 if (!(baseuv & (baseuv - 1))) {
947 /* We are raising power-of-2 to a positive integer.
948 The logic here will work for any base (even non-integer
949 bases) but it can be less accurate than
950 pow (base,power) or exp (power * log (base)) when the
951 intermediate values start to spill out of the mantissa.
952 With powers of 2 we know this can't happen.
953 And powers of 2 are the favourite thing for perl
954 programmers to notice ** not doing what they mean. */
956 NV base = baseuok ? baseuv : -(NV)baseuv;
959 for (; power; base *= base, n++) {
960 /* Do I look like I trust gcc with long longs here?
962 UV bit = (UV)1 << (UV)n;
965 /* Only bother to clear the bit if it is set. */
967 /* Avoid squaring base again if we're done. */
968 if (power == 0) break;
976 register unsigned int highbit = 8 * sizeof(UV);
977 register unsigned int lowbit = 0;
978 register unsigned int diff;
979 bool odd_power = (bool)(power & 1);
980 while ((diff = (highbit - lowbit) >> 1)) {
981 if (baseuv & ~((1 << (lowbit + diff)) - 1))
986 /* we now have baseuv < 2 ** highbit */
987 if (power * highbit <= 8 * sizeof(UV)) {
988 /* result will definitely fit in UV, so use UV math
989 on same algorithm as above */
990 register UV result = 1;
991 register UV base = baseuv;
993 for (; power; base *= base, n++) {
994 register UV bit = (UV)1 << (UV)n;
998 if (power == 0) break;
1002 if (baseuok || !odd_power)
1003 /* answer is positive */
1005 else if (result <= (UV)IV_MAX)
1006 /* answer negative, fits in IV */
1007 SETi( -(IV)result );
1008 else if (result == (UV)IV_MIN)
1009 /* 2's complement assumption: special case IV_MIN */
1012 /* answer negative, doesn't fit */
1013 SETn( -(NV)result );
1024 SETn( Perl_pow( left, right) );
1025 #ifdef PERL_PRESERVE_IVUV
1035 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1036 #ifdef PERL_PRESERVE_IVUV
1039 /* Unless the left argument is integer in range we are going to have to
1040 use NV maths. Hence only attempt to coerce the right argument if
1041 we know the left is integer. */
1042 /* Left operand is defined, so is it IV? */
1043 SvIV_please(TOPm1s);
1044 if (SvIOK(TOPm1s)) {
1045 bool auvok = SvUOK(TOPm1s);
1046 bool buvok = SvUOK(TOPs);
1047 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1048 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1055 alow = SvUVX(TOPm1s);
1057 IV aiv = SvIVX(TOPm1s);
1060 auvok = TRUE; /* effectively it's a UV now */
1062 alow = -aiv; /* abs, auvok == false records sign */
1068 IV biv = SvIVX(TOPs);
1071 buvok = TRUE; /* effectively it's a UV now */
1073 blow = -biv; /* abs, buvok == false records sign */
1077 /* If this does sign extension on unsigned it's time for plan B */
1078 ahigh = alow >> (4 * sizeof (UV));
1080 bhigh = blow >> (4 * sizeof (UV));
1082 if (ahigh && bhigh) {
1083 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1084 which is overflow. Drop to NVs below. */
1085 } else if (!ahigh && !bhigh) {
1086 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1087 so the unsigned multiply cannot overflow. */
1088 UV product = alow * blow;
1089 if (auvok == buvok) {
1090 /* -ve * -ve or +ve * +ve gives a +ve result. */
1094 } else if (product <= (UV)IV_MIN) {
1095 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1096 /* -ve result, which could overflow an IV */
1098 SETi( -(IV)product );
1100 } /* else drop to NVs below. */
1102 /* One operand is large, 1 small */
1105 /* swap the operands */
1107 bhigh = blow; /* bhigh now the temp var for the swap */
1111 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1112 multiplies can't overflow. shift can, add can, -ve can. */
1113 product_middle = ahigh * blow;
1114 if (!(product_middle & topmask)) {
1115 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1117 product_middle <<= (4 * sizeof (UV));
1118 product_low = alow * blow;
1120 /* as for pp_add, UV + something mustn't get smaller.
1121 IIRC ANSI mandates this wrapping *behaviour* for
1122 unsigned whatever the actual representation*/
1123 product_low += product_middle;
1124 if (product_low >= product_middle) {
1125 /* didn't overflow */
1126 if (auvok == buvok) {
1127 /* -ve * -ve or +ve * +ve gives a +ve result. */
1129 SETu( product_low );
1131 } else if (product_low <= (UV)IV_MIN) {
1132 /* 2s complement assumption again */
1133 /* -ve result, which could overflow an IV */
1135 SETi( -(IV)product_low );
1137 } /* else drop to NVs below. */
1139 } /* product_middle too large */
1140 } /* ahigh && bhigh */
1141 } /* SvIOK(TOPm1s) */
1146 SETn( left * right );
1153 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1154 /* Only try to do UV divide first
1155 if ((SLOPPYDIVIDE is true) or
1156 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1158 The assumption is that it is better to use floating point divide
1159 whenever possible, only doing integer divide first if we can't be sure.
1160 If NV_PRESERVES_UV is true then we know at compile time that no UV
1161 can be too large to preserve, so don't need to compile the code to
1162 test the size of UVs. */
1165 # define PERL_TRY_UV_DIVIDE
1166 /* ensure that 20./5. == 4. */
1168 # ifdef PERL_PRESERVE_IVUV
1169 # ifndef NV_PRESERVES_UV
1170 # define PERL_TRY_UV_DIVIDE
1175 #ifdef PERL_TRY_UV_DIVIDE
1178 SvIV_please(TOPm1s);
1179 if (SvIOK(TOPm1s)) {
1180 bool left_non_neg = SvUOK(TOPm1s);
1181 bool right_non_neg = SvUOK(TOPs);
1185 if (right_non_neg) {
1186 right = SvUVX(TOPs);
1189 IV biv = SvIVX(TOPs);
1192 right_non_neg = TRUE; /* effectively it's a UV now */
1198 /* historically undef()/0 gives a "Use of uninitialized value"
1199 warning before dieing, hence this test goes here.
1200 If it were immediately before the second SvIV_please, then
1201 DIE() would be invoked before left was even inspected, so
1202 no inpsection would give no warning. */
1204 DIE(aTHX_ "Illegal division by zero");
1207 left = SvUVX(TOPm1s);
1210 IV aiv = SvIVX(TOPm1s);
1213 left_non_neg = TRUE; /* effectively it's a UV now */
1222 /* For sloppy divide we always attempt integer division. */
1224 /* Otherwise we only attempt it if either or both operands
1225 would not be preserved by an NV. If both fit in NVs
1226 we fall through to the NV divide code below. However,
1227 as left >= right to ensure integer result here, we know that
1228 we can skip the test on the right operand - right big
1229 enough not to be preserved can't get here unless left is
1232 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1235 /* Integer division can't overflow, but it can be imprecise. */
1236 UV result = left / right;
1237 if (result * right == left) {
1238 SP--; /* result is valid */
1239 if (left_non_neg == right_non_neg) {
1240 /* signs identical, result is positive. */
1244 /* 2s complement assumption */
1245 if (result <= (UV)IV_MIN)
1246 SETi( -(IV)result );
1248 /* It's exact but too negative for IV. */
1249 SETn( -(NV)result );
1252 } /* tried integer divide but it was not an integer result */
1253 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1254 } /* left wasn't SvIOK */
1255 } /* right wasn't SvIOK */
1256 #endif /* PERL_TRY_UV_DIVIDE */
1260 DIE(aTHX_ "Illegal division by zero");
1261 PUSHn( left / right );
1268 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1272 bool left_neg = FALSE;
1273 bool right_neg = FALSE;
1274 bool use_double = FALSE;
1275 bool dright_valid = FALSE;
1281 right_neg = !SvUOK(TOPs);
1283 right = SvUVX(POPs);
1285 IV biv = SvIVX(POPs);
1288 right_neg = FALSE; /* effectively it's a UV now */
1296 right_neg = dright < 0;
1299 if (dright < UV_MAX_P1) {
1300 right = U_V(dright);
1301 dright_valid = TRUE; /* In case we need to use double below. */
1307 /* At this point use_double is only true if right is out of range for
1308 a UV. In range NV has been rounded down to nearest UV and
1309 use_double false. */
1311 if (!use_double && SvIOK(TOPs)) {
1313 left_neg = !SvUOK(TOPs);
1317 IV aiv = SvIVX(POPs);
1320 left_neg = FALSE; /* effectively it's a UV now */
1329 left_neg = dleft < 0;
1333 /* This should be exactly the 5.6 behaviour - if left and right are
1334 both in range for UV then use U_V() rather than floor. */
1336 if (dleft < UV_MAX_P1) {
1337 /* right was in range, so is dleft, so use UVs not double.
1341 /* left is out of range for UV, right was in range, so promote
1342 right (back) to double. */
1344 /* The +0.5 is used in 5.6 even though it is not strictly
1345 consistent with the implicit +0 floor in the U_V()
1346 inside the #if 1. */
1347 dleft = Perl_floor(dleft + 0.5);
1350 dright = Perl_floor(dright + 0.5);
1360 DIE(aTHX_ "Illegal modulus zero");
1362 dans = Perl_fmod(dleft, dright);
1363 if ((left_neg != right_neg) && dans)
1364 dans = dright - dans;
1367 sv_setnv(TARG, dans);
1373 DIE(aTHX_ "Illegal modulus zero");
1376 if ((left_neg != right_neg) && ans)
1379 /* XXX may warn: unary minus operator applied to unsigned type */
1380 /* could change -foo to be (~foo)+1 instead */
1381 if (ans <= ~((UV)IV_MAX)+1)
1382 sv_setiv(TARG, ~ans+1);
1384 sv_setnv(TARG, -(NV)ans);
1387 sv_setuv(TARG, ans);
1396 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1406 count = IV_MAX; /* The best we can do? */
1417 else if (SvNOKp(sv)) {
1426 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1428 I32 items = SP - MARK;
1430 static const char oom_list_extend[] =
1431 "Out of memory during list extend";
1433 max = items * count;
1434 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1435 /* Did the max computation overflow? */
1436 if (items > 0 && max > 0 && (max < items || max < count))
1437 Perl_croak(aTHX_ oom_list_extend);
1442 /* This code was intended to fix 20010809.028:
1445 for (($x =~ /./g) x 2) {
1446 print chop; # "abcdabcd" expected as output.
1449 * but that change (#11635) broke this code:
1451 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1453 * I can't think of a better fix that doesn't introduce
1454 * an efficiency hit by copying the SVs. The stack isn't
1455 * refcounted, and mortalisation obviously doesn't
1456 * Do The Right Thing when the stack has more than
1457 * one pointer to the same mortal value.
1461 *SP = sv_2mortal(newSVsv(*SP));
1471 repeatcpy((char*)(MARK + items), (char*)MARK,
1472 items * sizeof(SV*), count - 1);
1475 else if (count <= 0)
1478 else { /* Note: mark already snarfed by pp_list */
1482 static const char oom_string_extend[] =
1483 "Out of memory during string extend";
1485 SvSetSV(TARG, tmpstr);
1486 SvPV_force(TARG, len);
1487 isutf = DO_UTF8(TARG);
1492 IV max = count * len;
1493 if (len > ((MEM_SIZE)~0)/count)
1494 Perl_croak(aTHX_ oom_string_extend);
1495 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1496 SvGROW(TARG, (count * len) + 1);
1497 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1498 SvCUR_set(TARG, SvCUR(TARG) * count);
1500 *SvEND(TARG) = '\0';
1503 (void)SvPOK_only_UTF8(TARG);
1505 (void)SvPOK_only(TARG);
1507 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1508 /* The parser saw this as a list repeat, and there
1509 are probably several items on the stack. But we're
1510 in scalar context, and there's no pp_list to save us
1511 now. So drop the rest of the items -- robin@kitsite.com
1524 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1525 useleft = USE_LEFT(TOPm1s);
1526 #ifdef PERL_PRESERVE_IVUV
1527 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1528 "bad things" happen if you rely on signed integers wrapping. */
1531 /* Unless the left argument is integer in range we are going to have to
1532 use NV maths. Hence only attempt to coerce the right argument if
1533 we know the left is integer. */
1534 register UV auv = 0;
1540 a_valid = auvok = 1;
1541 /* left operand is undef, treat as zero. */
1543 /* Left operand is defined, so is it IV? */
1544 SvIV_please(TOPm1s);
1545 if (SvIOK(TOPm1s)) {
1546 if ((auvok = SvUOK(TOPm1s)))
1547 auv = SvUVX(TOPm1s);
1549 register IV aiv = SvIVX(TOPm1s);
1552 auvok = 1; /* Now acting as a sign flag. */
1553 } else { /* 2s complement assumption for IV_MIN */
1561 bool result_good = 0;
1564 bool buvok = SvUOK(TOPs);
1569 register IV biv = SvIVX(TOPs);
1576 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1577 else "IV" now, independent of how it came in.
1578 if a, b represents positive, A, B negative, a maps to -A etc
1583 all UV maths. negate result if A negative.
1584 subtract if signs same, add if signs differ. */
1586 if (auvok ^ buvok) {
1595 /* Must get smaller */
1600 if (result <= buv) {
1601 /* result really should be -(auv-buv). as its negation
1602 of true value, need to swap our result flag */
1614 if (result <= (UV)IV_MIN)
1615 SETi( -(IV)result );
1617 /* result valid, but out of range for IV. */
1618 SETn( -(NV)result );
1622 } /* Overflow, drop through to NVs. */
1626 useleft = USE_LEFT(TOPm1s);
1630 /* left operand is undef, treat as zero - value */
1634 SETn( TOPn - value );
1641 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1644 if (PL_op->op_private & HINT_INTEGER) {
1658 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1661 if (PL_op->op_private & HINT_INTEGER) {
1675 dSP; tryAMAGICbinSET(lt,0);
1676 #ifdef PERL_PRESERVE_IVUV
1679 SvIV_please(TOPm1s);
1680 if (SvIOK(TOPm1s)) {
1681 bool auvok = SvUOK(TOPm1s);
1682 bool buvok = SvUOK(TOPs);
1684 if (!auvok && !buvok) { /* ## IV < IV ## */
1685 IV aiv = SvIVX(TOPm1s);
1686 IV biv = SvIVX(TOPs);
1689 SETs(boolSV(aiv < biv));
1692 if (auvok && buvok) { /* ## UV < UV ## */
1693 UV auv = SvUVX(TOPm1s);
1694 UV buv = SvUVX(TOPs);
1697 SETs(boolSV(auv < buv));
1700 if (auvok) { /* ## UV < IV ## */
1707 /* As (a) is a UV, it's >=0, so it cannot be < */
1712 SETs(boolSV(auv < (UV)biv));
1715 { /* ## IV < UV ## */
1719 aiv = SvIVX(TOPm1s);
1721 /* As (b) is a UV, it's >=0, so it must be < */
1728 SETs(boolSV((UV)aiv < buv));
1734 #ifndef NV_PRESERVES_UV
1735 #ifdef PERL_PRESERVE_IVUV
1738 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1740 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1746 SETs(boolSV(TOPn < value));
1753 dSP; tryAMAGICbinSET(gt,0);
1754 #ifdef PERL_PRESERVE_IVUV
1757 SvIV_please(TOPm1s);
1758 if (SvIOK(TOPm1s)) {
1759 bool auvok = SvUOK(TOPm1s);
1760 bool buvok = SvUOK(TOPs);
1762 if (!auvok && !buvok) { /* ## IV > IV ## */
1763 IV aiv = SvIVX(TOPm1s);
1764 IV biv = SvIVX(TOPs);
1767 SETs(boolSV(aiv > biv));
1770 if (auvok && buvok) { /* ## UV > UV ## */
1771 UV auv = SvUVX(TOPm1s);
1772 UV buv = SvUVX(TOPs);
1775 SETs(boolSV(auv > buv));
1778 if (auvok) { /* ## UV > IV ## */
1785 /* As (a) is a UV, it's >=0, so it must be > */
1790 SETs(boolSV(auv > (UV)biv));
1793 { /* ## IV > UV ## */
1797 aiv = SvIVX(TOPm1s);
1799 /* As (b) is a UV, it's >=0, so it cannot be > */
1806 SETs(boolSV((UV)aiv > buv));
1812 #ifndef NV_PRESERVES_UV
1813 #ifdef PERL_PRESERVE_IVUV
1816 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1818 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1824 SETs(boolSV(TOPn > value));
1831 dSP; tryAMAGICbinSET(le,0);
1832 #ifdef PERL_PRESERVE_IVUV
1835 SvIV_please(TOPm1s);
1836 if (SvIOK(TOPm1s)) {
1837 bool auvok = SvUOK(TOPm1s);
1838 bool buvok = SvUOK(TOPs);
1840 if (!auvok && !buvok) { /* ## IV <= IV ## */
1841 IV aiv = SvIVX(TOPm1s);
1842 IV biv = SvIVX(TOPs);
1845 SETs(boolSV(aiv <= biv));
1848 if (auvok && buvok) { /* ## UV <= UV ## */
1849 UV auv = SvUVX(TOPm1s);
1850 UV buv = SvUVX(TOPs);
1853 SETs(boolSV(auv <= buv));
1856 if (auvok) { /* ## UV <= IV ## */
1863 /* As (a) is a UV, it's >=0, so a cannot be <= */
1868 SETs(boolSV(auv <= (UV)biv));
1871 { /* ## IV <= UV ## */
1875 aiv = SvIVX(TOPm1s);
1877 /* As (b) is a UV, it's >=0, so a must be <= */
1884 SETs(boolSV((UV)aiv <= buv));
1890 #ifndef NV_PRESERVES_UV
1891 #ifdef PERL_PRESERVE_IVUV
1894 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1896 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1902 SETs(boolSV(TOPn <= value));
1909 dSP; tryAMAGICbinSET(ge,0);
1910 #ifdef PERL_PRESERVE_IVUV
1913 SvIV_please(TOPm1s);
1914 if (SvIOK(TOPm1s)) {
1915 bool auvok = SvUOK(TOPm1s);
1916 bool buvok = SvUOK(TOPs);
1918 if (!auvok && !buvok) { /* ## IV >= IV ## */
1919 IV aiv = SvIVX(TOPm1s);
1920 IV biv = SvIVX(TOPs);
1923 SETs(boolSV(aiv >= biv));
1926 if (auvok && buvok) { /* ## UV >= UV ## */
1927 UV auv = SvUVX(TOPm1s);
1928 UV buv = SvUVX(TOPs);
1931 SETs(boolSV(auv >= buv));
1934 if (auvok) { /* ## UV >= IV ## */
1941 /* As (a) is a UV, it's >=0, so it must be >= */
1946 SETs(boolSV(auv >= (UV)biv));
1949 { /* ## IV >= UV ## */
1953 aiv = SvIVX(TOPm1s);
1955 /* As (b) is a UV, it's >=0, so a cannot be >= */
1962 SETs(boolSV((UV)aiv >= buv));
1968 #ifndef NV_PRESERVES_UV
1969 #ifdef PERL_PRESERVE_IVUV
1972 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1974 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1980 SETs(boolSV(TOPn >= value));
1987 dSP; tryAMAGICbinSET(ne,0);
1988 #ifndef NV_PRESERVES_UV
1989 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1991 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1995 #ifdef PERL_PRESERVE_IVUV
1998 SvIV_please(TOPm1s);
1999 if (SvIOK(TOPm1s)) {
2000 bool auvok = SvUOK(TOPm1s);
2001 bool buvok = SvUOK(TOPs);
2003 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2004 /* Casting IV to UV before comparison isn't going to matter
2005 on 2s complement. On 1s complement or sign&magnitude
2006 (if we have any of them) it could make negative zero
2007 differ from normal zero. As I understand it. (Need to
2008 check - is negative zero implementation defined behaviour
2010 UV buv = SvUVX(POPs);
2011 UV auv = SvUVX(TOPs);
2013 SETs(boolSV(auv != buv));
2016 { /* ## Mixed IV,UV ## */
2020 /* != is commutative so swap if needed (save code) */
2022 /* swap. top of stack (b) is the iv */
2026 /* As (a) is a UV, it's >0, so it cannot be == */
2035 /* As (b) is a UV, it's >0, so it cannot be == */
2039 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2041 SETs(boolSV((UV)iv != uv));
2049 SETs(boolSV(TOPn != value));
2056 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2057 #ifndef NV_PRESERVES_UV
2058 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2059 UV right = PTR2UV(SvRV(POPs));
2060 UV left = PTR2UV(SvRV(TOPs));
2061 SETi((left > right) - (left < right));
2065 #ifdef PERL_PRESERVE_IVUV
2066 /* Fortunately it seems NaN isn't IOK */
2069 SvIV_please(TOPm1s);
2070 if (SvIOK(TOPm1s)) {
2071 bool leftuvok = SvUOK(TOPm1s);
2072 bool rightuvok = SvUOK(TOPs);
2074 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2075 IV leftiv = SvIVX(TOPm1s);
2076 IV rightiv = SvIVX(TOPs);
2078 if (leftiv > rightiv)
2080 else if (leftiv < rightiv)
2084 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2085 UV leftuv = SvUVX(TOPm1s);
2086 UV rightuv = SvUVX(TOPs);
2088 if (leftuv > rightuv)
2090 else if (leftuv < rightuv)
2094 } else if (leftuvok) { /* ## UV <=> IV ## */
2098 rightiv = SvIVX(TOPs);
2100 /* As (a) is a UV, it's >=0, so it cannot be < */
2103 leftuv = SvUVX(TOPm1s);
2104 if (leftuv > (UV)rightiv) {
2106 } else if (leftuv < (UV)rightiv) {
2112 } else { /* ## IV <=> UV ## */
2116 leftiv = SvIVX(TOPm1s);
2118 /* As (b) is a UV, it's >=0, so it must be < */
2121 rightuv = SvUVX(TOPs);
2122 if ((UV)leftiv > rightuv) {
2124 } else if ((UV)leftiv < rightuv) {
2142 if (Perl_isnan(left) || Perl_isnan(right)) {
2146 value = (left > right) - (left < right);
2150 else if (left < right)
2152 else if (left > right)
2166 dSP; tryAMAGICbinSET(slt,0);
2169 int cmp = (IN_LOCALE_RUNTIME
2170 ? sv_cmp_locale(left, right)
2171 : sv_cmp(left, right));
2172 SETs(boolSV(cmp < 0));
2179 dSP; tryAMAGICbinSET(sgt,0);
2182 int cmp = (IN_LOCALE_RUNTIME
2183 ? sv_cmp_locale(left, right)
2184 : sv_cmp(left, right));
2185 SETs(boolSV(cmp > 0));
2192 dSP; tryAMAGICbinSET(sle,0);
2195 int cmp = (IN_LOCALE_RUNTIME
2196 ? sv_cmp_locale(left, right)
2197 : sv_cmp(left, right));
2198 SETs(boolSV(cmp <= 0));
2205 dSP; tryAMAGICbinSET(sge,0);
2208 int cmp = (IN_LOCALE_RUNTIME
2209 ? sv_cmp_locale(left, right)
2210 : sv_cmp(left, right));
2211 SETs(boolSV(cmp >= 0));
2218 dSP; tryAMAGICbinSET(seq,0);
2221 SETs(boolSV(sv_eq(left, right)));
2228 dSP; tryAMAGICbinSET(sne,0);
2231 SETs(boolSV(!sv_eq(left, right)));
2238 dSP; dTARGET; tryAMAGICbin(scmp,0);
2241 int cmp = (IN_LOCALE_RUNTIME
2242 ? sv_cmp_locale(left, right)
2243 : sv_cmp(left, right));
2251 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2254 if (SvGMAGICAL(left)) mg_get(left);
2255 if (SvGMAGICAL(right)) mg_get(right);
2256 if (SvNIOKp(left) || SvNIOKp(right)) {
2257 if (PL_op->op_private & HINT_INTEGER) {
2258 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2262 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2267 do_vop(PL_op->op_type, TARG, left, right);
2276 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2279 if (SvGMAGICAL(left)) mg_get(left);
2280 if (SvGMAGICAL(right)) mg_get(right);
2281 if (SvNIOKp(left) || SvNIOKp(right)) {
2282 if (PL_op->op_private & HINT_INTEGER) {
2283 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2287 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2292 do_vop(PL_op->op_type, TARG, left, right);
2301 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2304 if (SvGMAGICAL(left)) mg_get(left);
2305 if (SvGMAGICAL(right)) mg_get(right);
2306 if (SvNIOKp(left) || SvNIOKp(right)) {
2307 if (PL_op->op_private & HINT_INTEGER) {
2308 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2312 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2317 do_vop(PL_op->op_type, TARG, left, right);
2326 dSP; dTARGET; tryAMAGICun(neg);
2329 int flags = SvFLAGS(sv);
2332 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2333 /* It's publicly an integer, or privately an integer-not-float */
2336 if (SvIVX(sv) == IV_MIN) {
2337 /* 2s complement assumption. */
2338 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2341 else if (SvUVX(sv) <= IV_MAX) {
2346 else if (SvIVX(sv) != IV_MIN) {
2350 #ifdef PERL_PRESERVE_IVUV
2359 else if (SvPOKp(sv)) {
2361 char *s = SvPV(sv, len);
2362 if (isIDFIRST(*s)) {
2363 sv_setpvn(TARG, "-", 1);
2366 else if (*s == '+' || *s == '-') {
2368 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2370 else if (DO_UTF8(sv)) {
2373 goto oops_its_an_int;
2375 sv_setnv(TARG, -SvNV(sv));
2377 sv_setpvn(TARG, "-", 1);
2384 goto oops_its_an_int;
2385 sv_setnv(TARG, -SvNV(sv));
2397 dSP; tryAMAGICunSET(not);
2398 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2404 dSP; dTARGET; tryAMAGICun(compl);
2410 if (PL_op->op_private & HINT_INTEGER) {
2411 IV i = ~SvIV_nomg(sv);
2415 UV u = ~SvUV_nomg(sv);
2424 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2425 sv_setsv_nomg(TARG, sv);
2426 tmps = (U8*)SvPV_force(TARG, len);
2429 /* Calculate exact length, let's not estimate. */
2438 while (tmps < send) {
2439 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2440 tmps += UTF8SKIP(tmps);
2441 targlen += UNISKIP(~c);
2447 /* Now rewind strings and write them. */
2451 Newz(0, result, targlen + 1, U8);
2452 while (tmps < send) {
2453 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2454 tmps += UTF8SKIP(tmps);
2455 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2459 sv_setpvn(TARG, (char*)result, targlen);
2463 Newz(0, result, nchar + 1, U8);
2464 while (tmps < send) {
2465 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2466 tmps += UTF8SKIP(tmps);
2471 sv_setpvn(TARG, (char*)result, nchar);
2480 register long *tmpl;
2481 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2484 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2489 for ( ; anum > 0; anum--, tmps++)
2498 /* integer versions of some of the above */
2502 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2505 SETi( left * right );
2512 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2516 DIE(aTHX_ "Illegal division by zero");
2517 value = POPi / value;
2526 /* This is the vanilla old i_modulo. */
2527 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2531 DIE(aTHX_ "Illegal modulus zero");
2532 SETi( left % right );
2537 #if defined(__GLIBC__) && IVSIZE == 8
2541 /* This is the i_modulo with the workaround for the _moddi3 bug
2542 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2543 * See below for pp_i_modulo. */
2544 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2548 DIE(aTHX_ "Illegal modulus zero");
2549 SETi( left % PERL_ABS(right) );
2557 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2561 DIE(aTHX_ "Illegal modulus zero");
2562 /* The assumption is to use hereafter the old vanilla version... */
2564 PL_ppaddr[OP_I_MODULO] =
2565 &Perl_pp_i_modulo_0;
2566 /* .. but if we have glibc, we might have a buggy _moddi3
2567 * (at least glicb 2.2.5 is known to have this bug), in other
2568 * words our integer modulus with negative quad as the second
2569 * argument might be broken. Test for this and re-patch the
2570 * opcode dispatch table if that is the case, remembering to
2571 * also apply the workaround so that this first round works
2572 * right, too. See [perl #9402] for more information. */
2573 #if defined(__GLIBC__) && IVSIZE == 8
2577 /* Cannot do this check with inlined IV constants since
2578 * that seems to work correctly even with the buggy glibc. */
2580 /* Yikes, we have the bug.
2581 * Patch in the workaround version. */
2583 PL_ppaddr[OP_I_MODULO] =
2584 &Perl_pp_i_modulo_1;
2585 /* Make certain we work right this time, too. */
2586 right = PERL_ABS(right);
2590 SETi( left % right );
2597 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2600 SETi( left + right );
2607 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2610 SETi( left - right );
2617 dSP; tryAMAGICbinSET(lt,0);
2620 SETs(boolSV(left < right));
2627 dSP; tryAMAGICbinSET(gt,0);
2630 SETs(boolSV(left > right));
2637 dSP; tryAMAGICbinSET(le,0);
2640 SETs(boolSV(left <= right));
2647 dSP; tryAMAGICbinSET(ge,0);
2650 SETs(boolSV(left >= right));
2657 dSP; tryAMAGICbinSET(eq,0);
2660 SETs(boolSV(left == right));
2667 dSP; tryAMAGICbinSET(ne,0);
2670 SETs(boolSV(left != right));
2677 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2684 else if (left < right)
2695 dSP; dTARGET; tryAMAGICun(neg);
2700 /* High falutin' math. */
2704 dSP; dTARGET; tryAMAGICbin(atan2,0);
2707 SETn(Perl_atan2(left, right));
2714 dSP; dTARGET; tryAMAGICun(sin);
2718 value = Perl_sin(value);
2726 dSP; dTARGET; tryAMAGICun(cos);
2730 value = Perl_cos(value);
2736 /* Support Configure command-line overrides for rand() functions.
2737 After 5.005, perhaps we should replace this by Configure support
2738 for drand48(), random(), or rand(). For 5.005, though, maintain
2739 compatibility by calling rand() but allow the user to override it.
2740 See INSTALL for details. --Andy Dougherty 15 July 1998
2742 /* Now it's after 5.005, and Configure supports drand48() and random(),
2743 in addition to rand(). So the overrides should not be needed any more.
2744 --Jarkko Hietaniemi 27 September 1998
2747 #ifndef HAS_DRAND48_PROTO
2748 extern double drand48 (void);
2761 if (!PL_srand_called) {
2762 (void)seedDrand01((Rand_seed_t)seed());
2763 PL_srand_called = TRUE;
2778 (void)seedDrand01((Rand_seed_t)anum);
2779 PL_srand_called = TRUE;
2786 dSP; dTARGET; tryAMAGICun(exp);
2790 value = Perl_exp(value);
2798 dSP; dTARGET; tryAMAGICun(log);
2803 SET_NUMERIC_STANDARD();
2804 DIE(aTHX_ "Can't take log of %"NVgf, value);
2806 value = Perl_log(value);
2814 dSP; dTARGET; tryAMAGICun(sqrt);
2819 SET_NUMERIC_STANDARD();
2820 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2822 value = Perl_sqrt(value);
2830 dSP; dTARGET; tryAMAGICun(int);
2833 IV iv = TOPi; /* attempt to convert to IV if possible. */
2834 /* XXX it's arguable that compiler casting to IV might be subtly
2835 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2836 else preferring IV has introduced a subtle behaviour change bug. OTOH
2837 relying on floating point to be accurate is a bug. */
2841 else if (SvIOK(TOPs)) {
2850 if (value < (NV)UV_MAX + 0.5) {
2853 SETn(Perl_floor(value));
2857 if (value > (NV)IV_MIN - 0.5) {
2860 SETn(Perl_ceil(value));
2870 dSP; dTARGET; tryAMAGICun(abs);
2872 /* This will cache the NV value if string isn't actually integer */
2877 else if (SvIOK(TOPs)) {
2878 /* IVX is precise */
2880 SETu(TOPu); /* force it to be numeric only */
2888 /* 2s complement assumption. Also, not really needed as
2889 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2909 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2915 tmps = (SvPVx(sv, len));
2917 /* If Unicode, try to downgrade
2918 * If not possible, croak. */
2919 SV* tsv = sv_2mortal(newSVsv(sv));
2922 sv_utf8_downgrade(tsv, FALSE);
2925 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2926 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2939 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2945 tmps = (SvPVx(sv, len));
2947 /* If Unicode, try to downgrade
2948 * If not possible, croak. */
2949 SV* tsv = sv_2mortal(newSVsv(sv));
2952 sv_utf8_downgrade(tsv, FALSE);
2955 while (*tmps && len && isSPACE(*tmps))
2960 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2961 else if (*tmps == 'b')
2962 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2964 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2966 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2983 SETi(sv_len_utf8(sv));
2999 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3001 const I32 arybase = PL_curcop->cop_arybase;
3003 const char *repl = 0;
3005 int num_args = PL_op->op_private & 7;
3006 bool repl_need_utf8_upgrade = FALSE;
3007 bool repl_is_utf8 = FALSE;
3009 SvTAINTED_off(TARG); /* decontaminate */
3010 SvUTF8_off(TARG); /* decontaminate */
3014 repl = SvPV(repl_sv, repl_len);
3015 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3025 sv_utf8_upgrade(sv);
3027 else if (DO_UTF8(sv))
3028 repl_need_utf8_upgrade = TRUE;
3030 tmps = SvPV(sv, curlen);
3032 utf8_curlen = sv_len_utf8(sv);
3033 if (utf8_curlen == curlen)
3036 curlen = utf8_curlen;
3041 if (pos >= arybase) {
3059 else if (len >= 0) {
3061 if (rem > (I32)curlen)
3076 Perl_croak(aTHX_ "substr outside of string");
3077 if (ckWARN(WARN_SUBSTR))
3078 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3085 sv_pos_u2b(sv, &pos, &rem);
3087 /* we either return a PV or an LV. If the TARG hasn't been used
3088 * before, or is of that type, reuse it; otherwise use a mortal
3089 * instead. Note that LVs can have an extended lifetime, so also
3090 * dont reuse if refcount > 1 (bug #20933) */
3091 if (SvTYPE(TARG) > SVt_NULL) {
3092 if ( (SvTYPE(TARG) == SVt_PVLV)
3093 ? (!lvalue || SvREFCNT(TARG) > 1)
3096 TARG = sv_newmortal();
3100 sv_setpvn(TARG, tmps, rem);
3101 #ifdef USE_LOCALE_COLLATE
3102 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3107 SV* repl_sv_copy = NULL;
3109 if (repl_need_utf8_upgrade) {
3110 repl_sv_copy = newSVsv(repl_sv);
3111 sv_utf8_upgrade(repl_sv_copy);
3112 repl = SvPV(repl_sv_copy, repl_len);
3113 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3115 sv_insert(sv, pos, rem, repl, repl_len);
3119 SvREFCNT_dec(repl_sv_copy);
3121 else if (lvalue) { /* it's an lvalue! */
3122 if (!SvGMAGICAL(sv)) {
3126 if (ckWARN(WARN_SUBSTR))
3127 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3128 "Attempt to use reference as lvalue in substr");
3130 if (SvOK(sv)) /* is it defined ? */
3131 (void)SvPOK_only_UTF8(sv);
3133 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3136 if (SvTYPE(TARG) < SVt_PVLV) {
3137 sv_upgrade(TARG, SVt_PVLV);
3138 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3144 if (LvTARG(TARG) != sv) {
3146 SvREFCNT_dec(LvTARG(TARG));
3147 LvTARG(TARG) = SvREFCNT_inc(sv);
3149 LvTARGOFF(TARG) = upos;
3150 LvTARGLEN(TARG) = urem;
3154 PUSHs(TARG); /* avoid SvSETMAGIC here */
3161 register IV size = POPi;
3162 register IV offset = POPi;
3163 register SV *src = POPs;
3164 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3166 SvTAINTED_off(TARG); /* decontaminate */
3167 if (lvalue) { /* it's an lvalue! */
3168 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3169 TARG = sv_newmortal();
3170 if (SvTYPE(TARG) < SVt_PVLV) {
3171 sv_upgrade(TARG, SVt_PVLV);
3172 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3175 if (LvTARG(TARG) != src) {
3177 SvREFCNT_dec(LvTARG(TARG));
3178 LvTARG(TARG) = SvREFCNT_inc(src);
3180 LvTARGOFF(TARG) = offset;
3181 LvTARGLEN(TARG) = size;
3184 sv_setuv(TARG, do_vecget(src, offset, size));
3200 I32 arybase = PL_curcop->cop_arybase;
3207 offset = POPi - arybase;
3210 big_utf8 = DO_UTF8(big);
3211 little_utf8 = DO_UTF8(little);
3212 if (big_utf8 ^ little_utf8) {
3213 /* One needs to be upgraded. */
3214 SV *bytes = little_utf8 ? big : little;
3216 char *p = SvPV(bytes, len);
3218 temp = newSVpvn(p, len);
3221 sv_recode_to_utf8(temp, PL_encoding);
3223 sv_utf8_upgrade(temp);
3232 if (big_utf8 && offset > 0)
3233 sv_pos_u2b(big, &offset, 0);
3234 tmps = SvPV(big, biglen);
3237 else if (offset > (I32)biglen)
3239 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3240 (unsigned char*)tmps + biglen, little, 0)))
3243 retval = tmps2 - tmps;
3244 if (retval > 0 && big_utf8)
3245 sv_pos_b2u(big, &retval);
3248 PUSHi(retval + arybase);
3264 I32 arybase = PL_curcop->cop_arybase;
3272 big_utf8 = DO_UTF8(big);
3273 little_utf8 = DO_UTF8(little);
3274 if (big_utf8 ^ little_utf8) {
3275 /* One needs to be upgraded. */
3276 SV *bytes = little_utf8 ? big : little;
3278 char *p = SvPV(bytes, len);
3280 temp = newSVpvn(p, len);
3283 sv_recode_to_utf8(temp, PL_encoding);
3285 sv_utf8_upgrade(temp);
3294 tmps2 = SvPV(little, llen);
3295 tmps = SvPV(big, blen);
3300 if (offset > 0 && big_utf8)
3301 sv_pos_u2b(big, &offset, 0);
3302 offset = offset - arybase + llen;
3306 else if (offset > (I32)blen)
3308 if (!(tmps2 = rninstr(tmps, tmps + offset,
3309 tmps2, tmps2 + llen)))
3312 retval = tmps2 - tmps;
3313 if (retval > 0 && big_utf8)
3314 sv_pos_b2u(big, &retval);
3317 PUSHi(retval + arybase);
3323 dSP; dMARK; dORIGMARK; dTARGET;
3324 do_sprintf(TARG, SP-MARK, MARK+1);
3325 TAINT_IF(SvTAINTED(TARG));
3326 if (DO_UTF8(*(MARK+1)))
3338 U8 *s = (U8*)SvPVx(argsv, len);
3341 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3342 tmpsv = sv_2mortal(newSVsv(argsv));
3343 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3347 XPUSHu(DO_UTF8(argsv) ?
3348 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3360 (void)SvUPGRADE(TARG,SVt_PV);
3362 if (value > 255 && !IN_BYTES) {
3363 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3364 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3365 SvCUR_set(TARG, tmps - SvPVX(TARG));
3367 (void)SvPOK_only(TARG);
3376 *tmps++ = (char)value;
3378 (void)SvPOK_only(TARG);
3379 if (PL_encoding && !IN_BYTES) {
3380 sv_recode_to_utf8(TARG, PL_encoding);
3382 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3383 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3387 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3388 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3404 char *tmps = SvPV(left, len);
3406 if (DO_UTF8(left)) {
3407 /* If Unicode, try to downgrade.
3408 * If not possible, croak.
3409 * Yes, we made this up. */
3410 SV* tsv = sv_2mortal(newSVsv(left));
3413 sv_utf8_downgrade(tsv, FALSE);
3416 # ifdef USE_ITHREADS
3418 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3419 /* This should be threadsafe because in ithreads there is only
3420 * one thread per interpreter. If this would not be true,
3421 * we would need a mutex to protect this malloc. */
3422 PL_reentrant_buffer->_crypt_struct_buffer =
3423 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3424 #if defined(__GLIBC__) || defined(__EMX__)
3425 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3426 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3427 /* work around glibc-2.2.5 bug */
3428 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3432 # endif /* HAS_CRYPT_R */
3433 # endif /* USE_ITHREADS */
3435 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3437 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3443 "The crypt() function is unimplemented due to excessive paranoia.");
3456 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3457 UTF8_IS_START(*s)) {
3458 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3462 utf8_to_uvchr(s, &ulen);
3463 toTITLE_utf8(s, tmpbuf, &tculen);
3464 utf8_to_uvchr(tmpbuf, 0);
3466 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3468 /* slen is the byte length of the whole SV.
3469 * ulen is the byte length of the original Unicode character
3470 * stored as UTF-8 at s.
3471 * tculen is the byte length of the freshly titlecased
3472 * Unicode character stored as UTF-8 at tmpbuf.
3473 * We first set the result to be the titlecased character,
3474 * and then append the rest of the SV data. */
3475 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3477 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3482 s = (U8*)SvPV_force_nomg(sv, slen);
3483 Copy(tmpbuf, s, tculen, U8);
3487 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3489 SvUTF8_off(TARG); /* decontaminate */
3490 sv_setsv_nomg(TARG, sv);
3494 s = (U8*)SvPV_force_nomg(sv, slen);
3496 if (IN_LOCALE_RUNTIME) {
3499 *s = toUPPER_LC(*s);
3518 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3519 UTF8_IS_START(*s)) {
3521 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3525 toLOWER_utf8(s, tmpbuf, &ulen);
3526 uv = utf8_to_uvchr(tmpbuf, 0);
3527 tend = uvchr_to_utf8(tmpbuf, uv);
3529 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3531 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3533 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3538 s = (U8*)SvPV_force_nomg(sv, slen);
3539 Copy(tmpbuf, s, ulen, U8);
3543 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3545 SvUTF8_off(TARG); /* decontaminate */
3546 sv_setsv_nomg(TARG, sv);
3550 s = (U8*)SvPV_force_nomg(sv, slen);
3552 if (IN_LOCALE_RUNTIME) {
3555 *s = toLOWER_LC(*s);
3578 U8 tmpbuf[UTF8_MAXBYTES+1];
3580 s = (U8*)SvPV_nomg(sv,len);
3582 SvUTF8_off(TARG); /* decontaminate */
3583 sv_setpvn(TARG, "", 0);
3587 STRLEN min = len + 1;
3589 (void)SvUPGRADE(TARG, SVt_PV);
3591 (void)SvPOK_only(TARG);
3592 d = (U8*)SvPVX(TARG);
3595 STRLEN u = UTF8SKIP(s);
3597 toUPPER_utf8(s, tmpbuf, &ulen);
3598 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3599 /* If the eventually required minimum size outgrows
3600 * the available space, we need to grow. */
3601 UV o = d - (U8*)SvPVX(TARG);
3603 /* If someone uppercases one million U+03B0s we
3604 * SvGROW() one million times. Or we could try
3605 * guessing how much to allocate without allocating
3606 * too much. Such is life. */
3608 d = (U8*)SvPVX(TARG) + o;
3610 Copy(tmpbuf, d, ulen, U8);
3616 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3621 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3623 SvUTF8_off(TARG); /* decontaminate */
3624 sv_setsv_nomg(TARG, sv);
3628 s = (U8*)SvPV_force_nomg(sv, len);
3630 register U8 *send = s + len;
3632 if (IN_LOCALE_RUNTIME) {
3635 for (; s < send; s++)
3636 *s = toUPPER_LC(*s);
3639 for (; s < send; s++)
3661 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3663 s = (U8*)SvPV_nomg(sv,len);
3665 SvUTF8_off(TARG); /* decontaminate */
3666 sv_setpvn(TARG, "", 0);
3670 STRLEN min = len + 1;
3672 (void)SvUPGRADE(TARG, SVt_PV);
3674 (void)SvPOK_only(TARG);
3675 d = (U8*)SvPVX(TARG);
3678 STRLEN u = UTF8SKIP(s);
3679 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3681 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3682 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3684 * Now if the sigma is NOT followed by
3685 * /$ignorable_sequence$cased_letter/;
3686 * and it IS preceded by
3687 * /$cased_letter$ignorable_sequence/;
3688 * where $ignorable_sequence is
3689 * [\x{2010}\x{AD}\p{Mn}]*
3690 * and $cased_letter is
3691 * [\p{Ll}\p{Lo}\p{Lt}]
3692 * then it should be mapped to 0x03C2,
3693 * (GREEK SMALL LETTER FINAL SIGMA),
3694 * instead of staying 0x03A3.
3695 * "should be": in other words,
3696 * this is not implemented yet.
3697 * See lib/unicore/SpecialCasing.txt.
3700 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3701 /* If the eventually required minimum size outgrows
3702 * the available space, we need to grow. */
3703 UV o = d - (U8*)SvPVX(TARG);
3705 /* If someone lowercases one million U+0130s we
3706 * SvGROW() one million times. Or we could try
3707 * guessing how much to allocate without allocating.
3708 * too much. Such is life. */
3710 d = (U8*)SvPVX(TARG) + o;
3712 Copy(tmpbuf, d, ulen, U8);
3718 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3723 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3725 SvUTF8_off(TARG); /* decontaminate */
3726 sv_setsv_nomg(TARG, sv);
3731 s = (U8*)SvPV_force_nomg(sv, len);
3733 register U8 *send = s + len;
3735 if (IN_LOCALE_RUNTIME) {
3738 for (; s < send; s++)
3739 *s = toLOWER_LC(*s);
3742 for (; s < send; s++)
3756 register char *s = SvPV(sv,len);
3759 SvUTF8_off(TARG); /* decontaminate */
3761 (void)SvUPGRADE(TARG, SVt_PV);
3762 SvGROW(TARG, (len * 2) + 1);
3766 if (UTF8_IS_CONTINUED(*s)) {
3767 STRLEN ulen = UTF8SKIP(s);
3791 SvCUR_set(TARG, d - SvPVX(TARG));
3792 (void)SvPOK_only_UTF8(TARG);
3795 sv_setpvn(TARG, s, len);
3797 if (SvSMAGICAL(TARG))
3806 dSP; dMARK; dORIGMARK;
3808 register AV* av = (AV*)POPs;
3809 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3810 I32 arybase = PL_curcop->cop_arybase;
3813 if (SvTYPE(av) == SVt_PVAV) {
3814 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3816 for (svp = MARK + 1; svp <= SP; svp++) {
3821 if (max > AvMAX(av))
3824 while (++MARK <= SP) {
3825 elem = SvIVx(*MARK);
3829 svp = av_fetch(av, elem, lval);
3831 if (!svp || *svp == &PL_sv_undef)
3832 DIE(aTHX_ PL_no_aelem, elem);
3833 if (PL_op->op_private & OPpLVAL_INTRO)
3834 save_aelem(av, elem, svp);
3836 *MARK = svp ? *svp : &PL_sv_undef;
3839 if (GIMME != G_ARRAY) {
3841 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3847 /* Associative arrays. */
3852 HV *hash = (HV*)POPs;
3854 I32 gimme = GIMME_V;
3857 /* might clobber stack_sp */
3858 entry = hv_iternext(hash);
3863 SV* sv = hv_iterkeysv(entry);
3864 PUSHs(sv); /* won't clobber stack_sp */
3865 if (gimme == G_ARRAY) {
3868 /* might clobber stack_sp */
3869 val = hv_iterval(hash, entry);
3874 else if (gimme == G_SCALAR)
3893 I32 gimme = GIMME_V;
3894 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3898 if (PL_op->op_private & OPpSLICE) {
3902 hvtype = SvTYPE(hv);
3903 if (hvtype == SVt_PVHV) { /* hash element */
3904 while (++MARK <= SP) {
3905 sv = hv_delete_ent(hv, *MARK, discard, 0);
3906 *MARK = sv ? sv : &PL_sv_undef;
3909 else if (hvtype == SVt_PVAV) { /* array element */
3910 if (PL_op->op_flags & OPf_SPECIAL) {
3911 while (++MARK <= SP) {
3912 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3913 *MARK = sv ? sv : &PL_sv_undef;
3918 DIE(aTHX_ "Not a HASH reference");
3921 else if (gimme == G_SCALAR) {
3926 *++MARK = &PL_sv_undef;
3933 if (SvTYPE(hv) == SVt_PVHV)
3934 sv = hv_delete_ent(hv, keysv, discard, 0);
3935 else if (SvTYPE(hv) == SVt_PVAV) {
3936 if (PL_op->op_flags & OPf_SPECIAL)
3937 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3939 DIE(aTHX_ "panic: avhv_delete no longer supported");
3942 DIE(aTHX_ "Not a HASH reference");
3957 if (PL_op->op_private & OPpEXISTS_SUB) {
3961 cv = sv_2cv(sv, &hv, &gv, FALSE);
3964 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3970 if (SvTYPE(hv) == SVt_PVHV) {
3971 if (hv_exists_ent(hv, tmpsv, 0))
3974 else if (SvTYPE(hv) == SVt_PVAV) {
3975 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3976 if (av_exists((AV*)hv, SvIV(tmpsv)))
3981 DIE(aTHX_ "Not a HASH reference");
3988 dSP; dMARK; dORIGMARK;
3989 register HV *hv = (HV*)POPs;
3990 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3991 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3992 bool other_magic = FALSE;
3998 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3999 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4000 /* Try to preserve the existenceness of a tied hash
4001 * element by using EXISTS and DELETE if possible.
4002 * Fallback to FETCH and STORE otherwise */
4003 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4004 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4005 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4008 while (++MARK <= SP) {
4012 bool preeminent = FALSE;
4015 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4016 hv_exists_ent(hv, keysv, 0);
4019 he = hv_fetch_ent(hv, keysv, lval, 0);
4020 svp = he ? &HeVAL(he) : 0;
4023 if (!svp || *svp == &PL_sv_undef) {
4025 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
4029 save_helem(hv, keysv, svp);
4032 char *key = SvPV(keysv, keylen);
4033 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4037 *MARK = svp ? *svp : &PL_sv_undef;
4039 if (GIMME != G_ARRAY) {
4041 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4047 /* List operators. */
4052 if (GIMME != G_ARRAY) {
4054 *MARK = *SP; /* unwanted list, return last item */
4056 *MARK = &PL_sv_undef;
4065 SV **lastrelem = PL_stack_sp;
4066 SV **lastlelem = PL_stack_base + POPMARK;
4067 SV **firstlelem = PL_stack_base + POPMARK + 1;
4068 register SV **firstrelem = lastlelem + 1;
4069 I32 arybase = PL_curcop->cop_arybase;
4070 I32 lval = PL_op->op_flags & OPf_MOD;
4071 I32 is_something_there = lval;
4073 register I32 max = lastrelem - lastlelem;
4074 register SV **lelem;
4077 if (GIMME != G_ARRAY) {
4078 ix = SvIVx(*lastlelem);
4083 if (ix < 0 || ix >= max)
4084 *firstlelem = &PL_sv_undef;
4086 *firstlelem = firstrelem[ix];
4092 SP = firstlelem - 1;
4096 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4102 if (ix < 0 || ix >= max)
4103 *lelem = &PL_sv_undef;
4105 is_something_there = TRUE;
4106 if (!(*lelem = firstrelem[ix]))
4107 *lelem = &PL_sv_undef;
4110 if (is_something_there)
4113 SP = firstlelem - 1;
4119 dSP; dMARK; dORIGMARK;
4120 I32 items = SP - MARK;
4121 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4122 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4129 dSP; dMARK; dORIGMARK;
4130 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4134 SV *val = NEWSV(46, 0);
4136 sv_setsv(val, *++MARK);
4137 else if (ckWARN(WARN_MISC))
4138 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4139 (void)hv_store_ent(hv,key,val,0);
4148 dSP; dMARK; dORIGMARK;
4149 register AV *ary = (AV*)*++MARK;
4153 register I32 offset;
4154 register I32 length;
4161 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4162 *MARK-- = SvTIED_obj((SV*)ary, mg);
4166 call_method("SPLICE",GIMME_V);
4175 offset = i = SvIVx(*MARK);
4177 offset += AvFILLp(ary) + 1;
4179 offset -= PL_curcop->cop_arybase;
4181 DIE(aTHX_ PL_no_aelem, i);
4183 length = SvIVx(*MARK++);
4185 length += AvFILLp(ary) - offset + 1;
4191 length = AvMAX(ary) + 1; /* close enough to infinity */
4195 length = AvMAX(ary) + 1;
4197 if (offset > AvFILLp(ary) + 1) {
4198 if (ckWARN(WARN_MISC))
4199 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4200 offset = AvFILLp(ary) + 1;
4202 after = AvFILLp(ary) + 1 - (offset + length);
4203 if (after < 0) { /* not that much array */
4204 length += after; /* offset+length now in array */
4210 /* At this point, MARK .. SP-1 is our new LIST */
4213 diff = newlen - length;
4214 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4217 /* make new elements SVs now: avoid problems if they're from the array */
4218 for (dst = MARK, i = newlen; i; i--) {
4220 *dst++ = newSVsv(h);
4223 if (diff < 0) { /* shrinking the area */
4225 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4226 Copy(MARK, tmparyval, newlen, SV*);
4229 MARK = ORIGMARK + 1;
4230 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4231 MEXTEND(MARK, length);
4232 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4234 EXTEND_MORTAL(length);
4235 for (i = length, dst = MARK; i; i--) {
4236 sv_2mortal(*dst); /* free them eventualy */
4243 *MARK = AvARRAY(ary)[offset+length-1];
4246 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4247 SvREFCNT_dec(*dst++); /* free them now */
4250 AvFILLp(ary) += diff;
4252 /* pull up or down? */
4254 if (offset < after) { /* easier to pull up */
4255 if (offset) { /* esp. if nothing to pull */
4256 src = &AvARRAY(ary)[offset-1];
4257 dst = src - diff; /* diff is negative */
4258 for (i = offset; i > 0; i--) /* can't trust Copy */
4262 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4266 if (after) { /* anything to pull down? */
4267 src = AvARRAY(ary) + offset + length;
4268 dst = src + diff; /* diff is negative */
4269 Move(src, dst, after, SV*);
4271 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4272 /* avoid later double free */
4276 dst[--i] = &PL_sv_undef;
4279 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4280 Safefree(tmparyval);
4283 else { /* no, expanding (or same) */
4285 New(452, tmparyval, length, SV*); /* so remember deletion */
4286 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4289 if (diff > 0) { /* expanding */
4291 /* push up or down? */
4293 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4297 Move(src, dst, offset, SV*);
4299 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4301 AvFILLp(ary) += diff;
4304 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4305 av_extend(ary, AvFILLp(ary) + diff);
4306 AvFILLp(ary) += diff;
4309 dst = AvARRAY(ary) + AvFILLp(ary);
4311 for (i = after; i; i--) {
4319 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4322 MARK = ORIGMARK + 1;
4323 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4325 Copy(tmparyval, MARK, length, SV*);
4327 EXTEND_MORTAL(length);
4328 for (i = length, dst = MARK; i; i--) {
4329 sv_2mortal(*dst); /* free them eventualy */
4333 Safefree(tmparyval);
4337 else if (length--) {
4338 *MARK = tmparyval[length];
4341 while (length-- > 0)
4342 SvREFCNT_dec(tmparyval[length]);
4344 Safefree(tmparyval);
4347 *MARK = &PL_sv_undef;
4355 dSP; dMARK; dORIGMARK; dTARGET;
4356 register AV *ary = (AV*)*++MARK;
4357 register SV *sv = &PL_sv_undef;
4360 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4361 *MARK-- = SvTIED_obj((SV*)ary, mg);
4365 call_method("PUSH",G_SCALAR|G_DISCARD);
4370 /* Why no pre-extend of ary here ? */
4371 for (++MARK; MARK <= SP; MARK++) {
4374 sv_setsv(sv, *MARK);
4379 PUSHi( AvFILL(ary) + 1 );
4387 SV *sv = av_pop(av);
4389 (void)sv_2mortal(sv);
4398 SV *sv = av_shift(av);
4403 (void)sv_2mortal(sv);
4410 dSP; dMARK; dORIGMARK; dTARGET;
4411 register AV *ary = (AV*)*++MARK;
4416 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4417 *MARK-- = SvTIED_obj((SV*)ary, mg);
4421 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4426 av_unshift(ary, SP - MARK);
4428 sv = newSVsv(*++MARK);
4429 (void)av_store(ary, i++, sv);
4433 PUSHi( AvFILL(ary) + 1 );
4443 if (GIMME == G_ARRAY) {
4450 /* safe as long as stack cannot get extended in the above */
4455 register char *down;
4461 SvUTF8_off(TARG); /* decontaminate */
4463 do_join(TARG, &PL_sv_no, MARK, SP);
4465 sv_setsv(TARG, (SP > MARK)
4467 : (padoff_du = find_rundefsvoffset(),
4468 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4469 ? DEFSV : PAD_SVl(padoff_du)));
4470 up = SvPV_force(TARG, len);
4472 if (DO_UTF8(TARG)) { /* first reverse each character */
4473 U8* s = (U8*)SvPVX(TARG);
4474 U8* send = (U8*)(s + len);
4476 if (UTF8_IS_INVARIANT(*s)) {
4481 if (!utf8_to_uvchr(s, 0))
4485 down = (char*)(s - 1);
4486 /* reverse this character */
4490 *down-- = (char)tmp;
4496 down = SvPVX(TARG) + len - 1;
4500 *down-- = (char)tmp;
4502 (void)SvPOK_only_UTF8(TARG);
4514 register IV limit = POPi; /* note, negative is forever */
4517 register char *s = SvPV(sv, len);
4518 bool do_utf8 = DO_UTF8(sv);
4519 char *strend = s + len;
4521 register REGEXP *rx;
4525 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4526 I32 maxiters = slen + 10;
4529 I32 origlimit = limit;
4532 I32 gimme = GIMME_V;
4533 I32 oldsave = PL_savestack_ix;
4534 I32 make_mortal = 1;
4536 MAGIC *mg = (MAGIC *) NULL;
4539 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4544 DIE(aTHX_ "panic: pp_split");
4547 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4548 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4550 RX_MATCH_UTF8_set(rx, do_utf8);
4552 if (pm->op_pmreplroot) {
4554 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4556 ary = GvAVn((GV*)pm->op_pmreplroot);
4559 else if (gimme != G_ARRAY)
4560 ary = GvAVn(PL_defgv);
4563 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4569 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4571 XPUSHs(SvTIED_obj((SV*)ary, mg));
4577 for (i = AvFILLp(ary); i >= 0; i--)
4578 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4580 /* temporarily switch stacks */
4581 SAVESWITCHSTACK(PL_curstack, ary);
4585 base = SP - PL_stack_base;
4587 if (pm->op_pmflags & PMf_SKIPWHITE) {
4588 if (pm->op_pmflags & PMf_LOCALE) {
4589 while (isSPACE_LC(*s))
4597 if (pm->op_pmflags & PMf_MULTILINE) {
4602 limit = maxiters + 2;
4603 if (pm->op_pmflags & PMf_WHITE) {
4606 while (m < strend &&
4607 !((pm->op_pmflags & PMf_LOCALE)
4608 ? isSPACE_LC(*m) : isSPACE(*m)))
4613 dstr = newSVpvn(s, m-s);
4617 (void)SvUTF8_on(dstr);
4621 while (s < strend &&
4622 ((pm->op_pmflags & PMf_LOCALE)
4623 ? isSPACE_LC(*s) : isSPACE(*s)))
4627 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4630 for (m = s; m < strend && *m != '\n'; m++) ;
4634 dstr = newSVpvn(s, m-s);
4638 (void)SvUTF8_on(dstr);
4643 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4644 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4645 && (rx->reganch & ROPT_CHECK_ALL)
4646 && !(rx->reganch & ROPT_ANCH)) {
4647 int tail = (rx->reganch & RE_INTUIT_TAIL);
4648 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4651 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4653 char c = *SvPV(csv, n_a);
4656 for (m = s; m < strend && *m != c; m++) ;
4659 dstr = newSVpvn(s, m-s);
4663 (void)SvUTF8_on(dstr);
4665 /* The rx->minlen is in characters but we want to step
4666 * s ahead by bytes. */
4668 s = (char*)utf8_hop((U8*)m, len);
4670 s = m + len; /* Fake \n at the end */
4675 while (s < strend && --limit &&
4676 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4677 csv, multiline ? FBMrf_MULTILINE : 0)) )
4680 dstr = newSVpvn(s, m-s);
4684 (void)SvUTF8_on(dstr);
4686 /* The rx->minlen is in characters but we want to step
4687 * s ahead by bytes. */
4689 s = (char*)utf8_hop((U8*)m, len);
4691 s = m + len; /* Fake \n at the end */
4696 maxiters += slen * rx->nparens;
4697 while (s < strend && --limit)
4700 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4704 TAINT_IF(RX_MATCH_TAINTED(rx));
4705 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4710 strend = s + (strend - m);
4712 m = rx->startp[0] + orig;
4713 dstr = newSVpvn(s, m-s);
4717 (void)SvUTF8_on(dstr);
4720 for (i = 1; i <= (I32)rx->nparens; i++) {
4721 s = rx->startp[i] + orig;
4722 m = rx->endp[i] + orig;
4724 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4725 parens that didn't match -- they should be set to
4726 undef, not the empty string */
4727 if (m >= orig && s >= orig) {
4728 dstr = newSVpvn(s, m-s);
4731 dstr = &PL_sv_undef; /* undef, not "" */
4735 (void)SvUTF8_on(dstr);
4739 s = rx->endp[0] + orig;
4743 iters = (SP - PL_stack_base) - base;
4744 if (iters > maxiters)
4745 DIE(aTHX_ "Split loop");
4747 /* keep field after final delim? */
4748 if (s < strend || (iters && origlimit)) {
4749 STRLEN l = strend - s;
4750 dstr = newSVpvn(s, l);
4754 (void)SvUTF8_on(dstr);
4758 else if (!origlimit) {
4759 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4760 if (TOPs && !make_mortal)
4763 *SP-- = &PL_sv_undef;
4768 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4772 if (SvSMAGICAL(ary)) {
4777 if (gimme == G_ARRAY) {
4779 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4787 call_method("PUSH",G_SCALAR|G_DISCARD);
4790 if (gimme == G_ARRAY) {
4791 /* EXTEND should not be needed - we just popped them */
4793 for (i=0; i < iters; i++) {
4794 SV **svp = av_fetch(ary, i, FALSE);
4795 PUSHs((svp) ? *svp : &PL_sv_undef);
4802 if (gimme == G_ARRAY)
4817 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4818 || SvTYPE(retsv) == SVt_PVCV) {
4819 retsv = refto(retsv);
4827 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4832 * c-indentation-style: bsd
4834 * indent-tabs-mode: t
4837 * vim: shiftwidth=4: