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 */
181 SvLEN(sv)=SvCUR(sv)=0;
188 if (PL_op->op_flags & OPf_REF ||
189 PL_op->op_private & HINT_STRICT_REFS)
190 DIE(aTHX_ PL_no_usym, "a symbol");
191 if (ckWARN(WARN_UNINITIALIZED))
195 if ((PL_op->op_flags & OPf_SPECIAL) &&
196 !(PL_op->op_flags & OPf_MOD))
198 SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
200 && (!is_gv_magical_sv(sv,0)
201 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
207 if (PL_op->op_private & HINT_STRICT_REFS)
208 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
209 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
213 if (PL_op->op_private & OPpLVAL_INTRO)
214 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
226 tryAMAGICunDEREF(to_sv);
229 switch (SvTYPE(sv)) {
233 DIE(aTHX_ "Not a SCALAR reference");
239 if (SvTYPE(gv) != SVt_PVGV) {
240 if (SvGMAGICAL(sv)) {
246 if (PL_op->op_flags & OPf_REF ||
247 PL_op->op_private & HINT_STRICT_REFS)
248 DIE(aTHX_ PL_no_usym, "a SCALAR");
249 if (ckWARN(WARN_UNINITIALIZED))
253 if ((PL_op->op_flags & OPf_SPECIAL) &&
254 !(PL_op->op_flags & OPf_MOD))
256 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
258 && (!is_gv_magical_sv(sv, 0)
259 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
265 if (PL_op->op_private & HINT_STRICT_REFS)
266 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
267 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
272 if (PL_op->op_flags & OPf_MOD) {
273 if (PL_op->op_private & OPpLVAL_INTRO) {
274 if (cUNOP->op_first->op_type == OP_NULL)
275 sv = save_scalar((GV*)TOPs);
277 sv = save_scalar(gv);
279 Perl_croak(aTHX_ PL_no_localize_ref);
281 else if (PL_op->op_private & OPpDEREF)
282 vivify_ref(sv, PL_op->op_private & OPpDEREF);
292 SV *sv = AvARYLEN(av);
294 AvARYLEN(av) = sv = NEWSV(0,0);
295 sv_upgrade(sv, SVt_IV);
296 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
304 dSP; dTARGET; dPOPss;
306 if (PL_op->op_flags & OPf_MOD || LVRET) {
307 if (SvTYPE(TARG) < SVt_PVLV) {
308 sv_upgrade(TARG, SVt_PVLV);
309 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
313 if (LvTARG(TARG) != sv) {
315 SvREFCNT_dec(LvTARG(TARG));
316 LvTARG(TARG) = SvREFCNT_inc(sv);
318 PUSHs(TARG); /* no SvSETMAGIC */
324 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
325 mg = mg_find(sv, PERL_MAGIC_regex_global);
326 if (mg && mg->mg_len >= 0) {
330 PUSHi(i + PL_curcop->cop_arybase);
344 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
345 /* (But not in defined().) */
346 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
349 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
350 if ((PL_op->op_private & OPpLVAL_INTRO)) {
351 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
354 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
358 cv = (CV*)&PL_sv_undef;
372 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
373 char *s = SvPVX(TOPs);
374 if (strnEQ(s, "CORE::", 6)) {
377 code = keyword(s + 6, SvCUR(TOPs) - 6);
378 if (code < 0) { /* Overridable. */
379 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
380 int i = 0, n = 0, seen_question = 0;
382 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
384 if (code == -KEY_chop || code == -KEY_chomp)
386 while (i < MAXO) { /* The slow way. */
387 if (strEQ(s + 6, PL_op_name[i])
388 || strEQ(s + 6, PL_op_desc[i]))
394 goto nonesuch; /* Should not happen... */
396 oa = PL_opargs[i] >> OASHIFT;
398 if (oa & OA_OPTIONAL && !seen_question) {
402 else if (n && str[0] == ';' && seen_question)
403 goto set; /* XXXX system, exec */
404 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
405 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
406 /* But globs are already references (kinda) */
407 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
411 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
415 ret = sv_2mortal(newSVpvn(str, n - 1));
417 else if (code) /* Non-Overridable */
419 else { /* None such */
421 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
425 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
427 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
436 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
438 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
454 if (GIMME != G_ARRAY) {
458 *MARK = &PL_sv_undef;
459 *MARK = refto(*MARK);
463 EXTEND_MORTAL(SP - MARK);
465 *MARK = refto(*MARK);
470 S_refto(pTHX_ SV *sv)
474 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
477 if (!(sv = LvTARG(sv)))
480 (void)SvREFCNT_inc(sv);
482 else if (SvTYPE(sv) == SVt_PVAV) {
483 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
486 (void)SvREFCNT_inc(sv);
488 else if (SvPADTMP(sv) && !IS_PADGV(sv))
492 (void)SvREFCNT_inc(sv);
495 sv_upgrade(rv, SVt_RV);
509 if (sv && SvGMAGICAL(sv))
512 if (!sv || !SvROK(sv))
516 pv = sv_reftype(sv,TRUE);
517 PUSHp(pv, strlen(pv));
527 stash = CopSTASH(PL_curcop);
533 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
534 Perl_croak(aTHX_ "Attempt to bless into a reference");
536 if (ckWARN(WARN_MISC) && len == 0)
537 Perl_warner(aTHX_ packWARN(WARN_MISC),
538 "Explicit blessing to '' (assuming package main)");
539 stash = gv_stashpvn(ptr, len, TRUE);
542 (void)sv_bless(TOPs, stash);
556 elem = SvPV(sv, n_a);
561 /* elem will always be NUL terminated. */
562 const char *elem2 = elem + 1;
565 if (strEQ(elem2, "RRAY"))
566 tmpRef = (SV*)GvAV(gv);
569 if (strEQ(elem2, "ODE"))
570 tmpRef = (SV*)GvCVu(gv);
573 if (strEQ(elem2, "ILEHANDLE")) {
574 /* finally deprecated in 5.8.0 */
575 deprecate("*glob{FILEHANDLE}");
576 tmpRef = (SV*)GvIOp(gv);
579 if (strEQ(elem2, "ORMAT"))
580 tmpRef = (SV*)GvFORM(gv);
583 if (strEQ(elem2, "LOB"))
587 if (strEQ(elem2, "ASH"))
588 tmpRef = (SV*)GvHV(gv);
591 if (*elem2 == 'O' && !elem[2])
592 tmpRef = (SV*)GvIOp(gv);
595 if (strEQ(elem2, "AME"))
596 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
599 if (strEQ(elem2, "ACKAGE")) {
600 char *name = HvNAME(GvSTASH(gv));
601 sv = newSVpv(name ? name : "__ANON__", 0);
605 if (strEQ(elem2, "CALAR"))
620 /* Pattern matching */
625 register unsigned char *s;
628 register I32 *sfirst;
632 if (sv == PL_lastscream) {
638 SvSCREAM_off(PL_lastscream);
639 SvREFCNT_dec(PL_lastscream);
641 PL_lastscream = SvREFCNT_inc(sv);
644 s = (unsigned char*)(SvPV(sv, len));
648 if (pos > PL_maxscream) {
649 if (PL_maxscream < 0) {
650 PL_maxscream = pos + 80;
651 New(301, PL_screamfirst, 256, I32);
652 New(302, PL_screamnext, PL_maxscream, I32);
655 PL_maxscream = pos + pos / 4;
656 Renew(PL_screamnext, PL_maxscream, I32);
660 sfirst = PL_screamfirst;
661 snext = PL_screamnext;
663 if (!sfirst || !snext)
664 DIE(aTHX_ "do_study: out of memory");
666 for (ch = 256; ch; --ch)
673 snext[pos] = sfirst[ch] - pos;
680 /* piggyback on m//g magic */
681 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
690 if (PL_op->op_flags & OPf_STACKED)
692 else if (PL_op->op_private & OPpTARGET_MY)
698 TARG = sv_newmortal();
703 /* Lvalue operators. */
715 dSP; dMARK; dTARGET; dORIGMARK;
717 do_chop(TARG, *++MARK);
726 SETi(do_chomp(TOPs));
733 register I32 count = 0;
736 count += do_chomp(POPs);
747 if (!sv || !SvANY(sv))
749 switch (SvTYPE(sv)) {
751 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
752 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
756 if (HvARRAY(sv) || SvGMAGICAL(sv)
757 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
761 if (CvROOT(sv) || CvXSUB(sv))
778 if (!PL_op->op_private) {
787 SV_CHECK_THINKFIRST_COW_DROP(sv);
789 switch (SvTYPE(sv)) {
799 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
800 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
801 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
805 /* let user-undef'd sub keep its identity */
806 GV* gv = CvGV((CV*)sv);
813 SvSetMagicSV(sv, &PL_sv_undef);
817 Newz(602, gp, 1, GP);
818 GvGP(sv) = gp_ref(gp);
819 GvSV(sv) = NEWSV(72,0);
820 GvLINE(sv) = CopLINE(PL_curcop);
826 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
829 SvPV_set(sv, Nullch);
842 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
843 DIE(aTHX_ PL_no_modify);
844 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
845 && SvIVX(TOPs) != IV_MIN)
848 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
859 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
860 DIE(aTHX_ PL_no_modify);
861 sv_setsv(TARG, TOPs);
862 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
863 && SvIVX(TOPs) != IV_MAX)
866 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
871 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
881 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
882 DIE(aTHX_ PL_no_modify);
883 sv_setsv(TARG, TOPs);
884 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
885 && SvIVX(TOPs) != IV_MIN)
888 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
897 /* Ordinary operators. */
902 #ifdef PERL_PRESERVE_IVUV
905 tryAMAGICbin(pow,opASSIGN);
906 #ifdef PERL_PRESERVE_IVUV
907 /* For integer to integer power, we do the calculation by hand wherever
908 we're sure it is safe; otherwise we call pow() and try to convert to
909 integer afterwards. */
913 bool baseuok = SvUOK(TOPm1s);
917 baseuv = SvUVX(TOPm1s);
919 IV iv = SvIVX(TOPm1s);
922 baseuok = TRUE; /* effectively it's a UV now */
924 baseuv = -iv; /* abs, baseuok == false records sign */
938 goto float_it; /* Can't do negative powers this way. */
941 /* now we have integer ** positive integer. */
944 /* foo & (foo - 1) is zero only for a power of 2. */
945 if (!(baseuv & (baseuv - 1))) {
946 /* We are raising power-of-2 to a positive integer.
947 The logic here will work for any base (even non-integer
948 bases) but it can be less accurate than
949 pow (base,power) or exp (power * log (base)) when the
950 intermediate values start to spill out of the mantissa.
951 With powers of 2 we know this can't happen.
952 And powers of 2 are the favourite thing for perl
953 programmers to notice ** not doing what they mean. */
955 NV base = baseuok ? baseuv : -(NV)baseuv;
958 for (; power; base *= base, n++) {
959 /* Do I look like I trust gcc with long longs here?
961 UV bit = (UV)1 << (UV)n;
964 /* Only bother to clear the bit if it is set. */
966 /* Avoid squaring base again if we're done. */
967 if (power == 0) break;
975 register unsigned int highbit = 8 * sizeof(UV);
976 register unsigned int lowbit = 0;
977 register unsigned int diff;
978 bool odd_power = (bool)(power & 1);
979 while ((diff = (highbit - lowbit) >> 1)) {
980 if (baseuv & ~((1 << (lowbit + diff)) - 1))
985 /* we now have baseuv < 2 ** highbit */
986 if (power * highbit <= 8 * sizeof(UV)) {
987 /* result will definitely fit in UV, so use UV math
988 on same algorithm as above */
989 register UV result = 1;
990 register UV base = baseuv;
992 for (; power; base *= base, n++) {
993 register UV bit = (UV)1 << (UV)n;
997 if (power == 0) break;
1001 if (baseuok || !odd_power)
1002 /* answer is positive */
1004 else if (result <= (UV)IV_MAX)
1005 /* answer negative, fits in IV */
1006 SETi( -(IV)result );
1007 else if (result == (UV)IV_MIN)
1008 /* 2's complement assumption: special case IV_MIN */
1011 /* answer negative, doesn't fit */
1012 SETn( -(NV)result );
1023 SETn( Perl_pow( left, right) );
1024 #ifdef PERL_PRESERVE_IVUV
1034 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1035 #ifdef PERL_PRESERVE_IVUV
1038 /* Unless the left argument is integer in range we are going to have to
1039 use NV maths. Hence only attempt to coerce the right argument if
1040 we know the left is integer. */
1041 /* Left operand is defined, so is it IV? */
1042 SvIV_please(TOPm1s);
1043 if (SvIOK(TOPm1s)) {
1044 bool auvok = SvUOK(TOPm1s);
1045 bool buvok = SvUOK(TOPs);
1046 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1047 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1054 alow = SvUVX(TOPm1s);
1056 IV aiv = SvIVX(TOPm1s);
1059 auvok = TRUE; /* effectively it's a UV now */
1061 alow = -aiv; /* abs, auvok == false records sign */
1067 IV biv = SvIVX(TOPs);
1070 buvok = TRUE; /* effectively it's a UV now */
1072 blow = -biv; /* abs, buvok == false records sign */
1076 /* If this does sign extension on unsigned it's time for plan B */
1077 ahigh = alow >> (4 * sizeof (UV));
1079 bhigh = blow >> (4 * sizeof (UV));
1081 if (ahigh && bhigh) {
1082 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1083 which is overflow. Drop to NVs below. */
1084 } else if (!ahigh && !bhigh) {
1085 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1086 so the unsigned multiply cannot overflow. */
1087 UV product = alow * blow;
1088 if (auvok == buvok) {
1089 /* -ve * -ve or +ve * +ve gives a +ve result. */
1093 } else if (product <= (UV)IV_MIN) {
1094 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1095 /* -ve result, which could overflow an IV */
1097 SETi( -(IV)product );
1099 } /* else drop to NVs below. */
1101 /* One operand is large, 1 small */
1104 /* swap the operands */
1106 bhigh = blow; /* bhigh now the temp var for the swap */
1110 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1111 multiplies can't overflow. shift can, add can, -ve can. */
1112 product_middle = ahigh * blow;
1113 if (!(product_middle & topmask)) {
1114 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1116 product_middle <<= (4 * sizeof (UV));
1117 product_low = alow * blow;
1119 /* as for pp_add, UV + something mustn't get smaller.
1120 IIRC ANSI mandates this wrapping *behaviour* for
1121 unsigned whatever the actual representation*/
1122 product_low += product_middle;
1123 if (product_low >= product_middle) {
1124 /* didn't overflow */
1125 if (auvok == buvok) {
1126 /* -ve * -ve or +ve * +ve gives a +ve result. */
1128 SETu( product_low );
1130 } else if (product_low <= (UV)IV_MIN) {
1131 /* 2s complement assumption again */
1132 /* -ve result, which could overflow an IV */
1134 SETi( -(IV)product_low );
1136 } /* else drop to NVs below. */
1138 } /* product_middle too large */
1139 } /* ahigh && bhigh */
1140 } /* SvIOK(TOPm1s) */
1145 SETn( left * right );
1152 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1153 /* Only try to do UV divide first
1154 if ((SLOPPYDIVIDE is true) or
1155 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1157 The assumption is that it is better to use floating point divide
1158 whenever possible, only doing integer divide first if we can't be sure.
1159 If NV_PRESERVES_UV is true then we know at compile time that no UV
1160 can be too large to preserve, so don't need to compile the code to
1161 test the size of UVs. */
1164 # define PERL_TRY_UV_DIVIDE
1165 /* ensure that 20./5. == 4. */
1167 # ifdef PERL_PRESERVE_IVUV
1168 # ifndef NV_PRESERVES_UV
1169 # define PERL_TRY_UV_DIVIDE
1174 #ifdef PERL_TRY_UV_DIVIDE
1177 SvIV_please(TOPm1s);
1178 if (SvIOK(TOPm1s)) {
1179 bool left_non_neg = SvUOK(TOPm1s);
1180 bool right_non_neg = SvUOK(TOPs);
1184 if (right_non_neg) {
1185 right = SvUVX(TOPs);
1188 IV biv = SvIVX(TOPs);
1191 right_non_neg = TRUE; /* effectively it's a UV now */
1197 /* historically undef()/0 gives a "Use of uninitialized value"
1198 warning before dieing, hence this test goes here.
1199 If it were immediately before the second SvIV_please, then
1200 DIE() would be invoked before left was even inspected, so
1201 no inpsection would give no warning. */
1203 DIE(aTHX_ "Illegal division by zero");
1206 left = SvUVX(TOPm1s);
1209 IV aiv = SvIVX(TOPm1s);
1212 left_non_neg = TRUE; /* effectively it's a UV now */
1221 /* For sloppy divide we always attempt integer division. */
1223 /* Otherwise we only attempt it if either or both operands
1224 would not be preserved by an NV. If both fit in NVs
1225 we fall through to the NV divide code below. However,
1226 as left >= right to ensure integer result here, we know that
1227 we can skip the test on the right operand - right big
1228 enough not to be preserved can't get here unless left is
1231 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1234 /* Integer division can't overflow, but it can be imprecise. */
1235 UV result = left / right;
1236 if (result * right == left) {
1237 SP--; /* result is valid */
1238 if (left_non_neg == right_non_neg) {
1239 /* signs identical, result is positive. */
1243 /* 2s complement assumption */
1244 if (result <= (UV)IV_MIN)
1245 SETi( -(IV)result );
1247 /* It's exact but too negative for IV. */
1248 SETn( -(NV)result );
1251 } /* tried integer divide but it was not an integer result */
1252 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1253 } /* left wasn't SvIOK */
1254 } /* right wasn't SvIOK */
1255 #endif /* PERL_TRY_UV_DIVIDE */
1259 DIE(aTHX_ "Illegal division by zero");
1260 PUSHn( left / right );
1267 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1271 bool left_neg = FALSE;
1272 bool right_neg = FALSE;
1273 bool use_double = FALSE;
1274 bool dright_valid = FALSE;
1280 right_neg = !SvUOK(TOPs);
1282 right = SvUVX(POPs);
1284 IV biv = SvIVX(POPs);
1287 right_neg = FALSE; /* effectively it's a UV now */
1295 right_neg = dright < 0;
1298 if (dright < UV_MAX_P1) {
1299 right = U_V(dright);
1300 dright_valid = TRUE; /* In case we need to use double below. */
1306 /* At this point use_double is only true if right is out of range for
1307 a UV. In range NV has been rounded down to nearest UV and
1308 use_double false. */
1310 if (!use_double && SvIOK(TOPs)) {
1312 left_neg = !SvUOK(TOPs);
1316 IV aiv = SvIVX(POPs);
1319 left_neg = FALSE; /* effectively it's a UV now */
1328 left_neg = dleft < 0;
1332 /* This should be exactly the 5.6 behaviour - if left and right are
1333 both in range for UV then use U_V() rather than floor. */
1335 if (dleft < UV_MAX_P1) {
1336 /* right was in range, so is dleft, so use UVs not double.
1340 /* left is out of range for UV, right was in range, so promote
1341 right (back) to double. */
1343 /* The +0.5 is used in 5.6 even though it is not strictly
1344 consistent with the implicit +0 floor in the U_V()
1345 inside the #if 1. */
1346 dleft = Perl_floor(dleft + 0.5);
1349 dright = Perl_floor(dright + 0.5);
1359 DIE(aTHX_ "Illegal modulus zero");
1361 dans = Perl_fmod(dleft, dright);
1362 if ((left_neg != right_neg) && dans)
1363 dans = dright - dans;
1366 sv_setnv(TARG, dans);
1372 DIE(aTHX_ "Illegal modulus zero");
1375 if ((left_neg != right_neg) && ans)
1378 /* XXX may warn: unary minus operator applied to unsigned type */
1379 /* could change -foo to be (~foo)+1 instead */
1380 if (ans <= ~((UV)IV_MAX)+1)
1381 sv_setiv(TARG, ~ans+1);
1383 sv_setnv(TARG, -(NV)ans);
1386 sv_setuv(TARG, ans);
1395 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1405 count = IV_MAX; /* The best we can do? */
1416 else if (SvNOKp(sv)) {
1425 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1427 I32 items = SP - MARK;
1429 static const char oom_list_extend[] =
1430 "Out of memory during list extend";
1432 max = items * count;
1433 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1434 /* Did the max computation overflow? */
1435 if (items > 0 && max > 0 && (max < items || max < count))
1436 Perl_croak(aTHX_ oom_list_extend);
1441 /* This code was intended to fix 20010809.028:
1444 for (($x =~ /./g) x 2) {
1445 print chop; # "abcdabcd" expected as output.
1448 * but that change (#11635) broke this code:
1450 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1452 * I can't think of a better fix that doesn't introduce
1453 * an efficiency hit by copying the SVs. The stack isn't
1454 * refcounted, and mortalisation obviously doesn't
1455 * Do The Right Thing when the stack has more than
1456 * one pointer to the same mortal value.
1460 *SP = sv_2mortal(newSVsv(*SP));
1470 repeatcpy((char*)(MARK + items), (char*)MARK,
1471 items * sizeof(SV*), count - 1);
1474 else if (count <= 0)
1477 else { /* Note: mark already snarfed by pp_list */
1481 static const char oom_string_extend[] =
1482 "Out of memory during string extend";
1484 SvSetSV(TARG, tmpstr);
1485 SvPV_force(TARG, len);
1486 isutf = DO_UTF8(TARG);
1491 IV max = count * len;
1492 if (len > ((MEM_SIZE)~0)/count)
1493 Perl_croak(aTHX_ oom_string_extend);
1494 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1495 SvGROW(TARG, (count * len) + 1);
1496 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1497 SvCUR(TARG) *= count;
1499 *SvEND(TARG) = '\0';
1502 (void)SvPOK_only_UTF8(TARG);
1504 (void)SvPOK_only(TARG);
1506 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1507 /* The parser saw this as a list repeat, and there
1508 are probably several items on the stack. But we're
1509 in scalar context, and there's no pp_list to save us
1510 now. So drop the rest of the items -- robin@kitsite.com
1523 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1524 useleft = USE_LEFT(TOPm1s);
1525 #ifdef PERL_PRESERVE_IVUV
1526 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1527 "bad things" happen if you rely on signed integers wrapping. */
1530 /* Unless the left argument is integer in range we are going to have to
1531 use NV maths. Hence only attempt to coerce the right argument if
1532 we know the left is integer. */
1533 register UV auv = 0;
1539 a_valid = auvok = 1;
1540 /* left operand is undef, treat as zero. */
1542 /* Left operand is defined, so is it IV? */
1543 SvIV_please(TOPm1s);
1544 if (SvIOK(TOPm1s)) {
1545 if ((auvok = SvUOK(TOPm1s)))
1546 auv = SvUVX(TOPm1s);
1548 register IV aiv = SvIVX(TOPm1s);
1551 auvok = 1; /* Now acting as a sign flag. */
1552 } else { /* 2s complement assumption for IV_MIN */
1560 bool result_good = 0;
1563 bool buvok = SvUOK(TOPs);
1568 register IV biv = SvIVX(TOPs);
1575 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1576 else "IV" now, independent of how it came in.
1577 if a, b represents positive, A, B negative, a maps to -A etc
1582 all UV maths. negate result if A negative.
1583 subtract if signs same, add if signs differ. */
1585 if (auvok ^ buvok) {
1594 /* Must get smaller */
1599 if (result <= buv) {
1600 /* result really should be -(auv-buv). as its negation
1601 of true value, need to swap our result flag */
1613 if (result <= (UV)IV_MIN)
1614 SETi( -(IV)result );
1616 /* result valid, but out of range for IV. */
1617 SETn( -(NV)result );
1621 } /* Overflow, drop through to NVs. */
1625 useleft = USE_LEFT(TOPm1s);
1629 /* left operand is undef, treat as zero - value */
1633 SETn( TOPn - value );
1640 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1643 if (PL_op->op_private & HINT_INTEGER) {
1657 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1660 if (PL_op->op_private & HINT_INTEGER) {
1674 dSP; tryAMAGICbinSET(lt,0);
1675 #ifdef PERL_PRESERVE_IVUV
1678 SvIV_please(TOPm1s);
1679 if (SvIOK(TOPm1s)) {
1680 bool auvok = SvUOK(TOPm1s);
1681 bool buvok = SvUOK(TOPs);
1683 if (!auvok && !buvok) { /* ## IV < IV ## */
1684 IV aiv = SvIVX(TOPm1s);
1685 IV biv = SvIVX(TOPs);
1688 SETs(boolSV(aiv < biv));
1691 if (auvok && buvok) { /* ## UV < UV ## */
1692 UV auv = SvUVX(TOPm1s);
1693 UV buv = SvUVX(TOPs);
1696 SETs(boolSV(auv < buv));
1699 if (auvok) { /* ## UV < IV ## */
1706 /* As (a) is a UV, it's >=0, so it cannot be < */
1711 SETs(boolSV(auv < (UV)biv));
1714 { /* ## IV < UV ## */
1718 aiv = SvIVX(TOPm1s);
1720 /* As (b) is a UV, it's >=0, so it must be < */
1727 SETs(boolSV((UV)aiv < buv));
1733 #ifndef NV_PRESERVES_UV
1734 #ifdef PERL_PRESERVE_IVUV
1737 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1739 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1745 SETs(boolSV(TOPn < value));
1752 dSP; tryAMAGICbinSET(gt,0);
1753 #ifdef PERL_PRESERVE_IVUV
1756 SvIV_please(TOPm1s);
1757 if (SvIOK(TOPm1s)) {
1758 bool auvok = SvUOK(TOPm1s);
1759 bool buvok = SvUOK(TOPs);
1761 if (!auvok && !buvok) { /* ## IV > IV ## */
1762 IV aiv = SvIVX(TOPm1s);
1763 IV biv = SvIVX(TOPs);
1766 SETs(boolSV(aiv > biv));
1769 if (auvok && buvok) { /* ## UV > UV ## */
1770 UV auv = SvUVX(TOPm1s);
1771 UV buv = SvUVX(TOPs);
1774 SETs(boolSV(auv > buv));
1777 if (auvok) { /* ## UV > IV ## */
1784 /* As (a) is a UV, it's >=0, so it must be > */
1789 SETs(boolSV(auv > (UV)biv));
1792 { /* ## IV > UV ## */
1796 aiv = SvIVX(TOPm1s);
1798 /* As (b) is a UV, it's >=0, so it cannot be > */
1805 SETs(boolSV((UV)aiv > buv));
1811 #ifndef NV_PRESERVES_UV
1812 #ifdef PERL_PRESERVE_IVUV
1815 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1817 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1823 SETs(boolSV(TOPn > value));
1830 dSP; tryAMAGICbinSET(le,0);
1831 #ifdef PERL_PRESERVE_IVUV
1834 SvIV_please(TOPm1s);
1835 if (SvIOK(TOPm1s)) {
1836 bool auvok = SvUOK(TOPm1s);
1837 bool buvok = SvUOK(TOPs);
1839 if (!auvok && !buvok) { /* ## IV <= IV ## */
1840 IV aiv = SvIVX(TOPm1s);
1841 IV biv = SvIVX(TOPs);
1844 SETs(boolSV(aiv <= biv));
1847 if (auvok && buvok) { /* ## UV <= UV ## */
1848 UV auv = SvUVX(TOPm1s);
1849 UV buv = SvUVX(TOPs);
1852 SETs(boolSV(auv <= buv));
1855 if (auvok) { /* ## UV <= IV ## */
1862 /* As (a) is a UV, it's >=0, so a cannot be <= */
1867 SETs(boolSV(auv <= (UV)biv));
1870 { /* ## IV <= UV ## */
1874 aiv = SvIVX(TOPm1s);
1876 /* As (b) is a UV, it's >=0, so a must be <= */
1883 SETs(boolSV((UV)aiv <= buv));
1889 #ifndef NV_PRESERVES_UV
1890 #ifdef PERL_PRESERVE_IVUV
1893 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1895 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1901 SETs(boolSV(TOPn <= value));
1908 dSP; tryAMAGICbinSET(ge,0);
1909 #ifdef PERL_PRESERVE_IVUV
1912 SvIV_please(TOPm1s);
1913 if (SvIOK(TOPm1s)) {
1914 bool auvok = SvUOK(TOPm1s);
1915 bool buvok = SvUOK(TOPs);
1917 if (!auvok && !buvok) { /* ## IV >= IV ## */
1918 IV aiv = SvIVX(TOPm1s);
1919 IV biv = SvIVX(TOPs);
1922 SETs(boolSV(aiv >= biv));
1925 if (auvok && buvok) { /* ## UV >= UV ## */
1926 UV auv = SvUVX(TOPm1s);
1927 UV buv = SvUVX(TOPs);
1930 SETs(boolSV(auv >= buv));
1933 if (auvok) { /* ## UV >= IV ## */
1940 /* As (a) is a UV, it's >=0, so it must be >= */
1945 SETs(boolSV(auv >= (UV)biv));
1948 { /* ## IV >= UV ## */
1952 aiv = SvIVX(TOPm1s);
1954 /* As (b) is a UV, it's >=0, so a cannot be >= */
1961 SETs(boolSV((UV)aiv >= buv));
1967 #ifndef NV_PRESERVES_UV
1968 #ifdef PERL_PRESERVE_IVUV
1971 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1973 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1979 SETs(boolSV(TOPn >= value));
1986 dSP; tryAMAGICbinSET(ne,0);
1987 #ifndef NV_PRESERVES_UV
1988 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1990 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1994 #ifdef PERL_PRESERVE_IVUV
1997 SvIV_please(TOPm1s);
1998 if (SvIOK(TOPm1s)) {
1999 bool auvok = SvUOK(TOPm1s);
2000 bool buvok = SvUOK(TOPs);
2002 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2003 /* Casting IV to UV before comparison isn't going to matter
2004 on 2s complement. On 1s complement or sign&magnitude
2005 (if we have any of them) it could make negative zero
2006 differ from normal zero. As I understand it. (Need to
2007 check - is negative zero implementation defined behaviour
2009 UV buv = SvUVX(POPs);
2010 UV auv = SvUVX(TOPs);
2012 SETs(boolSV(auv != buv));
2015 { /* ## Mixed IV,UV ## */
2019 /* != is commutative so swap if needed (save code) */
2021 /* swap. top of stack (b) is the iv */
2025 /* As (a) is a UV, it's >0, so it cannot be == */
2034 /* As (b) is a UV, it's >0, so it cannot be == */
2038 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2040 SETs(boolSV((UV)iv != uv));
2048 SETs(boolSV(TOPn != value));
2055 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2056 #ifndef NV_PRESERVES_UV
2057 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2058 UV right = PTR2UV(SvRV(POPs));
2059 UV left = PTR2UV(SvRV(TOPs));
2060 SETi((left > right) - (left < right));
2064 #ifdef PERL_PRESERVE_IVUV
2065 /* Fortunately it seems NaN isn't IOK */
2068 SvIV_please(TOPm1s);
2069 if (SvIOK(TOPm1s)) {
2070 bool leftuvok = SvUOK(TOPm1s);
2071 bool rightuvok = SvUOK(TOPs);
2073 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2074 IV leftiv = SvIVX(TOPm1s);
2075 IV rightiv = SvIVX(TOPs);
2077 if (leftiv > rightiv)
2079 else if (leftiv < rightiv)
2083 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2084 UV leftuv = SvUVX(TOPm1s);
2085 UV rightuv = SvUVX(TOPs);
2087 if (leftuv > rightuv)
2089 else if (leftuv < rightuv)
2093 } else if (leftuvok) { /* ## UV <=> IV ## */
2097 rightiv = SvIVX(TOPs);
2099 /* As (a) is a UV, it's >=0, so it cannot be < */
2102 leftuv = SvUVX(TOPm1s);
2103 if (leftuv > (UV)rightiv) {
2105 } else if (leftuv < (UV)rightiv) {
2111 } else { /* ## IV <=> UV ## */
2115 leftiv = SvIVX(TOPm1s);
2117 /* As (b) is a UV, it's >=0, so it must be < */
2120 rightuv = SvUVX(TOPs);
2121 if ((UV)leftiv > rightuv) {
2123 } else if ((UV)leftiv < rightuv) {
2141 if (Perl_isnan(left) || Perl_isnan(right)) {
2145 value = (left > right) - (left < right);
2149 else if (left < right)
2151 else if (left > right)
2165 dSP; tryAMAGICbinSET(slt,0);
2168 int cmp = (IN_LOCALE_RUNTIME
2169 ? sv_cmp_locale(left, right)
2170 : sv_cmp(left, right));
2171 SETs(boolSV(cmp < 0));
2178 dSP; tryAMAGICbinSET(sgt,0);
2181 int cmp = (IN_LOCALE_RUNTIME
2182 ? sv_cmp_locale(left, right)
2183 : sv_cmp(left, right));
2184 SETs(boolSV(cmp > 0));
2191 dSP; tryAMAGICbinSET(sle,0);
2194 int cmp = (IN_LOCALE_RUNTIME
2195 ? sv_cmp_locale(left, right)
2196 : sv_cmp(left, right));
2197 SETs(boolSV(cmp <= 0));
2204 dSP; tryAMAGICbinSET(sge,0);
2207 int cmp = (IN_LOCALE_RUNTIME
2208 ? sv_cmp_locale(left, right)
2209 : sv_cmp(left, right));
2210 SETs(boolSV(cmp >= 0));
2217 dSP; tryAMAGICbinSET(seq,0);
2220 SETs(boolSV(sv_eq(left, right)));
2227 dSP; tryAMAGICbinSET(sne,0);
2230 SETs(boolSV(!sv_eq(left, right)));
2237 dSP; dTARGET; tryAMAGICbin(scmp,0);
2240 int cmp = (IN_LOCALE_RUNTIME
2241 ? sv_cmp_locale(left, right)
2242 : sv_cmp(left, right));
2250 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2253 if (SvGMAGICAL(left)) mg_get(left);
2254 if (SvGMAGICAL(right)) mg_get(right);
2255 if (SvNIOKp(left) || SvNIOKp(right)) {
2256 if (PL_op->op_private & HINT_INTEGER) {
2257 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2261 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2266 do_vop(PL_op->op_type, TARG, left, right);
2275 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2278 if (SvGMAGICAL(left)) mg_get(left);
2279 if (SvGMAGICAL(right)) mg_get(right);
2280 if (SvNIOKp(left) || SvNIOKp(right)) {
2281 if (PL_op->op_private & HINT_INTEGER) {
2282 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2286 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2291 do_vop(PL_op->op_type, TARG, left, right);
2300 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2303 if (SvGMAGICAL(left)) mg_get(left);
2304 if (SvGMAGICAL(right)) mg_get(right);
2305 if (SvNIOKp(left) || SvNIOKp(right)) {
2306 if (PL_op->op_private & HINT_INTEGER) {
2307 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2311 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2316 do_vop(PL_op->op_type, TARG, left, right);
2325 dSP; dTARGET; tryAMAGICun(neg);
2328 int flags = SvFLAGS(sv);
2331 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2332 /* It's publicly an integer, or privately an integer-not-float */
2335 if (SvIVX(sv) == IV_MIN) {
2336 /* 2s complement assumption. */
2337 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2340 else if (SvUVX(sv) <= IV_MAX) {
2345 else if (SvIVX(sv) != IV_MIN) {
2349 #ifdef PERL_PRESERVE_IVUV
2358 else if (SvPOKp(sv)) {
2360 char *s = SvPV(sv, len);
2361 if (isIDFIRST(*s)) {
2362 sv_setpvn(TARG, "-", 1);
2365 else if (*s == '+' || *s == '-') {
2367 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2369 else if (DO_UTF8(sv)) {
2372 goto oops_its_an_int;
2374 sv_setnv(TARG, -SvNV(sv));
2376 sv_setpvn(TARG, "-", 1);
2383 goto oops_its_an_int;
2384 sv_setnv(TARG, -SvNV(sv));
2396 dSP; tryAMAGICunSET(not);
2397 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2403 dSP; dTARGET; tryAMAGICun(compl);
2409 if (PL_op->op_private & HINT_INTEGER) {
2410 IV i = ~SvIV_nomg(sv);
2414 UV u = ~SvUV_nomg(sv);
2423 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2424 sv_setsv_nomg(TARG, sv);
2425 tmps = (U8*)SvPV_force(TARG, len);
2428 /* Calculate exact length, let's not estimate. */
2437 while (tmps < send) {
2438 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2439 tmps += UTF8SKIP(tmps);
2440 targlen += UNISKIP(~c);
2446 /* Now rewind strings and write them. */
2450 Newz(0, result, targlen + 1, U8);
2451 while (tmps < send) {
2452 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2453 tmps += UTF8SKIP(tmps);
2454 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2458 sv_setpvn(TARG, (char*)result, targlen);
2462 Newz(0, result, nchar + 1, U8);
2463 while (tmps < send) {
2464 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2465 tmps += UTF8SKIP(tmps);
2470 sv_setpvn(TARG, (char*)result, nchar);
2479 register long *tmpl;
2480 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2483 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2488 for ( ; anum > 0; anum--, tmps++)
2497 /* integer versions of some of the above */
2501 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2504 SETi( left * right );
2511 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2515 DIE(aTHX_ "Illegal division by zero");
2516 value = POPi / value;
2525 /* This is the vanilla old i_modulo. */
2526 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2530 DIE(aTHX_ "Illegal modulus zero");
2531 SETi( left % right );
2536 #if defined(__GLIBC__) && IVSIZE == 8
2540 /* This is the i_modulo with the workaround for the _moddi3 bug
2541 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2542 * See below for pp_i_modulo. */
2543 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2547 DIE(aTHX_ "Illegal modulus zero");
2548 SETi( left % PERL_ABS(right) );
2556 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2560 DIE(aTHX_ "Illegal modulus zero");
2561 /* The assumption is to use hereafter the old vanilla version... */
2563 PL_ppaddr[OP_I_MODULO] =
2564 &Perl_pp_i_modulo_0;
2565 /* .. but if we have glibc, we might have a buggy _moddi3
2566 * (at least glicb 2.2.5 is known to have this bug), in other
2567 * words our integer modulus with negative quad as the second
2568 * argument might be broken. Test for this and re-patch the
2569 * opcode dispatch table if that is the case, remembering to
2570 * also apply the workaround so that this first round works
2571 * right, too. See [perl #9402] for more information. */
2572 #if defined(__GLIBC__) && IVSIZE == 8
2576 /* Cannot do this check with inlined IV constants since
2577 * that seems to work correctly even with the buggy glibc. */
2579 /* Yikes, we have the bug.
2580 * Patch in the workaround version. */
2582 PL_ppaddr[OP_I_MODULO] =
2583 &Perl_pp_i_modulo_1;
2584 /* Make certain we work right this time, too. */
2585 right = PERL_ABS(right);
2589 SETi( left % right );
2596 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2599 SETi( left + right );
2606 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2609 SETi( left - right );
2616 dSP; tryAMAGICbinSET(lt,0);
2619 SETs(boolSV(left < right));
2626 dSP; tryAMAGICbinSET(gt,0);
2629 SETs(boolSV(left > right));
2636 dSP; tryAMAGICbinSET(le,0);
2639 SETs(boolSV(left <= right));
2646 dSP; tryAMAGICbinSET(ge,0);
2649 SETs(boolSV(left >= right));
2656 dSP; tryAMAGICbinSET(eq,0);
2659 SETs(boolSV(left == right));
2666 dSP; tryAMAGICbinSET(ne,0);
2669 SETs(boolSV(left != right));
2676 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2683 else if (left < right)
2694 dSP; dTARGET; tryAMAGICun(neg);
2699 /* High falutin' math. */
2703 dSP; dTARGET; tryAMAGICbin(atan2,0);
2706 SETn(Perl_atan2(left, right));
2713 dSP; dTARGET; tryAMAGICun(sin);
2717 value = Perl_sin(value);
2725 dSP; dTARGET; tryAMAGICun(cos);
2729 value = Perl_cos(value);
2735 /* Support Configure command-line overrides for rand() functions.
2736 After 5.005, perhaps we should replace this by Configure support
2737 for drand48(), random(), or rand(). For 5.005, though, maintain
2738 compatibility by calling rand() but allow the user to override it.
2739 See INSTALL for details. --Andy Dougherty 15 July 1998
2741 /* Now it's after 5.005, and Configure supports drand48() and random(),
2742 in addition to rand(). So the overrides should not be needed any more.
2743 --Jarkko Hietaniemi 27 September 1998
2746 #ifndef HAS_DRAND48_PROTO
2747 extern double drand48 (void);
2760 if (!PL_srand_called) {
2761 (void)seedDrand01((Rand_seed_t)seed());
2762 PL_srand_called = TRUE;
2777 (void)seedDrand01((Rand_seed_t)anum);
2778 PL_srand_called = TRUE;
2785 dSP; dTARGET; tryAMAGICun(exp);
2789 value = Perl_exp(value);
2797 dSP; dTARGET; tryAMAGICun(log);
2802 SET_NUMERIC_STANDARD();
2803 DIE(aTHX_ "Can't take log of %"NVgf, value);
2805 value = Perl_log(value);
2813 dSP; dTARGET; tryAMAGICun(sqrt);
2818 SET_NUMERIC_STANDARD();
2819 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2821 value = Perl_sqrt(value);
2829 dSP; dTARGET; tryAMAGICun(int);
2832 IV iv = TOPi; /* attempt to convert to IV if possible. */
2833 /* XXX it's arguable that compiler casting to IV might be subtly
2834 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2835 else preferring IV has introduced a subtle behaviour change bug. OTOH
2836 relying on floating point to be accurate is a bug. */
2840 else if (SvIOK(TOPs)) {
2849 if (value < (NV)UV_MAX + 0.5) {
2852 SETn(Perl_floor(value));
2856 if (value > (NV)IV_MIN - 0.5) {
2859 SETn(Perl_ceil(value));
2869 dSP; dTARGET; tryAMAGICun(abs);
2871 /* This will cache the NV value if string isn't actually integer */
2876 else if (SvIOK(TOPs)) {
2877 /* IVX is precise */
2879 SETu(TOPu); /* force it to be numeric only */
2887 /* 2s complement assumption. Also, not really needed as
2888 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2908 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2914 tmps = (SvPVx(sv, len));
2916 /* If Unicode, try to downgrade
2917 * If not possible, croak. */
2918 SV* tsv = sv_2mortal(newSVsv(sv));
2921 sv_utf8_downgrade(tsv, FALSE);
2924 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2925 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2938 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2944 tmps = (SvPVx(sv, len));
2946 /* If Unicode, try to downgrade
2947 * If not possible, croak. */
2948 SV* tsv = sv_2mortal(newSVsv(sv));
2951 sv_utf8_downgrade(tsv, FALSE);
2954 while (*tmps && len && isSPACE(*tmps))
2959 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2960 else if (*tmps == 'b')
2961 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2963 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2965 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2982 SETi(sv_len_utf8(sv));
2998 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3000 I32 arybase = PL_curcop->cop_arybase;
3004 int num_args = PL_op->op_private & 7;
3005 bool repl_need_utf8_upgrade = FALSE;
3006 bool repl_is_utf8 = FALSE;
3008 SvTAINTED_off(TARG); /* decontaminate */
3009 SvUTF8_off(TARG); /* decontaminate */
3013 repl = SvPV(repl_sv, repl_len);
3014 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3024 sv_utf8_upgrade(sv);
3026 else if (DO_UTF8(sv))
3027 repl_need_utf8_upgrade = TRUE;
3029 tmps = SvPV(sv, curlen);
3031 utf8_curlen = sv_len_utf8(sv);
3032 if (utf8_curlen == curlen)
3035 curlen = utf8_curlen;
3040 if (pos >= arybase) {
3058 else if (len >= 0) {
3060 if (rem > (I32)curlen)
3075 Perl_croak(aTHX_ "substr outside of string");
3076 if (ckWARN(WARN_SUBSTR))
3077 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3084 sv_pos_u2b(sv, &pos, &rem);
3086 /* we either return a PV or an LV. If the TARG hasn't been used
3087 * before, or is of that type, reuse it; otherwise use a mortal
3088 * instead. Note that LVs can have an extended lifetime, so also
3089 * dont reuse if refcount > 1 (bug #20933) */
3090 if (SvTYPE(TARG) > SVt_NULL) {
3091 if ( (SvTYPE(TARG) == SVt_PVLV)
3092 ? (!lvalue || SvREFCNT(TARG) > 1)
3095 TARG = sv_newmortal();
3099 sv_setpvn(TARG, tmps, rem);
3100 #ifdef USE_LOCALE_COLLATE
3101 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3106 SV* repl_sv_copy = NULL;
3108 if (repl_need_utf8_upgrade) {
3109 repl_sv_copy = newSVsv(repl_sv);
3110 sv_utf8_upgrade(repl_sv_copy);
3111 repl = SvPV(repl_sv_copy, repl_len);
3112 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3114 sv_insert(sv, pos, rem, repl, repl_len);
3118 SvREFCNT_dec(repl_sv_copy);
3120 else if (lvalue) { /* it's an lvalue! */
3121 if (!SvGMAGICAL(sv)) {
3125 if (ckWARN(WARN_SUBSTR))
3126 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3127 "Attempt to use reference as lvalue in substr");
3129 if (SvOK(sv)) /* is it defined ? */
3130 (void)SvPOK_only_UTF8(sv);
3132 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3135 if (SvTYPE(TARG) < SVt_PVLV) {
3136 sv_upgrade(TARG, SVt_PVLV);
3137 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3143 if (LvTARG(TARG) != sv) {
3145 SvREFCNT_dec(LvTARG(TARG));
3146 LvTARG(TARG) = SvREFCNT_inc(sv);
3148 LvTARGOFF(TARG) = upos;
3149 LvTARGLEN(TARG) = urem;
3153 PUSHs(TARG); /* avoid SvSETMAGIC here */
3160 register IV size = POPi;
3161 register IV offset = POPi;
3162 register SV *src = POPs;
3163 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3165 SvTAINTED_off(TARG); /* decontaminate */
3166 if (lvalue) { /* it's an lvalue! */
3167 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3168 TARG = sv_newmortal();
3169 if (SvTYPE(TARG) < SVt_PVLV) {
3170 sv_upgrade(TARG, SVt_PVLV);
3171 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3174 if (LvTARG(TARG) != src) {
3176 SvREFCNT_dec(LvTARG(TARG));
3177 LvTARG(TARG) = SvREFCNT_inc(src);
3179 LvTARGOFF(TARG) = offset;
3180 LvTARGLEN(TARG) = size;
3183 sv_setuv(TARG, do_vecget(src, offset, size));
3199 I32 arybase = PL_curcop->cop_arybase;
3206 offset = POPi - arybase;
3209 big_utf8 = DO_UTF8(big);
3210 little_utf8 = DO_UTF8(little);
3211 if (big_utf8 ^ little_utf8) {
3212 /* One needs to be upgraded. */
3213 SV *bytes = little_utf8 ? big : little;
3215 char *p = SvPV(bytes, len);
3217 temp = newSVpvn(p, len);
3220 sv_recode_to_utf8(temp, PL_encoding);
3222 sv_utf8_upgrade(temp);
3231 if (big_utf8 && offset > 0)
3232 sv_pos_u2b(big, &offset, 0);
3233 tmps = SvPV(big, biglen);
3236 else if (offset > (I32)biglen)
3238 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3239 (unsigned char*)tmps + biglen, little, 0)))
3242 retval = tmps2 - tmps;
3243 if (retval > 0 && big_utf8)
3244 sv_pos_b2u(big, &retval);
3247 PUSHi(retval + arybase);
3263 I32 arybase = PL_curcop->cop_arybase;
3271 big_utf8 = DO_UTF8(big);
3272 little_utf8 = DO_UTF8(little);
3273 if (big_utf8 ^ little_utf8) {
3274 /* One needs to be upgraded. */
3275 SV *bytes = little_utf8 ? big : little;
3277 char *p = SvPV(bytes, len);
3279 temp = newSVpvn(p, len);
3282 sv_recode_to_utf8(temp, PL_encoding);
3284 sv_utf8_upgrade(temp);
3293 tmps2 = SvPV(little, llen);
3294 tmps = SvPV(big, blen);
3299 if (offset > 0 && big_utf8)
3300 sv_pos_u2b(big, &offset, 0);
3301 offset = offset - arybase + llen;
3305 else if (offset > (I32)blen)
3307 if (!(tmps2 = rninstr(tmps, tmps + offset,
3308 tmps2, tmps2 + llen)))
3311 retval = tmps2 - tmps;
3312 if (retval > 0 && big_utf8)
3313 sv_pos_b2u(big, &retval);
3316 PUSHi(retval + arybase);
3322 dSP; dMARK; dORIGMARK; dTARGET;
3323 do_sprintf(TARG, SP-MARK, MARK+1);
3324 TAINT_IF(SvTAINTED(TARG));
3325 if (DO_UTF8(*(MARK+1)))
3337 U8 *s = (U8*)SvPVx(argsv, len);
3340 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3341 tmpsv = sv_2mortal(newSVsv(argsv));
3342 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3346 XPUSHu(DO_UTF8(argsv) ?
3347 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3359 (void)SvUPGRADE(TARG,SVt_PV);
3361 if (value > 255 && !IN_BYTES) {
3362 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3363 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3364 SvCUR_set(TARG, tmps - SvPVX(TARG));
3366 (void)SvPOK_only(TARG);
3375 *tmps++ = (char)value;
3377 (void)SvPOK_only(TARG);
3378 if (PL_encoding && !IN_BYTES) {
3379 sv_recode_to_utf8(TARG, PL_encoding);
3381 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3382 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3386 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3387 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3403 char *tmps = SvPV(left, len);
3405 if (DO_UTF8(left)) {
3406 /* If Unicode, try to downgrade.
3407 * If not possible, croak.
3408 * Yes, we made this up. */
3409 SV* tsv = sv_2mortal(newSVsv(left));
3412 sv_utf8_downgrade(tsv, FALSE);
3415 # ifdef USE_ITHREADS
3417 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3418 /* This should be threadsafe because in ithreads there is only
3419 * one thread per interpreter. If this would not be true,
3420 * we would need a mutex to protect this malloc. */
3421 PL_reentrant_buffer->_crypt_struct_buffer =
3422 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3423 #if defined(__GLIBC__) || defined(__EMX__)
3424 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3425 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3426 /* work around glibc-2.2.5 bug */
3427 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3431 # endif /* HAS_CRYPT_R */
3432 # endif /* USE_ITHREADS */
3434 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3436 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3442 "The crypt() function is unimplemented due to excessive paranoia.");
3455 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3456 UTF8_IS_START(*s)) {
3457 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3461 utf8_to_uvchr(s, &ulen);
3462 toTITLE_utf8(s, tmpbuf, &tculen);
3463 utf8_to_uvchr(tmpbuf, 0);
3465 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3467 /* slen is the byte length of the whole SV.
3468 * ulen is the byte length of the original Unicode character
3469 * stored as UTF-8 at s.
3470 * tculen is the byte length of the freshly titlecased
3471 * Unicode character stored as UTF-8 at tmpbuf.
3472 * We first set the result to be the titlecased character,
3473 * and then append the rest of the SV data. */
3474 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3476 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3481 s = (U8*)SvPV_force_nomg(sv, slen);
3482 Copy(tmpbuf, s, tculen, U8);
3486 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3488 SvUTF8_off(TARG); /* decontaminate */
3489 sv_setsv_nomg(TARG, sv);
3493 s = (U8*)SvPV_force_nomg(sv, slen);
3495 if (IN_LOCALE_RUNTIME) {
3498 *s = toUPPER_LC(*s);
3517 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3518 UTF8_IS_START(*s)) {
3520 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3524 toLOWER_utf8(s, tmpbuf, &ulen);
3525 uv = utf8_to_uvchr(tmpbuf, 0);
3526 tend = uvchr_to_utf8(tmpbuf, uv);
3528 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3530 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3532 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3537 s = (U8*)SvPV_force_nomg(sv, slen);
3538 Copy(tmpbuf, s, ulen, U8);
3542 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3544 SvUTF8_off(TARG); /* decontaminate */
3545 sv_setsv_nomg(TARG, sv);
3549 s = (U8*)SvPV_force_nomg(sv, slen);
3551 if (IN_LOCALE_RUNTIME) {
3554 *s = toLOWER_LC(*s);
3577 U8 tmpbuf[UTF8_MAXBYTES+1];
3579 s = (U8*)SvPV_nomg(sv,len);
3581 SvUTF8_off(TARG); /* decontaminate */
3582 sv_setpvn(TARG, "", 0);
3586 STRLEN min = len + 1;
3588 (void)SvUPGRADE(TARG, SVt_PV);
3590 (void)SvPOK_only(TARG);
3591 d = (U8*)SvPVX(TARG);
3594 STRLEN u = UTF8SKIP(s);
3596 toUPPER_utf8(s, tmpbuf, &ulen);
3597 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3598 /* If the eventually required minimum size outgrows
3599 * the available space, we need to grow. */
3600 UV o = d - (U8*)SvPVX(TARG);
3602 /* If someone uppercases one million U+03B0s we
3603 * SvGROW() one million times. Or we could try
3604 * guessing how much to allocate without allocating
3605 * too much. Such is life. */
3607 d = (U8*)SvPVX(TARG) + o;
3609 Copy(tmpbuf, d, ulen, U8);
3615 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3620 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3622 SvUTF8_off(TARG); /* decontaminate */
3623 sv_setsv_nomg(TARG, sv);
3627 s = (U8*)SvPV_force_nomg(sv, len);
3629 register U8 *send = s + len;
3631 if (IN_LOCALE_RUNTIME) {
3634 for (; s < send; s++)
3635 *s = toUPPER_LC(*s);
3638 for (; s < send; s++)
3660 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3662 s = (U8*)SvPV_nomg(sv,len);
3664 SvUTF8_off(TARG); /* decontaminate */
3665 sv_setpvn(TARG, "", 0);
3669 STRLEN min = len + 1;
3671 (void)SvUPGRADE(TARG, SVt_PV);
3673 (void)SvPOK_only(TARG);
3674 d = (U8*)SvPVX(TARG);
3677 STRLEN u = UTF8SKIP(s);
3678 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3680 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3681 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3683 * Now if the sigma is NOT followed by
3684 * /$ignorable_sequence$cased_letter/;
3685 * and it IS preceded by
3686 * /$cased_letter$ignorable_sequence/;
3687 * where $ignorable_sequence is
3688 * [\x{2010}\x{AD}\p{Mn}]*
3689 * and $cased_letter is
3690 * [\p{Ll}\p{Lo}\p{Lt}]
3691 * then it should be mapped to 0x03C2,
3692 * (GREEK SMALL LETTER FINAL SIGMA),
3693 * instead of staying 0x03A3.
3694 * "should be": in other words,
3695 * this is not implemented yet.
3696 * See lib/unicore/SpecialCasing.txt.
3699 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3700 /* If the eventually required minimum size outgrows
3701 * the available space, we need to grow. */
3702 UV o = d - (U8*)SvPVX(TARG);
3704 /* If someone lowercases one million U+0130s we
3705 * SvGROW() one million times. Or we could try
3706 * guessing how much to allocate without allocating.
3707 * too much. Such is life. */
3709 d = (U8*)SvPVX(TARG) + o;
3711 Copy(tmpbuf, d, ulen, U8);
3717 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3722 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3724 SvUTF8_off(TARG); /* decontaminate */
3725 sv_setsv_nomg(TARG, sv);
3730 s = (U8*)SvPV_force_nomg(sv, len);
3732 register U8 *send = s + len;
3734 if (IN_LOCALE_RUNTIME) {
3737 for (; s < send; s++)
3738 *s = toLOWER_LC(*s);
3741 for (; s < send; s++)
3755 register char *s = SvPV(sv,len);
3758 SvUTF8_off(TARG); /* decontaminate */
3760 (void)SvUPGRADE(TARG, SVt_PV);
3761 SvGROW(TARG, (len * 2) + 1);
3765 if (UTF8_IS_CONTINUED(*s)) {
3766 STRLEN ulen = UTF8SKIP(s);
3790 SvCUR_set(TARG, d - SvPVX(TARG));
3791 (void)SvPOK_only_UTF8(TARG);
3794 sv_setpvn(TARG, s, len);
3796 if (SvSMAGICAL(TARG))
3805 dSP; dMARK; dORIGMARK;
3807 register AV* av = (AV*)POPs;
3808 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3809 I32 arybase = PL_curcop->cop_arybase;
3812 if (SvTYPE(av) == SVt_PVAV) {
3813 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3815 for (svp = MARK + 1; svp <= SP; svp++) {
3820 if (max > AvMAX(av))
3823 while (++MARK <= SP) {
3824 elem = SvIVx(*MARK);
3828 svp = av_fetch(av, elem, lval);
3830 if (!svp || *svp == &PL_sv_undef)
3831 DIE(aTHX_ PL_no_aelem, elem);
3832 if (PL_op->op_private & OPpLVAL_INTRO)
3833 save_aelem(av, elem, svp);
3835 *MARK = svp ? *svp : &PL_sv_undef;
3838 if (GIMME != G_ARRAY) {
3840 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3846 /* Associative arrays. */
3851 HV *hash = (HV*)POPs;
3853 I32 gimme = GIMME_V;
3856 /* might clobber stack_sp */
3857 entry = hv_iternext(hash);
3862 SV* sv = hv_iterkeysv(entry);
3863 PUSHs(sv); /* won't clobber stack_sp */
3864 if (gimme == G_ARRAY) {
3867 /* might clobber stack_sp */
3868 val = hv_iterval(hash, entry);
3873 else if (gimme == G_SCALAR)
3892 I32 gimme = GIMME_V;
3893 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3897 if (PL_op->op_private & OPpSLICE) {
3901 hvtype = SvTYPE(hv);
3902 if (hvtype == SVt_PVHV) { /* hash element */
3903 while (++MARK <= SP) {
3904 sv = hv_delete_ent(hv, *MARK, discard, 0);
3905 *MARK = sv ? sv : &PL_sv_undef;
3908 else if (hvtype == SVt_PVAV) { /* array element */
3909 if (PL_op->op_flags & OPf_SPECIAL) {
3910 while (++MARK <= SP) {
3911 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3912 *MARK = sv ? sv : &PL_sv_undef;
3917 DIE(aTHX_ "Not a HASH reference");
3920 else if (gimme == G_SCALAR) {
3925 *++MARK = &PL_sv_undef;
3932 if (SvTYPE(hv) == SVt_PVHV)
3933 sv = hv_delete_ent(hv, keysv, discard, 0);
3934 else if (SvTYPE(hv) == SVt_PVAV) {
3935 if (PL_op->op_flags & OPf_SPECIAL)
3936 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3938 DIE(aTHX_ "panic: avhv_delete no longer supported");
3941 DIE(aTHX_ "Not a HASH reference");
3956 if (PL_op->op_private & OPpEXISTS_SUB) {
3960 cv = sv_2cv(sv, &hv, &gv, FALSE);
3963 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3969 if (SvTYPE(hv) == SVt_PVHV) {
3970 if (hv_exists_ent(hv, tmpsv, 0))
3973 else if (SvTYPE(hv) == SVt_PVAV) {
3974 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3975 if (av_exists((AV*)hv, SvIV(tmpsv)))
3980 DIE(aTHX_ "Not a HASH reference");
3987 dSP; dMARK; dORIGMARK;
3988 register HV *hv = (HV*)POPs;
3989 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3990 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3991 bool other_magic = FALSE;
3997 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3998 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3999 /* Try to preserve the existenceness of a tied hash
4000 * element by using EXISTS and DELETE if possible.
4001 * Fallback to FETCH and STORE otherwise */
4002 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4003 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4004 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4007 while (++MARK <= SP) {
4011 bool preeminent = FALSE;
4014 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4015 hv_exists_ent(hv, keysv, 0);
4018 he = hv_fetch_ent(hv, keysv, lval, 0);
4019 svp = he ? &HeVAL(he) : 0;
4022 if (!svp || *svp == &PL_sv_undef) {
4024 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
4028 save_helem(hv, keysv, svp);
4031 char *key = SvPV(keysv, keylen);
4032 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4036 *MARK = svp ? *svp : &PL_sv_undef;
4038 if (GIMME != G_ARRAY) {
4040 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4046 /* List operators. */
4051 if (GIMME != G_ARRAY) {
4053 *MARK = *SP; /* unwanted list, return last item */
4055 *MARK = &PL_sv_undef;
4064 SV **lastrelem = PL_stack_sp;
4065 SV **lastlelem = PL_stack_base + POPMARK;
4066 SV **firstlelem = PL_stack_base + POPMARK + 1;
4067 register SV **firstrelem = lastlelem + 1;
4068 I32 arybase = PL_curcop->cop_arybase;
4069 I32 lval = PL_op->op_flags & OPf_MOD;
4070 I32 is_something_there = lval;
4072 register I32 max = lastrelem - lastlelem;
4073 register SV **lelem;
4076 if (GIMME != G_ARRAY) {
4077 ix = SvIVx(*lastlelem);
4082 if (ix < 0 || ix >= max)
4083 *firstlelem = &PL_sv_undef;
4085 *firstlelem = firstrelem[ix];
4091 SP = firstlelem - 1;
4095 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4101 if (ix < 0 || ix >= max)
4102 *lelem = &PL_sv_undef;
4104 is_something_there = TRUE;
4105 if (!(*lelem = firstrelem[ix]))
4106 *lelem = &PL_sv_undef;
4109 if (is_something_there)
4112 SP = firstlelem - 1;
4118 dSP; dMARK; dORIGMARK;
4119 I32 items = SP - MARK;
4120 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4121 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4128 dSP; dMARK; dORIGMARK;
4129 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4133 SV *val = NEWSV(46, 0);
4135 sv_setsv(val, *++MARK);
4136 else if (ckWARN(WARN_MISC))
4137 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4138 (void)hv_store_ent(hv,key,val,0);
4147 dSP; dMARK; dORIGMARK;
4148 register AV *ary = (AV*)*++MARK;
4152 register I32 offset;
4153 register I32 length;
4160 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4161 *MARK-- = SvTIED_obj((SV*)ary, mg);
4165 call_method("SPLICE",GIMME_V);
4174 offset = i = SvIVx(*MARK);
4176 offset += AvFILLp(ary) + 1;
4178 offset -= PL_curcop->cop_arybase;
4180 DIE(aTHX_ PL_no_aelem, i);
4182 length = SvIVx(*MARK++);
4184 length += AvFILLp(ary) - offset + 1;
4190 length = AvMAX(ary) + 1; /* close enough to infinity */
4194 length = AvMAX(ary) + 1;
4196 if (offset > AvFILLp(ary) + 1) {
4197 if (ckWARN(WARN_MISC))
4198 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4199 offset = AvFILLp(ary) + 1;
4201 after = AvFILLp(ary) + 1 - (offset + length);
4202 if (after < 0) { /* not that much array */
4203 length += after; /* offset+length now in array */
4209 /* At this point, MARK .. SP-1 is our new LIST */
4212 diff = newlen - length;
4213 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4216 /* make new elements SVs now: avoid problems if they're from the array */
4217 for (dst = MARK, i = newlen; i; i--) {
4219 *dst++ = newSVsv(h);
4222 if (diff < 0) { /* shrinking the area */
4224 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4225 Copy(MARK, tmparyval, newlen, SV*);
4228 MARK = ORIGMARK + 1;
4229 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4230 MEXTEND(MARK, length);
4231 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4233 EXTEND_MORTAL(length);
4234 for (i = length, dst = MARK; i; i--) {
4235 sv_2mortal(*dst); /* free them eventualy */
4242 *MARK = AvARRAY(ary)[offset+length-1];
4245 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4246 SvREFCNT_dec(*dst++); /* free them now */
4249 AvFILLp(ary) += diff;
4251 /* pull up or down? */
4253 if (offset < after) { /* easier to pull up */
4254 if (offset) { /* esp. if nothing to pull */
4255 src = &AvARRAY(ary)[offset-1];
4256 dst = src - diff; /* diff is negative */
4257 for (i = offset; i > 0; i--) /* can't trust Copy */
4261 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4265 if (after) { /* anything to pull down? */
4266 src = AvARRAY(ary) + offset + length;
4267 dst = src + diff; /* diff is negative */
4268 Move(src, dst, after, SV*);
4270 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4271 /* avoid later double free */
4275 dst[--i] = &PL_sv_undef;
4278 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4279 Safefree(tmparyval);
4282 else { /* no, expanding (or same) */
4284 New(452, tmparyval, length, SV*); /* so remember deletion */
4285 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4288 if (diff > 0) { /* expanding */
4290 /* push up or down? */
4292 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4296 Move(src, dst, offset, SV*);
4298 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4300 AvFILLp(ary) += diff;
4303 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4304 av_extend(ary, AvFILLp(ary) + diff);
4305 AvFILLp(ary) += diff;
4308 dst = AvARRAY(ary) + AvFILLp(ary);
4310 for (i = after; i; i--) {
4318 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4321 MARK = ORIGMARK + 1;
4322 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4324 Copy(tmparyval, MARK, length, SV*);
4326 EXTEND_MORTAL(length);
4327 for (i = length, dst = MARK; i; i--) {
4328 sv_2mortal(*dst); /* free them eventualy */
4332 Safefree(tmparyval);
4336 else if (length--) {
4337 *MARK = tmparyval[length];
4340 while (length-- > 0)
4341 SvREFCNT_dec(tmparyval[length]);
4343 Safefree(tmparyval);
4346 *MARK = &PL_sv_undef;
4354 dSP; dMARK; dORIGMARK; dTARGET;
4355 register AV *ary = (AV*)*++MARK;
4356 register SV *sv = &PL_sv_undef;
4359 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4360 *MARK-- = SvTIED_obj((SV*)ary, mg);
4364 call_method("PUSH",G_SCALAR|G_DISCARD);
4369 /* Why no pre-extend of ary here ? */
4370 for (++MARK; MARK <= SP; MARK++) {
4373 sv_setsv(sv, *MARK);
4378 PUSHi( AvFILL(ary) + 1 );
4386 SV *sv = av_pop(av);
4388 (void)sv_2mortal(sv);
4397 SV *sv = av_shift(av);
4402 (void)sv_2mortal(sv);
4409 dSP; dMARK; dORIGMARK; dTARGET;
4410 register AV *ary = (AV*)*++MARK;
4415 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4416 *MARK-- = SvTIED_obj((SV*)ary, mg);
4420 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4425 av_unshift(ary, SP - MARK);
4427 sv = newSVsv(*++MARK);
4428 (void)av_store(ary, i++, sv);
4432 PUSHi( AvFILL(ary) + 1 );
4442 if (GIMME == G_ARRAY) {
4449 /* safe as long as stack cannot get extended in the above */
4454 register char *down;
4460 SvUTF8_off(TARG); /* decontaminate */
4462 do_join(TARG, &PL_sv_no, MARK, SP);
4464 sv_setsv(TARG, (SP > MARK)
4466 : (padoff_du = find_rundefsvoffset(),
4467 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4468 ? DEFSV : PAD_SVl(padoff_du)));
4469 up = SvPV_force(TARG, len);
4471 if (DO_UTF8(TARG)) { /* first reverse each character */
4472 U8* s = (U8*)SvPVX(TARG);
4473 U8* send = (U8*)(s + len);
4475 if (UTF8_IS_INVARIANT(*s)) {
4480 if (!utf8_to_uvchr(s, 0))
4484 down = (char*)(s - 1);
4485 /* reverse this character */
4489 *down-- = (char)tmp;
4495 down = SvPVX(TARG) + len - 1;
4499 *down-- = (char)tmp;
4501 (void)SvPOK_only_UTF8(TARG);
4513 register IV limit = POPi; /* note, negative is forever */
4516 register char *s = SvPV(sv, len);
4517 bool do_utf8 = DO_UTF8(sv);
4518 char *strend = s + len;
4520 register REGEXP *rx;
4524 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4525 I32 maxiters = slen + 10;
4528 I32 origlimit = limit;
4531 I32 gimme = GIMME_V;
4532 I32 oldsave = PL_savestack_ix;
4533 I32 make_mortal = 1;
4535 MAGIC *mg = (MAGIC *) NULL;
4538 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4543 DIE(aTHX_ "panic: pp_split");
4546 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4547 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4549 RX_MATCH_UTF8_set(rx, do_utf8);
4551 if (pm->op_pmreplroot) {
4553 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4555 ary = GvAVn((GV*)pm->op_pmreplroot);
4558 else if (gimme != G_ARRAY)
4559 ary = GvAVn(PL_defgv);
4562 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4568 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4570 XPUSHs(SvTIED_obj((SV*)ary, mg));
4576 for (i = AvFILLp(ary); i >= 0; i--)
4577 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4579 /* temporarily switch stacks */
4580 SAVESWITCHSTACK(PL_curstack, ary);
4584 base = SP - PL_stack_base;
4586 if (pm->op_pmflags & PMf_SKIPWHITE) {
4587 if (pm->op_pmflags & PMf_LOCALE) {
4588 while (isSPACE_LC(*s))
4596 if (pm->op_pmflags & PMf_MULTILINE) {
4601 limit = maxiters + 2;
4602 if (pm->op_pmflags & PMf_WHITE) {
4605 while (m < strend &&
4606 !((pm->op_pmflags & PMf_LOCALE)
4607 ? isSPACE_LC(*m) : isSPACE(*m)))
4612 dstr = newSVpvn(s, m-s);
4616 (void)SvUTF8_on(dstr);
4620 while (s < strend &&
4621 ((pm->op_pmflags & PMf_LOCALE)
4622 ? isSPACE_LC(*s) : isSPACE(*s)))
4626 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4629 for (m = s; m < strend && *m != '\n'; m++) ;
4633 dstr = newSVpvn(s, m-s);
4637 (void)SvUTF8_on(dstr);
4642 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4643 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4644 && (rx->reganch & ROPT_CHECK_ALL)
4645 && !(rx->reganch & ROPT_ANCH)) {
4646 int tail = (rx->reganch & RE_INTUIT_TAIL);
4647 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4650 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4652 char c = *SvPV(csv, n_a);
4655 for (m = s; m < strend && *m != c; m++) ;
4658 dstr = newSVpvn(s, m-s);
4662 (void)SvUTF8_on(dstr);
4664 /* The rx->minlen is in characters but we want to step
4665 * s ahead by bytes. */
4667 s = (char*)utf8_hop((U8*)m, len);
4669 s = m + len; /* Fake \n at the end */
4674 while (s < strend && --limit &&
4675 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4676 csv, multiline ? FBMrf_MULTILINE : 0)) )
4679 dstr = newSVpvn(s, m-s);
4683 (void)SvUTF8_on(dstr);
4685 /* The rx->minlen is in characters but we want to step
4686 * s ahead by bytes. */
4688 s = (char*)utf8_hop((U8*)m, len);
4690 s = m + len; /* Fake \n at the end */
4695 maxiters += slen * rx->nparens;
4696 while (s < strend && --limit)
4699 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4703 TAINT_IF(RX_MATCH_TAINTED(rx));
4704 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4709 strend = s + (strend - m);
4711 m = rx->startp[0] + orig;
4712 dstr = newSVpvn(s, m-s);
4716 (void)SvUTF8_on(dstr);
4719 for (i = 1; i <= (I32)rx->nparens; i++) {
4720 s = rx->startp[i] + orig;
4721 m = rx->endp[i] + orig;
4723 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4724 parens that didn't match -- they should be set to
4725 undef, not the empty string */
4726 if (m >= orig && s >= orig) {
4727 dstr = newSVpvn(s, m-s);
4730 dstr = &PL_sv_undef; /* undef, not "" */
4734 (void)SvUTF8_on(dstr);
4738 s = rx->endp[0] + orig;
4742 iters = (SP - PL_stack_base) - base;
4743 if (iters > maxiters)
4744 DIE(aTHX_ "Split loop");
4746 /* keep field after final delim? */
4747 if (s < strend || (iters && origlimit)) {
4748 STRLEN l = strend - s;
4749 dstr = newSVpvn(s, l);
4753 (void)SvUTF8_on(dstr);
4757 else if (!origlimit) {
4758 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4759 if (TOPs && !make_mortal)
4762 *SP-- = &PL_sv_undef;
4767 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4771 if (SvSMAGICAL(ary)) {
4776 if (gimme == G_ARRAY) {
4778 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4786 call_method("PUSH",G_SCALAR|G_DISCARD);
4789 if (gimme == G_ARRAY) {
4790 /* EXTEND should not be needed - we just popped them */
4792 for (i=0; i < iters; i++) {
4793 SV **svp = av_fetch(ary, i, FALSE);
4794 PUSHs((svp) ? *svp : &PL_sv_undef);
4801 if (gimme == G_ARRAY)
4816 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4817 || SvTYPE(retsv) == SVt_PVCV) {
4818 retsv = refto(retsv);
4826 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4831 * c-indentation-style: bsd
4833 * indent-tabs-mode: t
4836 * vim: shiftwidth=4: