3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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) {
153 if (SvGMAGICAL(sv)) {
158 if (!SvOK(sv) && sv != &PL_sv_undef) {
159 /* If this is a 'my' scalar and flag is set then vivify
162 if (PL_op->op_private & OPpDEREF) {
165 if (cUNOP->op_targ) {
167 SV *namesv = PAD_SV(cUNOP->op_targ);
168 name = SvPV(namesv, len);
169 gv = (GV*)NEWSV(0,0);
170 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
173 name = CopSTASHPV(PL_curcop);
176 if (SvTYPE(sv) < SVt_RV)
177 sv_upgrade(sv, SVt_RV);
179 (void)SvOOK_off(sv); /* backoff */
182 SvLEN(sv)=SvCUR(sv)=0;
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))
197 if ((PL_op->op_flags & OPf_SPECIAL) &&
198 !(PL_op->op_flags & OPf_MOD))
200 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
202 && (!is_gv_magical(sym,len,0)
203 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
209 if (PL_op->op_private & HINT_STRICT_REFS)
210 DIE(aTHX_ PL_no_symref, sym, "a symbol");
211 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
215 if (PL_op->op_private & OPpLVAL_INTRO)
216 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
228 tryAMAGICunDEREF(to_sv);
231 switch (SvTYPE(sv)) {
235 DIE(aTHX_ "Not a SCALAR reference");
243 if (SvTYPE(gv) != SVt_PVGV) {
244 if (SvGMAGICAL(sv)) {
250 if (PL_op->op_flags & OPf_REF ||
251 PL_op->op_private & HINT_STRICT_REFS)
252 DIE(aTHX_ PL_no_usym, "a SCALAR");
253 if (ckWARN(WARN_UNINITIALIZED))
258 if ((PL_op->op_flags & OPf_SPECIAL) &&
259 !(PL_op->op_flags & OPf_MOD))
261 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
263 && (!is_gv_magical(sym,len,0)
264 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
270 if (PL_op->op_private & HINT_STRICT_REFS)
271 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
272 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
277 if (PL_op->op_flags & OPf_MOD) {
278 if (PL_op->op_private & OPpLVAL_INTRO) {
279 if (cUNOP->op_first->op_type == OP_NULL)
280 sv = save_scalar((GV*)TOPs);
282 sv = save_scalar(gv);
284 Perl_croak(aTHX_ PL_no_localize_ref);
286 else if (PL_op->op_private & OPpDEREF)
287 vivify_ref(sv, PL_op->op_private & OPpDEREF);
297 SV *sv = AvARYLEN(av);
299 AvARYLEN(av) = sv = NEWSV(0,0);
300 sv_upgrade(sv, SVt_IV);
301 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
309 dSP; dTARGET; dPOPss;
311 if (PL_op->op_flags & OPf_MOD || LVRET) {
312 if (SvTYPE(TARG) < SVt_PVLV) {
313 sv_upgrade(TARG, SVt_PVLV);
314 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
318 if (LvTARG(TARG) != sv) {
320 SvREFCNT_dec(LvTARG(TARG));
321 LvTARG(TARG) = SvREFCNT_inc(sv);
323 PUSHs(TARG); /* no SvSETMAGIC */
329 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
330 mg = mg_find(sv, PERL_MAGIC_regex_global);
331 if (mg && mg->mg_len >= 0) {
335 PUSHi(i + PL_curcop->cop_arybase);
349 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
350 /* (But not in defined().) */
351 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
354 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
355 if ((PL_op->op_private & OPpLVAL_INTRO)) {
356 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
359 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
363 cv = (CV*)&PL_sv_undef;
377 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
378 char *s = SvPVX(TOPs);
379 if (strnEQ(s, "CORE::", 6)) {
382 code = keyword(s + 6, SvCUR(TOPs) - 6);
383 if (code < 0) { /* Overridable. */
384 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
385 int i = 0, n = 0, seen_question = 0;
387 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
389 if (code == -KEY_chop || code == -KEY_chomp)
391 while (i < MAXO) { /* The slow way. */
392 if (strEQ(s + 6, PL_op_name[i])
393 || strEQ(s + 6, PL_op_desc[i]))
399 goto nonesuch; /* Should not happen... */
401 oa = PL_opargs[i] >> OASHIFT;
403 if (oa & OA_OPTIONAL && !seen_question) {
407 else if (n && str[0] == ';' && seen_question)
408 goto set; /* XXXX system, exec */
409 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
410 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
411 /* But globs are already references (kinda) */
412 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
416 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
420 ret = sv_2mortal(newSVpvn(str, n - 1));
422 else if (code) /* Non-Overridable */
424 else { /* None such */
426 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
430 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
432 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
441 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
443 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
459 if (GIMME != G_ARRAY) {
463 *MARK = &PL_sv_undef;
464 *MARK = refto(*MARK);
468 EXTEND_MORTAL(SP - MARK);
470 *MARK = refto(*MARK);
475 S_refto(pTHX_ SV *sv)
479 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
482 if (!(sv = LvTARG(sv)))
485 (void)SvREFCNT_inc(sv);
487 else if (SvTYPE(sv) == SVt_PVAV) {
488 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
491 (void)SvREFCNT_inc(sv);
493 else if (SvPADTMP(sv) && !IS_PADGV(sv))
497 (void)SvREFCNT_inc(sv);
500 sv_upgrade(rv, SVt_RV);
514 if (sv && SvGMAGICAL(sv))
517 if (!sv || !SvROK(sv))
521 pv = sv_reftype(sv,TRUE);
522 PUSHp(pv, strlen(pv));
532 stash = CopSTASH(PL_curcop);
538 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
539 Perl_croak(aTHX_ "Attempt to bless into a reference");
541 if (ckWARN(WARN_MISC) && len == 0)
542 Perl_warner(aTHX_ packWARN(WARN_MISC),
543 "Explicit blessing to '' (assuming package main)");
544 stash = gv_stashpvn(ptr, len, TRUE);
547 (void)sv_bless(TOPs, stash);
561 elem = SvPV(sv, n_a);
565 switch (elem ? *elem : '\0')
568 if (strEQ(elem, "ARRAY"))
569 tmpRef = (SV*)GvAV(gv);
572 if (strEQ(elem, "CODE"))
573 tmpRef = (SV*)GvCVu(gv);
576 if (strEQ(elem, "FILEHANDLE")) {
577 /* finally deprecated in 5.8.0 */
578 deprecate("*glob{FILEHANDLE}");
579 tmpRef = (SV*)GvIOp(gv);
582 if (strEQ(elem, "FORMAT"))
583 tmpRef = (SV*)GvFORM(gv);
586 if (strEQ(elem, "GLOB"))
590 if (strEQ(elem, "HASH"))
591 tmpRef = (SV*)GvHV(gv);
594 if (strEQ(elem, "IO"))
595 tmpRef = (SV*)GvIOp(gv);
598 if (strEQ(elem, "NAME"))
599 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
602 if (strEQ(elem, "PACKAGE")) {
603 if (HvNAME(GvSTASH(gv)))
604 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
606 sv = newSVpv("__ANON__",0);
610 if (strEQ(elem, "SCALAR"))
624 /* Pattern matching */
629 register unsigned char *s;
632 register I32 *sfirst;
636 if (sv == PL_lastscream) {
642 SvSCREAM_off(PL_lastscream);
643 SvREFCNT_dec(PL_lastscream);
645 PL_lastscream = SvREFCNT_inc(sv);
648 s = (unsigned char*)(SvPV(sv, len));
652 if (pos > PL_maxscream) {
653 if (PL_maxscream < 0) {
654 PL_maxscream = pos + 80;
655 New(301, PL_screamfirst, 256, I32);
656 New(302, PL_screamnext, PL_maxscream, I32);
659 PL_maxscream = pos + pos / 4;
660 Renew(PL_screamnext, PL_maxscream, I32);
664 sfirst = PL_screamfirst;
665 snext = PL_screamnext;
667 if (!sfirst || !snext)
668 DIE(aTHX_ "do_study: out of memory");
670 for (ch = 256; ch; --ch)
677 snext[pos] = sfirst[ch] - pos;
684 /* piggyback on m//g magic */
685 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
694 if (PL_op->op_flags & OPf_STACKED)
696 else if (PL_op->op_private & OPpTARGET_MY)
702 TARG = sv_newmortal();
707 /* Lvalue operators. */
719 dSP; dMARK; dTARGET; dORIGMARK;
721 do_chop(TARG, *++MARK);
730 SETi(do_chomp(TOPs));
737 register I32 count = 0;
740 count += do_chomp(POPs);
751 if (!sv || !SvANY(sv))
753 switch (SvTYPE(sv)) {
755 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
756 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
760 if (HvARRAY(sv) || SvGMAGICAL(sv)
761 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
765 if (CvROOT(sv) || CvXSUB(sv))
782 if (!PL_op->op_private) {
791 SV_CHECK_THINKFIRST_COW_DROP(sv);
793 switch (SvTYPE(sv)) {
803 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
804 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
805 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
809 /* let user-undef'd sub keep its identity */
810 GV* gv = CvGV((CV*)sv);
817 SvSetMagicSV(sv, &PL_sv_undef);
821 Newz(602, gp, 1, GP);
822 GvGP(sv) = gp_ref(gp);
823 GvSV(sv) = NEWSV(72,0);
824 GvLINE(sv) = CopLINE(PL_curcop);
830 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
833 SvPV_set(sv, Nullch);
846 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
847 DIE(aTHX_ PL_no_modify);
848 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
849 && SvIVX(TOPs) != IV_MIN)
852 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
863 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 sv_setsv(TARG, TOPs);
866 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
867 && SvIVX(TOPs) != IV_MAX)
870 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
875 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
885 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
886 DIE(aTHX_ PL_no_modify);
887 sv_setsv(TARG, TOPs);
888 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
889 && SvIVX(TOPs) != IV_MIN)
892 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
901 /* Ordinary operators. */
906 #ifdef PERL_PRESERVE_IVUV
909 tryAMAGICbin(pow,opASSIGN);
910 #ifdef PERL_PRESERVE_IVUV
911 /* For integer to integer power, we do the calculation by hand wherever
912 we're sure it is safe; otherwise we call pow() and try to convert to
913 integer afterwards. */
917 bool baseuok = SvUOK(TOPm1s);
921 baseuv = SvUVX(TOPm1s);
923 IV iv = SvIVX(TOPm1s);
926 baseuok = TRUE; /* effectively it's a UV now */
928 baseuv = -iv; /* abs, baseuok == false records sign */
942 goto float_it; /* Can't do negative powers this way. */
945 /* now we have integer ** positive integer. */
948 /* foo & (foo - 1) is zero only for a power of 2. */
949 if (!(baseuv & (baseuv - 1))) {
950 /* We are raising power-of-2 to a positive integer.
951 The logic here will work for any base (even non-integer
952 bases) but it can be less accurate than
953 pow (base,power) or exp (power * log (base)) when the
954 intermediate values start to spill out of the mantissa.
955 With powers of 2 we know this can't happen.
956 And powers of 2 are the favourite thing for perl
957 programmers to notice ** not doing what they mean. */
959 NV base = baseuok ? baseuv : -(NV)baseuv;
962 for (; power; base *= base, n++) {
963 /* Do I look like I trust gcc with long longs here?
965 UV bit = (UV)1 << (UV)n;
968 /* Only bother to clear the bit if it is set. */
970 /* Avoid squaring base again if we're done. */
971 if (power == 0) break;
979 register unsigned int highbit = 8 * sizeof(UV);
980 register unsigned int lowbit = 0;
981 register unsigned int diff;
982 bool odd_power = (bool)(power & 1);
983 while ((diff = (highbit - lowbit) >> 1)) {
984 if (baseuv & ~((1 << (lowbit + diff)) - 1))
989 /* we now have baseuv < 2 ** highbit */
990 if (power * highbit <= 8 * sizeof(UV)) {
991 /* result will definitely fit in UV, so use UV math
992 on same algorithm as above */
993 register UV result = 1;
994 register UV base = baseuv;
996 for (; power; base *= base, n++) {
997 register UV bit = (UV)1 << (UV)n;
1001 if (power == 0) break;
1005 if (baseuok || !odd_power)
1006 /* answer is positive */
1008 else if (result <= (UV)IV_MAX)
1009 /* answer negative, fits in IV */
1010 SETi( -(IV)result );
1011 else if (result == (UV)IV_MIN)
1012 /* 2's complement assumption: special case IV_MIN */
1015 /* answer negative, doesn't fit */
1016 SETn( -(NV)result );
1027 SETn( Perl_pow( left, right) );
1028 #ifdef PERL_PRESERVE_IVUV
1038 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1039 #ifdef PERL_PRESERVE_IVUV
1042 /* Unless the left argument is integer in range we are going to have to
1043 use NV maths. Hence only attempt to coerce the right argument if
1044 we know the left is integer. */
1045 /* Left operand is defined, so is it IV? */
1046 SvIV_please(TOPm1s);
1047 if (SvIOK(TOPm1s)) {
1048 bool auvok = SvUOK(TOPm1s);
1049 bool buvok = SvUOK(TOPs);
1050 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1051 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1058 alow = SvUVX(TOPm1s);
1060 IV aiv = SvIVX(TOPm1s);
1063 auvok = TRUE; /* effectively it's a UV now */
1065 alow = -aiv; /* abs, auvok == false records sign */
1071 IV biv = SvIVX(TOPs);
1074 buvok = TRUE; /* effectively it's a UV now */
1076 blow = -biv; /* abs, buvok == false records sign */
1080 /* If this does sign extension on unsigned it's time for plan B */
1081 ahigh = alow >> (4 * sizeof (UV));
1083 bhigh = blow >> (4 * sizeof (UV));
1085 if (ahigh && bhigh) {
1086 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1087 which is overflow. Drop to NVs below. */
1088 } else if (!ahigh && !bhigh) {
1089 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1090 so the unsigned multiply cannot overflow. */
1091 UV product = alow * blow;
1092 if (auvok == buvok) {
1093 /* -ve * -ve or +ve * +ve gives a +ve result. */
1097 } else if (product <= (UV)IV_MIN) {
1098 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1099 /* -ve result, which could overflow an IV */
1101 SETi( -(IV)product );
1103 } /* else drop to NVs below. */
1105 /* One operand is large, 1 small */
1108 /* swap the operands */
1110 bhigh = blow; /* bhigh now the temp var for the swap */
1114 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1115 multiplies can't overflow. shift can, add can, -ve can. */
1116 product_middle = ahigh * blow;
1117 if (!(product_middle & topmask)) {
1118 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1120 product_middle <<= (4 * sizeof (UV));
1121 product_low = alow * blow;
1123 /* as for pp_add, UV + something mustn't get smaller.
1124 IIRC ANSI mandates this wrapping *behaviour* for
1125 unsigned whatever the actual representation*/
1126 product_low += product_middle;
1127 if (product_low >= product_middle) {
1128 /* didn't overflow */
1129 if (auvok == buvok) {
1130 /* -ve * -ve or +ve * +ve gives a +ve result. */
1132 SETu( product_low );
1134 } else if (product_low <= (UV)IV_MIN) {
1135 /* 2s complement assumption again */
1136 /* -ve result, which could overflow an IV */
1138 SETi( -(IV)product_low );
1140 } /* else drop to NVs below. */
1142 } /* product_middle too large */
1143 } /* ahigh && bhigh */
1144 } /* SvIOK(TOPm1s) */
1149 SETn( left * right );
1156 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1157 /* Only try to do UV divide first
1158 if ((SLOPPYDIVIDE is true) or
1159 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1161 The assumption is that it is better to use floating point divide
1162 whenever possible, only doing integer divide first if we can't be sure.
1163 If NV_PRESERVES_UV is true then we know at compile time that no UV
1164 can be too large to preserve, so don't need to compile the code to
1165 test the size of UVs. */
1168 # define PERL_TRY_UV_DIVIDE
1169 /* ensure that 20./5. == 4. */
1171 # ifdef PERL_PRESERVE_IVUV
1172 # ifndef NV_PRESERVES_UV
1173 # define PERL_TRY_UV_DIVIDE
1178 #ifdef PERL_TRY_UV_DIVIDE
1181 SvIV_please(TOPm1s);
1182 if (SvIOK(TOPm1s)) {
1183 bool left_non_neg = SvUOK(TOPm1s);
1184 bool right_non_neg = SvUOK(TOPs);
1188 if (right_non_neg) {
1189 right = SvUVX(TOPs);
1192 IV biv = SvIVX(TOPs);
1195 right_non_neg = TRUE; /* effectively it's a UV now */
1201 /* historically undef()/0 gives a "Use of uninitialized value"
1202 warning before dieing, hence this test goes here.
1203 If it were immediately before the second SvIV_please, then
1204 DIE() would be invoked before left was even inspected, so
1205 no inpsection would give no warning. */
1207 DIE(aTHX_ "Illegal division by zero");
1210 left = SvUVX(TOPm1s);
1213 IV aiv = SvIVX(TOPm1s);
1216 left_non_neg = TRUE; /* effectively it's a UV now */
1225 /* For sloppy divide we always attempt integer division. */
1227 /* Otherwise we only attempt it if either or both operands
1228 would not be preserved by an NV. If both fit in NVs
1229 we fall through to the NV divide code below. However,
1230 as left >= right to ensure integer result here, we know that
1231 we can skip the test on the right operand - right big
1232 enough not to be preserved can't get here unless left is
1235 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1238 /* Integer division can't overflow, but it can be imprecise. */
1239 UV result = left / right;
1240 if (result * right == left) {
1241 SP--; /* result is valid */
1242 if (left_non_neg == right_non_neg) {
1243 /* signs identical, result is positive. */
1247 /* 2s complement assumption */
1248 if (result <= (UV)IV_MIN)
1249 SETi( -(IV)result );
1251 /* It's exact but too negative for IV. */
1252 SETn( -(NV)result );
1255 } /* tried integer divide but it was not an integer result */
1256 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1257 } /* left wasn't SvIOK */
1258 } /* right wasn't SvIOK */
1259 #endif /* PERL_TRY_UV_DIVIDE */
1263 DIE(aTHX_ "Illegal division by zero");
1264 PUSHn( left / right );
1271 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1275 bool left_neg = FALSE;
1276 bool right_neg = FALSE;
1277 bool use_double = FALSE;
1278 bool dright_valid = FALSE;
1284 right_neg = !SvUOK(TOPs);
1286 right = SvUVX(POPs);
1288 IV biv = SvIVX(POPs);
1291 right_neg = FALSE; /* effectively it's a UV now */
1299 right_neg = dright < 0;
1302 if (dright < UV_MAX_P1) {
1303 right = U_V(dright);
1304 dright_valid = TRUE; /* In case we need to use double below. */
1310 /* At this point use_double is only true if right is out of range for
1311 a UV. In range NV has been rounded down to nearest UV and
1312 use_double false. */
1314 if (!use_double && SvIOK(TOPs)) {
1316 left_neg = !SvUOK(TOPs);
1320 IV aiv = SvIVX(POPs);
1323 left_neg = FALSE; /* effectively it's a UV now */
1332 left_neg = dleft < 0;
1336 /* This should be exactly the 5.6 behaviour - if left and right are
1337 both in range for UV then use U_V() rather than floor. */
1339 if (dleft < UV_MAX_P1) {
1340 /* right was in range, so is dleft, so use UVs not double.
1344 /* left is out of range for UV, right was in range, so promote
1345 right (back) to double. */
1347 /* The +0.5 is used in 5.6 even though it is not strictly
1348 consistent with the implicit +0 floor in the U_V()
1349 inside the #if 1. */
1350 dleft = Perl_floor(dleft + 0.5);
1353 dright = Perl_floor(dright + 0.5);
1363 DIE(aTHX_ "Illegal modulus zero");
1365 dans = Perl_fmod(dleft, dright);
1366 if ((left_neg != right_neg) && dans)
1367 dans = dright - dans;
1370 sv_setnv(TARG, dans);
1376 DIE(aTHX_ "Illegal modulus zero");
1379 if ((left_neg != right_neg) && ans)
1382 /* XXX may warn: unary minus operator applied to unsigned type */
1383 /* could change -foo to be (~foo)+1 instead */
1384 if (ans <= ~((UV)IV_MAX)+1)
1385 sv_setiv(TARG, ~ans+1);
1387 sv_setnv(TARG, -(NV)ans);
1390 sv_setuv(TARG, ans);
1399 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1409 count = IV_MAX; /* The best we can do? */
1420 else if (SvNOKp(sv)) {
1429 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1431 I32 items = SP - MARK;
1433 static const char oom_list_extend[] =
1434 "Out of memory during list extend";
1436 max = items * count;
1437 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1438 /* Did the max computation overflow? */
1439 if (items > 0 && max > 0 && (max < items || max < count))
1440 Perl_croak(aTHX_ oom_list_extend);
1445 /* This code was intended to fix 20010809.028:
1448 for (($x =~ /./g) x 2) {
1449 print chop; # "abcdabcd" expected as output.
1452 * but that change (#11635) broke this code:
1454 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1456 * I can't think of a better fix that doesn't introduce
1457 * an efficiency hit by copying the SVs. The stack isn't
1458 * refcounted, and mortalisation obviously doesn't
1459 * Do The Right Thing when the stack has more than
1460 * one pointer to the same mortal value.
1464 *SP = sv_2mortal(newSVsv(*SP));
1474 repeatcpy((char*)(MARK + items), (char*)MARK,
1475 items * sizeof(SV*), count - 1);
1478 else if (count <= 0)
1481 else { /* Note: mark already snarfed by pp_list */
1485 static const char oom_string_extend[] =
1486 "Out of memory during string extend";
1488 SvSetSV(TARG, tmpstr);
1489 SvPV_force(TARG, len);
1490 isutf = DO_UTF8(TARG);
1495 IV max = count * len;
1496 if (len > ((MEM_SIZE)~0)/count)
1497 Perl_croak(aTHX_ oom_string_extend);
1498 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1499 SvGROW(TARG, (count * len) + 1);
1500 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1501 SvCUR(TARG) *= count;
1503 *SvEND(TARG) = '\0';
1506 (void)SvPOK_only_UTF8(TARG);
1508 (void)SvPOK_only(TARG);
1510 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1511 /* The parser saw this as a list repeat, and there
1512 are probably several items on the stack. But we're
1513 in scalar context, and there's no pp_list to save us
1514 now. So drop the rest of the items -- robin@kitsite.com
1527 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1528 useleft = USE_LEFT(TOPm1s);
1529 #ifdef PERL_PRESERVE_IVUV
1530 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1531 "bad things" happen if you rely on signed integers wrapping. */
1534 /* Unless the left argument is integer in range we are going to have to
1535 use NV maths. Hence only attempt to coerce the right argument if
1536 we know the left is integer. */
1537 register UV auv = 0;
1543 a_valid = auvok = 1;
1544 /* left operand is undef, treat as zero. */
1546 /* Left operand is defined, so is it IV? */
1547 SvIV_please(TOPm1s);
1548 if (SvIOK(TOPm1s)) {
1549 if ((auvok = SvUOK(TOPm1s)))
1550 auv = SvUVX(TOPm1s);
1552 register IV aiv = SvIVX(TOPm1s);
1555 auvok = 1; /* Now acting as a sign flag. */
1556 } else { /* 2s complement assumption for IV_MIN */
1564 bool result_good = 0;
1567 bool buvok = SvUOK(TOPs);
1572 register IV biv = SvIVX(TOPs);
1579 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1580 else "IV" now, independent of how it came in.
1581 if a, b represents positive, A, B negative, a maps to -A etc
1586 all UV maths. negate result if A negative.
1587 subtract if signs same, add if signs differ. */
1589 if (auvok ^ buvok) {
1598 /* Must get smaller */
1603 if (result <= buv) {
1604 /* result really should be -(auv-buv). as its negation
1605 of true value, need to swap our result flag */
1617 if (result <= (UV)IV_MIN)
1618 SETi( -(IV)result );
1620 /* result valid, but out of range for IV. */
1621 SETn( -(NV)result );
1625 } /* Overflow, drop through to NVs. */
1629 useleft = USE_LEFT(TOPm1s);
1633 /* left operand is undef, treat as zero - value */
1637 SETn( TOPn - value );
1644 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1647 if (PL_op->op_private & HINT_INTEGER) {
1661 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1664 if (PL_op->op_private & HINT_INTEGER) {
1678 dSP; tryAMAGICbinSET(lt,0);
1679 #ifdef PERL_PRESERVE_IVUV
1682 SvIV_please(TOPm1s);
1683 if (SvIOK(TOPm1s)) {
1684 bool auvok = SvUOK(TOPm1s);
1685 bool buvok = SvUOK(TOPs);
1687 if (!auvok && !buvok) { /* ## IV < IV ## */
1688 IV aiv = SvIVX(TOPm1s);
1689 IV biv = SvIVX(TOPs);
1692 SETs(boolSV(aiv < biv));
1695 if (auvok && buvok) { /* ## UV < UV ## */
1696 UV auv = SvUVX(TOPm1s);
1697 UV buv = SvUVX(TOPs);
1700 SETs(boolSV(auv < buv));
1703 if (auvok) { /* ## UV < IV ## */
1710 /* As (a) is a UV, it's >=0, so it cannot be < */
1715 SETs(boolSV(auv < (UV)biv));
1718 { /* ## IV < UV ## */
1722 aiv = SvIVX(TOPm1s);
1724 /* As (b) is a UV, it's >=0, so it must be < */
1731 SETs(boolSV((UV)aiv < buv));
1737 #ifndef NV_PRESERVES_UV
1738 #ifdef PERL_PRESERVE_IVUV
1741 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1743 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1749 SETs(boolSV(TOPn < value));
1756 dSP; tryAMAGICbinSET(gt,0);
1757 #ifdef PERL_PRESERVE_IVUV
1760 SvIV_please(TOPm1s);
1761 if (SvIOK(TOPm1s)) {
1762 bool auvok = SvUOK(TOPm1s);
1763 bool buvok = SvUOK(TOPs);
1765 if (!auvok && !buvok) { /* ## IV > IV ## */
1766 IV aiv = SvIVX(TOPm1s);
1767 IV biv = SvIVX(TOPs);
1770 SETs(boolSV(aiv > biv));
1773 if (auvok && buvok) { /* ## UV > UV ## */
1774 UV auv = SvUVX(TOPm1s);
1775 UV buv = SvUVX(TOPs);
1778 SETs(boolSV(auv > buv));
1781 if (auvok) { /* ## UV > IV ## */
1788 /* As (a) is a UV, it's >=0, so it must be > */
1793 SETs(boolSV(auv > (UV)biv));
1796 { /* ## IV > UV ## */
1800 aiv = SvIVX(TOPm1s);
1802 /* As (b) is a UV, it's >=0, so it cannot be > */
1809 SETs(boolSV((UV)aiv > buv));
1815 #ifndef NV_PRESERVES_UV
1816 #ifdef PERL_PRESERVE_IVUV
1819 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1821 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1827 SETs(boolSV(TOPn > value));
1834 dSP; tryAMAGICbinSET(le,0);
1835 #ifdef PERL_PRESERVE_IVUV
1838 SvIV_please(TOPm1s);
1839 if (SvIOK(TOPm1s)) {
1840 bool auvok = SvUOK(TOPm1s);
1841 bool buvok = SvUOK(TOPs);
1843 if (!auvok && !buvok) { /* ## IV <= IV ## */
1844 IV aiv = SvIVX(TOPm1s);
1845 IV biv = SvIVX(TOPs);
1848 SETs(boolSV(aiv <= biv));
1851 if (auvok && buvok) { /* ## UV <= UV ## */
1852 UV auv = SvUVX(TOPm1s);
1853 UV buv = SvUVX(TOPs);
1856 SETs(boolSV(auv <= buv));
1859 if (auvok) { /* ## UV <= IV ## */
1866 /* As (a) is a UV, it's >=0, so a cannot be <= */
1871 SETs(boolSV(auv <= (UV)biv));
1874 { /* ## IV <= UV ## */
1878 aiv = SvIVX(TOPm1s);
1880 /* As (b) is a UV, it's >=0, so a must be <= */
1887 SETs(boolSV((UV)aiv <= buv));
1893 #ifndef NV_PRESERVES_UV
1894 #ifdef PERL_PRESERVE_IVUV
1897 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1899 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1905 SETs(boolSV(TOPn <= value));
1912 dSP; tryAMAGICbinSET(ge,0);
1913 #ifdef PERL_PRESERVE_IVUV
1916 SvIV_please(TOPm1s);
1917 if (SvIOK(TOPm1s)) {
1918 bool auvok = SvUOK(TOPm1s);
1919 bool buvok = SvUOK(TOPs);
1921 if (!auvok && !buvok) { /* ## IV >= IV ## */
1922 IV aiv = SvIVX(TOPm1s);
1923 IV biv = SvIVX(TOPs);
1926 SETs(boolSV(aiv >= biv));
1929 if (auvok && buvok) { /* ## UV >= UV ## */
1930 UV auv = SvUVX(TOPm1s);
1931 UV buv = SvUVX(TOPs);
1934 SETs(boolSV(auv >= buv));
1937 if (auvok) { /* ## UV >= IV ## */
1944 /* As (a) is a UV, it's >=0, so it must be >= */
1949 SETs(boolSV(auv >= (UV)biv));
1952 { /* ## IV >= UV ## */
1956 aiv = SvIVX(TOPm1s);
1958 /* As (b) is a UV, it's >=0, so a cannot be >= */
1965 SETs(boolSV((UV)aiv >= buv));
1971 #ifndef NV_PRESERVES_UV
1972 #ifdef PERL_PRESERVE_IVUV
1975 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1977 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1983 SETs(boolSV(TOPn >= value));
1990 dSP; tryAMAGICbinSET(ne,0);
1991 #ifndef NV_PRESERVES_UV
1992 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1994 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1998 #ifdef PERL_PRESERVE_IVUV
2001 SvIV_please(TOPm1s);
2002 if (SvIOK(TOPm1s)) {
2003 bool auvok = SvUOK(TOPm1s);
2004 bool buvok = SvUOK(TOPs);
2006 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2007 /* Casting IV to UV before comparison isn't going to matter
2008 on 2s complement. On 1s complement or sign&magnitude
2009 (if we have any of them) it could make negative zero
2010 differ from normal zero. As I understand it. (Need to
2011 check - is negative zero implementation defined behaviour
2013 UV buv = SvUVX(POPs);
2014 UV auv = SvUVX(TOPs);
2016 SETs(boolSV(auv != buv));
2019 { /* ## Mixed IV,UV ## */
2023 /* != is commutative so swap if needed (save code) */
2025 /* swap. top of stack (b) is the iv */
2029 /* As (a) is a UV, it's >0, so it cannot be == */
2038 /* As (b) is a UV, it's >0, so it cannot be == */
2042 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2044 SETs(boolSV((UV)iv != uv));
2052 SETs(boolSV(TOPn != value));
2059 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2060 #ifndef NV_PRESERVES_UV
2061 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2062 UV right = PTR2UV(SvRV(POPs));
2063 UV left = PTR2UV(SvRV(TOPs));
2064 SETi((left > right) - (left < right));
2068 #ifdef PERL_PRESERVE_IVUV
2069 /* Fortunately it seems NaN isn't IOK */
2072 SvIV_please(TOPm1s);
2073 if (SvIOK(TOPm1s)) {
2074 bool leftuvok = SvUOK(TOPm1s);
2075 bool rightuvok = SvUOK(TOPs);
2077 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2078 IV leftiv = SvIVX(TOPm1s);
2079 IV rightiv = SvIVX(TOPs);
2081 if (leftiv > rightiv)
2083 else if (leftiv < rightiv)
2087 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2088 UV leftuv = SvUVX(TOPm1s);
2089 UV rightuv = SvUVX(TOPs);
2091 if (leftuv > rightuv)
2093 else if (leftuv < rightuv)
2097 } else if (leftuvok) { /* ## UV <=> IV ## */
2101 rightiv = SvIVX(TOPs);
2103 /* As (a) is a UV, it's >=0, so it cannot be < */
2106 leftuv = SvUVX(TOPm1s);
2107 if (leftuv > (UV)rightiv) {
2109 } else if (leftuv < (UV)rightiv) {
2115 } else { /* ## IV <=> UV ## */
2119 leftiv = SvIVX(TOPm1s);
2121 /* As (b) is a UV, it's >=0, so it must be < */
2124 rightuv = SvUVX(TOPs);
2125 if ((UV)leftiv > rightuv) {
2127 } else if ((UV)leftiv < rightuv) {
2145 if (Perl_isnan(left) || Perl_isnan(right)) {
2149 value = (left > right) - (left < right);
2153 else if (left < right)
2155 else if (left > right)
2169 dSP; tryAMAGICbinSET(slt,0);
2172 int cmp = (IN_LOCALE_RUNTIME
2173 ? sv_cmp_locale(left, right)
2174 : sv_cmp(left, right));
2175 SETs(boolSV(cmp < 0));
2182 dSP; tryAMAGICbinSET(sgt,0);
2185 int cmp = (IN_LOCALE_RUNTIME
2186 ? sv_cmp_locale(left, right)
2187 : sv_cmp(left, right));
2188 SETs(boolSV(cmp > 0));
2195 dSP; tryAMAGICbinSET(sle,0);
2198 int cmp = (IN_LOCALE_RUNTIME
2199 ? sv_cmp_locale(left, right)
2200 : sv_cmp(left, right));
2201 SETs(boolSV(cmp <= 0));
2208 dSP; tryAMAGICbinSET(sge,0);
2211 int cmp = (IN_LOCALE_RUNTIME
2212 ? sv_cmp_locale(left, right)
2213 : sv_cmp(left, right));
2214 SETs(boolSV(cmp >= 0));
2221 dSP; tryAMAGICbinSET(seq,0);
2224 SETs(boolSV(sv_eq(left, right)));
2231 dSP; tryAMAGICbinSET(sne,0);
2234 SETs(boolSV(!sv_eq(left, right)));
2241 dSP; dTARGET; tryAMAGICbin(scmp,0);
2244 int cmp = (IN_LOCALE_RUNTIME
2245 ? sv_cmp_locale(left, right)
2246 : sv_cmp(left, right));
2254 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2257 if (SvGMAGICAL(left)) mg_get(left);
2258 if (SvGMAGICAL(right)) mg_get(right);
2259 if (SvNIOKp(left) || SvNIOKp(right)) {
2260 if (PL_op->op_private & HINT_INTEGER) {
2261 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2265 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2270 do_vop(PL_op->op_type, TARG, left, right);
2279 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2282 if (SvGMAGICAL(left)) mg_get(left);
2283 if (SvGMAGICAL(right)) mg_get(right);
2284 if (SvNIOKp(left) || SvNIOKp(right)) {
2285 if (PL_op->op_private & HINT_INTEGER) {
2286 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2290 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2295 do_vop(PL_op->op_type, TARG, left, right);
2304 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2307 if (SvGMAGICAL(left)) mg_get(left);
2308 if (SvGMAGICAL(right)) mg_get(right);
2309 if (SvNIOKp(left) || SvNIOKp(right)) {
2310 if (PL_op->op_private & HINT_INTEGER) {
2311 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2315 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2320 do_vop(PL_op->op_type, TARG, left, right);
2329 dSP; dTARGET; tryAMAGICun(neg);
2332 int flags = SvFLAGS(sv);
2335 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2336 /* It's publicly an integer, or privately an integer-not-float */
2339 if (SvIVX(sv) == IV_MIN) {
2340 /* 2s complement assumption. */
2341 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2344 else if (SvUVX(sv) <= IV_MAX) {
2349 else if (SvIVX(sv) != IV_MIN) {
2353 #ifdef PERL_PRESERVE_IVUV
2362 else if (SvPOKp(sv)) {
2364 char *s = SvPV(sv, len);
2365 if (isIDFIRST(*s)) {
2366 sv_setpvn(TARG, "-", 1);
2369 else if (*s == '+' || *s == '-') {
2371 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2373 else if (DO_UTF8(sv)) {
2376 goto oops_its_an_int;
2378 sv_setnv(TARG, -SvNV(sv));
2380 sv_setpvn(TARG, "-", 1);
2387 goto oops_its_an_int;
2388 sv_setnv(TARG, -SvNV(sv));
2400 dSP; tryAMAGICunSET(not);
2401 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2407 dSP; dTARGET; tryAMAGICun(compl);
2413 if (PL_op->op_private & HINT_INTEGER) {
2414 IV i = ~SvIV_nomg(sv);
2418 UV u = ~SvUV_nomg(sv);
2427 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2428 sv_setsv_nomg(TARG, sv);
2429 tmps = (U8*)SvPV_force(TARG, len);
2432 /* Calculate exact length, let's not estimate. */
2441 while (tmps < send) {
2442 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2443 tmps += UTF8SKIP(tmps);
2444 targlen += UNISKIP(~c);
2450 /* Now rewind strings and write them. */
2454 Newz(0, result, targlen + 1, U8);
2455 while (tmps < send) {
2456 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2457 tmps += UTF8SKIP(tmps);
2458 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2462 sv_setpvn(TARG, (char*)result, targlen);
2466 Newz(0, result, nchar + 1, U8);
2467 while (tmps < send) {
2468 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2469 tmps += UTF8SKIP(tmps);
2474 sv_setpvn(TARG, (char*)result, nchar);
2483 register long *tmpl;
2484 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2487 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2492 for ( ; anum > 0; anum--, tmps++)
2501 /* integer versions of some of the above */
2505 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2508 SETi( left * right );
2515 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2519 DIE(aTHX_ "Illegal division by zero");
2520 value = POPi / value;
2529 /* This is the vanilla old i_modulo. */
2530 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2534 DIE(aTHX_ "Illegal modulus zero");
2535 SETi( left % right );
2540 #if defined(__GLIBC__) && IVSIZE == 8
2544 /* This is the i_modulo with the workaround for the _moddi3 bug
2545 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2546 * See below for pp_i_modulo. */
2547 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2551 DIE(aTHX_ "Illegal modulus zero");
2552 SETi( left % PERL_ABS(right) );
2560 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2564 DIE(aTHX_ "Illegal modulus zero");
2565 /* The assumption is to use hereafter the old vanilla version... */
2567 PL_ppaddr[OP_I_MODULO] =
2568 &Perl_pp_i_modulo_0;
2569 /* .. but if we have glibc, we might have a buggy _moddi3
2570 * (at least glicb 2.2.5 is known to have this bug), in other
2571 * words our integer modulus with negative quad as the second
2572 * argument might be broken. Test for this and re-patch the
2573 * opcode dispatch table if that is the case, remembering to
2574 * also apply the workaround so that this first round works
2575 * right, too. See [perl #9402] for more information. */
2576 #if defined(__GLIBC__) && IVSIZE == 8
2580 /* Cannot do this check with inlined IV constants since
2581 * that seems to work correctly even with the buggy glibc. */
2583 /* Yikes, we have the bug.
2584 * Patch in the workaround version. */
2586 PL_ppaddr[OP_I_MODULO] =
2587 &Perl_pp_i_modulo_1;
2588 /* Make certain we work right this time, too. */
2589 right = PERL_ABS(right);
2593 SETi( left % right );
2600 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2603 SETi( left + right );
2610 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2613 SETi( left - right );
2620 dSP; tryAMAGICbinSET(lt,0);
2623 SETs(boolSV(left < right));
2630 dSP; tryAMAGICbinSET(gt,0);
2633 SETs(boolSV(left > right));
2640 dSP; tryAMAGICbinSET(le,0);
2643 SETs(boolSV(left <= right));
2650 dSP; tryAMAGICbinSET(ge,0);
2653 SETs(boolSV(left >= right));
2660 dSP; tryAMAGICbinSET(eq,0);
2663 SETs(boolSV(left == right));
2670 dSP; tryAMAGICbinSET(ne,0);
2673 SETs(boolSV(left != right));
2680 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2687 else if (left < right)
2698 dSP; dTARGET; tryAMAGICun(neg);
2703 /* High falutin' math. */
2707 dSP; dTARGET; tryAMAGICbin(atan2,0);
2710 SETn(Perl_atan2(left, right));
2717 dSP; dTARGET; tryAMAGICun(sin);
2721 value = Perl_sin(value);
2729 dSP; dTARGET; tryAMAGICun(cos);
2733 value = Perl_cos(value);
2739 /* Support Configure command-line overrides for rand() functions.
2740 After 5.005, perhaps we should replace this by Configure support
2741 for drand48(), random(), or rand(). For 5.005, though, maintain
2742 compatibility by calling rand() but allow the user to override it.
2743 See INSTALL for details. --Andy Dougherty 15 July 1998
2745 /* Now it's after 5.005, and Configure supports drand48() and random(),
2746 in addition to rand(). So the overrides should not be needed any more.
2747 --Jarkko Hietaniemi 27 September 1998
2750 #ifndef HAS_DRAND48_PROTO
2751 extern double drand48 (void);
2764 if (!PL_srand_called) {
2765 (void)seedDrand01((Rand_seed_t)seed());
2766 PL_srand_called = TRUE;
2781 (void)seedDrand01((Rand_seed_t)anum);
2782 PL_srand_called = TRUE;
2789 dSP; dTARGET; tryAMAGICun(exp);
2793 value = Perl_exp(value);
2801 dSP; dTARGET; tryAMAGICun(log);
2806 SET_NUMERIC_STANDARD();
2807 DIE(aTHX_ "Can't take log of %"NVgf, value);
2809 value = Perl_log(value);
2817 dSP; dTARGET; tryAMAGICun(sqrt);
2822 SET_NUMERIC_STANDARD();
2823 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2825 value = Perl_sqrt(value);
2833 dSP; dTARGET; tryAMAGICun(int);
2836 IV iv = TOPi; /* attempt to convert to IV if possible. */
2837 /* XXX it's arguable that compiler casting to IV might be subtly
2838 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2839 else preferring IV has introduced a subtle behaviour change bug. OTOH
2840 relying on floating point to be accurate is a bug. */
2844 else if (SvIOK(TOPs)) {
2853 if (value < (NV)UV_MAX + 0.5) {
2856 SETn(Perl_floor(value));
2860 if (value > (NV)IV_MIN - 0.5) {
2863 SETn(Perl_ceil(value));
2873 dSP; dTARGET; tryAMAGICun(abs);
2875 /* This will cache the NV value if string isn't actually integer */
2880 else if (SvIOK(TOPs)) {
2881 /* IVX is precise */
2883 SETu(TOPu); /* force it to be numeric only */
2891 /* 2s complement assumption. Also, not really needed as
2892 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2912 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2918 tmps = (SvPVx(sv, len));
2920 /* If Unicode, try to downgrade
2921 * If not possible, croak. */
2922 SV* tsv = sv_2mortal(newSVsv(sv));
2925 sv_utf8_downgrade(tsv, FALSE);
2928 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2929 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2942 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2948 tmps = (SvPVx(sv, len));
2950 /* If Unicode, try to downgrade
2951 * If not possible, croak. */
2952 SV* tsv = sv_2mortal(newSVsv(sv));
2955 sv_utf8_downgrade(tsv, FALSE);
2958 while (*tmps && len && isSPACE(*tmps))
2963 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2964 else if (*tmps == 'b')
2965 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2967 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2969 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2986 SETi(sv_len_utf8(sv));
3002 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3004 I32 arybase = PL_curcop->cop_arybase;
3008 int num_args = PL_op->op_private & 7;
3009 bool repl_need_utf8_upgrade = FALSE;
3010 bool repl_is_utf8 = FALSE;
3012 SvTAINTED_off(TARG); /* decontaminate */
3013 SvUTF8_off(TARG); /* decontaminate */
3017 repl = SvPV(repl_sv, repl_len);
3018 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3028 sv_utf8_upgrade(sv);
3030 else if (DO_UTF8(sv))
3031 repl_need_utf8_upgrade = TRUE;
3033 tmps = SvPV(sv, curlen);
3035 utf8_curlen = sv_len_utf8(sv);
3036 if (utf8_curlen == curlen)
3039 curlen = utf8_curlen;
3044 if (pos >= arybase) {
3062 else if (len >= 0) {
3064 if (rem > (I32)curlen)
3079 Perl_croak(aTHX_ "substr outside of string");
3080 if (ckWARN(WARN_SUBSTR))
3081 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3088 sv_pos_u2b(sv, &pos, &rem);
3090 /* we either return a PV or an LV. If the TARG hasn't been used
3091 * before, or is of that type, reuse it; otherwise use a mortal
3092 * instead. Note that LVs can have an extended lifetime, so also
3093 * dont reuse if refcount > 1 (bug #20933) */
3094 if (SvTYPE(TARG) > SVt_NULL) {
3095 if ( (SvTYPE(TARG) == SVt_PVLV)
3096 ? (!lvalue || SvREFCNT(TARG) > 1)
3099 TARG = sv_newmortal();
3103 sv_setpvn(TARG, tmps, rem);
3104 #ifdef USE_LOCALE_COLLATE
3105 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3110 SV* repl_sv_copy = NULL;
3112 if (repl_need_utf8_upgrade) {
3113 repl_sv_copy = newSVsv(repl_sv);
3114 sv_utf8_upgrade(repl_sv_copy);
3115 repl = SvPV(repl_sv_copy, repl_len);
3116 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3118 sv_insert(sv, pos, rem, repl, repl_len);
3122 SvREFCNT_dec(repl_sv_copy);
3124 else if (lvalue) { /* it's an lvalue! */
3125 if (!SvGMAGICAL(sv)) {
3129 if (ckWARN(WARN_SUBSTR))
3130 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3131 "Attempt to use reference as lvalue in substr");
3133 if (SvOK(sv)) /* is it defined ? */
3134 (void)SvPOK_only_UTF8(sv);
3136 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3139 if (SvTYPE(TARG) < SVt_PVLV) {
3140 sv_upgrade(TARG, SVt_PVLV);
3141 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3144 (void)SvOK_off(TARG);
3147 if (LvTARG(TARG) != sv) {
3149 SvREFCNT_dec(LvTARG(TARG));
3150 LvTARG(TARG) = SvREFCNT_inc(sv);
3152 LvTARGOFF(TARG) = upos;
3153 LvTARGLEN(TARG) = urem;
3157 PUSHs(TARG); /* avoid SvSETMAGIC here */
3164 register IV size = POPi;
3165 register IV offset = POPi;
3166 register SV *src = POPs;
3167 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3169 SvTAINTED_off(TARG); /* decontaminate */
3170 if (lvalue) { /* it's an lvalue! */
3171 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3172 TARG = sv_newmortal();
3173 if (SvTYPE(TARG) < SVt_PVLV) {
3174 sv_upgrade(TARG, SVt_PVLV);
3175 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3178 if (LvTARG(TARG) != src) {
3180 SvREFCNT_dec(LvTARG(TARG));
3181 LvTARG(TARG) = SvREFCNT_inc(src);
3183 LvTARGOFF(TARG) = offset;
3184 LvTARGLEN(TARG) = size;
3187 sv_setuv(TARG, do_vecget(src, offset, size));
3202 I32 arybase = PL_curcop->cop_arybase;
3207 offset = POPi - arybase;
3210 tmps = SvPV(big, biglen);
3211 if (offset > 0 && DO_UTF8(big))
3212 sv_pos_u2b(big, &offset, 0);
3215 else if (offset > (I32)biglen)
3217 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3218 (unsigned char*)tmps + biglen, little, 0)))
3221 retval = tmps2 - tmps;
3222 if (retval > 0 && DO_UTF8(big))
3223 sv_pos_b2u(big, &retval);
3224 PUSHi(retval + arybase);
3239 I32 arybase = PL_curcop->cop_arybase;
3245 tmps2 = SvPV(little, llen);
3246 tmps = SvPV(big, blen);
3250 if (offset > 0 && DO_UTF8(big))
3251 sv_pos_u2b(big, &offset, 0);
3252 offset = offset - arybase + llen;
3256 else if (offset > (I32)blen)
3258 if (!(tmps2 = rninstr(tmps, tmps + offset,
3259 tmps2, tmps2 + llen)))
3262 retval = tmps2 - tmps;
3263 if (retval > 0 && DO_UTF8(big))
3264 sv_pos_b2u(big, &retval);
3265 PUSHi(retval + arybase);
3271 dSP; dMARK; dORIGMARK; dTARGET;
3272 do_sprintf(TARG, SP-MARK, MARK+1);
3273 TAINT_IF(SvTAINTED(TARG));
3274 if (DO_UTF8(*(MARK+1)))
3286 U8 *s = (U8*)SvPVx(argsv, len);
3289 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3290 tmpsv = sv_2mortal(newSVsv(argsv));
3291 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3295 XPUSHu(DO_UTF8(argsv) ?
3296 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3308 (void)SvUPGRADE(TARG,SVt_PV);
3310 if (value > 255 && !IN_BYTES) {
3311 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3312 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3313 SvCUR_set(TARG, tmps - SvPVX(TARG));
3315 (void)SvPOK_only(TARG);
3324 *tmps++ = (char)value;
3326 (void)SvPOK_only(TARG);
3327 if (PL_encoding && !IN_BYTES) {
3328 sv_recode_to_utf8(TARG, PL_encoding);
3330 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3331 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3335 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3336 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3352 char *tmps = SvPV(left, len);
3354 if (DO_UTF8(left)) {
3355 /* If Unicode, try to downgrade.
3356 * If not possible, croak.
3357 * Yes, we made this up. */
3358 SV* tsv = sv_2mortal(newSVsv(left));
3361 sv_utf8_downgrade(tsv, FALSE);
3364 # ifdef USE_ITHREADS
3366 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3367 /* This should be threadsafe because in ithreads there is only
3368 * one thread per interpreter. If this would not be true,
3369 * we would need a mutex to protect this malloc. */
3370 PL_reentrant_buffer->_crypt_struct_buffer =
3371 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3372 #if defined(__GLIBC__) || defined(__EMX__)
3373 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3374 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3375 /* work around glibc-2.2.5 bug */
3376 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3380 # endif /* HAS_CRYPT_R */
3381 # endif /* USE_ITHREADS */
3383 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3385 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3391 "The crypt() function is unimplemented due to excessive paranoia.");
3404 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3405 UTF8_IS_START(*s)) {
3406 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3410 utf8_to_uvchr(s, &ulen);
3411 toTITLE_utf8(s, tmpbuf, &tculen);
3412 utf8_to_uvchr(tmpbuf, 0);
3414 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3416 /* slen is the byte length of the whole SV.
3417 * ulen is the byte length of the original Unicode character
3418 * stored as UTF-8 at s.
3419 * tculen is the byte length of the freshly titlecased
3420 * Unicode character stored as UTF-8 at tmpbuf.
3421 * We first set the result to be the titlecased character,
3422 * and then append the rest of the SV data. */
3423 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3425 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3430 s = (U8*)SvPV_force_nomg(sv, slen);
3431 Copy(tmpbuf, s, tculen, U8);
3435 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3437 SvUTF8_off(TARG); /* decontaminate */
3438 sv_setsv_nomg(TARG, sv);
3442 s = (U8*)SvPV_force_nomg(sv, slen);
3444 if (IN_LOCALE_RUNTIME) {
3447 *s = toUPPER_LC(*s);
3466 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3467 UTF8_IS_START(*s)) {
3469 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3473 toLOWER_utf8(s, tmpbuf, &ulen);
3474 uv = utf8_to_uvchr(tmpbuf, 0);
3475 tend = uvchr_to_utf8(tmpbuf, uv);
3477 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3479 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3481 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3486 s = (U8*)SvPV_force_nomg(sv, slen);
3487 Copy(tmpbuf, s, ulen, U8);
3491 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3493 SvUTF8_off(TARG); /* decontaminate */
3494 sv_setsv_nomg(TARG, sv);
3498 s = (U8*)SvPV_force_nomg(sv, slen);
3500 if (IN_LOCALE_RUNTIME) {
3503 *s = toLOWER_LC(*s);
3526 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3528 s = (U8*)SvPV_nomg(sv,len);
3530 SvUTF8_off(TARG); /* decontaminate */
3531 sv_setpvn(TARG, "", 0);
3535 STRLEN nchar = utf8_length(s, s + len);
3537 (void)SvUPGRADE(TARG, SVt_PV);
3538 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3539 (void)SvPOK_only(TARG);
3540 d = (U8*)SvPVX(TARG);
3543 toUPPER_utf8(s, tmpbuf, &ulen);
3544 Copy(tmpbuf, d, ulen, U8);
3550 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3555 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3557 SvUTF8_off(TARG); /* decontaminate */
3558 sv_setsv_nomg(TARG, sv);
3562 s = (U8*)SvPV_force_nomg(sv, len);
3564 register U8 *send = s + len;
3566 if (IN_LOCALE_RUNTIME) {
3569 for (; s < send; s++)
3570 *s = toUPPER_LC(*s);
3573 for (; s < send; s++)
3595 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3597 s = (U8*)SvPV_nomg(sv,len);
3599 SvUTF8_off(TARG); /* decontaminate */
3600 sv_setpvn(TARG, "", 0);
3604 STRLEN nchar = utf8_length(s, s + len);
3606 (void)SvUPGRADE(TARG, SVt_PV);
3607 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3608 (void)SvPOK_only(TARG);
3609 d = (U8*)SvPVX(TARG);
3612 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3613 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3614 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3616 * Now if the sigma is NOT followed by
3617 * /$ignorable_sequence$cased_letter/;
3618 * and it IS preceded by
3619 * /$cased_letter$ignorable_sequence/;
3620 * where $ignorable_sequence is
3621 * [\x{2010}\x{AD}\p{Mn}]*
3622 * and $cased_letter is
3623 * [\p{Ll}\p{Lo}\p{Lt}]
3624 * then it should be mapped to 0x03C2,
3625 * (GREEK SMALL LETTER FINAL SIGMA),
3626 * instead of staying 0x03A3.
3627 * See lib/unicore/SpecCase.txt.
3630 Copy(tmpbuf, d, ulen, U8);
3636 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3641 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3643 SvUTF8_off(TARG); /* decontaminate */
3644 sv_setsv_nomg(TARG, sv);
3649 s = (U8*)SvPV_force_nomg(sv, len);
3651 register U8 *send = s + len;
3653 if (IN_LOCALE_RUNTIME) {
3656 for (; s < send; s++)
3657 *s = toLOWER_LC(*s);
3660 for (; s < send; s++)
3674 register char *s = SvPV(sv,len);
3677 SvUTF8_off(TARG); /* decontaminate */
3679 (void)SvUPGRADE(TARG, SVt_PV);
3680 SvGROW(TARG, (len * 2) + 1);
3684 if (UTF8_IS_CONTINUED(*s)) {
3685 STRLEN ulen = UTF8SKIP(s);
3709 SvCUR_set(TARG, d - SvPVX(TARG));
3710 (void)SvPOK_only_UTF8(TARG);
3713 sv_setpvn(TARG, s, len);
3715 if (SvSMAGICAL(TARG))
3724 dSP; dMARK; dORIGMARK;
3726 register AV* av = (AV*)POPs;
3727 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3728 I32 arybase = PL_curcop->cop_arybase;
3731 if (SvTYPE(av) == SVt_PVAV) {
3732 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3734 for (svp = MARK + 1; svp <= SP; svp++) {
3739 if (max > AvMAX(av))
3742 while (++MARK <= SP) {
3743 elem = SvIVx(*MARK);
3747 svp = av_fetch(av, elem, lval);
3749 if (!svp || *svp == &PL_sv_undef)
3750 DIE(aTHX_ PL_no_aelem, elem);
3751 if (PL_op->op_private & OPpLVAL_INTRO)
3752 save_aelem(av, elem, svp);
3754 *MARK = svp ? *svp : &PL_sv_undef;
3757 if (GIMME != G_ARRAY) {
3759 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3765 /* Associative arrays. */
3770 HV *hash = (HV*)POPs;
3772 I32 gimme = GIMME_V;
3775 /* might clobber stack_sp */
3776 entry = hv_iternext(hash);
3781 SV* sv = hv_iterkeysv(entry);
3782 PUSHs(sv); /* won't clobber stack_sp */
3783 if (gimme == G_ARRAY) {
3786 /* might clobber stack_sp */
3787 val = hv_iterval(hash, entry);
3792 else if (gimme == G_SCALAR)
3811 I32 gimme = GIMME_V;
3812 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3816 if (PL_op->op_private & OPpSLICE) {
3820 hvtype = SvTYPE(hv);
3821 if (hvtype == SVt_PVHV) { /* hash element */
3822 while (++MARK <= SP) {
3823 sv = hv_delete_ent(hv, *MARK, discard, 0);
3824 *MARK = sv ? sv : &PL_sv_undef;
3827 else if (hvtype == SVt_PVAV) { /* array element */
3828 if (PL_op->op_flags & OPf_SPECIAL) {
3829 while (++MARK <= SP) {
3830 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3831 *MARK = sv ? sv : &PL_sv_undef;
3836 DIE(aTHX_ "Not a HASH reference");
3839 else if (gimme == G_SCALAR) {
3844 *++MARK = &PL_sv_undef;
3851 if (SvTYPE(hv) == SVt_PVHV)
3852 sv = hv_delete_ent(hv, keysv, discard, 0);
3853 else if (SvTYPE(hv) == SVt_PVAV) {
3854 if (PL_op->op_flags & OPf_SPECIAL)
3855 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3857 DIE(aTHX_ "panic: avhv_delete no longer supported");
3860 DIE(aTHX_ "Not a HASH reference");
3875 if (PL_op->op_private & OPpEXISTS_SUB) {
3879 cv = sv_2cv(sv, &hv, &gv, FALSE);
3882 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3888 if (SvTYPE(hv) == SVt_PVHV) {
3889 if (hv_exists_ent(hv, tmpsv, 0))
3892 else if (SvTYPE(hv) == SVt_PVAV) {
3893 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3894 if (av_exists((AV*)hv, SvIV(tmpsv)))
3899 DIE(aTHX_ "Not a HASH reference");
3906 dSP; dMARK; dORIGMARK;
3907 register HV *hv = (HV*)POPs;
3908 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3909 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3910 bool other_magic = FALSE;
3916 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3917 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3918 /* Try to preserve the existenceness of a tied hash
3919 * element by using EXISTS and DELETE if possible.
3920 * Fallback to FETCH and STORE otherwise */
3921 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3922 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3923 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3926 while (++MARK <= SP) {
3930 bool preeminent = FALSE;
3933 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3934 hv_exists_ent(hv, keysv, 0);
3937 he = hv_fetch_ent(hv, keysv, lval, 0);
3938 svp = he ? &HeVAL(he) : 0;
3941 if (!svp || *svp == &PL_sv_undef) {
3943 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3947 save_helem(hv, keysv, svp);
3950 char *key = SvPV(keysv, keylen);
3951 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3955 *MARK = svp ? *svp : &PL_sv_undef;
3957 if (GIMME != G_ARRAY) {
3959 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3965 /* List operators. */
3970 if (GIMME != G_ARRAY) {
3972 *MARK = *SP; /* unwanted list, return last item */
3974 *MARK = &PL_sv_undef;
3983 SV **lastrelem = PL_stack_sp;
3984 SV **lastlelem = PL_stack_base + POPMARK;
3985 SV **firstlelem = PL_stack_base + POPMARK + 1;
3986 register SV **firstrelem = lastlelem + 1;
3987 I32 arybase = PL_curcop->cop_arybase;
3988 I32 lval = PL_op->op_flags & OPf_MOD;
3989 I32 is_something_there = lval;
3991 register I32 max = lastrelem - lastlelem;
3992 register SV **lelem;
3995 if (GIMME != G_ARRAY) {
3996 ix = SvIVx(*lastlelem);
4001 if (ix < 0 || ix >= max)
4002 *firstlelem = &PL_sv_undef;
4004 *firstlelem = firstrelem[ix];
4010 SP = firstlelem - 1;
4014 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4020 if (ix < 0 || ix >= max)
4021 *lelem = &PL_sv_undef;
4023 is_something_there = TRUE;
4024 if (!(*lelem = firstrelem[ix]))
4025 *lelem = &PL_sv_undef;
4028 if (is_something_there)
4031 SP = firstlelem - 1;
4037 dSP; dMARK; dORIGMARK;
4038 I32 items = SP - MARK;
4039 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4040 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4047 dSP; dMARK; dORIGMARK;
4048 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4052 SV *val = NEWSV(46, 0);
4054 sv_setsv(val, *++MARK);
4055 else if (ckWARN(WARN_MISC))
4056 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4057 (void)hv_store_ent(hv,key,val,0);
4066 dSP; dMARK; dORIGMARK;
4067 register AV *ary = (AV*)*++MARK;
4071 register I32 offset;
4072 register I32 length;
4079 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4080 *MARK-- = SvTIED_obj((SV*)ary, mg);
4084 call_method("SPLICE",GIMME_V);
4093 offset = i = SvIVx(*MARK);
4095 offset += AvFILLp(ary) + 1;
4097 offset -= PL_curcop->cop_arybase;
4099 DIE(aTHX_ PL_no_aelem, i);
4101 length = SvIVx(*MARK++);
4103 length += AvFILLp(ary) - offset + 1;
4109 length = AvMAX(ary) + 1; /* close enough to infinity */
4113 length = AvMAX(ary) + 1;
4115 if (offset > AvFILLp(ary) + 1) {
4116 if (ckWARN(WARN_MISC))
4117 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4118 offset = AvFILLp(ary) + 1;
4120 after = AvFILLp(ary) + 1 - (offset + length);
4121 if (after < 0) { /* not that much array */
4122 length += after; /* offset+length now in array */
4128 /* At this point, MARK .. SP-1 is our new LIST */
4131 diff = newlen - length;
4132 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4135 /* make new elements SVs now: avoid problems if they're from the array */
4136 for (dst = MARK, i = newlen; i; i--) {
4138 *dst = NEWSV(46, 0);
4139 sv_setsv(*dst++, h);
4142 if (diff < 0) { /* shrinking the area */
4144 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4145 Copy(MARK, tmparyval, newlen, SV*);
4148 MARK = ORIGMARK + 1;
4149 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4150 MEXTEND(MARK, length);
4151 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4153 EXTEND_MORTAL(length);
4154 for (i = length, dst = MARK; i; i--) {
4155 sv_2mortal(*dst); /* free them eventualy */
4162 *MARK = AvARRAY(ary)[offset+length-1];
4165 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4166 SvREFCNT_dec(*dst++); /* free them now */
4169 AvFILLp(ary) += diff;
4171 /* pull up or down? */
4173 if (offset < after) { /* easier to pull up */
4174 if (offset) { /* esp. if nothing to pull */
4175 src = &AvARRAY(ary)[offset-1];
4176 dst = src - diff; /* diff is negative */
4177 for (i = offset; i > 0; i--) /* can't trust Copy */
4181 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4185 if (after) { /* anything to pull down? */
4186 src = AvARRAY(ary) + offset + length;
4187 dst = src + diff; /* diff is negative */
4188 Move(src, dst, after, SV*);
4190 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4191 /* avoid later double free */
4195 dst[--i] = &PL_sv_undef;
4198 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4199 Safefree(tmparyval);
4202 else { /* no, expanding (or same) */
4204 New(452, tmparyval, length, SV*); /* so remember deletion */
4205 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4208 if (diff > 0) { /* expanding */
4210 /* push up or down? */
4212 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4216 Move(src, dst, offset, SV*);
4218 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4220 AvFILLp(ary) += diff;
4223 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4224 av_extend(ary, AvFILLp(ary) + diff);
4225 AvFILLp(ary) += diff;
4228 dst = AvARRAY(ary) + AvFILLp(ary);
4230 for (i = after; i; i--) {
4238 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4241 MARK = ORIGMARK + 1;
4242 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4244 Copy(tmparyval, MARK, length, SV*);
4246 EXTEND_MORTAL(length);
4247 for (i = length, dst = MARK; i; i--) {
4248 sv_2mortal(*dst); /* free them eventualy */
4252 Safefree(tmparyval);
4256 else if (length--) {
4257 *MARK = tmparyval[length];
4260 while (length-- > 0)
4261 SvREFCNT_dec(tmparyval[length]);
4263 Safefree(tmparyval);
4266 *MARK = &PL_sv_undef;
4274 dSP; dMARK; dORIGMARK; dTARGET;
4275 register AV *ary = (AV*)*++MARK;
4276 register SV *sv = &PL_sv_undef;
4279 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4280 *MARK-- = SvTIED_obj((SV*)ary, mg);
4284 call_method("PUSH",G_SCALAR|G_DISCARD);
4289 /* Why no pre-extend of ary here ? */
4290 for (++MARK; MARK <= SP; MARK++) {
4293 sv_setsv(sv, *MARK);
4298 PUSHi( AvFILL(ary) + 1 );
4306 SV *sv = av_pop(av);
4308 (void)sv_2mortal(sv);
4317 SV *sv = av_shift(av);
4322 (void)sv_2mortal(sv);
4329 dSP; dMARK; dORIGMARK; dTARGET;
4330 register AV *ary = (AV*)*++MARK;
4335 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4336 *MARK-- = SvTIED_obj((SV*)ary, mg);
4340 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4345 av_unshift(ary, SP - MARK);
4348 sv_setsv(sv, *++MARK);
4349 (void)av_store(ary, i++, sv);
4353 PUSHi( AvFILL(ary) + 1 );
4363 if (GIMME == G_ARRAY) {
4370 /* safe as long as stack cannot get extended in the above */
4375 register char *down;
4381 SvUTF8_off(TARG); /* decontaminate */
4383 do_join(TARG, &PL_sv_no, MARK, SP);
4385 sv_setsv(TARG, (SP > MARK)
4387 : (padoff_du = find_rundefsvoffset(),
4388 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4389 ? DEFSV : PAD_SVl(padoff_du)));
4390 up = SvPV_force(TARG, len);
4392 if (DO_UTF8(TARG)) { /* first reverse each character */
4393 U8* s = (U8*)SvPVX(TARG);
4394 U8* send = (U8*)(s + len);
4396 if (UTF8_IS_INVARIANT(*s)) {
4401 if (!utf8_to_uvchr(s, 0))
4405 down = (char*)(s - 1);
4406 /* reverse this character */
4410 *down-- = (char)tmp;
4416 down = SvPVX(TARG) + len - 1;
4420 *down-- = (char)tmp;
4422 (void)SvPOK_only_UTF8(TARG);
4434 register IV limit = POPi; /* note, negative is forever */
4437 register char *s = SvPV(sv, len);
4438 bool do_utf8 = DO_UTF8(sv);
4439 char *strend = s + len;
4441 register REGEXP *rx;
4445 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4446 I32 maxiters = slen + 10;
4449 I32 origlimit = limit;
4452 I32 gimme = GIMME_V;
4453 I32 oldsave = PL_savestack_ix;
4454 I32 make_mortal = 1;
4455 MAGIC *mg = (MAGIC *) NULL;
4458 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4463 DIE(aTHX_ "panic: pp_split");
4466 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4467 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4469 RX_MATCH_UTF8_set(rx, do_utf8);
4471 if (pm->op_pmreplroot) {
4473 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4475 ary = GvAVn((GV*)pm->op_pmreplroot);
4478 else if (gimme != G_ARRAY)
4479 ary = GvAVn(PL_defgv);
4482 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4488 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4490 XPUSHs(SvTIED_obj((SV*)ary, mg));
4496 for (i = AvFILLp(ary); i >= 0; i--)
4497 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4499 /* temporarily switch stacks */
4500 SAVESWITCHSTACK(PL_curstack, ary);
4504 base = SP - PL_stack_base;
4506 if (pm->op_pmflags & PMf_SKIPWHITE) {
4507 if (pm->op_pmflags & PMf_LOCALE) {
4508 while (isSPACE_LC(*s))
4516 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4517 SAVEINT(PL_multiline);
4518 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4522 limit = maxiters + 2;
4523 if (pm->op_pmflags & PMf_WHITE) {
4526 while (m < strend &&
4527 !((pm->op_pmflags & PMf_LOCALE)
4528 ? isSPACE_LC(*m) : isSPACE(*m)))
4533 dstr = NEWSV(30, m-s);
4534 sv_setpvn(dstr, s, m-s);
4538 (void)SvUTF8_on(dstr);
4542 while (s < strend &&
4543 ((pm->op_pmflags & PMf_LOCALE)
4544 ? isSPACE_LC(*s) : isSPACE(*s)))
4548 else if (strEQ("^", rx->precomp)) {
4551 for (m = s; m < strend && *m != '\n'; m++) ;
4555 dstr = NEWSV(30, m-s);
4556 sv_setpvn(dstr, s, m-s);
4560 (void)SvUTF8_on(dstr);
4565 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4566 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4567 && (rx->reganch & ROPT_CHECK_ALL)
4568 && !(rx->reganch & ROPT_ANCH)) {
4569 int tail = (rx->reganch & RE_INTUIT_TAIL);
4570 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4573 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4575 char c = *SvPV(csv, n_a);
4578 for (m = s; m < strend && *m != c; m++) ;
4581 dstr = NEWSV(30, m-s);
4582 sv_setpvn(dstr, s, m-s);
4586 (void)SvUTF8_on(dstr);
4588 /* The rx->minlen is in characters but we want to step
4589 * s ahead by bytes. */
4591 s = (char*)utf8_hop((U8*)m, len);
4593 s = m + len; /* Fake \n at the end */
4598 while (s < strend && --limit &&
4599 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4600 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4603 dstr = NEWSV(31, m-s);
4604 sv_setpvn(dstr, s, m-s);
4608 (void)SvUTF8_on(dstr);
4610 /* The rx->minlen is in characters but we want to step
4611 * s ahead by bytes. */
4613 s = (char*)utf8_hop((U8*)m, len);
4615 s = m + len; /* Fake \n at the end */
4620 maxiters += slen * rx->nparens;
4621 while (s < strend && --limit)
4624 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4628 TAINT_IF(RX_MATCH_TAINTED(rx));
4629 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4634 strend = s + (strend - m);
4636 m = rx->startp[0] + orig;
4637 dstr = NEWSV(32, m-s);
4638 sv_setpvn(dstr, s, m-s);
4642 (void)SvUTF8_on(dstr);
4645 for (i = 1; i <= (I32)rx->nparens; i++) {
4646 s = rx->startp[i] + orig;
4647 m = rx->endp[i] + orig;
4649 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4650 parens that didn't match -- they should be set to
4651 undef, not the empty string */
4652 if (m >= orig && s >= orig) {
4653 dstr = NEWSV(33, m-s);
4654 sv_setpvn(dstr, s, m-s);
4657 dstr = &PL_sv_undef; /* undef, not "" */
4661 (void)SvUTF8_on(dstr);
4665 s = rx->endp[0] + orig;
4669 iters = (SP - PL_stack_base) - base;
4670 if (iters > maxiters)
4671 DIE(aTHX_ "Split loop");
4673 /* keep field after final delim? */
4674 if (s < strend || (iters && origlimit)) {
4675 STRLEN l = strend - s;
4676 dstr = NEWSV(34, l);
4677 sv_setpvn(dstr, s, l);
4681 (void)SvUTF8_on(dstr);
4685 else if (!origlimit) {
4686 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4687 if (TOPs && !make_mortal)
4690 *SP-- = &PL_sv_undef;
4695 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4699 if (SvSMAGICAL(ary)) {
4704 if (gimme == G_ARRAY) {
4706 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4714 call_method("PUSH",G_SCALAR|G_DISCARD);
4717 if (gimme == G_ARRAY) {
4718 /* EXTEND should not be needed - we just popped them */
4720 for (i=0; i < iters; i++) {
4721 SV **svp = av_fetch(ary, i, FALSE);
4722 PUSHs((svp) ? *svp : &PL_sv_undef);
4729 if (gimme == G_ARRAY)
4744 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4745 || SvTYPE(retsv) == SVt_PVCV) {
4746 retsv = refto(retsv);
4754 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");