3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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
23 /* XXX I can't imagine anyone who doesn't have this actually _needs_
24 it, since pid_t is an integral type.
27 #ifdef NEED_GETPID_PROTO
28 extern Pid_t getpid (void);
31 /* variations on pp_null */
36 if (GIMME_V == G_SCALAR)
52 if (PL_op->op_private & OPpLVAL_INTRO)
53 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
55 if (PL_op->op_flags & OPf_REF) {
59 if (GIMME == G_SCALAR)
60 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
65 if (gimme == G_ARRAY) {
66 I32 maxarg = AvFILL((AV*)TARG) + 1;
68 if (SvMAGICAL(TARG)) {
70 for (i=0; i < (U32)maxarg; i++) {
71 SV **svp = av_fetch((AV*)TARG, i, FALSE);
72 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
76 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
80 else if (gimme == G_SCALAR) {
81 SV* sv = sv_newmortal();
82 I32 maxarg = AvFILL((AV*)TARG) + 1;
95 if (PL_op->op_private & OPpLVAL_INTRO)
96 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
97 if (PL_op->op_flags & OPf_REF)
100 if (GIMME == G_SCALAR)
101 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
105 if (gimme == G_ARRAY) {
108 else if (gimme == G_SCALAR) {
109 SV* sv = sv_newmortal();
110 if (HvFILL((HV*)TARG))
111 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
112 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
122 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
133 tryAMAGICunDEREF(to_gv);
136 if (SvTYPE(sv) == SVt_PVIO) {
137 GV *gv = (GV*) sv_newmortal();
138 gv_init(gv, 0, "", 0, 0);
139 GvIOp(gv) = (IO *)sv;
140 (void)SvREFCNT_inc(sv);
143 else if (SvTYPE(sv) != SVt_PVGV)
144 DIE(aTHX_ "Not a GLOB reference");
147 if (SvTYPE(sv) != SVt_PVGV) {
151 if (SvGMAGICAL(sv)) {
156 if (!SvOK(sv) && sv != &PL_sv_undef) {
157 /* If this is a 'my' scalar and flag is set then vivify
160 if (PL_op->op_private & OPpDEREF) {
163 if (cUNOP->op_targ) {
165 SV *namesv = PAD_SV(cUNOP->op_targ);
166 name = SvPV(namesv, len);
167 gv = (GV*)NEWSV(0,0);
168 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
171 name = CopSTASHPV(PL_curcop);
174 if (SvTYPE(sv) < SVt_RV)
175 sv_upgrade(sv, SVt_RV);
181 if (PL_op->op_flags & OPf_REF ||
182 PL_op->op_private & HINT_STRICT_REFS)
183 DIE(aTHX_ PL_no_usym, "a symbol");
184 if (ckWARN(WARN_UNINITIALIZED))
189 if ((PL_op->op_flags & OPf_SPECIAL) &&
190 !(PL_op->op_flags & OPf_MOD))
192 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
194 && (!is_gv_magical(sym,len,0)
195 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
201 if (PL_op->op_private & HINT_STRICT_REFS)
202 DIE(aTHX_ PL_no_symref, sym, "a symbol");
203 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
207 if (PL_op->op_private & OPpLVAL_INTRO)
208 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
220 tryAMAGICunDEREF(to_sv);
223 switch (SvTYPE(sv)) {
227 DIE(aTHX_ "Not a SCALAR reference");
235 if (SvTYPE(gv) != SVt_PVGV) {
236 if (SvGMAGICAL(sv)) {
242 if (PL_op->op_flags & OPf_REF ||
243 PL_op->op_private & HINT_STRICT_REFS)
244 DIE(aTHX_ PL_no_usym, "a SCALAR");
245 if (ckWARN(WARN_UNINITIALIZED))
250 if ((PL_op->op_flags & OPf_SPECIAL) &&
251 !(PL_op->op_flags & OPf_MOD))
253 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
255 && (!is_gv_magical(sym,len,0)
256 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
262 if (PL_op->op_private & HINT_STRICT_REFS)
263 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
264 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
269 if (PL_op->op_flags & OPf_MOD) {
270 if (PL_op->op_private & OPpLVAL_INTRO) {
271 if (cUNOP->op_first->op_type == OP_NULL)
272 sv = save_scalar((GV*)TOPs);
274 sv = save_scalar(gv);
276 Perl_croak(aTHX_ PL_no_localize_ref);
278 else if (PL_op->op_private & OPpDEREF)
279 vivify_ref(sv, PL_op->op_private & OPpDEREF);
289 SV *sv = AvARYLEN(av);
291 AvARYLEN(av) = sv = NEWSV(0,0);
292 sv_upgrade(sv, SVt_IV);
293 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
301 dSP; dTARGET; dPOPss;
303 if (PL_op->op_flags & OPf_MOD || LVRET) {
304 if (SvTYPE(TARG) < SVt_PVLV) {
305 sv_upgrade(TARG, SVt_PVLV);
306 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
310 if (LvTARG(TARG) != sv) {
312 SvREFCNT_dec(LvTARG(TARG));
313 LvTARG(TARG) = SvREFCNT_inc(sv);
315 PUSHs(TARG); /* no SvSETMAGIC */
321 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
322 mg = mg_find(sv, PERL_MAGIC_regex_global);
323 if (mg && mg->mg_len >= 0) {
327 PUSHi(i + PL_curcop->cop_arybase);
341 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
342 /* (But not in defined().) */
343 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
346 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
347 if ((PL_op->op_private & OPpLVAL_INTRO)) {
348 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
351 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
355 cv = (CV*)&PL_sv_undef;
369 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
370 char *s = SvPVX(TOPs);
371 if (strnEQ(s, "CORE::", 6)) {
374 code = keyword(s + 6, SvCUR(TOPs) - 6);
375 if (code < 0) { /* Overridable. */
376 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
377 int i = 0, n = 0, seen_question = 0;
379 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
381 if (code == -KEY_chop || code == -KEY_chomp)
383 while (i < MAXO) { /* The slow way. */
384 if (strEQ(s + 6, PL_op_name[i])
385 || strEQ(s + 6, PL_op_desc[i]))
391 goto nonesuch; /* Should not happen... */
393 oa = PL_opargs[i] >> OASHIFT;
395 if (oa & OA_OPTIONAL && !seen_question) {
399 else if (n && str[0] == ';' && seen_question)
400 goto set; /* XXXX system, exec */
401 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
402 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
403 /* But globs are already references (kinda) */
404 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
408 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
412 ret = sv_2mortal(newSVpvn(str, n - 1));
414 else if (code) /* Non-Overridable */
416 else { /* None such */
418 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
422 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
424 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
433 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
435 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
451 if (GIMME != G_ARRAY) {
455 *MARK = &PL_sv_undef;
456 *MARK = refto(*MARK);
460 EXTEND_MORTAL(SP - MARK);
462 *MARK = refto(*MARK);
467 S_refto(pTHX_ SV *sv)
471 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
474 if (!(sv = LvTARG(sv)))
477 (void)SvREFCNT_inc(sv);
479 else if (SvTYPE(sv) == SVt_PVAV) {
480 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
483 (void)SvREFCNT_inc(sv);
485 else if (SvPADTMP(sv) && !IS_PADGV(sv))
489 (void)SvREFCNT_inc(sv);
492 sv_upgrade(rv, SVt_RV);
506 if (sv && SvGMAGICAL(sv))
509 if (!sv || !SvROK(sv))
513 pv = sv_reftype(sv,TRUE);
514 PUSHp(pv, strlen(pv));
524 stash = CopSTASH(PL_curcop);
530 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
531 Perl_croak(aTHX_ "Attempt to bless into a reference");
533 if (ckWARN(WARN_MISC) && len == 0)
534 Perl_warner(aTHX_ packWARN(WARN_MISC),
535 "Explicit blessing to '' (assuming package main)");
536 stash = gv_stashpvn(ptr, len, TRUE);
539 (void)sv_bless(TOPs, stash);
553 elem = SvPV(sv, n_a);
557 switch (elem ? *elem : '\0')
560 if (strEQ(elem, "ARRAY"))
561 tmpRef = (SV*)GvAV(gv);
564 if (strEQ(elem, "CODE"))
565 tmpRef = (SV*)GvCVu(gv);
568 if (strEQ(elem, "FILEHANDLE")) {
569 /* finally deprecated in 5.8.0 */
570 deprecate("*glob{FILEHANDLE}");
571 tmpRef = (SV*)GvIOp(gv);
574 if (strEQ(elem, "FORMAT"))
575 tmpRef = (SV*)GvFORM(gv);
578 if (strEQ(elem, "GLOB"))
582 if (strEQ(elem, "HASH"))
583 tmpRef = (SV*)GvHV(gv);
586 if (strEQ(elem, "IO"))
587 tmpRef = (SV*)GvIOp(gv);
590 if (strEQ(elem, "NAME"))
591 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
594 if (strEQ(elem, "PACKAGE"))
595 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
598 if (strEQ(elem, "SCALAR"))
612 /* Pattern matching */
617 register unsigned char *s;
620 register I32 *sfirst;
624 if (sv == PL_lastscream) {
630 SvSCREAM_off(PL_lastscream);
631 SvREFCNT_dec(PL_lastscream);
633 PL_lastscream = SvREFCNT_inc(sv);
636 s = (unsigned char*)(SvPV(sv, len));
640 if (pos > PL_maxscream) {
641 if (PL_maxscream < 0) {
642 PL_maxscream = pos + 80;
643 New(301, PL_screamfirst, 256, I32);
644 New(302, PL_screamnext, PL_maxscream, I32);
647 PL_maxscream = pos + pos / 4;
648 Renew(PL_screamnext, PL_maxscream, I32);
652 sfirst = PL_screamfirst;
653 snext = PL_screamnext;
655 if (!sfirst || !snext)
656 DIE(aTHX_ "do_study: out of memory");
658 for (ch = 256; ch; --ch)
665 snext[pos] = sfirst[ch] - pos;
672 /* piggyback on m//g magic */
673 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
682 if (PL_op->op_flags & OPf_STACKED)
688 TARG = sv_newmortal();
693 /* Lvalue operators. */
705 dSP; dMARK; dTARGET; dORIGMARK;
707 do_chop(TARG, *++MARK);
716 SETi(do_chomp(TOPs));
723 register I32 count = 0;
726 count += do_chomp(POPs);
737 if (!sv || !SvANY(sv))
739 switch (SvTYPE(sv)) {
741 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
742 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
746 if (HvARRAY(sv) || SvGMAGICAL(sv)
747 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
751 if (CvROOT(sv) || CvXSUB(sv))
768 if (!PL_op->op_private) {
777 SV_CHECK_THINKFIRST_COW_DROP(sv);
779 switch (SvTYPE(sv)) {
789 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
790 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
791 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
795 /* let user-undef'd sub keep its identity */
796 GV* gv = CvGV((CV*)sv);
803 SvSetMagicSV(sv, &PL_sv_undef);
807 Newz(602, gp, 1, GP);
808 GvGP(sv) = gp_ref(gp);
809 GvSV(sv) = NEWSV(72,0);
810 GvLINE(sv) = CopLINE(PL_curcop);
816 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
819 SvPV_set(sv, Nullch);
832 if (SvTYPE(TOPs) > SVt_PVLV)
833 DIE(aTHX_ PL_no_modify);
834 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
835 && SvIVX(TOPs) != IV_MIN)
838 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
849 if (SvTYPE(TOPs) > SVt_PVLV)
850 DIE(aTHX_ PL_no_modify);
851 sv_setsv(TARG, TOPs);
852 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
853 && SvIVX(TOPs) != IV_MAX)
856 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
861 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
871 if (SvTYPE(TOPs) > SVt_PVLV)
872 DIE(aTHX_ PL_no_modify);
873 sv_setsv(TARG, TOPs);
874 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
875 && SvIVX(TOPs) != IV_MIN)
878 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
887 /* Ordinary operators. */
892 #ifdef PERL_PRESERVE_IVUV
895 tryAMAGICbin(pow,opASSIGN);
896 #ifdef PERL_PRESERVE_IVUV
897 /* For integer to integer power, we do the calculation by hand wherever
898 we're sure it is safe; otherwise we call pow() and try to convert to
899 integer afterwards. */
903 bool baseuok = SvUOK(TOPm1s);
907 baseuv = SvUVX(TOPm1s);
909 IV iv = SvIVX(TOPm1s);
912 baseuok = TRUE; /* effectively it's a UV now */
914 baseuv = -iv; /* abs, baseuok == false records sign */
928 goto float_it; /* Can't do negative powers this way. */
931 /* now we have integer ** positive integer. */
934 /* foo & (foo - 1) is zero only for a power of 2. */
935 if (!(baseuv & (baseuv - 1))) {
936 /* We are raising power-of-2 to a positive integer.
937 The logic here will work for any base (even non-integer
938 bases) but it can be less accurate than
939 pow (base,power) or exp (power * log (base)) when the
940 intermediate values start to spill out of the mantissa.
941 With powers of 2 we know this can't happen.
942 And powers of 2 are the favourite thing for perl
943 programmers to notice ** not doing what they mean. */
945 NV base = baseuok ? baseuv : -(NV)baseuv;
948 for (; power; base *= base, n++) {
949 /* Do I look like I trust gcc with long longs here?
951 UV bit = (UV)1 << (UV)n;
954 /* Only bother to clear the bit if it is set. */
956 /* Avoid squaring base again if we're done. */
957 if (power == 0) break;
965 register unsigned int highbit = 8 * sizeof(UV);
966 register unsigned int lowbit = 0;
967 register unsigned int diff;
968 while ((diff = (highbit - lowbit) >> 1)) {
969 if (baseuv & ~((1 << (lowbit + diff)) - 1))
974 /* we now have baseuv < 2 ** highbit */
975 if (power * highbit <= 8 * sizeof(UV)) {
976 /* result will definitely fit in UV, so use UV math
977 on same algorithm as above */
978 register UV result = 1;
979 register UV base = baseuv;
981 for (; power; base *= base, n++) {
982 register UV bit = (UV)1 << (UV)n;
986 if (power == 0) break;
990 if (baseuok || !(power & 1))
991 /* answer is positive */
993 else if (result <= (UV)IV_MAX)
994 /* answer negative, fits in IV */
996 else if (result == (UV)IV_MIN)
997 /* 2's complement assumption: special case IV_MIN */
1000 /* answer negative, doesn't fit */
1001 SETn( -(NV)result );
1012 SETn( Perl_pow( left, right) );
1013 #ifdef PERL_PRESERVE_IVUV
1023 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1024 #ifdef PERL_PRESERVE_IVUV
1027 /* Unless the left argument is integer in range we are going to have to
1028 use NV maths. Hence only attempt to coerce the right argument if
1029 we know the left is integer. */
1030 /* Left operand is defined, so is it IV? */
1031 SvIV_please(TOPm1s);
1032 if (SvIOK(TOPm1s)) {
1033 bool auvok = SvUOK(TOPm1s);
1034 bool buvok = SvUOK(TOPs);
1035 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1036 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1043 alow = SvUVX(TOPm1s);
1045 IV aiv = SvIVX(TOPm1s);
1048 auvok = TRUE; /* effectively it's a UV now */
1050 alow = -aiv; /* abs, auvok == false records sign */
1056 IV biv = SvIVX(TOPs);
1059 buvok = TRUE; /* effectively it's a UV now */
1061 blow = -biv; /* abs, buvok == false records sign */
1065 /* If this does sign extension on unsigned it's time for plan B */
1066 ahigh = alow >> (4 * sizeof (UV));
1068 bhigh = blow >> (4 * sizeof (UV));
1070 if (ahigh && bhigh) {
1071 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1072 which is overflow. Drop to NVs below. */
1073 } else if (!ahigh && !bhigh) {
1074 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1075 so the unsigned multiply cannot overflow. */
1076 UV product = alow * blow;
1077 if (auvok == buvok) {
1078 /* -ve * -ve or +ve * +ve gives a +ve result. */
1082 } else if (product <= (UV)IV_MIN) {
1083 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1084 /* -ve result, which could overflow an IV */
1086 SETi( -(IV)product );
1088 } /* else drop to NVs below. */
1090 /* One operand is large, 1 small */
1093 /* swap the operands */
1095 bhigh = blow; /* bhigh now the temp var for the swap */
1099 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1100 multiplies can't overflow. shift can, add can, -ve can. */
1101 product_middle = ahigh * blow;
1102 if (!(product_middle & topmask)) {
1103 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1105 product_middle <<= (4 * sizeof (UV));
1106 product_low = alow * blow;
1108 /* as for pp_add, UV + something mustn't get smaller.
1109 IIRC ANSI mandates this wrapping *behaviour* for
1110 unsigned whatever the actual representation*/
1111 product_low += product_middle;
1112 if (product_low >= product_middle) {
1113 /* didn't overflow */
1114 if (auvok == buvok) {
1115 /* -ve * -ve or +ve * +ve gives a +ve result. */
1117 SETu( product_low );
1119 } else if (product_low <= (UV)IV_MIN) {
1120 /* 2s complement assumption again */
1121 /* -ve result, which could overflow an IV */
1123 SETi( -(IV)product_low );
1125 } /* else drop to NVs below. */
1127 } /* product_middle too large */
1128 } /* ahigh && bhigh */
1129 } /* SvIOK(TOPm1s) */
1134 SETn( left * right );
1141 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1142 /* Only try to do UV divide first
1143 if ((SLOPPYDIVIDE is true) or
1144 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1146 The assumption is that it is better to use floating point divide
1147 whenever possible, only doing integer divide first if we can't be sure.
1148 If NV_PRESERVES_UV is true then we know at compile time that no UV
1149 can be too large to preserve, so don't need to compile the code to
1150 test the size of UVs. */
1153 # define PERL_TRY_UV_DIVIDE
1154 /* ensure that 20./5. == 4. */
1156 # ifdef PERL_PRESERVE_IVUV
1157 # ifndef NV_PRESERVES_UV
1158 # define PERL_TRY_UV_DIVIDE
1163 #ifdef PERL_TRY_UV_DIVIDE
1166 SvIV_please(TOPm1s);
1167 if (SvIOK(TOPm1s)) {
1168 bool left_non_neg = SvUOK(TOPm1s);
1169 bool right_non_neg = SvUOK(TOPs);
1173 if (right_non_neg) {
1174 right = SvUVX(TOPs);
1177 IV biv = SvIVX(TOPs);
1180 right_non_neg = TRUE; /* effectively it's a UV now */
1186 /* historically undef()/0 gives a "Use of uninitialized value"
1187 warning before dieing, hence this test goes here.
1188 If it were immediately before the second SvIV_please, then
1189 DIE() would be invoked before left was even inspected, so
1190 no inpsection would give no warning. */
1192 DIE(aTHX_ "Illegal division by zero");
1195 left = SvUVX(TOPm1s);
1198 IV aiv = SvIVX(TOPm1s);
1201 left_non_neg = TRUE; /* effectively it's a UV now */
1210 /* For sloppy divide we always attempt integer division. */
1212 /* Otherwise we only attempt it if either or both operands
1213 would not be preserved by an NV. If both fit in NVs
1214 we fall through to the NV divide code below. However,
1215 as left >= right to ensure integer result here, we know that
1216 we can skip the test on the right operand - right big
1217 enough not to be preserved can't get here unless left is
1220 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1223 /* Integer division can't overflow, but it can be imprecise. */
1224 UV result = left / right;
1225 if (result * right == left) {
1226 SP--; /* result is valid */
1227 if (left_non_neg == right_non_neg) {
1228 /* signs identical, result is positive. */
1232 /* 2s complement assumption */
1233 if (result <= (UV)IV_MIN)
1234 SETi( -(IV)result );
1236 /* It's exact but too negative for IV. */
1237 SETn( -(NV)result );
1240 } /* tried integer divide but it was not an integer result */
1241 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1242 } /* left wasn't SvIOK */
1243 } /* right wasn't SvIOK */
1244 #endif /* PERL_TRY_UV_DIVIDE */
1248 DIE(aTHX_ "Illegal division by zero");
1249 PUSHn( left / right );
1256 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1260 bool left_neg = FALSE;
1261 bool right_neg = FALSE;
1262 bool use_double = FALSE;
1263 bool dright_valid = FALSE;
1269 right_neg = !SvUOK(TOPs);
1271 right = SvUVX(POPs);
1273 IV biv = SvIVX(POPs);
1276 right_neg = FALSE; /* effectively it's a UV now */
1284 right_neg = dright < 0;
1287 if (dright < UV_MAX_P1) {
1288 right = U_V(dright);
1289 dright_valid = TRUE; /* In case we need to use double below. */
1295 /* At this point use_double is only true if right is out of range for
1296 a UV. In range NV has been rounded down to nearest UV and
1297 use_double false. */
1299 if (!use_double && SvIOK(TOPs)) {
1301 left_neg = !SvUOK(TOPs);
1305 IV aiv = SvIVX(POPs);
1308 left_neg = FALSE; /* effectively it's a UV now */
1317 left_neg = dleft < 0;
1321 /* This should be exactly the 5.6 behaviour - if left and right are
1322 both in range for UV then use U_V() rather than floor. */
1324 if (dleft < UV_MAX_P1) {
1325 /* right was in range, so is dleft, so use UVs not double.
1329 /* left is out of range for UV, right was in range, so promote
1330 right (back) to double. */
1332 /* The +0.5 is used in 5.6 even though it is not strictly
1333 consistent with the implicit +0 floor in the U_V()
1334 inside the #if 1. */
1335 dleft = Perl_floor(dleft + 0.5);
1338 dright = Perl_floor(dright + 0.5);
1348 DIE(aTHX_ "Illegal modulus zero");
1350 dans = Perl_fmod(dleft, dright);
1351 if ((left_neg != right_neg) && dans)
1352 dans = dright - dans;
1355 sv_setnv(TARG, dans);
1361 DIE(aTHX_ "Illegal modulus zero");
1364 if ((left_neg != right_neg) && ans)
1367 /* XXX may warn: unary minus operator applied to unsigned type */
1368 /* could change -foo to be (~foo)+1 instead */
1369 if (ans <= ~((UV)IV_MAX)+1)
1370 sv_setiv(TARG, ~ans+1);
1372 sv_setnv(TARG, -(NV)ans);
1375 sv_setuv(TARG, ans);
1384 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1386 register IV count = POPi;
1387 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1389 I32 items = SP - MARK;
1392 max = items * count;
1397 /* This code was intended to fix 20010809.028:
1400 for (($x =~ /./g) x 2) {
1401 print chop; # "abcdabcd" expected as output.
1404 * but that change (#11635) broke this code:
1406 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1408 * I can't think of a better fix that doesn't introduce
1409 * an efficiency hit by copying the SVs. The stack isn't
1410 * refcounted, and mortalisation obviously doesn't
1411 * Do The Right Thing when the stack has more than
1412 * one pointer to the same mortal value.
1416 *SP = sv_2mortal(newSVsv(*SP));
1426 repeatcpy((char*)(MARK + items), (char*)MARK,
1427 items * sizeof(SV*), count - 1);
1430 else if (count <= 0)
1433 else { /* Note: mark already snarfed by pp_list */
1438 SvSetSV(TARG, tmpstr);
1439 SvPV_force(TARG, len);
1440 isutf = DO_UTF8(TARG);
1445 SvGROW(TARG, (count * len) + 1);
1446 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1447 SvCUR(TARG) *= count;
1449 *SvEND(TARG) = '\0';
1452 (void)SvPOK_only_UTF8(TARG);
1454 (void)SvPOK_only(TARG);
1456 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1457 /* The parser saw this as a list repeat, and there
1458 are probably several items on the stack. But we're
1459 in scalar context, and there's no pp_list to save us
1460 now. So drop the rest of the items -- robin@kitsite.com
1473 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1474 useleft = USE_LEFT(TOPm1s);
1475 #ifdef PERL_PRESERVE_IVUV
1476 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1477 "bad things" happen if you rely on signed integers wrapping. */
1480 /* Unless the left argument is integer in range we are going to have to
1481 use NV maths. Hence only attempt to coerce the right argument if
1482 we know the left is integer. */
1483 register UV auv = 0;
1489 a_valid = auvok = 1;
1490 /* left operand is undef, treat as zero. */
1492 /* Left operand is defined, so is it IV? */
1493 SvIV_please(TOPm1s);
1494 if (SvIOK(TOPm1s)) {
1495 if ((auvok = SvUOK(TOPm1s)))
1496 auv = SvUVX(TOPm1s);
1498 register IV aiv = SvIVX(TOPm1s);
1501 auvok = 1; /* Now acting as a sign flag. */
1502 } else { /* 2s complement assumption for IV_MIN */
1510 bool result_good = 0;
1513 bool buvok = SvUOK(TOPs);
1518 register IV biv = SvIVX(TOPs);
1525 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1526 else "IV" now, independent of how it came in.
1527 if a, b represents positive, A, B negative, a maps to -A etc
1532 all UV maths. negate result if A negative.
1533 subtract if signs same, add if signs differ. */
1535 if (auvok ^ buvok) {
1544 /* Must get smaller */
1549 if (result <= buv) {
1550 /* result really should be -(auv-buv). as its negation
1551 of true value, need to swap our result flag */
1563 if (result <= (UV)IV_MIN)
1564 SETi( -(IV)result );
1566 /* result valid, but out of range for IV. */
1567 SETn( -(NV)result );
1571 } /* Overflow, drop through to NVs. */
1575 useleft = USE_LEFT(TOPm1s);
1579 /* left operand is undef, treat as zero - value */
1583 SETn( TOPn - value );
1590 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1593 if (PL_op->op_private & HINT_INTEGER) {
1607 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1610 if (PL_op->op_private & HINT_INTEGER) {
1624 dSP; tryAMAGICbinSET(lt,0);
1625 #ifdef PERL_PRESERVE_IVUV
1628 SvIV_please(TOPm1s);
1629 if (SvIOK(TOPm1s)) {
1630 bool auvok = SvUOK(TOPm1s);
1631 bool buvok = SvUOK(TOPs);
1633 if (!auvok && !buvok) { /* ## IV < IV ## */
1634 IV aiv = SvIVX(TOPm1s);
1635 IV biv = SvIVX(TOPs);
1638 SETs(boolSV(aiv < biv));
1641 if (auvok && buvok) { /* ## UV < UV ## */
1642 UV auv = SvUVX(TOPm1s);
1643 UV buv = SvUVX(TOPs);
1646 SETs(boolSV(auv < buv));
1649 if (auvok) { /* ## UV < IV ## */
1656 /* As (a) is a UV, it's >=0, so it cannot be < */
1661 SETs(boolSV(auv < (UV)biv));
1664 { /* ## IV < UV ## */
1668 aiv = SvIVX(TOPm1s);
1670 /* As (b) is a UV, it's >=0, so it must be < */
1677 SETs(boolSV((UV)aiv < buv));
1683 #ifndef NV_PRESERVES_UV
1684 #ifdef PERL_PRESERVE_IVUV
1687 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1689 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1695 SETs(boolSV(TOPn < value));
1702 dSP; tryAMAGICbinSET(gt,0);
1703 #ifdef PERL_PRESERVE_IVUV
1706 SvIV_please(TOPm1s);
1707 if (SvIOK(TOPm1s)) {
1708 bool auvok = SvUOK(TOPm1s);
1709 bool buvok = SvUOK(TOPs);
1711 if (!auvok && !buvok) { /* ## IV > IV ## */
1712 IV aiv = SvIVX(TOPm1s);
1713 IV biv = SvIVX(TOPs);
1716 SETs(boolSV(aiv > biv));
1719 if (auvok && buvok) { /* ## UV > UV ## */
1720 UV auv = SvUVX(TOPm1s);
1721 UV buv = SvUVX(TOPs);
1724 SETs(boolSV(auv > buv));
1727 if (auvok) { /* ## UV > IV ## */
1734 /* As (a) is a UV, it's >=0, so it must be > */
1739 SETs(boolSV(auv > (UV)biv));
1742 { /* ## IV > UV ## */
1746 aiv = SvIVX(TOPm1s);
1748 /* As (b) is a UV, it's >=0, so it cannot be > */
1755 SETs(boolSV((UV)aiv > buv));
1761 #ifndef NV_PRESERVES_UV
1762 #ifdef PERL_PRESERVE_IVUV
1765 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1767 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1773 SETs(boolSV(TOPn > value));
1780 dSP; tryAMAGICbinSET(le,0);
1781 #ifdef PERL_PRESERVE_IVUV
1784 SvIV_please(TOPm1s);
1785 if (SvIOK(TOPm1s)) {
1786 bool auvok = SvUOK(TOPm1s);
1787 bool buvok = SvUOK(TOPs);
1789 if (!auvok && !buvok) { /* ## IV <= IV ## */
1790 IV aiv = SvIVX(TOPm1s);
1791 IV biv = SvIVX(TOPs);
1794 SETs(boolSV(aiv <= biv));
1797 if (auvok && buvok) { /* ## UV <= UV ## */
1798 UV auv = SvUVX(TOPm1s);
1799 UV buv = SvUVX(TOPs);
1802 SETs(boolSV(auv <= buv));
1805 if (auvok) { /* ## UV <= IV ## */
1812 /* As (a) is a UV, it's >=0, so a cannot be <= */
1817 SETs(boolSV(auv <= (UV)biv));
1820 { /* ## IV <= UV ## */
1824 aiv = SvIVX(TOPm1s);
1826 /* As (b) is a UV, it's >=0, so a must be <= */
1833 SETs(boolSV((UV)aiv <= buv));
1839 #ifndef NV_PRESERVES_UV
1840 #ifdef PERL_PRESERVE_IVUV
1843 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1845 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1851 SETs(boolSV(TOPn <= value));
1858 dSP; tryAMAGICbinSET(ge,0);
1859 #ifdef PERL_PRESERVE_IVUV
1862 SvIV_please(TOPm1s);
1863 if (SvIOK(TOPm1s)) {
1864 bool auvok = SvUOK(TOPm1s);
1865 bool buvok = SvUOK(TOPs);
1867 if (!auvok && !buvok) { /* ## IV >= IV ## */
1868 IV aiv = SvIVX(TOPm1s);
1869 IV biv = SvIVX(TOPs);
1872 SETs(boolSV(aiv >= biv));
1875 if (auvok && buvok) { /* ## UV >= UV ## */
1876 UV auv = SvUVX(TOPm1s);
1877 UV buv = SvUVX(TOPs);
1880 SETs(boolSV(auv >= buv));
1883 if (auvok) { /* ## UV >= IV ## */
1890 /* As (a) is a UV, it's >=0, so it must be >= */
1895 SETs(boolSV(auv >= (UV)biv));
1898 { /* ## IV >= UV ## */
1902 aiv = SvIVX(TOPm1s);
1904 /* As (b) is a UV, it's >=0, so a cannot be >= */
1911 SETs(boolSV((UV)aiv >= buv));
1917 #ifndef NV_PRESERVES_UV
1918 #ifdef PERL_PRESERVE_IVUV
1921 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1923 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1929 SETs(boolSV(TOPn >= value));
1936 dSP; tryAMAGICbinSET(ne,0);
1937 #ifndef NV_PRESERVES_UV
1938 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1940 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1944 #ifdef PERL_PRESERVE_IVUV
1947 SvIV_please(TOPm1s);
1948 if (SvIOK(TOPm1s)) {
1949 bool auvok = SvUOK(TOPm1s);
1950 bool buvok = SvUOK(TOPs);
1952 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1953 /* Casting IV to UV before comparison isn't going to matter
1954 on 2s complement. On 1s complement or sign&magnitude
1955 (if we have any of them) it could make negative zero
1956 differ from normal zero. As I understand it. (Need to
1957 check - is negative zero implementation defined behaviour
1959 UV buv = SvUVX(POPs);
1960 UV auv = SvUVX(TOPs);
1962 SETs(boolSV(auv != buv));
1965 { /* ## Mixed IV,UV ## */
1969 /* != is commutative so swap if needed (save code) */
1971 /* swap. top of stack (b) is the iv */
1975 /* As (a) is a UV, it's >0, so it cannot be == */
1984 /* As (b) is a UV, it's >0, so it cannot be == */
1988 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1990 SETs(boolSV((UV)iv != uv));
1998 SETs(boolSV(TOPn != value));
2005 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2006 #ifndef NV_PRESERVES_UV
2007 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2008 UV right = PTR2UV(SvRV(POPs));
2009 UV left = PTR2UV(SvRV(TOPs));
2010 SETi((left > right) - (left < right));
2014 #ifdef PERL_PRESERVE_IVUV
2015 /* Fortunately it seems NaN isn't IOK */
2018 SvIV_please(TOPm1s);
2019 if (SvIOK(TOPm1s)) {
2020 bool leftuvok = SvUOK(TOPm1s);
2021 bool rightuvok = SvUOK(TOPs);
2023 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2024 IV leftiv = SvIVX(TOPm1s);
2025 IV rightiv = SvIVX(TOPs);
2027 if (leftiv > rightiv)
2029 else if (leftiv < rightiv)
2033 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2034 UV leftuv = SvUVX(TOPm1s);
2035 UV rightuv = SvUVX(TOPs);
2037 if (leftuv > rightuv)
2039 else if (leftuv < rightuv)
2043 } else if (leftuvok) { /* ## UV <=> IV ## */
2047 rightiv = SvIVX(TOPs);
2049 /* As (a) is a UV, it's >=0, so it cannot be < */
2052 leftuv = SvUVX(TOPm1s);
2053 if (leftuv > (UV)rightiv) {
2055 } else if (leftuv < (UV)rightiv) {
2061 } else { /* ## IV <=> UV ## */
2065 leftiv = SvIVX(TOPm1s);
2067 /* As (b) is a UV, it's >=0, so it must be < */
2070 rightuv = SvUVX(TOPs);
2071 if ((UV)leftiv > rightuv) {
2073 } else if ((UV)leftiv < rightuv) {
2091 if (Perl_isnan(left) || Perl_isnan(right)) {
2095 value = (left > right) - (left < right);
2099 else if (left < right)
2101 else if (left > right)
2115 dSP; tryAMAGICbinSET(slt,0);
2118 int cmp = (IN_LOCALE_RUNTIME
2119 ? sv_cmp_locale(left, right)
2120 : sv_cmp(left, right));
2121 SETs(boolSV(cmp < 0));
2128 dSP; tryAMAGICbinSET(sgt,0);
2131 int cmp = (IN_LOCALE_RUNTIME
2132 ? sv_cmp_locale(left, right)
2133 : sv_cmp(left, right));
2134 SETs(boolSV(cmp > 0));
2141 dSP; tryAMAGICbinSET(sle,0);
2144 int cmp = (IN_LOCALE_RUNTIME
2145 ? sv_cmp_locale(left, right)
2146 : sv_cmp(left, right));
2147 SETs(boolSV(cmp <= 0));
2154 dSP; tryAMAGICbinSET(sge,0);
2157 int cmp = (IN_LOCALE_RUNTIME
2158 ? sv_cmp_locale(left, right)
2159 : sv_cmp(left, right));
2160 SETs(boolSV(cmp >= 0));
2167 dSP; tryAMAGICbinSET(seq,0);
2170 SETs(boolSV(sv_eq(left, right)));
2177 dSP; tryAMAGICbinSET(sne,0);
2180 SETs(boolSV(!sv_eq(left, right)));
2187 dSP; dTARGET; tryAMAGICbin(scmp,0);
2190 int cmp = (IN_LOCALE_RUNTIME
2191 ? sv_cmp_locale(left, right)
2192 : sv_cmp(left, right));
2200 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2203 if (SvNIOKp(left) || SvNIOKp(right)) {
2204 if (PL_op->op_private & HINT_INTEGER) {
2205 IV i = SvIV(left) & SvIV(right);
2209 UV u = SvUV(left) & SvUV(right);
2214 do_vop(PL_op->op_type, TARG, left, right);
2223 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2226 if (SvNIOKp(left) || SvNIOKp(right)) {
2227 if (PL_op->op_private & HINT_INTEGER) {
2228 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2232 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2237 do_vop(PL_op->op_type, TARG, left, right);
2246 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2249 if (SvNIOKp(left) || SvNIOKp(right)) {
2250 if (PL_op->op_private & HINT_INTEGER) {
2251 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2255 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2260 do_vop(PL_op->op_type, TARG, left, right);
2269 dSP; dTARGET; tryAMAGICun(neg);
2272 int flags = SvFLAGS(sv);
2275 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2276 /* It's publicly an integer, or privately an integer-not-float */
2279 if (SvIVX(sv) == IV_MIN) {
2280 /* 2s complement assumption. */
2281 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2284 else if (SvUVX(sv) <= IV_MAX) {
2289 else if (SvIVX(sv) != IV_MIN) {
2293 #ifdef PERL_PRESERVE_IVUV
2302 else if (SvPOKp(sv)) {
2304 char *s = SvPV(sv, len);
2305 if (isIDFIRST(*s)) {
2306 sv_setpvn(TARG, "-", 1);
2309 else if (*s == '+' || *s == '-') {
2311 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2313 else if (DO_UTF8(sv)) {
2316 goto oops_its_an_int;
2318 sv_setnv(TARG, -SvNV(sv));
2320 sv_setpvn(TARG, "-", 1);
2327 goto oops_its_an_int;
2328 sv_setnv(TARG, -SvNV(sv));
2340 dSP; tryAMAGICunSET(not);
2341 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2347 dSP; dTARGET; tryAMAGICun(compl);
2351 if (PL_op->op_private & HINT_INTEGER) {
2366 tmps = (U8*)SvPV_force(TARG, len);
2369 /* Calculate exact length, let's not estimate. */
2378 while (tmps < send) {
2379 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2380 tmps += UTF8SKIP(tmps);
2381 targlen += UNISKIP(~c);
2387 /* Now rewind strings and write them. */
2391 Newz(0, result, targlen + 1, U8);
2392 while (tmps < send) {
2393 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2394 tmps += UTF8SKIP(tmps);
2395 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2399 sv_setpvn(TARG, (char*)result, targlen);
2403 Newz(0, result, nchar + 1, U8);
2404 while (tmps < send) {
2405 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2406 tmps += UTF8SKIP(tmps);
2411 sv_setpvn(TARG, (char*)result, nchar);
2419 register long *tmpl;
2420 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2423 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2428 for ( ; anum > 0; anum--, tmps++)
2437 /* integer versions of some of the above */
2441 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2444 SETi( left * right );
2451 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2455 DIE(aTHX_ "Illegal division by zero");
2456 value = POPi / value;
2465 /* This is the vanilla old i_modulo. */
2466 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2470 DIE(aTHX_ "Illegal modulus zero");
2471 SETi( left % right );
2476 #if defined(__GLIBC__) && IVSIZE == 8
2480 /* This is the i_modulo with the workaround for the _moddi3 bug
2481 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2482 * See below for pp_i_modulo. */
2483 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2487 DIE(aTHX_ "Illegal modulus zero");
2488 SETi( left % PERL_ABS(right) );
2496 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2500 DIE(aTHX_ "Illegal modulus zero");
2501 /* The assumption is to use hereafter the old vanilla version... */
2503 PL_ppaddr[OP_I_MODULO] =
2504 &Perl_pp_i_modulo_0;
2505 /* .. but if we have glibc, we might have a buggy _moddi3
2506 * (at least glicb 2.2.5 is known to have this bug), in other
2507 * words our integer modulus with negative quad as the second
2508 * argument might be broken. Test for this and re-patch the
2509 * opcode dispatch table if that is the case, remembering to
2510 * also apply the workaround so that this first round works
2511 * right, too. See [perl #9402] for more information. */
2512 #if defined(__GLIBC__) && IVSIZE == 8
2516 /* Cannot do this check with inlined IV constants since
2517 * that seems to work correctly even with the buggy glibc. */
2519 /* Yikes, we have the bug.
2520 * Patch in the workaround version. */
2522 PL_ppaddr[OP_I_MODULO] =
2523 &Perl_pp_i_modulo_1;
2524 /* Make certain we work right this time, too. */
2525 right = PERL_ABS(right);
2529 SETi( left % right );
2536 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2539 SETi( left + right );
2546 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2549 SETi( left - right );
2556 dSP; tryAMAGICbinSET(lt,0);
2559 SETs(boolSV(left < right));
2566 dSP; tryAMAGICbinSET(gt,0);
2569 SETs(boolSV(left > right));
2576 dSP; tryAMAGICbinSET(le,0);
2579 SETs(boolSV(left <= right));
2586 dSP; tryAMAGICbinSET(ge,0);
2589 SETs(boolSV(left >= right));
2596 dSP; tryAMAGICbinSET(eq,0);
2599 SETs(boolSV(left == right));
2606 dSP; tryAMAGICbinSET(ne,0);
2609 SETs(boolSV(left != right));
2616 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2623 else if (left < right)
2634 dSP; dTARGET; tryAMAGICun(neg);
2639 /* High falutin' math. */
2643 dSP; dTARGET; tryAMAGICbin(atan2,0);
2646 SETn(Perl_atan2(left, right));
2653 dSP; dTARGET; tryAMAGICun(sin);
2657 value = Perl_sin(value);
2665 dSP; dTARGET; tryAMAGICun(cos);
2669 value = Perl_cos(value);
2675 /* Support Configure command-line overrides for rand() functions.
2676 After 5.005, perhaps we should replace this by Configure support
2677 for drand48(), random(), or rand(). For 5.005, though, maintain
2678 compatibility by calling rand() but allow the user to override it.
2679 See INSTALL for details. --Andy Dougherty 15 July 1998
2681 /* Now it's after 5.005, and Configure supports drand48() and random(),
2682 in addition to rand(). So the overrides should not be needed any more.
2683 --Jarkko Hietaniemi 27 September 1998
2686 #ifndef HAS_DRAND48_PROTO
2687 extern double drand48 (void);
2700 if (!PL_srand_called) {
2701 (void)seedDrand01((Rand_seed_t)seed());
2702 PL_srand_called = TRUE;
2717 (void)seedDrand01((Rand_seed_t)anum);
2718 PL_srand_called = TRUE;
2727 * This is really just a quick hack which grabs various garbage
2728 * values. It really should be a real hash algorithm which
2729 * spreads the effect of every input bit onto every output bit,
2730 * if someone who knows about such things would bother to write it.
2731 * Might be a good idea to add that function to CORE as well.
2732 * No numbers below come from careful analysis or anything here,
2733 * except they are primes and SEED_C1 > 1E6 to get a full-width
2734 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2735 * probably be bigger too.
2738 # define SEED_C1 1000003
2739 #define SEED_C4 73819
2741 # define SEED_C1 25747
2742 #define SEED_C4 20639
2746 #define SEED_C5 26107
2748 #ifndef PERL_NO_DEV_RANDOM
2753 # include <starlet.h>
2754 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2755 * in 100-ns units, typically incremented ever 10 ms. */
2756 unsigned int when[2];
2758 # ifdef HAS_GETTIMEOFDAY
2759 struct timeval when;
2765 /* This test is an escape hatch, this symbol isn't set by Configure. */
2766 #ifndef PERL_NO_DEV_RANDOM
2767 #ifndef PERL_RANDOM_DEVICE
2768 /* /dev/random isn't used by default because reads from it will block
2769 * if there isn't enough entropy available. You can compile with
2770 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2771 * is enough real entropy to fill the seed. */
2772 # define PERL_RANDOM_DEVICE "/dev/urandom"
2774 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2776 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2785 _ckvmssts(sys$gettim(when));
2786 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2788 # ifdef HAS_GETTIMEOFDAY
2789 PerlProc_gettimeofday(&when,NULL);
2790 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2793 u = (U32)SEED_C1 * when;
2796 u += SEED_C3 * (U32)PerlProc_getpid();
2797 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2798 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2799 u += SEED_C5 * (U32)PTR2UV(&when);
2806 dSP; dTARGET; tryAMAGICun(exp);
2810 value = Perl_exp(value);
2818 dSP; dTARGET; tryAMAGICun(log);
2823 SET_NUMERIC_STANDARD();
2824 DIE(aTHX_ "Can't take log of %"NVgf, value);
2826 value = Perl_log(value);
2834 dSP; dTARGET; tryAMAGICun(sqrt);
2839 SET_NUMERIC_STANDARD();
2840 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2842 value = Perl_sqrt(value);
2849 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2850 * These need to be revisited when a newer toolchain becomes available.
2852 #if defined(__sparc64__) && defined(__GNUC__)
2853 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2854 # undef SPARC64_MODF_WORKAROUND
2855 # define SPARC64_MODF_WORKAROUND 1
2859 #if defined(SPARC64_MODF_WORKAROUND)
2861 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2864 ret = Perl_modf(theVal, &res);
2872 dSP; dTARGET; tryAMAGICun(int);
2875 IV iv = TOPi; /* attempt to convert to IV if possible. */
2876 /* XXX it's arguable that compiler casting to IV might be subtly
2877 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2878 else preferring IV has introduced a subtle behaviour change bug. OTOH
2879 relying on floating point to be accurate is a bug. */
2890 if (value < (NV)UV_MAX + 0.5) {
2893 #if defined(SPARC64_MODF_WORKAROUND)
2894 (void)sparc64_workaround_modf(value, &value);
2895 #elif defined(HAS_MODFL_POW32_BUG)
2896 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2897 NV offset = Perl_modf(value, &value);
2898 (void)Perl_modf(offset, &offset);
2901 (void)Perl_modf(value, &value);
2907 if (value > (NV)IV_MIN - 0.5) {
2910 #if defined(SPARC64_MODF_WORKAROUND)
2911 (void)sparc64_workaround_modf(-value, &value);
2912 #elif defined(HAS_MODFL_POW32_BUG)
2913 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2914 NV offset = Perl_modf(-value, &value);
2915 (void)Perl_modf(offset, &offset);
2918 (void)Perl_modf(-value, &value);
2930 dSP; dTARGET; tryAMAGICun(abs);
2932 /* This will cache the NV value if string isn't actually integer */
2936 /* IVX is precise */
2938 SETu(TOPu); /* force it to be numeric only */
2946 /* 2s complement assumption. Also, not really needed as
2947 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2967 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2973 tmps = (SvPVx(sv, len));
2975 /* If Unicode, try to downgrade
2976 * If not possible, croak. */
2977 SV* tsv = sv_2mortal(newSVsv(sv));
2980 sv_utf8_downgrade(tsv, FALSE);
2983 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2984 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2997 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3003 tmps = (SvPVx(sv, len));
3005 /* If Unicode, try to downgrade
3006 * If not possible, croak. */
3007 SV* tsv = sv_2mortal(newSVsv(sv));
3010 sv_utf8_downgrade(tsv, FALSE);
3013 while (*tmps && len && isSPACE(*tmps))
3018 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3019 else if (*tmps == 'b')
3020 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3022 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3024 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3041 SETi(sv_len_utf8(sv));
3057 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3059 I32 arybase = PL_curcop->cop_arybase;
3063 int num_args = PL_op->op_private & 7;
3064 bool repl_need_utf8_upgrade = FALSE;
3065 bool repl_is_utf8 = FALSE;
3067 SvTAINTED_off(TARG); /* decontaminate */
3068 SvUTF8_off(TARG); /* decontaminate */
3072 repl = SvPV(repl_sv, repl_len);
3073 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3083 sv_utf8_upgrade(sv);
3085 else if (DO_UTF8(sv))
3086 repl_need_utf8_upgrade = TRUE;
3088 tmps = SvPV(sv, curlen);
3090 utf8_curlen = sv_len_utf8(sv);
3091 if (utf8_curlen == curlen)
3094 curlen = utf8_curlen;
3099 if (pos >= arybase) {
3117 else if (len >= 0) {
3119 if (rem > (I32)curlen)
3134 Perl_croak(aTHX_ "substr outside of string");
3135 if (ckWARN(WARN_SUBSTR))
3136 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3143 sv_pos_u2b(sv, &pos, &rem);
3145 sv_setpvn(TARG, tmps, rem);
3146 #ifdef USE_LOCALE_COLLATE
3147 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3152 SV* repl_sv_copy = NULL;
3154 if (repl_need_utf8_upgrade) {
3155 repl_sv_copy = newSVsv(repl_sv);
3156 sv_utf8_upgrade(repl_sv_copy);
3157 repl = SvPV(repl_sv_copy, repl_len);
3158 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3160 sv_insert(sv, pos, rem, repl, repl_len);
3164 SvREFCNT_dec(repl_sv_copy);
3166 else if (lvalue) { /* it's an lvalue! */
3167 if (!SvGMAGICAL(sv)) {
3171 if (ckWARN(WARN_SUBSTR))
3172 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3173 "Attempt to use reference as lvalue in substr");
3175 if (SvOK(sv)) /* is it defined ? */
3176 (void)SvPOK_only_UTF8(sv);
3178 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3181 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3182 TARG = sv_newmortal();
3183 if (SvTYPE(TARG) < SVt_PVLV) {
3184 sv_upgrade(TARG, SVt_PVLV);
3185 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3189 if (LvTARG(TARG) != sv) {
3191 SvREFCNT_dec(LvTARG(TARG));
3192 LvTARG(TARG) = SvREFCNT_inc(sv);
3194 LvTARGOFF(TARG) = upos;
3195 LvTARGLEN(TARG) = urem;
3199 PUSHs(TARG); /* avoid SvSETMAGIC here */
3206 register IV size = POPi;
3207 register IV offset = POPi;
3208 register SV *src = POPs;
3209 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3211 SvTAINTED_off(TARG); /* decontaminate */
3212 if (lvalue) { /* it's an lvalue! */
3213 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3214 TARG = sv_newmortal();
3215 if (SvTYPE(TARG) < SVt_PVLV) {
3216 sv_upgrade(TARG, SVt_PVLV);
3217 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3220 if (LvTARG(TARG) != src) {
3222 SvREFCNT_dec(LvTARG(TARG));
3223 LvTARG(TARG) = SvREFCNT_inc(src);
3225 LvTARGOFF(TARG) = offset;
3226 LvTARGLEN(TARG) = size;
3229 sv_setuv(TARG, do_vecget(src, offset, size));
3244 I32 arybase = PL_curcop->cop_arybase;
3249 offset = POPi - arybase;
3252 tmps = SvPV(big, biglen);
3253 if (offset > 0 && DO_UTF8(big))
3254 sv_pos_u2b(big, &offset, 0);
3257 else if (offset > (I32)biglen)
3259 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3260 (unsigned char*)tmps + biglen, little, 0)))
3263 retval = tmps2 - tmps;
3264 if (retval > 0 && DO_UTF8(big))
3265 sv_pos_b2u(big, &retval);
3266 PUSHi(retval + arybase);
3281 I32 arybase = PL_curcop->cop_arybase;
3287 tmps2 = SvPV(little, llen);
3288 tmps = SvPV(big, blen);
3292 if (offset > 0 && DO_UTF8(big))
3293 sv_pos_u2b(big, &offset, 0);
3294 offset = offset - arybase + llen;
3298 else if (offset > (I32)blen)
3300 if (!(tmps2 = rninstr(tmps, tmps + offset,
3301 tmps2, tmps2 + llen)))
3304 retval = tmps2 - tmps;
3305 if (retval > 0 && DO_UTF8(big))
3306 sv_pos_b2u(big, &retval);
3307 PUSHi(retval + arybase);
3313 dSP; dMARK; dORIGMARK; dTARGET;
3314 do_sprintf(TARG, SP-MARK, MARK+1);
3315 TAINT_IF(SvTAINTED(TARG));
3316 if (DO_UTF8(*(MARK+1)))
3328 U8 *s = (U8*)SvPVx(argsv, len);
3331 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3332 tmpsv = sv_2mortal(newSVsv(argsv));
3333 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3337 XPUSHu(DO_UTF8(argsv) ?
3338 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3350 (void)SvUPGRADE(TARG,SVt_PV);
3352 if (value > 255 && !IN_BYTES) {
3353 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3354 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3355 SvCUR_set(TARG, tmps - SvPVX(TARG));
3357 (void)SvPOK_only(TARG);
3366 *tmps++ = (char)value;
3368 (void)SvPOK_only(TARG);
3369 if (PL_encoding && !IN_BYTES) {
3370 sv_recode_to_utf8(TARG, PL_encoding);
3372 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3373 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3377 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3378 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3394 char *tmps = SvPV(left, len);
3396 if (DO_UTF8(left)) {
3397 /* If Unicode, try to downgrade.
3398 * If not possible, croak.
3399 * Yes, we made this up. */
3400 SV* tsv = sv_2mortal(newSVsv(left));
3403 sv_utf8_downgrade(tsv, FALSE);
3406 # ifdef USE_ITHREADS
3408 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3409 /* This should be threadsafe because in ithreads there is only
3410 * one thread per interpreter. If this would not be true,
3411 * we would need a mutex to protect this malloc. */
3412 PL_reentrant_buffer->_crypt_struct_buffer =
3413 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3414 #if defined(__GLIBC__) || defined(__EMX__)
3415 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3416 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3417 /* work around glibc-2.2.5 bug */
3418 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3422 # endif /* HAS_CRYPT_R */
3423 # endif /* USE_ITHREADS */
3425 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3427 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3433 "The crypt() function is unimplemented due to excessive paranoia.");
3446 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3447 UTF8_IS_START(*s)) {
3448 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3452 utf8_to_uvchr(s, &ulen);
3453 toTITLE_utf8(s, tmpbuf, &tculen);
3454 utf8_to_uvchr(tmpbuf, 0);
3456 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3458 /* slen is the byte length of the whole SV.
3459 * ulen is the byte length of the original Unicode character
3460 * stored as UTF-8 at s.
3461 * tculen is the byte length of the freshly titlecased
3462 * Unicode character stored as UTF-8 at tmpbuf.
3463 * We first set the result to be the titlecased character,
3464 * and then append the rest of the SV data. */
3465 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3467 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3472 s = (U8*)SvPV_force_nomg(sv, slen);
3473 Copy(tmpbuf, s, tculen, U8);
3477 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3479 SvUTF8_off(TARG); /* decontaminate */
3480 sv_setsv_nomg(TARG, sv);
3484 s = (U8*)SvPV_force_nomg(sv, slen);
3486 if (IN_LOCALE_RUNTIME) {
3489 *s = toUPPER_LC(*s);
3508 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3509 UTF8_IS_START(*s)) {
3511 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3515 toLOWER_utf8(s, tmpbuf, &ulen);
3516 uv = utf8_to_uvchr(tmpbuf, 0);
3517 tend = uvchr_to_utf8(tmpbuf, uv);
3519 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3521 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3523 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3528 s = (U8*)SvPV_force_nomg(sv, slen);
3529 Copy(tmpbuf, s, ulen, U8);
3533 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3535 SvUTF8_off(TARG); /* decontaminate */
3536 sv_setsv_nomg(TARG, sv);
3540 s = (U8*)SvPV_force_nomg(sv, slen);
3542 if (IN_LOCALE_RUNTIME) {
3545 *s = toLOWER_LC(*s);
3568 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3570 s = (U8*)SvPV_nomg(sv,len);
3572 SvUTF8_off(TARG); /* decontaminate */
3573 sv_setpvn(TARG, "", 0);
3577 STRLEN nchar = utf8_length(s, s + len);
3579 (void)SvUPGRADE(TARG, SVt_PV);
3580 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3581 (void)SvPOK_only(TARG);
3582 d = (U8*)SvPVX(TARG);
3585 toUPPER_utf8(s, tmpbuf, &ulen);
3586 Copy(tmpbuf, d, ulen, U8);
3592 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3597 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3599 SvUTF8_off(TARG); /* decontaminate */
3600 sv_setsv_nomg(TARG, sv);
3604 s = (U8*)SvPV_force_nomg(sv, len);
3606 register U8 *send = s + len;
3608 if (IN_LOCALE_RUNTIME) {
3611 for (; s < send; s++)
3612 *s = toUPPER_LC(*s);
3615 for (; s < send; s++)
3637 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3639 s = (U8*)SvPV_nomg(sv,len);
3641 SvUTF8_off(TARG); /* decontaminate */
3642 sv_setpvn(TARG, "", 0);
3646 STRLEN nchar = utf8_length(s, s + len);
3648 (void)SvUPGRADE(TARG, SVt_PV);
3649 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3650 (void)SvPOK_only(TARG);
3651 d = (U8*)SvPVX(TARG);
3654 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3655 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3656 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3658 * Now if the sigma is NOT followed by
3659 * /$ignorable_sequence$cased_letter/;
3660 * and it IS preceded by
3661 * /$cased_letter$ignorable_sequence/;
3662 * where $ignorable_sequence is
3663 * [\x{2010}\x{AD}\p{Mn}]*
3664 * and $cased_letter is
3665 * [\p{Ll}\p{Lo}\p{Lt}]
3666 * then it should be mapped to 0x03C2,
3667 * (GREEK SMALL LETTER FINAL SIGMA),
3668 * instead of staying 0x03A3.
3669 * See lib/unicore/SpecCase.txt.
3672 Copy(tmpbuf, d, ulen, U8);
3678 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3683 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3685 SvUTF8_off(TARG); /* decontaminate */
3686 sv_setsv_nomg(TARG, sv);
3691 s = (U8*)SvPV_force_nomg(sv, len);
3693 register U8 *send = s + len;
3695 if (IN_LOCALE_RUNTIME) {
3698 for (; s < send; s++)
3699 *s = toLOWER_LC(*s);
3702 for (; s < send; s++)
3716 register char *s = SvPV(sv,len);
3719 SvUTF8_off(TARG); /* decontaminate */
3721 (void)SvUPGRADE(TARG, SVt_PV);
3722 SvGROW(TARG, (len * 2) + 1);
3726 if (UTF8_IS_CONTINUED(*s)) {
3727 STRLEN ulen = UTF8SKIP(s);
3751 SvCUR_set(TARG, d - SvPVX(TARG));
3752 (void)SvPOK_only_UTF8(TARG);
3755 sv_setpvn(TARG, s, len);
3757 if (SvSMAGICAL(TARG))
3766 dSP; dMARK; dORIGMARK;
3768 register AV* av = (AV*)POPs;
3769 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3770 I32 arybase = PL_curcop->cop_arybase;
3773 if (SvTYPE(av) == SVt_PVAV) {
3774 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3776 for (svp = MARK + 1; svp <= SP; svp++) {
3781 if (max > AvMAX(av))
3784 while (++MARK <= SP) {
3785 elem = SvIVx(*MARK);
3789 svp = av_fetch(av, elem, lval);
3791 if (!svp || *svp == &PL_sv_undef)
3792 DIE(aTHX_ PL_no_aelem, elem);
3793 if (PL_op->op_private & OPpLVAL_INTRO)
3794 save_aelem(av, elem, svp);
3796 *MARK = svp ? *svp : &PL_sv_undef;
3799 if (GIMME != G_ARRAY) {
3807 /* Associative arrays. */
3812 HV *hash = (HV*)POPs;
3814 I32 gimme = GIMME_V;
3817 /* might clobber stack_sp */
3818 entry = hv_iternext(hash);
3823 SV* sv = hv_iterkeysv(entry);
3824 PUSHs(sv); /* won't clobber stack_sp */
3825 if (gimme == G_ARRAY) {
3828 /* might clobber stack_sp */
3829 val = hv_iterval(hash, entry);
3834 else if (gimme == G_SCALAR)
3853 I32 gimme = GIMME_V;
3854 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3858 if (PL_op->op_private & OPpSLICE) {
3862 hvtype = SvTYPE(hv);
3863 if (hvtype == SVt_PVHV) { /* hash element */
3864 while (++MARK <= SP) {
3865 sv = hv_delete_ent(hv, *MARK, discard, 0);
3866 *MARK = sv ? sv : &PL_sv_undef;
3869 else if (hvtype == SVt_PVAV) { /* array element */
3870 if (PL_op->op_flags & OPf_SPECIAL) {
3871 while (++MARK <= SP) {
3872 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3873 *MARK = sv ? sv : &PL_sv_undef;
3878 DIE(aTHX_ "Not a HASH reference");
3881 else if (gimme == G_SCALAR) {
3890 if (SvTYPE(hv) == SVt_PVHV)
3891 sv = hv_delete_ent(hv, keysv, discard, 0);
3892 else if (SvTYPE(hv) == SVt_PVAV) {
3893 if (PL_op->op_flags & OPf_SPECIAL)
3894 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3896 DIE(aTHX_ "panic: avhv_delete no longer supported");
3899 DIE(aTHX_ "Not a HASH reference");
3914 if (PL_op->op_private & OPpEXISTS_SUB) {
3918 cv = sv_2cv(sv, &hv, &gv, FALSE);
3921 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3927 if (SvTYPE(hv) == SVt_PVHV) {
3928 if (hv_exists_ent(hv, tmpsv, 0))
3931 else if (SvTYPE(hv) == SVt_PVAV) {
3932 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3933 if (av_exists((AV*)hv, SvIV(tmpsv)))
3938 DIE(aTHX_ "Not a HASH reference");
3945 dSP; dMARK; dORIGMARK;
3946 register HV *hv = (HV*)POPs;
3947 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3948 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3949 bool other_magic = FALSE;
3955 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3956 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3957 /* Try to preserve the existenceness of a tied hash
3958 * element by using EXISTS and DELETE if possible.
3959 * Fallback to FETCH and STORE otherwise */
3960 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3961 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3962 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3965 while (++MARK <= SP) {
3969 bool preeminent = FALSE;
3972 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3973 hv_exists_ent(hv, keysv, 0);
3976 he = hv_fetch_ent(hv, keysv, lval, 0);
3977 svp = he ? &HeVAL(he) : 0;
3980 if (!svp || *svp == &PL_sv_undef) {
3982 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3986 save_helem(hv, keysv, svp);
3989 char *key = SvPV(keysv, keylen);
3990 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3994 *MARK = svp ? *svp : &PL_sv_undef;
3996 if (GIMME != G_ARRAY) {
4004 /* List operators. */
4009 if (GIMME != G_ARRAY) {
4011 *MARK = *SP; /* unwanted list, return last item */
4013 *MARK = &PL_sv_undef;
4022 SV **lastrelem = PL_stack_sp;
4023 SV **lastlelem = PL_stack_base + POPMARK;
4024 SV **firstlelem = PL_stack_base + POPMARK + 1;
4025 register SV **firstrelem = lastlelem + 1;
4026 I32 arybase = PL_curcop->cop_arybase;
4027 I32 lval = PL_op->op_flags & OPf_MOD;
4028 I32 is_something_there = lval;
4030 register I32 max = lastrelem - lastlelem;
4031 register SV **lelem;
4034 if (GIMME != G_ARRAY) {
4035 ix = SvIVx(*lastlelem);
4040 if (ix < 0 || ix >= max)
4041 *firstlelem = &PL_sv_undef;
4043 *firstlelem = firstrelem[ix];
4049 SP = firstlelem - 1;
4053 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4059 if (ix < 0 || ix >= max)
4060 *lelem = &PL_sv_undef;
4062 is_something_there = TRUE;
4063 if (!(*lelem = firstrelem[ix]))
4064 *lelem = &PL_sv_undef;
4067 if (is_something_there)
4070 SP = firstlelem - 1;
4076 dSP; dMARK; dORIGMARK;
4077 I32 items = SP - MARK;
4078 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4079 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4086 dSP; dMARK; dORIGMARK;
4087 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4091 SV *val = NEWSV(46, 0);
4093 sv_setsv(val, *++MARK);
4094 else if (ckWARN(WARN_MISC))
4095 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4096 (void)hv_store_ent(hv,key,val,0);
4105 dSP; dMARK; dORIGMARK;
4106 register AV *ary = (AV*)*++MARK;
4110 register I32 offset;
4111 register I32 length;
4118 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4119 *MARK-- = SvTIED_obj((SV*)ary, mg);
4123 call_method("SPLICE",GIMME_V);
4132 offset = i = SvIVx(*MARK);
4134 offset += AvFILLp(ary) + 1;
4136 offset -= PL_curcop->cop_arybase;
4138 DIE(aTHX_ PL_no_aelem, i);
4140 length = SvIVx(*MARK++);
4142 length += AvFILLp(ary) - offset + 1;
4148 length = AvMAX(ary) + 1; /* close enough to infinity */
4152 length = AvMAX(ary) + 1;
4154 if (offset > AvFILLp(ary) + 1) {
4155 if (ckWARN(WARN_MISC))
4156 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4157 offset = AvFILLp(ary) + 1;
4159 after = AvFILLp(ary) + 1 - (offset + length);
4160 if (after < 0) { /* not that much array */
4161 length += after; /* offset+length now in array */
4167 /* At this point, MARK .. SP-1 is our new LIST */
4170 diff = newlen - length;
4171 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4174 if (diff < 0) { /* shrinking the area */
4176 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4177 Copy(MARK, tmparyval, newlen, SV*);
4180 MARK = ORIGMARK + 1;
4181 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4182 MEXTEND(MARK, length);
4183 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4185 EXTEND_MORTAL(length);
4186 for (i = length, dst = MARK; i; i--) {
4187 sv_2mortal(*dst); /* free them eventualy */
4194 *MARK = AvARRAY(ary)[offset+length-1];
4197 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4198 SvREFCNT_dec(*dst++); /* free them now */
4201 AvFILLp(ary) += diff;
4203 /* pull up or down? */
4205 if (offset < after) { /* easier to pull up */
4206 if (offset) { /* esp. if nothing to pull */
4207 src = &AvARRAY(ary)[offset-1];
4208 dst = src - diff; /* diff is negative */
4209 for (i = offset; i > 0; i--) /* can't trust Copy */
4213 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4217 if (after) { /* anything to pull down? */
4218 src = AvARRAY(ary) + offset + length;
4219 dst = src + diff; /* diff is negative */
4220 Move(src, dst, after, SV*);
4222 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4223 /* avoid later double free */
4227 dst[--i] = &PL_sv_undef;
4230 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4232 *dst = NEWSV(46, 0);
4233 sv_setsv(*dst++, *src++);
4235 Safefree(tmparyval);
4238 else { /* no, expanding (or same) */
4240 New(452, tmparyval, length, SV*); /* so remember deletion */
4241 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4244 if (diff > 0) { /* expanding */
4246 /* push up or down? */
4248 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4252 Move(src, dst, offset, SV*);
4254 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4256 AvFILLp(ary) += diff;
4259 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4260 av_extend(ary, AvFILLp(ary) + diff);
4261 AvFILLp(ary) += diff;
4264 dst = AvARRAY(ary) + AvFILLp(ary);
4266 for (i = after; i; i--) {
4273 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4274 *dst = NEWSV(46, 0);
4275 sv_setsv(*dst++, *src++);
4277 MARK = ORIGMARK + 1;
4278 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4280 Copy(tmparyval, MARK, length, SV*);
4282 EXTEND_MORTAL(length);
4283 for (i = length, dst = MARK; i; i--) {
4284 sv_2mortal(*dst); /* free them eventualy */
4288 Safefree(tmparyval);
4292 else if (length--) {
4293 *MARK = tmparyval[length];
4296 while (length-- > 0)
4297 SvREFCNT_dec(tmparyval[length]);
4299 Safefree(tmparyval);
4302 *MARK = &PL_sv_undef;
4310 dSP; dMARK; dORIGMARK; dTARGET;
4311 register AV *ary = (AV*)*++MARK;
4312 register SV *sv = &PL_sv_undef;
4315 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4316 *MARK-- = SvTIED_obj((SV*)ary, mg);
4320 call_method("PUSH",G_SCALAR|G_DISCARD);
4325 /* Why no pre-extend of ary here ? */
4326 for (++MARK; MARK <= SP; MARK++) {
4329 sv_setsv(sv, *MARK);
4334 PUSHi( AvFILL(ary) + 1 );
4342 SV *sv = av_pop(av);
4344 (void)sv_2mortal(sv);
4353 SV *sv = av_shift(av);
4358 (void)sv_2mortal(sv);
4365 dSP; dMARK; dORIGMARK; dTARGET;
4366 register AV *ary = (AV*)*++MARK;
4371 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4372 *MARK-- = SvTIED_obj((SV*)ary, mg);
4376 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4381 av_unshift(ary, SP - MARK);
4384 sv_setsv(sv, *++MARK);
4385 (void)av_store(ary, i++, sv);
4389 PUSHi( AvFILL(ary) + 1 );
4399 if (GIMME == G_ARRAY) {
4406 /* safe as long as stack cannot get extended in the above */
4411 register char *down;
4416 SvUTF8_off(TARG); /* decontaminate */
4418 do_join(TARG, &PL_sv_no, MARK, SP);
4420 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4421 up = SvPV_force(TARG, len);
4423 if (DO_UTF8(TARG)) { /* first reverse each character */
4424 U8* s = (U8*)SvPVX(TARG);
4425 U8* send = (U8*)(s + len);
4427 if (UTF8_IS_INVARIANT(*s)) {
4432 if (!utf8_to_uvchr(s, 0))
4436 down = (char*)(s - 1);
4437 /* reverse this character */
4441 *down-- = (char)tmp;
4447 down = SvPVX(TARG) + len - 1;
4451 *down-- = (char)tmp;
4453 (void)SvPOK_only_UTF8(TARG);
4465 register IV limit = POPi; /* note, negative is forever */
4468 register char *s = SvPV(sv, len);
4469 bool do_utf8 = DO_UTF8(sv);
4470 char *strend = s + len;
4472 register REGEXP *rx;
4476 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4477 I32 maxiters = slen + 10;
4480 I32 origlimit = limit;
4483 AV *oldstack = PL_curstack;
4484 I32 gimme = GIMME_V;
4485 I32 oldsave = PL_savestack_ix;
4486 I32 make_mortal = 1;
4487 MAGIC *mg = (MAGIC *) NULL;
4490 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4495 DIE(aTHX_ "panic: pp_split");
4498 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4499 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4501 RX_MATCH_UTF8_set(rx, do_utf8);
4503 if (pm->op_pmreplroot) {
4505 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4507 ary = GvAVn((GV*)pm->op_pmreplroot);
4510 else if (gimme != G_ARRAY)
4511 ary = GvAVn(PL_defgv);
4514 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4520 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4522 XPUSHs(SvTIED_obj((SV*)ary, mg));
4528 for (i = AvFILLp(ary); i >= 0; i--)
4529 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4531 /* temporarily switch stacks */
4532 SWITCHSTACK(PL_curstack, ary);
4533 PL_curstackinfo->si_stack = ary;
4537 base = SP - PL_stack_base;
4539 if (pm->op_pmflags & PMf_SKIPWHITE) {
4540 if (pm->op_pmflags & PMf_LOCALE) {
4541 while (isSPACE_LC(*s))
4549 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4550 SAVEINT(PL_multiline);
4551 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4555 limit = maxiters + 2;
4556 if (pm->op_pmflags & PMf_WHITE) {
4559 while (m < strend &&
4560 !((pm->op_pmflags & PMf_LOCALE)
4561 ? isSPACE_LC(*m) : isSPACE(*m)))
4566 dstr = NEWSV(30, m-s);
4567 sv_setpvn(dstr, s, m-s);
4571 (void)SvUTF8_on(dstr);
4575 while (s < strend &&
4576 ((pm->op_pmflags & PMf_LOCALE)
4577 ? isSPACE_LC(*s) : isSPACE(*s)))
4581 else if (strEQ("^", rx->precomp)) {
4584 for (m = s; m < strend && *m != '\n'; m++) ;
4588 dstr = NEWSV(30, m-s);
4589 sv_setpvn(dstr, s, m-s);
4593 (void)SvUTF8_on(dstr);
4598 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4599 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4600 && (rx->reganch & ROPT_CHECK_ALL)
4601 && !(rx->reganch & ROPT_ANCH)) {
4602 int tail = (rx->reganch & RE_INTUIT_TAIL);
4603 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4606 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4608 char c = *SvPV(csv, n_a);
4611 for (m = s; m < strend && *m != c; m++) ;
4614 dstr = NEWSV(30, m-s);
4615 sv_setpvn(dstr, s, m-s);
4619 (void)SvUTF8_on(dstr);
4621 /* The rx->minlen is in characters but we want to step
4622 * s ahead by bytes. */
4624 s = (char*)utf8_hop((U8*)m, len);
4626 s = m + len; /* Fake \n at the end */
4631 while (s < strend && --limit &&
4632 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4633 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4636 dstr = NEWSV(31, m-s);
4637 sv_setpvn(dstr, s, m-s);
4641 (void)SvUTF8_on(dstr);
4643 /* The rx->minlen is in characters but we want to step
4644 * s ahead by bytes. */
4646 s = (char*)utf8_hop((U8*)m, len);
4648 s = m + len; /* Fake \n at the end */
4653 maxiters += slen * rx->nparens;
4654 while (s < strend && --limit
4655 /* && (!rx->check_substr
4656 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4658 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4659 1 /* minend */, sv, NULL, 0))
4661 TAINT_IF(RX_MATCH_TAINTED(rx));
4662 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4667 strend = s + (strend - m);
4669 m = rx->startp[0] + orig;
4670 dstr = NEWSV(32, m-s);
4671 sv_setpvn(dstr, s, m-s);
4675 (void)SvUTF8_on(dstr);
4678 for (i = 1; i <= (I32)rx->nparens; i++) {
4679 s = rx->startp[i] + orig;
4680 m = rx->endp[i] + orig;
4682 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4683 parens that didn't match -- they should be set to
4684 undef, not the empty string */
4685 if (m >= orig && s >= orig) {
4686 dstr = NEWSV(33, m-s);
4687 sv_setpvn(dstr, s, m-s);
4690 dstr = &PL_sv_undef; /* undef, not "" */
4694 (void)SvUTF8_on(dstr);
4698 s = rx->endp[0] + orig;
4703 LEAVE_SCOPE(oldsave);
4704 iters = (SP - PL_stack_base) - base;
4705 if (iters > maxiters)
4706 DIE(aTHX_ "Split loop");
4708 /* keep field after final delim? */
4709 if (s < strend || (iters && origlimit)) {
4710 STRLEN l = strend - s;
4711 dstr = NEWSV(34, l);
4712 sv_setpvn(dstr, s, l);
4716 (void)SvUTF8_on(dstr);
4720 else if (!origlimit) {
4721 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4722 if (TOPs && !make_mortal)
4731 SWITCHSTACK(ary, oldstack);
4732 PL_curstackinfo->si_stack = oldstack;
4733 if (SvSMAGICAL(ary)) {
4738 if (gimme == G_ARRAY) {
4740 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4748 call_method("PUSH",G_SCALAR|G_DISCARD);
4751 if (gimme == G_ARRAY) {
4752 /* EXTEND should not be needed - we just popped them */
4754 for (i=0; i < iters; i++) {
4755 SV **svp = av_fetch(ary, i, FALSE);
4756 PUSHs((svp) ? *svp : &PL_sv_undef);
4763 if (gimme == G_ARRAY)
4778 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4779 || SvTYPE(retsv) == SVt_PVCV) {
4780 retsv = refto(retsv);
4788 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");