3 * Copyright (c) 1991-2003, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
22 /* XXX I can't imagine anyone who doesn't have this actually _needs_
23 it, since pid_t is an integral type.
26 #ifdef NEED_GETPID_PROTO
27 extern Pid_t getpid (void);
30 /* variations on pp_null */
35 if (GIMME_V == G_SCALAR)
51 if (PL_op->op_private & OPpLVAL_INTRO)
52 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
54 if (PL_op->op_flags & OPf_REF) {
58 if (GIMME == G_SCALAR)
59 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
64 if (gimme == G_ARRAY) {
65 I32 maxarg = AvFILL((AV*)TARG) + 1;
67 if (SvMAGICAL(TARG)) {
69 for (i=0; i < (U32)maxarg; i++) {
70 SV **svp = av_fetch((AV*)TARG, i, FALSE);
71 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
75 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
79 else if (gimme == G_SCALAR) {
80 SV* sv = sv_newmortal();
81 I32 maxarg = AvFILL((AV*)TARG) + 1;
94 if (PL_op->op_private & OPpLVAL_INTRO)
95 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
96 if (PL_op->op_flags & OPf_REF)
99 if (GIMME == G_SCALAR)
100 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
104 if (gimme == G_ARRAY) {
107 else if (gimme == G_SCALAR) {
108 SV* sv = sv_newmortal();
109 if (HvFILL((HV*)TARG))
110 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
111 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
121 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
132 tryAMAGICunDEREF(to_gv);
135 if (SvTYPE(sv) == SVt_PVIO) {
136 GV *gv = (GV*) sv_newmortal();
137 gv_init(gv, 0, "", 0, 0);
138 GvIOp(gv) = (IO *)sv;
139 (void)SvREFCNT_inc(sv);
142 else if (SvTYPE(sv) != SVt_PVGV)
143 DIE(aTHX_ "Not a GLOB reference");
146 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
159 if (PL_op->op_private & OPpDEREF) {
162 if (cUNOP->op_targ) {
164 SV *namesv = PAD_SV(cUNOP->op_targ);
165 name = SvPV(namesv, len);
166 gv = (GV*)NEWSV(0,0);
167 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
170 name = CopSTASHPV(PL_curcop);
173 if (SvTYPE(sv) < SVt_RV)
174 sv_upgrade(sv, SVt_RV);
180 if (PL_op->op_flags & OPf_REF ||
181 PL_op->op_private & HINT_STRICT_REFS)
182 DIE(aTHX_ PL_no_usym, "a symbol");
183 if (ckWARN(WARN_UNINITIALIZED))
188 if ((PL_op->op_flags & OPf_SPECIAL) &&
189 !(PL_op->op_flags & OPf_MOD))
191 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
193 && (!is_gv_magical(sym,len,0)
194 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
200 if (PL_op->op_private & HINT_STRICT_REFS)
201 DIE(aTHX_ PL_no_symref, sym, "a symbol");
202 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
206 if (PL_op->op_private & OPpLVAL_INTRO)
207 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
219 tryAMAGICunDEREF(to_sv);
222 switch (SvTYPE(sv)) {
226 DIE(aTHX_ "Not a SCALAR reference");
234 if (SvTYPE(gv) != SVt_PVGV) {
235 if (SvGMAGICAL(sv)) {
241 if (PL_op->op_flags & OPf_REF ||
242 PL_op->op_private & HINT_STRICT_REFS)
243 DIE(aTHX_ PL_no_usym, "a SCALAR");
244 if (ckWARN(WARN_UNINITIALIZED))
249 if ((PL_op->op_flags & OPf_SPECIAL) &&
250 !(PL_op->op_flags & OPf_MOD))
252 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
254 && (!is_gv_magical(sym,len,0)
255 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
261 if (PL_op->op_private & HINT_STRICT_REFS)
262 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
263 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
268 if (PL_op->op_flags & OPf_MOD) {
269 if (PL_op->op_private & OPpLVAL_INTRO) {
270 if (cUNOP->op_first->op_type == OP_NULL)
271 sv = save_scalar((GV*)TOPs);
273 sv = save_scalar(gv);
275 Perl_croak(aTHX_ PL_no_localize_ref);
277 else if (PL_op->op_private & OPpDEREF)
278 vivify_ref(sv, PL_op->op_private & OPpDEREF);
288 SV *sv = AvARYLEN(av);
290 AvARYLEN(av) = sv = NEWSV(0,0);
291 sv_upgrade(sv, SVt_IV);
292 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
300 dSP; dTARGET; dPOPss;
302 if (PL_op->op_flags & OPf_MOD || LVRET) {
303 if (SvTYPE(TARG) < SVt_PVLV) {
304 sv_upgrade(TARG, SVt_PVLV);
305 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
309 if (LvTARG(TARG) != sv) {
311 SvREFCNT_dec(LvTARG(TARG));
312 LvTARG(TARG) = SvREFCNT_inc(sv);
314 PUSHs(TARG); /* no SvSETMAGIC */
320 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
321 mg = mg_find(sv, PERL_MAGIC_regex_global);
322 if (mg && mg->mg_len >= 0) {
326 PUSHi(i + PL_curcop->cop_arybase);
340 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
341 /* (But not in defined().) */
342 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
345 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
346 if ((PL_op->op_private & OPpLVAL_INTRO)) {
347 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
350 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
354 cv = (CV*)&PL_sv_undef;
368 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
369 char *s = SvPVX(TOPs);
370 if (strnEQ(s, "CORE::", 6)) {
373 code = keyword(s + 6, SvCUR(TOPs) - 6);
374 if (code < 0) { /* Overridable. */
375 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
376 int i = 0, n = 0, seen_question = 0;
378 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
380 if (code == -KEY_chop || code == -KEY_chomp)
382 while (i < MAXO) { /* The slow way. */
383 if (strEQ(s + 6, PL_op_name[i])
384 || strEQ(s + 6, PL_op_desc[i]))
390 goto nonesuch; /* Should not happen... */
392 oa = PL_opargs[i] >> OASHIFT;
394 if (oa & OA_OPTIONAL && !seen_question) {
398 else if (n && str[0] == ';' && seen_question)
399 goto set; /* XXXX system, exec */
400 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
401 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
402 /* But globs are already references (kinda) */
403 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
407 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
411 ret = sv_2mortal(newSVpvn(str, n - 1));
413 else if (code) /* Non-Overridable */
415 else { /* None such */
417 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
421 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
423 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
432 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
434 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
450 if (GIMME != G_ARRAY) {
454 *MARK = &PL_sv_undef;
455 *MARK = refto(*MARK);
459 EXTEND_MORTAL(SP - MARK);
461 *MARK = refto(*MARK);
466 S_refto(pTHX_ SV *sv)
470 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
473 if (!(sv = LvTARG(sv)))
476 (void)SvREFCNT_inc(sv);
478 else if (SvTYPE(sv) == SVt_PVAV) {
479 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
482 (void)SvREFCNT_inc(sv);
484 else if (SvPADTMP(sv) && !IS_PADGV(sv))
488 (void)SvREFCNT_inc(sv);
491 sv_upgrade(rv, SVt_RV);
505 if (sv && SvGMAGICAL(sv))
508 if (!sv || !SvROK(sv))
512 pv = sv_reftype(sv,TRUE);
513 PUSHp(pv, strlen(pv));
523 stash = CopSTASH(PL_curcop);
529 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
530 Perl_croak(aTHX_ "Attempt to bless into a reference");
532 if (ckWARN(WARN_MISC) && len == 0)
533 Perl_warner(aTHX_ packWARN(WARN_MISC),
534 "Explicit blessing to '' (assuming package main)");
535 stash = gv_stashpvn(ptr, len, TRUE);
538 (void)sv_bless(TOPs, stash);
552 elem = SvPV(sv, n_a);
556 switch (elem ? *elem : '\0')
559 if (strEQ(elem, "ARRAY"))
560 tmpRef = (SV*)GvAV(gv);
563 if (strEQ(elem, "CODE"))
564 tmpRef = (SV*)GvCVu(gv);
567 if (strEQ(elem, "FILEHANDLE")) {
568 /* finally deprecated in 5.8.0 */
569 deprecate("*glob{FILEHANDLE}");
570 tmpRef = (SV*)GvIOp(gv);
573 if (strEQ(elem, "FORMAT"))
574 tmpRef = (SV*)GvFORM(gv);
577 if (strEQ(elem, "GLOB"))
581 if (strEQ(elem, "HASH"))
582 tmpRef = (SV*)GvHV(gv);
585 if (strEQ(elem, "IO"))
586 tmpRef = (SV*)GvIOp(gv);
589 if (strEQ(elem, "NAME"))
590 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
593 if (strEQ(elem, "PACKAGE"))
594 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
597 if (strEQ(elem, "SCALAR"))
611 /* Pattern matching */
616 register unsigned char *s;
619 register I32 *sfirst;
623 if (sv == PL_lastscream) {
629 SvSCREAM_off(PL_lastscream);
630 SvREFCNT_dec(PL_lastscream);
632 PL_lastscream = SvREFCNT_inc(sv);
635 s = (unsigned char*)(SvPV(sv, len));
639 if (pos > PL_maxscream) {
640 if (PL_maxscream < 0) {
641 PL_maxscream = pos + 80;
642 New(301, PL_screamfirst, 256, I32);
643 New(302, PL_screamnext, PL_maxscream, I32);
646 PL_maxscream = pos + pos / 4;
647 Renew(PL_screamnext, PL_maxscream, I32);
651 sfirst = PL_screamfirst;
652 snext = PL_screamnext;
654 if (!sfirst || !snext)
655 DIE(aTHX_ "do_study: out of memory");
657 for (ch = 256; ch; --ch)
664 snext[pos] = sfirst[ch] - pos;
671 /* piggyback on m//g magic */
672 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
681 if (PL_op->op_flags & OPf_STACKED)
687 TARG = sv_newmortal();
692 /* Lvalue operators. */
704 dSP; dMARK; dTARGET; dORIGMARK;
706 do_chop(TARG, *++MARK);
715 SETi(do_chomp(TOPs));
722 register I32 count = 0;
725 count += do_chomp(POPs);
736 if (!sv || !SvANY(sv))
738 switch (SvTYPE(sv)) {
740 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
741 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
745 if (HvARRAY(sv) || SvGMAGICAL(sv)
746 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
750 if (CvROOT(sv) || CvXSUB(sv))
767 if (!PL_op->op_private) {
776 SV_CHECK_THINKFIRST_COW_DROP(sv);
778 switch (SvTYPE(sv)) {
788 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
789 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
790 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
794 /* let user-undef'd sub keep its identity */
795 GV* gv = CvGV((CV*)sv);
802 SvSetMagicSV(sv, &PL_sv_undef);
806 Newz(602, gp, 1, GP);
807 GvGP(sv) = gp_ref(gp);
808 GvSV(sv) = NEWSV(72,0);
809 GvLINE(sv) = CopLINE(PL_curcop);
815 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
818 SvPV_set(sv, Nullch);
831 if (SvTYPE(TOPs) > SVt_PVLV)
832 DIE(aTHX_ PL_no_modify);
833 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
834 && SvIVX(TOPs) != IV_MIN)
837 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
848 if (SvTYPE(TOPs) > SVt_PVLV)
849 DIE(aTHX_ PL_no_modify);
850 sv_setsv(TARG, TOPs);
851 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
852 && SvIVX(TOPs) != IV_MAX)
855 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
860 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
870 if (SvTYPE(TOPs) > SVt_PVLV)
871 DIE(aTHX_ PL_no_modify);
872 sv_setsv(TARG, TOPs);
873 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
874 && SvIVX(TOPs) != IV_MIN)
877 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
886 /* Ordinary operators. */
891 #ifdef PERL_PRESERVE_IVUV
894 tryAMAGICbin(pow,opASSIGN);
895 #ifdef PERL_PRESERVE_IVUV
896 /* For integer to integer power, we do the calculation by hand wherever
897 we're sure it is safe; otherwise we call pow() and try to convert to
898 integer afterwards. */
902 bool baseuok = SvUOK(TOPm1s);
906 baseuv = SvUVX(TOPm1s);
908 IV iv = SvIVX(TOPm1s);
911 baseuok = TRUE; /* effectively it's a UV now */
913 baseuv = -iv; /* abs, baseuok == false records sign */
927 goto float_it; /* Can't do negative powers this way. */
930 /* now we have integer ** positive integer. */
933 /* foo & (foo - 1) is zero only for a power of 2. */
934 if (!(baseuv & (baseuv - 1))) {
935 /* We are raising power-of-2 to a positive integer.
936 The logic here will work for any base (even non-integer
937 bases) but it can be less accurate than
938 pow (base,power) or exp (power * log (base)) when the
939 intermediate values start to spill out of the mantissa.
940 With powers of 2 we know this can't happen.
941 And powers of 2 are the favourite thing for perl
942 programmers to notice ** not doing what they mean. */
944 NV base = baseuok ? baseuv : -(NV)baseuv;
947 for (; power; base *= base, n++) {
948 /* Do I look like I trust gcc with long longs here?
950 UV bit = (UV)1 << (UV)n;
953 /* Only bother to clear the bit if it is set. */
955 /* Avoid squaring base again if we're done. */
956 if (power == 0) break;
964 register unsigned int highbit = 8 * sizeof(UV);
965 register unsigned int lowbit = 0;
966 register unsigned int diff;
967 while ((diff = (highbit - lowbit) >> 1)) {
968 if (baseuv & ~((1 << (lowbit + diff)) - 1))
973 /* we now have baseuv < 2 ** highbit */
974 if (power * highbit <= 8 * sizeof(UV)) {
975 /* result will definitely fit in UV, so use UV math
976 on same algorithm as above */
977 register UV result = 1;
978 register UV base = baseuv;
980 for (; power; base *= base, n++) {
981 register UV bit = (UV)1 << (UV)n;
985 if (power == 0) break;
989 if (baseuok || !(power & 1))
990 /* answer is positive */
992 else if (result <= (UV)IV_MAX)
993 /* answer negative, fits in IV */
995 else if (result == (UV)IV_MIN)
996 /* 2's complement assumption: special case IV_MIN */
999 /* answer negative, doesn't fit */
1000 SETn( -(NV)result );
1011 SETn( Perl_pow( left, right) );
1012 #ifdef PERL_PRESERVE_IVUV
1022 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1023 #ifdef PERL_PRESERVE_IVUV
1026 /* Unless the left argument is integer in range we are going to have to
1027 use NV maths. Hence only attempt to coerce the right argument if
1028 we know the left is integer. */
1029 /* Left operand is defined, so is it IV? */
1030 SvIV_please(TOPm1s);
1031 if (SvIOK(TOPm1s)) {
1032 bool auvok = SvUOK(TOPm1s);
1033 bool buvok = SvUOK(TOPs);
1034 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1035 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1042 alow = SvUVX(TOPm1s);
1044 IV aiv = SvIVX(TOPm1s);
1047 auvok = TRUE; /* effectively it's a UV now */
1049 alow = -aiv; /* abs, auvok == false records sign */
1055 IV biv = SvIVX(TOPs);
1058 buvok = TRUE; /* effectively it's a UV now */
1060 blow = -biv; /* abs, buvok == false records sign */
1064 /* If this does sign extension on unsigned it's time for plan B */
1065 ahigh = alow >> (4 * sizeof (UV));
1067 bhigh = blow >> (4 * sizeof (UV));
1069 if (ahigh && bhigh) {
1070 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1071 which is overflow. Drop to NVs below. */
1072 } else if (!ahigh && !bhigh) {
1073 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1074 so the unsigned multiply cannot overflow. */
1075 UV product = alow * blow;
1076 if (auvok == buvok) {
1077 /* -ve * -ve or +ve * +ve gives a +ve result. */
1081 } else if (product <= (UV)IV_MIN) {
1082 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1083 /* -ve result, which could overflow an IV */
1085 SETi( -(IV)product );
1087 } /* else drop to NVs below. */
1089 /* One operand is large, 1 small */
1092 /* swap the operands */
1094 bhigh = blow; /* bhigh now the temp var for the swap */
1098 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1099 multiplies can't overflow. shift can, add can, -ve can. */
1100 product_middle = ahigh * blow;
1101 if (!(product_middle & topmask)) {
1102 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1104 product_middle <<= (4 * sizeof (UV));
1105 product_low = alow * blow;
1107 /* as for pp_add, UV + something mustn't get smaller.
1108 IIRC ANSI mandates this wrapping *behaviour* for
1109 unsigned whatever the actual representation*/
1110 product_low += product_middle;
1111 if (product_low >= product_middle) {
1112 /* didn't overflow */
1113 if (auvok == buvok) {
1114 /* -ve * -ve or +ve * +ve gives a +ve result. */
1116 SETu( product_low );
1118 } else if (product_low <= (UV)IV_MIN) {
1119 /* 2s complement assumption again */
1120 /* -ve result, which could overflow an IV */
1122 SETi( -(IV)product_low );
1124 } /* else drop to NVs below. */
1126 } /* product_middle too large */
1127 } /* ahigh && bhigh */
1128 } /* SvIOK(TOPm1s) */
1133 SETn( left * right );
1140 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1141 /* Only try to do UV divide first
1142 if ((SLOPPYDIVIDE is true) or
1143 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1145 The assumption is that it is better to use floating point divide
1146 whenever possible, only doing integer divide first if we can't be sure.
1147 If NV_PRESERVES_UV is true then we know at compile time that no UV
1148 can be too large to preserve, so don't need to compile the code to
1149 test the size of UVs. */
1152 # define PERL_TRY_UV_DIVIDE
1153 /* ensure that 20./5. == 4. */
1155 # ifdef PERL_PRESERVE_IVUV
1156 # ifndef NV_PRESERVES_UV
1157 # define PERL_TRY_UV_DIVIDE
1162 #ifdef PERL_TRY_UV_DIVIDE
1165 SvIV_please(TOPm1s);
1166 if (SvIOK(TOPm1s)) {
1167 bool left_non_neg = SvUOK(TOPm1s);
1168 bool right_non_neg = SvUOK(TOPs);
1172 if (right_non_neg) {
1173 right = SvUVX(TOPs);
1176 IV biv = SvIVX(TOPs);
1179 right_non_neg = TRUE; /* effectively it's a UV now */
1185 /* historically undef()/0 gives a "Use of uninitialized value"
1186 warning before dieing, hence this test goes here.
1187 If it were immediately before the second SvIV_please, then
1188 DIE() would be invoked before left was even inspected, so
1189 no inpsection would give no warning. */
1191 DIE(aTHX_ "Illegal division by zero");
1194 left = SvUVX(TOPm1s);
1197 IV aiv = SvIVX(TOPm1s);
1200 left_non_neg = TRUE; /* effectively it's a UV now */
1209 /* For sloppy divide we always attempt integer division. */
1211 /* Otherwise we only attempt it if either or both operands
1212 would not be preserved by an NV. If both fit in NVs
1213 we fall through to the NV divide code below. However,
1214 as left >= right to ensure integer result here, we know that
1215 we can skip the test on the right operand - right big
1216 enough not to be preserved can't get here unless left is
1219 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1222 /* Integer division can't overflow, but it can be imprecise. */
1223 UV result = left / right;
1224 if (result * right == left) {
1225 SP--; /* result is valid */
1226 if (left_non_neg == right_non_neg) {
1227 /* signs identical, result is positive. */
1231 /* 2s complement assumption */
1232 if (result <= (UV)IV_MIN)
1233 SETi( -(IV)result );
1235 /* It's exact but too negative for IV. */
1236 SETn( -(NV)result );
1239 } /* tried integer divide but it was not an integer result */
1240 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1241 } /* left wasn't SvIOK */
1242 } /* right wasn't SvIOK */
1243 #endif /* PERL_TRY_UV_DIVIDE */
1247 DIE(aTHX_ "Illegal division by zero");
1248 PUSHn( left / right );
1255 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1259 bool left_neg = FALSE;
1260 bool right_neg = FALSE;
1261 bool use_double = FALSE;
1262 bool dright_valid = FALSE;
1268 right_neg = !SvUOK(TOPs);
1270 right = SvUVX(POPs);
1272 IV biv = SvIVX(POPs);
1275 right_neg = FALSE; /* effectively it's a UV now */
1283 right_neg = dright < 0;
1286 if (dright < UV_MAX_P1) {
1287 right = U_V(dright);
1288 dright_valid = TRUE; /* In case we need to use double below. */
1294 /* At this point use_double is only true if right is out of range for
1295 a UV. In range NV has been rounded down to nearest UV and
1296 use_double false. */
1298 if (!use_double && SvIOK(TOPs)) {
1300 left_neg = !SvUOK(TOPs);
1304 IV aiv = SvIVX(POPs);
1307 left_neg = FALSE; /* effectively it's a UV now */
1316 left_neg = dleft < 0;
1320 /* This should be exactly the 5.6 behaviour - if left and right are
1321 both in range for UV then use U_V() rather than floor. */
1323 if (dleft < UV_MAX_P1) {
1324 /* right was in range, so is dleft, so use UVs not double.
1328 /* left is out of range for UV, right was in range, so promote
1329 right (back) to double. */
1331 /* The +0.5 is used in 5.6 even though it is not strictly
1332 consistent with the implicit +0 floor in the U_V()
1333 inside the #if 1. */
1334 dleft = Perl_floor(dleft + 0.5);
1337 dright = Perl_floor(dright + 0.5);
1347 DIE(aTHX_ "Illegal modulus zero");
1349 dans = Perl_fmod(dleft, dright);
1350 if ((left_neg != right_neg) && dans)
1351 dans = dright - dans;
1354 sv_setnv(TARG, dans);
1360 DIE(aTHX_ "Illegal modulus zero");
1363 if ((left_neg != right_neg) && ans)
1366 /* XXX may warn: unary minus operator applied to unsigned type */
1367 /* could change -foo to be (~foo)+1 instead */
1368 if (ans <= ~((UV)IV_MAX)+1)
1369 sv_setiv(TARG, ~ans+1);
1371 sv_setnv(TARG, -(NV)ans);
1374 sv_setuv(TARG, ans);
1383 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1385 register IV count = POPi;
1386 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1388 I32 items = SP - MARK;
1391 max = items * count;
1396 /* This code was intended to fix 20010809.028:
1399 for (($x =~ /./g) x 2) {
1400 print chop; # "abcdabcd" expected as output.
1403 * but that change (#11635) broke this code:
1405 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1407 * I can't think of a better fix that doesn't introduce
1408 * an efficiency hit by copying the SVs. The stack isn't
1409 * refcounted, and mortalisation obviously doesn't
1410 * Do The Right Thing when the stack has more than
1411 * one pointer to the same mortal value.
1415 *SP = sv_2mortal(newSVsv(*SP));
1425 repeatcpy((char*)(MARK + items), (char*)MARK,
1426 items * sizeof(SV*), count - 1);
1429 else if (count <= 0)
1432 else { /* Note: mark already snarfed by pp_list */
1437 SvSetSV(TARG, tmpstr);
1438 SvPV_force(TARG, len);
1439 isutf = DO_UTF8(TARG);
1444 SvGROW(TARG, (count * len) + 1);
1445 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1446 SvCUR(TARG) *= count;
1448 *SvEND(TARG) = '\0';
1451 (void)SvPOK_only_UTF8(TARG);
1453 (void)SvPOK_only(TARG);
1455 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1456 /* The parser saw this as a list repeat, and there
1457 are probably several items on the stack. But we're
1458 in scalar context, and there's no pp_list to save us
1459 now. So drop the rest of the items -- robin@kitsite.com
1472 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1473 useleft = USE_LEFT(TOPm1s);
1474 #ifdef PERL_PRESERVE_IVUV
1475 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1476 "bad things" happen if you rely on signed integers wrapping. */
1479 /* Unless the left argument is integer in range we are going to have to
1480 use NV maths. Hence only attempt to coerce the right argument if
1481 we know the left is integer. */
1482 register UV auv = 0;
1488 a_valid = auvok = 1;
1489 /* left operand is undef, treat as zero. */
1491 /* Left operand is defined, so is it IV? */
1492 SvIV_please(TOPm1s);
1493 if (SvIOK(TOPm1s)) {
1494 if ((auvok = SvUOK(TOPm1s)))
1495 auv = SvUVX(TOPm1s);
1497 register IV aiv = SvIVX(TOPm1s);
1500 auvok = 1; /* Now acting as a sign flag. */
1501 } else { /* 2s complement assumption for IV_MIN */
1509 bool result_good = 0;
1512 bool buvok = SvUOK(TOPs);
1517 register IV biv = SvIVX(TOPs);
1524 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1525 else "IV" now, independent of how it came in.
1526 if a, b represents positive, A, B negative, a maps to -A etc
1531 all UV maths. negate result if A negative.
1532 subtract if signs same, add if signs differ. */
1534 if (auvok ^ buvok) {
1543 /* Must get smaller */
1548 if (result <= buv) {
1549 /* result really should be -(auv-buv). as its negation
1550 of true value, need to swap our result flag */
1562 if (result <= (UV)IV_MIN)
1563 SETi( -(IV)result );
1565 /* result valid, but out of range for IV. */
1566 SETn( -(NV)result );
1570 } /* Overflow, drop through to NVs. */
1574 useleft = USE_LEFT(TOPm1s);
1578 /* left operand is undef, treat as zero - value */
1582 SETn( TOPn - value );
1589 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1592 if (PL_op->op_private & HINT_INTEGER) {
1606 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1609 if (PL_op->op_private & HINT_INTEGER) {
1623 dSP; tryAMAGICbinSET(lt,0);
1624 #ifdef PERL_PRESERVE_IVUV
1627 SvIV_please(TOPm1s);
1628 if (SvIOK(TOPm1s)) {
1629 bool auvok = SvUOK(TOPm1s);
1630 bool buvok = SvUOK(TOPs);
1632 if (!auvok && !buvok) { /* ## IV < IV ## */
1633 IV aiv = SvIVX(TOPm1s);
1634 IV biv = SvIVX(TOPs);
1637 SETs(boolSV(aiv < biv));
1640 if (auvok && buvok) { /* ## UV < UV ## */
1641 UV auv = SvUVX(TOPm1s);
1642 UV buv = SvUVX(TOPs);
1645 SETs(boolSV(auv < buv));
1648 if (auvok) { /* ## UV < IV ## */
1655 /* As (a) is a UV, it's >=0, so it cannot be < */
1660 SETs(boolSV(auv < (UV)biv));
1663 { /* ## IV < UV ## */
1667 aiv = SvIVX(TOPm1s);
1669 /* As (b) is a UV, it's >=0, so it must be < */
1676 SETs(boolSV((UV)aiv < buv));
1682 #ifndef NV_PRESERVES_UV
1683 #ifdef PERL_PRESERVE_IVUV
1686 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1688 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1694 SETs(boolSV(TOPn < value));
1701 dSP; tryAMAGICbinSET(gt,0);
1702 #ifdef PERL_PRESERVE_IVUV
1705 SvIV_please(TOPm1s);
1706 if (SvIOK(TOPm1s)) {
1707 bool auvok = SvUOK(TOPm1s);
1708 bool buvok = SvUOK(TOPs);
1710 if (!auvok && !buvok) { /* ## IV > IV ## */
1711 IV aiv = SvIVX(TOPm1s);
1712 IV biv = SvIVX(TOPs);
1715 SETs(boolSV(aiv > biv));
1718 if (auvok && buvok) { /* ## UV > UV ## */
1719 UV auv = SvUVX(TOPm1s);
1720 UV buv = SvUVX(TOPs);
1723 SETs(boolSV(auv > buv));
1726 if (auvok) { /* ## UV > IV ## */
1733 /* As (a) is a UV, it's >=0, so it must be > */
1738 SETs(boolSV(auv > (UV)biv));
1741 { /* ## IV > UV ## */
1745 aiv = SvIVX(TOPm1s);
1747 /* As (b) is a UV, it's >=0, so it cannot be > */
1754 SETs(boolSV((UV)aiv > buv));
1760 #ifndef NV_PRESERVES_UV
1761 #ifdef PERL_PRESERVE_IVUV
1764 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1766 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1772 SETs(boolSV(TOPn > value));
1779 dSP; tryAMAGICbinSET(le,0);
1780 #ifdef PERL_PRESERVE_IVUV
1783 SvIV_please(TOPm1s);
1784 if (SvIOK(TOPm1s)) {
1785 bool auvok = SvUOK(TOPm1s);
1786 bool buvok = SvUOK(TOPs);
1788 if (!auvok && !buvok) { /* ## IV <= IV ## */
1789 IV aiv = SvIVX(TOPm1s);
1790 IV biv = SvIVX(TOPs);
1793 SETs(boolSV(aiv <= biv));
1796 if (auvok && buvok) { /* ## UV <= UV ## */
1797 UV auv = SvUVX(TOPm1s);
1798 UV buv = SvUVX(TOPs);
1801 SETs(boolSV(auv <= buv));
1804 if (auvok) { /* ## UV <= IV ## */
1811 /* As (a) is a UV, it's >=0, so a cannot be <= */
1816 SETs(boolSV(auv <= (UV)biv));
1819 { /* ## IV <= UV ## */
1823 aiv = SvIVX(TOPm1s);
1825 /* As (b) is a UV, it's >=0, so a must be <= */
1832 SETs(boolSV((UV)aiv <= buv));
1838 #ifndef NV_PRESERVES_UV
1839 #ifdef PERL_PRESERVE_IVUV
1842 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1844 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1850 SETs(boolSV(TOPn <= value));
1857 dSP; tryAMAGICbinSET(ge,0);
1858 #ifdef PERL_PRESERVE_IVUV
1861 SvIV_please(TOPm1s);
1862 if (SvIOK(TOPm1s)) {
1863 bool auvok = SvUOK(TOPm1s);
1864 bool buvok = SvUOK(TOPs);
1866 if (!auvok && !buvok) { /* ## IV >= IV ## */
1867 IV aiv = SvIVX(TOPm1s);
1868 IV biv = SvIVX(TOPs);
1871 SETs(boolSV(aiv >= biv));
1874 if (auvok && buvok) { /* ## UV >= UV ## */
1875 UV auv = SvUVX(TOPm1s);
1876 UV buv = SvUVX(TOPs);
1879 SETs(boolSV(auv >= buv));
1882 if (auvok) { /* ## UV >= IV ## */
1889 /* As (a) is a UV, it's >=0, so it must be >= */
1894 SETs(boolSV(auv >= (UV)biv));
1897 { /* ## IV >= UV ## */
1901 aiv = SvIVX(TOPm1s);
1903 /* As (b) is a UV, it's >=0, so a cannot be >= */
1910 SETs(boolSV((UV)aiv >= buv));
1916 #ifndef NV_PRESERVES_UV
1917 #ifdef PERL_PRESERVE_IVUV
1920 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1922 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1928 SETs(boolSV(TOPn >= value));
1935 dSP; tryAMAGICbinSET(ne,0);
1936 #ifndef NV_PRESERVES_UV
1937 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1939 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1943 #ifdef PERL_PRESERVE_IVUV
1946 SvIV_please(TOPm1s);
1947 if (SvIOK(TOPm1s)) {
1948 bool auvok = SvUOK(TOPm1s);
1949 bool buvok = SvUOK(TOPs);
1951 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1952 /* Casting IV to UV before comparison isn't going to matter
1953 on 2s complement. On 1s complement or sign&magnitude
1954 (if we have any of them) it could make negative zero
1955 differ from normal zero. As I understand it. (Need to
1956 check - is negative zero implementation defined behaviour
1958 UV buv = SvUVX(POPs);
1959 UV auv = SvUVX(TOPs);
1961 SETs(boolSV(auv != buv));
1964 { /* ## Mixed IV,UV ## */
1968 /* != is commutative so swap if needed (save code) */
1970 /* swap. top of stack (b) is the iv */
1974 /* As (a) is a UV, it's >0, so it cannot be == */
1983 /* As (b) is a UV, it's >0, so it cannot be == */
1987 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1989 SETs(boolSV((UV)iv != uv));
1997 SETs(boolSV(TOPn != value));
2004 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2005 #ifndef NV_PRESERVES_UV
2006 if (SvROK(TOPs) && SvROK(TOPm1s)) {
2007 UV right = PTR2UV(SvRV(POPs));
2008 UV left = PTR2UV(SvRV(TOPs));
2009 SETi((left > right) - (left < right));
2013 #ifdef PERL_PRESERVE_IVUV
2014 /* Fortunately it seems NaN isn't IOK */
2017 SvIV_please(TOPm1s);
2018 if (SvIOK(TOPm1s)) {
2019 bool leftuvok = SvUOK(TOPm1s);
2020 bool rightuvok = SvUOK(TOPs);
2022 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2023 IV leftiv = SvIVX(TOPm1s);
2024 IV rightiv = SvIVX(TOPs);
2026 if (leftiv > rightiv)
2028 else if (leftiv < rightiv)
2032 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2033 UV leftuv = SvUVX(TOPm1s);
2034 UV rightuv = SvUVX(TOPs);
2036 if (leftuv > rightuv)
2038 else if (leftuv < rightuv)
2042 } else if (leftuvok) { /* ## UV <=> IV ## */
2046 rightiv = SvIVX(TOPs);
2048 /* As (a) is a UV, it's >=0, so it cannot be < */
2051 leftuv = SvUVX(TOPm1s);
2052 if (leftuv > (UV)rightiv) {
2054 } else if (leftuv < (UV)rightiv) {
2060 } else { /* ## IV <=> UV ## */
2064 leftiv = SvIVX(TOPm1s);
2066 /* As (b) is a UV, it's >=0, so it must be < */
2069 rightuv = SvUVX(TOPs);
2070 if ((UV)leftiv > rightuv) {
2072 } else if ((UV)leftiv < rightuv) {
2090 if (Perl_isnan(left) || Perl_isnan(right)) {
2094 value = (left > right) - (left < right);
2098 else if (left < right)
2100 else if (left > right)
2114 dSP; tryAMAGICbinSET(slt,0);
2117 int cmp = (IN_LOCALE_RUNTIME
2118 ? sv_cmp_locale(left, right)
2119 : sv_cmp(left, right));
2120 SETs(boolSV(cmp < 0));
2127 dSP; tryAMAGICbinSET(sgt,0);
2130 int cmp = (IN_LOCALE_RUNTIME
2131 ? sv_cmp_locale(left, right)
2132 : sv_cmp(left, right));
2133 SETs(boolSV(cmp > 0));
2140 dSP; tryAMAGICbinSET(sle,0);
2143 int cmp = (IN_LOCALE_RUNTIME
2144 ? sv_cmp_locale(left, right)
2145 : sv_cmp(left, right));
2146 SETs(boolSV(cmp <= 0));
2153 dSP; tryAMAGICbinSET(sge,0);
2156 int cmp = (IN_LOCALE_RUNTIME
2157 ? sv_cmp_locale(left, right)
2158 : sv_cmp(left, right));
2159 SETs(boolSV(cmp >= 0));
2166 dSP; tryAMAGICbinSET(seq,0);
2169 SETs(boolSV(sv_eq(left, right)));
2176 dSP; tryAMAGICbinSET(sne,0);
2179 SETs(boolSV(!sv_eq(left, right)));
2186 dSP; dTARGET; tryAMAGICbin(scmp,0);
2189 int cmp = (IN_LOCALE_RUNTIME
2190 ? sv_cmp_locale(left, right)
2191 : sv_cmp(left, right));
2199 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2202 if (SvNIOKp(left) || SvNIOKp(right)) {
2203 if (PL_op->op_private & HINT_INTEGER) {
2204 IV i = SvIV(left) & SvIV(right);
2208 UV u = SvUV(left) & SvUV(right);
2213 do_vop(PL_op->op_type, TARG, left, right);
2222 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2225 if (SvNIOKp(left) || SvNIOKp(right)) {
2226 if (PL_op->op_private & HINT_INTEGER) {
2227 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2231 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2236 do_vop(PL_op->op_type, TARG, left, right);
2245 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2248 if (SvNIOKp(left) || SvNIOKp(right)) {
2249 if (PL_op->op_private & HINT_INTEGER) {
2250 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2254 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2259 do_vop(PL_op->op_type, TARG, left, right);
2268 dSP; dTARGET; tryAMAGICun(neg);
2271 int flags = SvFLAGS(sv);
2274 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2275 /* It's publicly an integer, or privately an integer-not-float */
2278 if (SvIVX(sv) == IV_MIN) {
2279 /* 2s complement assumption. */
2280 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2283 else if (SvUVX(sv) <= IV_MAX) {
2288 else if (SvIVX(sv) != IV_MIN) {
2292 #ifdef PERL_PRESERVE_IVUV
2301 else if (SvPOKp(sv)) {
2303 char *s = SvPV(sv, len);
2304 if (isIDFIRST(*s)) {
2305 sv_setpvn(TARG, "-", 1);
2308 else if (*s == '+' || *s == '-') {
2310 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2312 else if (DO_UTF8(sv)) {
2315 goto oops_its_an_int;
2317 sv_setnv(TARG, -SvNV(sv));
2319 sv_setpvn(TARG, "-", 1);
2326 goto oops_its_an_int;
2327 sv_setnv(TARG, -SvNV(sv));
2339 dSP; tryAMAGICunSET(not);
2340 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2346 dSP; dTARGET; tryAMAGICun(compl);
2350 if (PL_op->op_private & HINT_INTEGER) {
2365 tmps = (U8*)SvPV_force(TARG, len);
2368 /* Calculate exact length, let's not estimate. */
2377 while (tmps < send) {
2378 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2379 tmps += UTF8SKIP(tmps);
2380 targlen += UNISKIP(~c);
2386 /* Now rewind strings and write them. */
2390 Newz(0, result, targlen + 1, U8);
2391 while (tmps < send) {
2392 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2393 tmps += UTF8SKIP(tmps);
2394 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2398 sv_setpvn(TARG, (char*)result, targlen);
2402 Newz(0, result, nchar + 1, U8);
2403 while (tmps < send) {
2404 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2405 tmps += UTF8SKIP(tmps);
2410 sv_setpvn(TARG, (char*)result, nchar);
2418 register long *tmpl;
2419 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2422 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2427 for ( ; anum > 0; anum--, tmps++)
2436 /* integer versions of some of the above */
2440 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2443 SETi( left * right );
2450 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2454 DIE(aTHX_ "Illegal division by zero");
2455 value = POPi / value;
2464 /* This is the vanilla old i_modulo. */
2465 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2469 DIE(aTHX_ "Illegal modulus zero");
2470 SETi( left % right );
2475 #if defined(__GLIBC__) && IVSIZE == 8
2479 /* This is the i_modulo with the workaround for the _moddi3 bug
2480 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2481 * See below for pp_i_modulo. */
2482 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2486 DIE(aTHX_ "Illegal modulus zero");
2487 SETi( left % PERL_ABS(right) );
2495 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2499 DIE(aTHX_ "Illegal modulus zero");
2500 /* The assumption is to use hereafter the old vanilla version... */
2502 PL_ppaddr[OP_I_MODULO] =
2503 &Perl_pp_i_modulo_0;
2504 /* .. but if we have glibc, we might have a buggy _moddi3
2505 * (at least glicb 2.2.5 is known to have this bug), in other
2506 * words our integer modulus with negative quad as the second
2507 * argument might be broken. Test for this and re-patch the
2508 * opcode dispatch table if that is the case, remembering to
2509 * also apply the workaround so that this first round works
2510 * right, too. See [perl #9402] for more information. */
2511 #if defined(__GLIBC__) && IVSIZE == 8
2515 /* Cannot do this check with inlined IV constants since
2516 * that seems to work correctly even with the buggy glibc. */
2518 /* Yikes, we have the bug.
2519 * Patch in the workaround version. */
2521 PL_ppaddr[OP_I_MODULO] =
2522 &Perl_pp_i_modulo_1;
2523 /* Make certain we work right this time, too. */
2524 right = PERL_ABS(right);
2528 SETi( left % right );
2535 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2538 SETi( left + right );
2545 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2548 SETi( left - right );
2555 dSP; tryAMAGICbinSET(lt,0);
2558 SETs(boolSV(left < right));
2565 dSP; tryAMAGICbinSET(gt,0);
2568 SETs(boolSV(left > right));
2575 dSP; tryAMAGICbinSET(le,0);
2578 SETs(boolSV(left <= right));
2585 dSP; tryAMAGICbinSET(ge,0);
2588 SETs(boolSV(left >= right));
2595 dSP; tryAMAGICbinSET(eq,0);
2598 SETs(boolSV(left == right));
2605 dSP; tryAMAGICbinSET(ne,0);
2608 SETs(boolSV(left != right));
2615 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2622 else if (left < right)
2633 dSP; dTARGET; tryAMAGICun(neg);
2638 /* High falutin' math. */
2642 dSP; dTARGET; tryAMAGICbin(atan2,0);
2645 SETn(Perl_atan2(left, right));
2652 dSP; dTARGET; tryAMAGICun(sin);
2656 value = Perl_sin(value);
2664 dSP; dTARGET; tryAMAGICun(cos);
2668 value = Perl_cos(value);
2674 /* Support Configure command-line overrides for rand() functions.
2675 After 5.005, perhaps we should replace this by Configure support
2676 for drand48(), random(), or rand(). For 5.005, though, maintain
2677 compatibility by calling rand() but allow the user to override it.
2678 See INSTALL for details. --Andy Dougherty 15 July 1998
2680 /* Now it's after 5.005, and Configure supports drand48() and random(),
2681 in addition to rand(). So the overrides should not be needed any more.
2682 --Jarkko Hietaniemi 27 September 1998
2685 #ifndef HAS_DRAND48_PROTO
2686 extern double drand48 (void);
2699 if (!PL_srand_called) {
2700 (void)seedDrand01((Rand_seed_t)seed());
2701 PL_srand_called = TRUE;
2716 (void)seedDrand01((Rand_seed_t)anum);
2717 PL_srand_called = TRUE;
2726 * This is really just a quick hack which grabs various garbage
2727 * values. It really should be a real hash algorithm which
2728 * spreads the effect of every input bit onto every output bit,
2729 * if someone who knows about such things would bother to write it.
2730 * Might be a good idea to add that function to CORE as well.
2731 * No numbers below come from careful analysis or anything here,
2732 * except they are primes and SEED_C1 > 1E6 to get a full-width
2733 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2734 * probably be bigger too.
2737 # define SEED_C1 1000003
2738 #define SEED_C4 73819
2740 # define SEED_C1 25747
2741 #define SEED_C4 20639
2745 #define SEED_C5 26107
2747 #ifndef PERL_NO_DEV_RANDOM
2752 # include <starlet.h>
2753 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2754 * in 100-ns units, typically incremented ever 10 ms. */
2755 unsigned int when[2];
2757 # ifdef HAS_GETTIMEOFDAY
2758 struct timeval when;
2764 /* This test is an escape hatch, this symbol isn't set by Configure. */
2765 #ifndef PERL_NO_DEV_RANDOM
2766 #ifndef PERL_RANDOM_DEVICE
2767 /* /dev/random isn't used by default because reads from it will block
2768 * if there isn't enough entropy available. You can compile with
2769 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2770 * is enough real entropy to fill the seed. */
2771 # define PERL_RANDOM_DEVICE "/dev/urandom"
2773 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2775 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2784 _ckvmssts(sys$gettim(when));
2785 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2787 # ifdef HAS_GETTIMEOFDAY
2788 PerlProc_gettimeofday(&when,NULL);
2789 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2792 u = (U32)SEED_C1 * when;
2795 u += SEED_C3 * (U32)PerlProc_getpid();
2796 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2797 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2798 u += SEED_C5 * (U32)PTR2UV(&when);
2805 dSP; dTARGET; tryAMAGICun(exp);
2809 value = Perl_exp(value);
2817 dSP; dTARGET; tryAMAGICun(log);
2822 SET_NUMERIC_STANDARD();
2823 DIE(aTHX_ "Can't take log of %"NVgf, value);
2825 value = Perl_log(value);
2833 dSP; dTARGET; tryAMAGICun(sqrt);
2838 SET_NUMERIC_STANDARD();
2839 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2841 value = Perl_sqrt(value);
2848 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2849 * These need to be revisited when a newer toolchain becomes available.
2851 #if defined(__sparc64__) && defined(__GNUC__)
2852 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2853 # undef SPARC64_MODF_WORKAROUND
2854 # define SPARC64_MODF_WORKAROUND 1
2858 #if defined(SPARC64_MODF_WORKAROUND)
2860 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2863 ret = Perl_modf(theVal, &res);
2871 dSP; dTARGET; tryAMAGICun(int);
2874 IV iv = TOPi; /* attempt to convert to IV if possible. */
2875 /* XXX it's arguable that compiler casting to IV might be subtly
2876 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2877 else preferring IV has introduced a subtle behaviour change bug. OTOH
2878 relying on floating point to be accurate is a bug. */
2889 if (value < (NV)UV_MAX + 0.5) {
2892 #if defined(SPARC64_MODF_WORKAROUND)
2893 (void)sparc64_workaround_modf(value, &value);
2895 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2896 # ifdef HAS_MODFL_POW32_BUG
2897 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2899 NV offset = Perl_modf(value, &value);
2900 (void)Perl_modf(offset, &offset);
2904 (void)Perl_modf(value, &value);
2907 double tmp = (double)value;
2908 (void)Perl_modf(tmp, &tmp);
2916 if (value > (NV)IV_MIN - 0.5) {
2919 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2920 # ifdef HAS_MODFL_POW32_BUG
2921 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2923 NV offset = Perl_modf(-value, &value);
2924 (void)Perl_modf(offset, &offset);
2928 (void)Perl_modf(-value, &value);
2932 double tmp = (double)value;
2933 (void)Perl_modf(-tmp, &tmp);
2946 dSP; dTARGET; tryAMAGICun(abs);
2948 /* This will cache the NV value if string isn't actually integer */
2952 /* IVX is precise */
2954 SETu(TOPu); /* force it to be numeric only */
2962 /* 2s complement assumption. Also, not really needed as
2963 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2983 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2989 tmps = (SvPVx(sv, len));
2991 /* If Unicode, try to downgrade
2992 * If not possible, croak. */
2993 SV* tsv = sv_2mortal(newSVsv(sv));
2996 sv_utf8_downgrade(tsv, FALSE);
2999 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3000 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3013 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3019 tmps = (SvPVx(sv, len));
3021 /* If Unicode, try to downgrade
3022 * If not possible, croak. */
3023 SV* tsv = sv_2mortal(newSVsv(sv));
3026 sv_utf8_downgrade(tsv, FALSE);
3029 while (*tmps && len && isSPACE(*tmps))
3034 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3035 else if (*tmps == 'b')
3036 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3038 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3040 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3057 SETi(sv_len_utf8(sv));
3073 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3075 I32 arybase = PL_curcop->cop_arybase;
3079 int num_args = PL_op->op_private & 7;
3080 bool repl_need_utf8_upgrade = FALSE;
3081 bool repl_is_utf8 = FALSE;
3083 SvTAINTED_off(TARG); /* decontaminate */
3084 SvUTF8_off(TARG); /* decontaminate */
3088 repl = SvPV(repl_sv, repl_len);
3089 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3099 sv_utf8_upgrade(sv);
3101 else if (DO_UTF8(sv))
3102 repl_need_utf8_upgrade = TRUE;
3104 tmps = SvPV(sv, curlen);
3106 utf8_curlen = sv_len_utf8(sv);
3107 if (utf8_curlen == curlen)
3110 curlen = utf8_curlen;
3115 if (pos >= arybase) {
3133 else if (len >= 0) {
3135 if (rem > (I32)curlen)
3150 Perl_croak(aTHX_ "substr outside of string");
3151 if (ckWARN(WARN_SUBSTR))
3152 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3159 sv_pos_u2b(sv, &pos, &rem);
3161 sv_setpvn(TARG, tmps, rem);
3162 #ifdef USE_LOCALE_COLLATE
3163 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3168 SV* repl_sv_copy = NULL;
3170 if (repl_need_utf8_upgrade) {
3171 repl_sv_copy = newSVsv(repl_sv);
3172 sv_utf8_upgrade(repl_sv_copy);
3173 repl = SvPV(repl_sv_copy, repl_len);
3174 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3176 sv_insert(sv, pos, rem, repl, repl_len);
3180 SvREFCNT_dec(repl_sv_copy);
3182 else if (lvalue) { /* it's an lvalue! */
3183 if (!SvGMAGICAL(sv)) {
3187 if (ckWARN(WARN_SUBSTR))
3188 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3189 "Attempt to use reference as lvalue in substr");
3191 if (SvOK(sv)) /* is it defined ? */
3192 (void)SvPOK_only_UTF8(sv);
3194 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3197 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3198 TARG = sv_newmortal();
3199 if (SvTYPE(TARG) < SVt_PVLV) {
3200 sv_upgrade(TARG, SVt_PVLV);
3201 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3205 if (LvTARG(TARG) != sv) {
3207 SvREFCNT_dec(LvTARG(TARG));
3208 LvTARG(TARG) = SvREFCNT_inc(sv);
3210 LvTARGOFF(TARG) = upos;
3211 LvTARGLEN(TARG) = urem;
3215 PUSHs(TARG); /* avoid SvSETMAGIC here */
3222 register IV size = POPi;
3223 register IV offset = POPi;
3224 register SV *src = POPs;
3225 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3227 SvTAINTED_off(TARG); /* decontaminate */
3228 if (lvalue) { /* it's an lvalue! */
3229 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3230 TARG = sv_newmortal();
3231 if (SvTYPE(TARG) < SVt_PVLV) {
3232 sv_upgrade(TARG, SVt_PVLV);
3233 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3236 if (LvTARG(TARG) != src) {
3238 SvREFCNT_dec(LvTARG(TARG));
3239 LvTARG(TARG) = SvREFCNT_inc(src);
3241 LvTARGOFF(TARG) = offset;
3242 LvTARGLEN(TARG) = size;
3245 sv_setuv(TARG, do_vecget(src, offset, size));
3260 I32 arybase = PL_curcop->cop_arybase;
3265 offset = POPi - arybase;
3268 tmps = SvPV(big, biglen);
3269 if (offset > 0 && DO_UTF8(big))
3270 sv_pos_u2b(big, &offset, 0);
3273 else if (offset > (I32)biglen)
3275 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3276 (unsigned char*)tmps + biglen, little, 0)))
3279 retval = tmps2 - tmps;
3280 if (retval > 0 && DO_UTF8(big))
3281 sv_pos_b2u(big, &retval);
3282 PUSHi(retval + arybase);
3297 I32 arybase = PL_curcop->cop_arybase;
3303 tmps2 = SvPV(little, llen);
3304 tmps = SvPV(big, blen);
3308 if (offset > 0 && DO_UTF8(big))
3309 sv_pos_u2b(big, &offset, 0);
3310 offset = offset - arybase + llen;
3314 else if (offset > (I32)blen)
3316 if (!(tmps2 = rninstr(tmps, tmps + offset,
3317 tmps2, tmps2 + llen)))
3320 retval = tmps2 - tmps;
3321 if (retval > 0 && DO_UTF8(big))
3322 sv_pos_b2u(big, &retval);
3323 PUSHi(retval + arybase);
3329 dSP; dMARK; dORIGMARK; dTARGET;
3330 do_sprintf(TARG, SP-MARK, MARK+1);
3331 TAINT_IF(SvTAINTED(TARG));
3332 if (DO_UTF8(*(MARK+1)))
3344 U8 *s = (U8*)SvPVx(argsv, len);
3347 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3348 tmpsv = sv_2mortal(newSVsv(argsv));
3349 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3353 XPUSHu(DO_UTF8(argsv) ?
3354 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3366 (void)SvUPGRADE(TARG,SVt_PV);
3368 if (value > 255 && !IN_BYTES) {
3369 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3370 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3371 SvCUR_set(TARG, tmps - SvPVX(TARG));
3373 (void)SvPOK_only(TARG);
3382 *tmps++ = (char)value;
3384 (void)SvPOK_only(TARG);
3385 if (PL_encoding && !IN_BYTES) {
3386 sv_recode_to_utf8(TARG, PL_encoding);
3388 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3389 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3393 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3394 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3410 char *tmps = SvPV(left, len);
3412 if (DO_UTF8(left)) {
3413 /* If Unicode, try to downgrade.
3414 * If not possible, croak.
3415 * Yes, we made this up. */
3416 SV* tsv = sv_2mortal(newSVsv(left));
3419 sv_utf8_downgrade(tsv, FALSE);
3422 # ifdef USE_ITHREADS
3424 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3425 /* This should be threadsafe because in ithreads there is only
3426 * one thread per interpreter. If this would not be true,
3427 * we would need a mutex to protect this malloc. */
3428 PL_reentrant_buffer->_crypt_struct_buffer =
3429 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3430 #if defined(__GLIBC__) || defined(__EMX__)
3431 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3432 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3433 /* work around glibc-2.2.5 bug */
3434 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3438 # endif /* HAS_CRYPT_R */
3439 # endif /* USE_ITHREADS */
3441 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3443 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3449 "The crypt() function is unimplemented due to excessive paranoia.");
3462 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3463 UTF8_IS_START(*s)) {
3464 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3468 utf8_to_uvchr(s, &ulen);
3469 toTITLE_utf8(s, tmpbuf, &tculen);
3470 utf8_to_uvchr(tmpbuf, 0);
3472 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3474 /* slen is the byte length of the whole SV.
3475 * ulen is the byte length of the original Unicode character
3476 * stored as UTF-8 at s.
3477 * tculen is the byte length of the freshly titlecased
3478 * Unicode character stored as UTF-8 at tmpbuf.
3479 * We first set the result to be the titlecased character,
3480 * and then append the rest of the SV data. */
3481 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3483 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3488 s = (U8*)SvPV_force_nomg(sv, slen);
3489 Copy(tmpbuf, s, tculen, U8);
3493 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3495 SvUTF8_off(TARG); /* decontaminate */
3496 sv_setsv_nomg(TARG, sv);
3500 s = (U8*)SvPV_force_nomg(sv, slen);
3502 if (IN_LOCALE_RUNTIME) {
3505 *s = toUPPER_LC(*s);
3524 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3525 UTF8_IS_START(*s)) {
3527 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3531 toLOWER_utf8(s, tmpbuf, &ulen);
3532 uv = utf8_to_uvchr(tmpbuf, 0);
3533 tend = uvchr_to_utf8(tmpbuf, uv);
3535 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3537 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3539 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3544 s = (U8*)SvPV_force_nomg(sv, slen);
3545 Copy(tmpbuf, s, ulen, U8);
3549 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3551 SvUTF8_off(TARG); /* decontaminate */
3552 sv_setsv_nomg(TARG, sv);
3556 s = (U8*)SvPV_force_nomg(sv, slen);
3558 if (IN_LOCALE_RUNTIME) {
3561 *s = toLOWER_LC(*s);
3584 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3586 s = (U8*)SvPV_nomg(sv,len);
3588 SvUTF8_off(TARG); /* decontaminate */
3589 sv_setpvn(TARG, "", 0);
3593 STRLEN nchar = utf8_length(s, s + len);
3595 (void)SvUPGRADE(TARG, SVt_PV);
3596 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3597 (void)SvPOK_only(TARG);
3598 d = (U8*)SvPVX(TARG);
3601 toUPPER_utf8(s, tmpbuf, &ulen);
3602 Copy(tmpbuf, d, ulen, U8);
3608 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3613 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3615 SvUTF8_off(TARG); /* decontaminate */
3616 sv_setsv_nomg(TARG, sv);
3620 s = (U8*)SvPV_force_nomg(sv, len);
3622 register U8 *send = s + len;
3624 if (IN_LOCALE_RUNTIME) {
3627 for (; s < send; s++)
3628 *s = toUPPER_LC(*s);
3631 for (; s < send; s++)
3653 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3655 s = (U8*)SvPV_nomg(sv,len);
3657 SvUTF8_off(TARG); /* decontaminate */
3658 sv_setpvn(TARG, "", 0);
3662 STRLEN nchar = utf8_length(s, s + len);
3664 (void)SvUPGRADE(TARG, SVt_PV);
3665 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3666 (void)SvPOK_only(TARG);
3667 d = (U8*)SvPVX(TARG);
3670 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3671 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3672 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3674 * Now if the sigma is NOT followed by
3675 * /$ignorable_sequence$cased_letter/;
3676 * and it IS preceded by
3677 * /$cased_letter$ignorable_sequence/;
3678 * where $ignorable_sequence is
3679 * [\x{2010}\x{AD}\p{Mn}]*
3680 * and $cased_letter is
3681 * [\p{Ll}\p{Lo}\p{Lt}]
3682 * then it should be mapped to 0x03C2,
3683 * (GREEK SMALL LETTER FINAL SIGMA),
3684 * instead of staying 0x03A3.
3685 * See lib/unicore/SpecCase.txt.
3688 Copy(tmpbuf, d, ulen, U8);
3694 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3699 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3701 SvUTF8_off(TARG); /* decontaminate */
3702 sv_setsv_nomg(TARG, sv);
3707 s = (U8*)SvPV_force_nomg(sv, len);
3709 register U8 *send = s + len;
3711 if (IN_LOCALE_RUNTIME) {
3714 for (; s < send; s++)
3715 *s = toLOWER_LC(*s);
3718 for (; s < send; s++)
3732 register char *s = SvPV(sv,len);
3735 SvUTF8_off(TARG); /* decontaminate */
3737 (void)SvUPGRADE(TARG, SVt_PV);
3738 SvGROW(TARG, (len * 2) + 1);
3742 if (UTF8_IS_CONTINUED(*s)) {
3743 STRLEN ulen = UTF8SKIP(s);
3767 SvCUR_set(TARG, d - SvPVX(TARG));
3768 (void)SvPOK_only_UTF8(TARG);
3771 sv_setpvn(TARG, s, len);
3773 if (SvSMAGICAL(TARG))
3782 dSP; dMARK; dORIGMARK;
3784 register AV* av = (AV*)POPs;
3785 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3786 I32 arybase = PL_curcop->cop_arybase;
3789 if (SvTYPE(av) == SVt_PVAV) {
3790 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3792 for (svp = MARK + 1; svp <= SP; svp++) {
3797 if (max > AvMAX(av))
3800 while (++MARK <= SP) {
3801 elem = SvIVx(*MARK);
3805 svp = av_fetch(av, elem, lval);
3807 if (!svp || *svp == &PL_sv_undef)
3808 DIE(aTHX_ PL_no_aelem, elem);
3809 if (PL_op->op_private & OPpLVAL_INTRO)
3810 save_aelem(av, elem, svp);
3812 *MARK = svp ? *svp : &PL_sv_undef;
3815 if (GIMME != G_ARRAY) {
3823 /* Associative arrays. */
3828 HV *hash = (HV*)POPs;
3830 I32 gimme = GIMME_V;
3833 /* might clobber stack_sp */
3834 entry = hv_iternext(hash);
3839 SV* sv = hv_iterkeysv(entry);
3840 PUSHs(sv); /* won't clobber stack_sp */
3841 if (gimme == G_ARRAY) {
3844 /* might clobber stack_sp */
3845 val = hv_iterval(hash, entry);
3850 else if (gimme == G_SCALAR)
3869 I32 gimme = GIMME_V;
3870 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3874 if (PL_op->op_private & OPpSLICE) {
3878 hvtype = SvTYPE(hv);
3879 if (hvtype == SVt_PVHV) { /* hash element */
3880 while (++MARK <= SP) {
3881 sv = hv_delete_ent(hv, *MARK, discard, 0);
3882 *MARK = sv ? sv : &PL_sv_undef;
3885 else if (hvtype == SVt_PVAV) { /* array element */
3886 if (PL_op->op_flags & OPf_SPECIAL) {
3887 while (++MARK <= SP) {
3888 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3889 *MARK = sv ? sv : &PL_sv_undef;
3894 DIE(aTHX_ "Not a HASH reference");
3897 else if (gimme == G_SCALAR) {
3906 if (SvTYPE(hv) == SVt_PVHV)
3907 sv = hv_delete_ent(hv, keysv, discard, 0);
3908 else if (SvTYPE(hv) == SVt_PVAV) {
3909 if (PL_op->op_flags & OPf_SPECIAL)
3910 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3912 DIE(aTHX_ "panic: avhv_delete no longer supported");
3915 DIE(aTHX_ "Not a HASH reference");
3930 if (PL_op->op_private & OPpEXISTS_SUB) {
3934 cv = sv_2cv(sv, &hv, &gv, FALSE);
3937 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3943 if (SvTYPE(hv) == SVt_PVHV) {
3944 if (hv_exists_ent(hv, tmpsv, 0))
3947 else if (SvTYPE(hv) == SVt_PVAV) {
3948 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3949 if (av_exists((AV*)hv, SvIV(tmpsv)))
3954 DIE(aTHX_ "Not a HASH reference");
3961 dSP; dMARK; dORIGMARK;
3962 register HV *hv = (HV*)POPs;
3963 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3964 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3965 bool other_magic = FALSE;
3971 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3972 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3973 /* Try to preserve the existenceness of a tied hash
3974 * element by using EXISTS and DELETE if possible.
3975 * Fallback to FETCH and STORE otherwise */
3976 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3977 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3978 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3981 while (++MARK <= SP) {
3985 bool preeminent = FALSE;
3988 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3989 hv_exists_ent(hv, keysv, 0);
3992 he = hv_fetch_ent(hv, keysv, lval, 0);
3993 svp = he ? &HeVAL(he) : 0;
3996 if (!svp || *svp == &PL_sv_undef) {
3998 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
4002 save_helem(hv, keysv, svp);
4005 char *key = SvPV(keysv, keylen);
4006 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4010 *MARK = svp ? *svp : &PL_sv_undef;
4012 if (GIMME != G_ARRAY) {
4020 /* List operators. */
4025 if (GIMME != G_ARRAY) {
4027 *MARK = *SP; /* unwanted list, return last item */
4029 *MARK = &PL_sv_undef;
4038 SV **lastrelem = PL_stack_sp;
4039 SV **lastlelem = PL_stack_base + POPMARK;
4040 SV **firstlelem = PL_stack_base + POPMARK + 1;
4041 register SV **firstrelem = lastlelem + 1;
4042 I32 arybase = PL_curcop->cop_arybase;
4043 I32 lval = PL_op->op_flags & OPf_MOD;
4044 I32 is_something_there = lval;
4046 register I32 max = lastrelem - lastlelem;
4047 register SV **lelem;
4050 if (GIMME != G_ARRAY) {
4051 ix = SvIVx(*lastlelem);
4056 if (ix < 0 || ix >= max)
4057 *firstlelem = &PL_sv_undef;
4059 *firstlelem = firstrelem[ix];
4065 SP = firstlelem - 1;
4069 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4075 if (ix < 0 || ix >= max)
4076 *lelem = &PL_sv_undef;
4078 is_something_there = TRUE;
4079 if (!(*lelem = firstrelem[ix]))
4080 *lelem = &PL_sv_undef;
4083 if (is_something_there)
4086 SP = firstlelem - 1;
4092 dSP; dMARK; dORIGMARK;
4093 I32 items = SP - MARK;
4094 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4095 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4102 dSP; dMARK; dORIGMARK;
4103 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4107 SV *val = NEWSV(46, 0);
4109 sv_setsv(val, *++MARK);
4110 else if (ckWARN(WARN_MISC))
4111 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4112 (void)hv_store_ent(hv,key,val,0);
4121 dSP; dMARK; dORIGMARK;
4122 register AV *ary = (AV*)*++MARK;
4126 register I32 offset;
4127 register I32 length;
4134 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4135 *MARK-- = SvTIED_obj((SV*)ary, mg);
4139 call_method("SPLICE",GIMME_V);
4148 offset = i = SvIVx(*MARK);
4150 offset += AvFILLp(ary) + 1;
4152 offset -= PL_curcop->cop_arybase;
4154 DIE(aTHX_ PL_no_aelem, i);
4156 length = SvIVx(*MARK++);
4158 length += AvFILLp(ary) - offset + 1;
4164 length = AvMAX(ary) + 1; /* close enough to infinity */
4168 length = AvMAX(ary) + 1;
4170 if (offset > AvFILLp(ary) + 1) {
4171 if (ckWARN(WARN_MISC))
4172 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4173 offset = AvFILLp(ary) + 1;
4175 after = AvFILLp(ary) + 1 - (offset + length);
4176 if (after < 0) { /* not that much array */
4177 length += after; /* offset+length now in array */
4183 /* At this point, MARK .. SP-1 is our new LIST */
4186 diff = newlen - length;
4187 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4190 if (diff < 0) { /* shrinking the area */
4192 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4193 Copy(MARK, tmparyval, newlen, SV*);
4196 MARK = ORIGMARK + 1;
4197 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4198 MEXTEND(MARK, length);
4199 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4201 EXTEND_MORTAL(length);
4202 for (i = length, dst = MARK; i; i--) {
4203 sv_2mortal(*dst); /* free them eventualy */
4210 *MARK = AvARRAY(ary)[offset+length-1];
4213 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4214 SvREFCNT_dec(*dst++); /* free them now */
4217 AvFILLp(ary) += diff;
4219 /* pull up or down? */
4221 if (offset < after) { /* easier to pull up */
4222 if (offset) { /* esp. if nothing to pull */
4223 src = &AvARRAY(ary)[offset-1];
4224 dst = src - diff; /* diff is negative */
4225 for (i = offset; i > 0; i--) /* can't trust Copy */
4229 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4233 if (after) { /* anything to pull down? */
4234 src = AvARRAY(ary) + offset + length;
4235 dst = src + diff; /* diff is negative */
4236 Move(src, dst, after, SV*);
4238 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4239 /* avoid later double free */
4243 dst[--i] = &PL_sv_undef;
4246 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4248 *dst = NEWSV(46, 0);
4249 sv_setsv(*dst++, *src++);
4251 Safefree(tmparyval);
4254 else { /* no, expanding (or same) */
4256 New(452, tmparyval, length, SV*); /* so remember deletion */
4257 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4260 if (diff > 0) { /* expanding */
4262 /* push up or down? */
4264 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4268 Move(src, dst, offset, SV*);
4270 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4272 AvFILLp(ary) += diff;
4275 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4276 av_extend(ary, AvFILLp(ary) + diff);
4277 AvFILLp(ary) += diff;
4280 dst = AvARRAY(ary) + AvFILLp(ary);
4282 for (i = after; i; i--) {
4289 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4290 *dst = NEWSV(46, 0);
4291 sv_setsv(*dst++, *src++);
4293 MARK = ORIGMARK + 1;
4294 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4296 Copy(tmparyval, MARK, length, SV*);
4298 EXTEND_MORTAL(length);
4299 for (i = length, dst = MARK; i; i--) {
4300 sv_2mortal(*dst); /* free them eventualy */
4304 Safefree(tmparyval);
4308 else if (length--) {
4309 *MARK = tmparyval[length];
4312 while (length-- > 0)
4313 SvREFCNT_dec(tmparyval[length]);
4315 Safefree(tmparyval);
4318 *MARK = &PL_sv_undef;
4326 dSP; dMARK; dORIGMARK; dTARGET;
4327 register AV *ary = (AV*)*++MARK;
4328 register SV *sv = &PL_sv_undef;
4331 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4332 *MARK-- = SvTIED_obj((SV*)ary, mg);
4336 call_method("PUSH",G_SCALAR|G_DISCARD);
4341 /* Why no pre-extend of ary here ? */
4342 for (++MARK; MARK <= SP; MARK++) {
4345 sv_setsv(sv, *MARK);
4350 PUSHi( AvFILL(ary) + 1 );
4358 SV *sv = av_pop(av);
4360 (void)sv_2mortal(sv);
4369 SV *sv = av_shift(av);
4374 (void)sv_2mortal(sv);
4381 dSP; dMARK; dORIGMARK; dTARGET;
4382 register AV *ary = (AV*)*++MARK;
4387 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4388 *MARK-- = SvTIED_obj((SV*)ary, mg);
4392 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4397 av_unshift(ary, SP - MARK);
4400 sv_setsv(sv, *++MARK);
4401 (void)av_store(ary, i++, sv);
4405 PUSHi( AvFILL(ary) + 1 );
4415 if (GIMME == G_ARRAY) {
4422 /* safe as long as stack cannot get extended in the above */
4427 register char *down;
4432 SvUTF8_off(TARG); /* decontaminate */
4434 do_join(TARG, &PL_sv_no, MARK, SP);
4436 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4437 up = SvPV_force(TARG, len);
4439 if (DO_UTF8(TARG)) { /* first reverse each character */
4440 U8* s = (U8*)SvPVX(TARG);
4441 U8* send = (U8*)(s + len);
4443 if (UTF8_IS_INVARIANT(*s)) {
4448 if (!utf8_to_uvchr(s, 0))
4452 down = (char*)(s - 1);
4453 /* reverse this character */
4457 *down-- = (char)tmp;
4463 down = SvPVX(TARG) + len - 1;
4467 *down-- = (char)tmp;
4469 (void)SvPOK_only_UTF8(TARG);
4481 register IV limit = POPi; /* note, negative is forever */
4484 register char *s = SvPV(sv, len);
4485 bool do_utf8 = DO_UTF8(sv);
4486 char *strend = s + len;
4488 register REGEXP *rx;
4492 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4493 I32 maxiters = slen + 10;
4496 I32 origlimit = limit;
4499 AV *oldstack = PL_curstack;
4500 I32 gimme = GIMME_V;
4501 I32 oldsave = PL_savestack_ix;
4502 I32 make_mortal = 1;
4503 MAGIC *mg = (MAGIC *) NULL;
4506 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4511 DIE(aTHX_ "panic: pp_split");
4514 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4515 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4517 RX_MATCH_UTF8_set(rx, do_utf8);
4519 if (pm->op_pmreplroot) {
4521 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4523 ary = GvAVn((GV*)pm->op_pmreplroot);
4526 else if (gimme != G_ARRAY)
4527 ary = GvAVn(PL_defgv);
4530 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4536 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4538 XPUSHs(SvTIED_obj((SV*)ary, mg));
4544 for (i = AvFILLp(ary); i >= 0; i--)
4545 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4547 /* temporarily switch stacks */
4548 SWITCHSTACK(PL_curstack, ary);
4549 PL_curstackinfo->si_stack = ary;
4553 base = SP - PL_stack_base;
4555 if (pm->op_pmflags & PMf_SKIPWHITE) {
4556 if (pm->op_pmflags & PMf_LOCALE) {
4557 while (isSPACE_LC(*s))
4565 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4566 SAVEINT(PL_multiline);
4567 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4571 limit = maxiters + 2;
4572 if (pm->op_pmflags & PMf_WHITE) {
4575 while (m < strend &&
4576 !((pm->op_pmflags & PMf_LOCALE)
4577 ? isSPACE_LC(*m) : isSPACE(*m)))
4582 dstr = NEWSV(30, m-s);
4583 sv_setpvn(dstr, s, m-s);
4587 (void)SvUTF8_on(dstr);
4591 while (s < strend &&
4592 ((pm->op_pmflags & PMf_LOCALE)
4593 ? isSPACE_LC(*s) : isSPACE(*s)))
4597 else if (strEQ("^", rx->precomp)) {
4600 for (m = s; m < strend && *m != '\n'; m++) ;
4604 dstr = NEWSV(30, m-s);
4605 sv_setpvn(dstr, s, m-s);
4609 (void)SvUTF8_on(dstr);
4614 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4615 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4616 && (rx->reganch & ROPT_CHECK_ALL)
4617 && !(rx->reganch & ROPT_ANCH)) {
4618 int tail = (rx->reganch & RE_INTUIT_TAIL);
4619 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4622 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4624 char c = *SvPV(csv, n_a);
4627 for (m = s; m < strend && *m != c; m++) ;
4630 dstr = NEWSV(30, m-s);
4631 sv_setpvn(dstr, s, m-s);
4635 (void)SvUTF8_on(dstr);
4637 /* The rx->minlen is in characters but we want to step
4638 * s ahead by bytes. */
4640 s = (char*)utf8_hop((U8*)m, len);
4642 s = m + len; /* Fake \n at the end */
4647 while (s < strend && --limit &&
4648 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4649 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4652 dstr = NEWSV(31, m-s);
4653 sv_setpvn(dstr, s, m-s);
4657 (void)SvUTF8_on(dstr);
4659 /* The rx->minlen is in characters but we want to step
4660 * s ahead by bytes. */
4662 s = (char*)utf8_hop((U8*)m, len);
4664 s = m + len; /* Fake \n at the end */
4669 maxiters += slen * rx->nparens;
4670 while (s < strend && --limit
4671 /* && (!rx->check_substr
4672 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4674 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4675 1 /* minend */, sv, NULL, 0))
4677 TAINT_IF(RX_MATCH_TAINTED(rx));
4678 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4683 strend = s + (strend - m);
4685 m = rx->startp[0] + orig;
4686 dstr = NEWSV(32, m-s);
4687 sv_setpvn(dstr, s, m-s);
4691 (void)SvUTF8_on(dstr);
4694 for (i = 1; i <= (I32)rx->nparens; i++) {
4695 s = rx->startp[i] + orig;
4696 m = rx->endp[i] + orig;
4698 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4699 parens that didn't match -- they should be set to
4700 undef, not the empty string */
4701 if (m >= orig && s >= orig) {
4702 dstr = NEWSV(33, m-s);
4703 sv_setpvn(dstr, s, m-s);
4706 dstr = &PL_sv_undef; /* undef, not "" */
4710 (void)SvUTF8_on(dstr);
4714 s = rx->endp[0] + orig;
4719 LEAVE_SCOPE(oldsave);
4720 iters = (SP - PL_stack_base) - base;
4721 if (iters > maxiters)
4722 DIE(aTHX_ "Split loop");
4724 /* keep field after final delim? */
4725 if (s < strend || (iters && origlimit)) {
4726 STRLEN l = strend - s;
4727 dstr = NEWSV(34, l);
4728 sv_setpvn(dstr, s, l);
4732 (void)SvUTF8_on(dstr);
4736 else if (!origlimit) {
4737 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4738 if (TOPs && !make_mortal)
4747 SWITCHSTACK(ary, oldstack);
4748 PL_curstackinfo->si_stack = oldstack;
4749 if (SvSMAGICAL(ary)) {
4754 if (gimme == G_ARRAY) {
4756 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4764 call_method("PUSH",G_SCALAR|G_DISCARD);
4767 if (gimme == G_ARRAY) {
4768 /* EXTEND should not be needed - we just popped them */
4770 for (i=0; i < iters; i++) {
4771 SV **svp = av_fetch(ary, i, FALSE);
4772 PUSHs((svp) ? *svp : &PL_sv_undef);
4779 if (gimme == G_ARRAY)
4794 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4795 || SvTYPE(retsv) == SVt_PVCV) {
4796 retsv = refto(retsv);
4804 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");