3 * Copyright (c) 1991-2002, 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));
218 tryAMAGICunDEREF(to_sv);
221 switch (SvTYPE(sv)) {
225 DIE(aTHX_ "Not a SCALAR reference");
233 if (SvTYPE(gv) != SVt_PVGV) {
234 if (SvGMAGICAL(sv)) {
240 if (PL_op->op_flags & OPf_REF ||
241 PL_op->op_private & HINT_STRICT_REFS)
242 DIE(aTHX_ PL_no_usym, "a SCALAR");
243 if (ckWARN(WARN_UNINITIALIZED))
248 if ((PL_op->op_flags & OPf_SPECIAL) &&
249 !(PL_op->op_flags & OPf_MOD))
251 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
253 && (!is_gv_magical(sym,len,0)
254 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
260 if (PL_op->op_private & HINT_STRICT_REFS)
261 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
262 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
267 if (PL_op->op_flags & OPf_MOD) {
268 if (PL_op->op_private & OPpLVAL_INTRO)
269 sv = save_scalar((GV*)TOPs);
270 else if (PL_op->op_private & OPpDEREF)
271 vivify_ref(sv, PL_op->op_private & OPpDEREF);
281 SV *sv = AvARYLEN(av);
283 AvARYLEN(av) = sv = NEWSV(0,0);
284 sv_upgrade(sv, SVt_IV);
285 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
293 dSP; dTARGET; dPOPss;
295 if (PL_op->op_flags & OPf_MOD || LVRET) {
296 if (SvTYPE(TARG) < SVt_PVLV) {
297 sv_upgrade(TARG, SVt_PVLV);
298 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
302 if (LvTARG(TARG) != sv) {
304 SvREFCNT_dec(LvTARG(TARG));
305 LvTARG(TARG) = SvREFCNT_inc(sv);
307 PUSHs(TARG); /* no SvSETMAGIC */
313 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
314 mg = mg_find(sv, PERL_MAGIC_regex_global);
315 if (mg && mg->mg_len >= 0) {
319 PUSHi(i + PL_curcop->cop_arybase);
333 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
334 /* (But not in defined().) */
335 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
338 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
339 if ((PL_op->op_private & OPpLVAL_INTRO)) {
340 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
343 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
347 cv = (CV*)&PL_sv_undef;
361 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
362 char *s = SvPVX(TOPs);
363 if (strnEQ(s, "CORE::", 6)) {
366 code = keyword(s + 6, SvCUR(TOPs) - 6);
367 if (code < 0) { /* Overridable. */
368 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
369 int i = 0, n = 0, seen_question = 0;
371 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
373 if (code == -KEY_chop || code == -KEY_chomp)
375 while (i < MAXO) { /* The slow way. */
376 if (strEQ(s + 6, PL_op_name[i])
377 || strEQ(s + 6, PL_op_desc[i]))
383 goto nonesuch; /* Should not happen... */
385 oa = PL_opargs[i] >> OASHIFT;
387 if (oa & OA_OPTIONAL && !seen_question) {
391 else if (n && str[0] == ';' && seen_question)
392 goto set; /* XXXX system, exec */
393 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
394 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
395 /* But globs are already references (kinda) */
396 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
400 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
404 ret = sv_2mortal(newSVpvn(str, n - 1));
406 else if (code) /* Non-Overridable */
408 else { /* None such */
410 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
414 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
416 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
425 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
427 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
443 if (GIMME != G_ARRAY) {
447 *MARK = &PL_sv_undef;
448 *MARK = refto(*MARK);
452 EXTEND_MORTAL(SP - MARK);
454 *MARK = refto(*MARK);
459 S_refto(pTHX_ SV *sv)
463 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
466 if (!(sv = LvTARG(sv)))
469 (void)SvREFCNT_inc(sv);
471 else if (SvTYPE(sv) == SVt_PVAV) {
472 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
475 (void)SvREFCNT_inc(sv);
477 else if (SvPADTMP(sv) && !IS_PADGV(sv))
481 (void)SvREFCNT_inc(sv);
484 sv_upgrade(rv, SVt_RV);
498 if (sv && SvGMAGICAL(sv))
501 if (!sv || !SvROK(sv))
505 pv = sv_reftype(sv,TRUE);
506 PUSHp(pv, strlen(pv));
516 stash = CopSTASH(PL_curcop);
522 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
523 Perl_croak(aTHX_ "Attempt to bless into a reference");
525 if (ckWARN(WARN_MISC) && len == 0)
526 Perl_warner(aTHX_ packWARN(WARN_MISC),
527 "Explicit blessing to '' (assuming package main)");
528 stash = gv_stashpvn(ptr, len, TRUE);
531 (void)sv_bless(TOPs, stash);
545 elem = SvPV(sv, n_a);
549 switch (elem ? *elem : '\0')
552 if (strEQ(elem, "ARRAY"))
553 tmpRef = (SV*)GvAV(gv);
556 if (strEQ(elem, "CODE"))
557 tmpRef = (SV*)GvCVu(gv);
560 if (strEQ(elem, "FILEHANDLE")) {
561 /* finally deprecated in 5.8.0 */
562 deprecate("*glob{FILEHANDLE}");
563 tmpRef = (SV*)GvIOp(gv);
566 if (strEQ(elem, "FORMAT"))
567 tmpRef = (SV*)GvFORM(gv);
570 if (strEQ(elem, "GLOB"))
574 if (strEQ(elem, "HASH"))
575 tmpRef = (SV*)GvHV(gv);
578 if (strEQ(elem, "IO"))
579 tmpRef = (SV*)GvIOp(gv);
582 if (strEQ(elem, "NAME"))
583 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
586 if (strEQ(elem, "PACKAGE"))
587 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
590 if (strEQ(elem, "SCALAR"))
604 /* Pattern matching */
609 register unsigned char *s;
612 register I32 *sfirst;
616 if (sv == PL_lastscream) {
622 SvSCREAM_off(PL_lastscream);
623 SvREFCNT_dec(PL_lastscream);
625 PL_lastscream = SvREFCNT_inc(sv);
628 s = (unsigned char*)(SvPV(sv, len));
632 if (pos > PL_maxscream) {
633 if (PL_maxscream < 0) {
634 PL_maxscream = pos + 80;
635 New(301, PL_screamfirst, 256, I32);
636 New(302, PL_screamnext, PL_maxscream, I32);
639 PL_maxscream = pos + pos / 4;
640 Renew(PL_screamnext, PL_maxscream, I32);
644 sfirst = PL_screamfirst;
645 snext = PL_screamnext;
647 if (!sfirst || !snext)
648 DIE(aTHX_ "do_study: out of memory");
650 for (ch = 256; ch; --ch)
657 snext[pos] = sfirst[ch] - pos;
664 /* piggyback on m//g magic */
665 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
674 if (PL_op->op_flags & OPf_STACKED)
680 TARG = sv_newmortal();
685 /* Lvalue operators. */
697 dSP; dMARK; dTARGET; dORIGMARK;
699 do_chop(TARG, *++MARK);
708 SETi(do_chomp(TOPs));
715 register I32 count = 0;
718 count += do_chomp(POPs);
729 if (!sv || !SvANY(sv))
731 switch (SvTYPE(sv)) {
733 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
734 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
738 if (HvARRAY(sv) || SvGMAGICAL(sv)
739 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
743 if (CvROOT(sv) || CvXSUB(sv))
760 if (!PL_op->op_private) {
769 SV_CHECK_THINKFIRST_COW_DROP(sv);
771 switch (SvTYPE(sv)) {
781 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
782 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
783 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
787 /* let user-undef'd sub keep its identity */
788 GV* gv = CvGV((CV*)sv);
795 SvSetMagicSV(sv, &PL_sv_undef);
799 Newz(602, gp, 1, GP);
800 GvGP(sv) = gp_ref(gp);
801 GvSV(sv) = NEWSV(72,0);
802 GvLINE(sv) = CopLINE(PL_curcop);
808 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
811 SvPV_set(sv, Nullch);
824 if (SvTYPE(TOPs) > SVt_PVLV)
825 DIE(aTHX_ PL_no_modify);
826 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
827 && SvIVX(TOPs) != IV_MIN)
830 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841 if (SvTYPE(TOPs) > SVt_PVLV)
842 DIE(aTHX_ PL_no_modify);
843 sv_setsv(TARG, TOPs);
844 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
845 && SvIVX(TOPs) != IV_MAX)
848 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
862 if (SvTYPE(TOPs) > SVt_PVLV)
863 DIE(aTHX_ PL_no_modify);
864 sv_setsv(TARG, TOPs);
865 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
866 && SvIVX(TOPs) != IV_MIN)
869 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
878 /* Ordinary operators. */
883 #ifdef PERL_PRESERVE_IVUV
886 tryAMAGICbin(pow,opASSIGN);
887 #ifdef PERL_PRESERVE_IVUV
888 /* For integer to integer power, we do the calculation by hand wherever
889 we're sure it is safe; otherwise we call pow() and try to convert to
890 integer afterwards. */
894 bool baseuok = SvUOK(TOPm1s);
898 baseuv = SvUVX(TOPm1s);
900 IV iv = SvIVX(TOPm1s);
903 baseuok = TRUE; /* effectively it's a UV now */
905 baseuv = -iv; /* abs, baseuok == false records sign */
919 goto float_it; /* Can't do negative powers this way. */
922 /* now we have integer ** positive integer. */
925 /* foo & (foo - 1) is zero only for a power of 2. */
926 if (!(baseuv & (baseuv - 1))) {
927 /* We are raising power-of-2 to a positive integer.
928 The logic here will work for any base (even non-integer
929 bases) but it can be less accurate than
930 pow (base,power) or exp (power * log (base)) when the
931 intermediate values start to spill out of the mantissa.
932 With powers of 2 we know this can't happen.
933 And powers of 2 are the favourite thing for perl
934 programmers to notice ** not doing what they mean. */
936 NV base = baseuok ? baseuv : -(NV)baseuv;
939 for (; power; base *= base, n++) {
940 /* Do I look like I trust gcc with long longs here?
942 UV bit = (UV)1 << (UV)n;
945 /* Only bother to clear the bit if it is set. */
947 /* Avoid squaring base again if we're done. */
948 if (power == 0) break;
956 register unsigned int highbit = 8 * sizeof(UV);
957 register unsigned int lowbit = 0;
958 register unsigned int diff;
959 while ((diff = (highbit - lowbit) >> 1)) {
960 if (baseuv & ~((1 << (lowbit + diff)) - 1))
965 /* we now have baseuv < 2 ** highbit */
966 if (power * highbit <= 8 * sizeof(UV)) {
967 /* result will definitely fit in UV, so use UV math
968 on same algorithm as above */
969 register UV result = 1;
970 register UV base = baseuv;
972 for (; power; base *= base, n++) {
973 register UV bit = (UV)1 << (UV)n;
977 if (power == 0) break;
981 if (baseuok || !(power & 1))
982 /* answer is positive */
984 else if (result <= (UV)IV_MAX)
985 /* answer negative, fits in IV */
987 else if (result == (UV)IV_MIN)
988 /* 2's complement assumption: special case IV_MIN */
991 /* answer negative, doesn't fit */
1003 SETn( Perl_pow( left, right) );
1004 #ifdef PERL_PRESERVE_IVUV
1014 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1015 #ifdef PERL_PRESERVE_IVUV
1018 /* Unless the left argument is integer in range we are going to have to
1019 use NV maths. Hence only attempt to coerce the right argument if
1020 we know the left is integer. */
1021 /* Left operand is defined, so is it IV? */
1022 SvIV_please(TOPm1s);
1023 if (SvIOK(TOPm1s)) {
1024 bool auvok = SvUOK(TOPm1s);
1025 bool buvok = SvUOK(TOPs);
1026 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1027 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1034 alow = SvUVX(TOPm1s);
1036 IV aiv = SvIVX(TOPm1s);
1039 auvok = TRUE; /* effectively it's a UV now */
1041 alow = -aiv; /* abs, auvok == false records sign */
1047 IV biv = SvIVX(TOPs);
1050 buvok = TRUE; /* effectively it's a UV now */
1052 blow = -biv; /* abs, buvok == false records sign */
1056 /* If this does sign extension on unsigned it's time for plan B */
1057 ahigh = alow >> (4 * sizeof (UV));
1059 bhigh = blow >> (4 * sizeof (UV));
1061 if (ahigh && bhigh) {
1062 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1063 which is overflow. Drop to NVs below. */
1064 } else if (!ahigh && !bhigh) {
1065 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1066 so the unsigned multiply cannot overflow. */
1067 UV product = alow * blow;
1068 if (auvok == buvok) {
1069 /* -ve * -ve or +ve * +ve gives a +ve result. */
1073 } else if (product <= (UV)IV_MIN) {
1074 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1075 /* -ve result, which could overflow an IV */
1077 SETi( -(IV)product );
1079 } /* else drop to NVs below. */
1081 /* One operand is large, 1 small */
1084 /* swap the operands */
1086 bhigh = blow; /* bhigh now the temp var for the swap */
1090 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1091 multiplies can't overflow. shift can, add can, -ve can. */
1092 product_middle = ahigh * blow;
1093 if (!(product_middle & topmask)) {
1094 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1096 product_middle <<= (4 * sizeof (UV));
1097 product_low = alow * blow;
1099 /* as for pp_add, UV + something mustn't get smaller.
1100 IIRC ANSI mandates this wrapping *behaviour* for
1101 unsigned whatever the actual representation*/
1102 product_low += product_middle;
1103 if (product_low >= product_middle) {
1104 /* didn't overflow */
1105 if (auvok == buvok) {
1106 /* -ve * -ve or +ve * +ve gives a +ve result. */
1108 SETu( product_low );
1110 } else if (product_low <= (UV)IV_MIN) {
1111 /* 2s complement assumption again */
1112 /* -ve result, which could overflow an IV */
1114 SETi( -(IV)product_low );
1116 } /* else drop to NVs below. */
1118 } /* product_middle too large */
1119 } /* ahigh && bhigh */
1120 } /* SvIOK(TOPm1s) */
1125 SETn( left * right );
1132 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1133 /* Only try to do UV divide first
1134 if ((SLOPPYDIVIDE is true) or
1135 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1137 The assumption is that it is better to use floating point divide
1138 whenever possible, only doing integer divide first if we can't be sure.
1139 If NV_PRESERVES_UV is true then we know at compile time that no UV
1140 can be too large to preserve, so don't need to compile the code to
1141 test the size of UVs. */
1144 # define PERL_TRY_UV_DIVIDE
1145 /* ensure that 20./5. == 4. */
1147 # ifdef PERL_PRESERVE_IVUV
1148 # ifndef NV_PRESERVES_UV
1149 # define PERL_TRY_UV_DIVIDE
1154 #ifdef PERL_TRY_UV_DIVIDE
1157 SvIV_please(TOPm1s);
1158 if (SvIOK(TOPm1s)) {
1159 bool left_non_neg = SvUOK(TOPm1s);
1160 bool right_non_neg = SvUOK(TOPs);
1164 if (right_non_neg) {
1165 right = SvUVX(TOPs);
1168 IV biv = SvIVX(TOPs);
1171 right_non_neg = TRUE; /* effectively it's a UV now */
1177 /* historically undef()/0 gives a "Use of uninitialized value"
1178 warning before dieing, hence this test goes here.
1179 If it were immediately before the second SvIV_please, then
1180 DIE() would be invoked before left was even inspected, so
1181 no inpsection would give no warning. */
1183 DIE(aTHX_ "Illegal division by zero");
1186 left = SvUVX(TOPm1s);
1189 IV aiv = SvIVX(TOPm1s);
1192 left_non_neg = TRUE; /* effectively it's a UV now */
1201 /* For sloppy divide we always attempt integer division. */
1203 /* Otherwise we only attempt it if either or both operands
1204 would not be preserved by an NV. If both fit in NVs
1205 we fall through to the NV divide code below. However,
1206 as left >= right to ensure integer result here, we know that
1207 we can skip the test on the right operand - right big
1208 enough not to be preserved can't get here unless left is
1211 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1214 /* Integer division can't overflow, but it can be imprecise. */
1215 UV result = left / right;
1216 if (result * right == left) {
1217 SP--; /* result is valid */
1218 if (left_non_neg == right_non_neg) {
1219 /* signs identical, result is positive. */
1223 /* 2s complement assumption */
1224 if (result <= (UV)IV_MIN)
1225 SETi( -(IV)result );
1227 /* It's exact but too negative for IV. */
1228 SETn( -(NV)result );
1231 } /* tried integer divide but it was not an integer result */
1232 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1233 } /* left wasn't SvIOK */
1234 } /* right wasn't SvIOK */
1235 #endif /* PERL_TRY_UV_DIVIDE */
1239 DIE(aTHX_ "Illegal division by zero");
1240 PUSHn( left / right );
1247 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1251 bool left_neg = FALSE;
1252 bool right_neg = FALSE;
1253 bool use_double = FALSE;
1254 bool dright_valid = FALSE;
1260 right_neg = !SvUOK(TOPs);
1262 right = SvUVX(POPs);
1264 IV biv = SvIVX(POPs);
1267 right_neg = FALSE; /* effectively it's a UV now */
1275 right_neg = dright < 0;
1278 if (dright < UV_MAX_P1) {
1279 right = U_V(dright);
1280 dright_valid = TRUE; /* In case we need to use double below. */
1286 /* At this point use_double is only true if right is out of range for
1287 a UV. In range NV has been rounded down to nearest UV and
1288 use_double false. */
1290 if (!use_double && SvIOK(TOPs)) {
1292 left_neg = !SvUOK(TOPs);
1296 IV aiv = SvIVX(POPs);
1299 left_neg = FALSE; /* effectively it's a UV now */
1308 left_neg = dleft < 0;
1312 /* This should be exactly the 5.6 behaviour - if left and right are
1313 both in range for UV then use U_V() rather than floor. */
1315 if (dleft < UV_MAX_P1) {
1316 /* right was in range, so is dleft, so use UVs not double.
1320 /* left is out of range for UV, right was in range, so promote
1321 right (back) to double. */
1323 /* The +0.5 is used in 5.6 even though it is not strictly
1324 consistent with the implicit +0 floor in the U_V()
1325 inside the #if 1. */
1326 dleft = Perl_floor(dleft + 0.5);
1329 dright = Perl_floor(dright + 0.5);
1339 DIE(aTHX_ "Illegal modulus zero");
1341 dans = Perl_fmod(dleft, dright);
1342 if ((left_neg != right_neg) && dans)
1343 dans = dright - dans;
1346 sv_setnv(TARG, dans);
1352 DIE(aTHX_ "Illegal modulus zero");
1355 if ((left_neg != right_neg) && ans)
1358 /* XXX may warn: unary minus operator applied to unsigned type */
1359 /* could change -foo to be (~foo)+1 instead */
1360 if (ans <= ~((UV)IV_MAX)+1)
1361 sv_setiv(TARG, ~ans+1);
1363 sv_setnv(TARG, -(NV)ans);
1366 sv_setuv(TARG, ans);
1375 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1377 register IV count = POPi;
1378 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1380 I32 items = SP - MARK;
1383 max = items * count;
1388 /* This code was intended to fix 20010809.028:
1391 for (($x =~ /./g) x 2) {
1392 print chop; # "abcdabcd" expected as output.
1395 * but that change (#11635) broke this code:
1397 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1399 * I can't think of a better fix that doesn't introduce
1400 * an efficiency hit by copying the SVs. The stack isn't
1401 * refcounted, and mortalisation obviously doesn't
1402 * Do The Right Thing when the stack has more than
1403 * one pointer to the same mortal value.
1407 *SP = sv_2mortal(newSVsv(*SP));
1417 repeatcpy((char*)(MARK + items), (char*)MARK,
1418 items * sizeof(SV*), count - 1);
1421 else if (count <= 0)
1424 else { /* Note: mark already snarfed by pp_list */
1429 SvSetSV(TARG, tmpstr);
1430 SvPV_force(TARG, len);
1431 isutf = DO_UTF8(TARG);
1436 SvGROW(TARG, (count * len) + 1);
1437 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1438 SvCUR(TARG) *= count;
1440 *SvEND(TARG) = '\0';
1443 (void)SvPOK_only_UTF8(TARG);
1445 (void)SvPOK_only(TARG);
1447 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1448 /* The parser saw this as a list repeat, and there
1449 are probably several items on the stack. But we're
1450 in scalar context, and there's no pp_list to save us
1451 now. So drop the rest of the items -- robin@kitsite.com
1464 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1465 useleft = USE_LEFT(TOPm1s);
1466 #ifdef PERL_PRESERVE_IVUV
1467 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1468 "bad things" happen if you rely on signed integers wrapping. */
1471 /* Unless the left argument is integer in range we are going to have to
1472 use NV maths. Hence only attempt to coerce the right argument if
1473 we know the left is integer. */
1474 register UV auv = 0;
1480 a_valid = auvok = 1;
1481 /* left operand is undef, treat as zero. */
1483 /* Left operand is defined, so is it IV? */
1484 SvIV_please(TOPm1s);
1485 if (SvIOK(TOPm1s)) {
1486 if ((auvok = SvUOK(TOPm1s)))
1487 auv = SvUVX(TOPm1s);
1489 register IV aiv = SvIVX(TOPm1s);
1492 auvok = 1; /* Now acting as a sign flag. */
1493 } else { /* 2s complement assumption for IV_MIN */
1501 bool result_good = 0;
1504 bool buvok = SvUOK(TOPs);
1509 register IV biv = SvIVX(TOPs);
1516 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1517 else "IV" now, independent of how it came in.
1518 if a, b represents positive, A, B negative, a maps to -A etc
1523 all UV maths. negate result if A negative.
1524 subtract if signs same, add if signs differ. */
1526 if (auvok ^ buvok) {
1535 /* Must get smaller */
1540 if (result <= buv) {
1541 /* result really should be -(auv-buv). as its negation
1542 of true value, need to swap our result flag */
1554 if (result <= (UV)IV_MIN)
1555 SETi( -(IV)result );
1557 /* result valid, but out of range for IV. */
1558 SETn( -(NV)result );
1562 } /* Overflow, drop through to NVs. */
1566 useleft = USE_LEFT(TOPm1s);
1570 /* left operand is undef, treat as zero - value */
1574 SETn( TOPn - value );
1581 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1584 if (PL_op->op_private & HINT_INTEGER) {
1598 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1601 if (PL_op->op_private & HINT_INTEGER) {
1615 dSP; tryAMAGICbinSET(lt,0);
1616 #ifdef PERL_PRESERVE_IVUV
1619 SvIV_please(TOPm1s);
1620 if (SvIOK(TOPm1s)) {
1621 bool auvok = SvUOK(TOPm1s);
1622 bool buvok = SvUOK(TOPs);
1624 if (!auvok && !buvok) { /* ## IV < IV ## */
1625 IV aiv = SvIVX(TOPm1s);
1626 IV biv = SvIVX(TOPs);
1629 SETs(boolSV(aiv < biv));
1632 if (auvok && buvok) { /* ## UV < UV ## */
1633 UV auv = SvUVX(TOPm1s);
1634 UV buv = SvUVX(TOPs);
1637 SETs(boolSV(auv < buv));
1640 if (auvok) { /* ## UV < IV ## */
1647 /* As (a) is a UV, it's >=0, so it cannot be < */
1652 SETs(boolSV(auv < (UV)biv));
1655 { /* ## IV < UV ## */
1659 aiv = SvIVX(TOPm1s);
1661 /* As (b) is a UV, it's >=0, so it must be < */
1668 SETs(boolSV((UV)aiv < buv));
1674 #ifndef NV_PRESERVES_UV
1675 #ifdef PERL_PRESERVE_IVUV
1678 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1680 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1686 SETs(boolSV(TOPn < value));
1693 dSP; tryAMAGICbinSET(gt,0);
1694 #ifdef PERL_PRESERVE_IVUV
1697 SvIV_please(TOPm1s);
1698 if (SvIOK(TOPm1s)) {
1699 bool auvok = SvUOK(TOPm1s);
1700 bool buvok = SvUOK(TOPs);
1702 if (!auvok && !buvok) { /* ## IV > IV ## */
1703 IV aiv = SvIVX(TOPm1s);
1704 IV biv = SvIVX(TOPs);
1707 SETs(boolSV(aiv > biv));
1710 if (auvok && buvok) { /* ## UV > UV ## */
1711 UV auv = SvUVX(TOPm1s);
1712 UV buv = SvUVX(TOPs);
1715 SETs(boolSV(auv > buv));
1718 if (auvok) { /* ## UV > IV ## */
1725 /* As (a) is a UV, it's >=0, so it must be > */
1730 SETs(boolSV(auv > (UV)biv));
1733 { /* ## IV > UV ## */
1737 aiv = SvIVX(TOPm1s);
1739 /* As (b) is a UV, it's >=0, so it cannot be > */
1746 SETs(boolSV((UV)aiv > buv));
1752 #ifndef NV_PRESERVES_UV
1753 #ifdef PERL_PRESERVE_IVUV
1756 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1758 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1764 SETs(boolSV(TOPn > value));
1771 dSP; tryAMAGICbinSET(le,0);
1772 #ifdef PERL_PRESERVE_IVUV
1775 SvIV_please(TOPm1s);
1776 if (SvIOK(TOPm1s)) {
1777 bool auvok = SvUOK(TOPm1s);
1778 bool buvok = SvUOK(TOPs);
1780 if (!auvok && !buvok) { /* ## IV <= IV ## */
1781 IV aiv = SvIVX(TOPm1s);
1782 IV biv = SvIVX(TOPs);
1785 SETs(boolSV(aiv <= biv));
1788 if (auvok && buvok) { /* ## UV <= UV ## */
1789 UV auv = SvUVX(TOPm1s);
1790 UV buv = SvUVX(TOPs);
1793 SETs(boolSV(auv <= buv));
1796 if (auvok) { /* ## UV <= IV ## */
1803 /* As (a) is a UV, it's >=0, so a cannot be <= */
1808 SETs(boolSV(auv <= (UV)biv));
1811 { /* ## IV <= UV ## */
1815 aiv = SvIVX(TOPm1s);
1817 /* As (b) is a UV, it's >=0, so a must be <= */
1824 SETs(boolSV((UV)aiv <= buv));
1830 #ifndef NV_PRESERVES_UV
1831 #ifdef PERL_PRESERVE_IVUV
1834 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1836 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1842 SETs(boolSV(TOPn <= value));
1849 dSP; tryAMAGICbinSET(ge,0);
1850 #ifdef PERL_PRESERVE_IVUV
1853 SvIV_please(TOPm1s);
1854 if (SvIOK(TOPm1s)) {
1855 bool auvok = SvUOK(TOPm1s);
1856 bool buvok = SvUOK(TOPs);
1858 if (!auvok && !buvok) { /* ## IV >= IV ## */
1859 IV aiv = SvIVX(TOPm1s);
1860 IV biv = SvIVX(TOPs);
1863 SETs(boolSV(aiv >= biv));
1866 if (auvok && buvok) { /* ## UV >= UV ## */
1867 UV auv = SvUVX(TOPm1s);
1868 UV buv = SvUVX(TOPs);
1871 SETs(boolSV(auv >= buv));
1874 if (auvok) { /* ## UV >= IV ## */
1881 /* As (a) is a UV, it's >=0, so it must be >= */
1886 SETs(boolSV(auv >= (UV)biv));
1889 { /* ## IV >= UV ## */
1893 aiv = SvIVX(TOPm1s);
1895 /* As (b) is a UV, it's >=0, so a cannot be >= */
1902 SETs(boolSV((UV)aiv >= buv));
1908 #ifndef NV_PRESERVES_UV
1909 #ifdef PERL_PRESERVE_IVUV
1912 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1914 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1920 SETs(boolSV(TOPn >= value));
1927 dSP; tryAMAGICbinSET(ne,0);
1928 #ifndef NV_PRESERVES_UV
1929 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1931 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1935 #ifdef PERL_PRESERVE_IVUV
1938 SvIV_please(TOPm1s);
1939 if (SvIOK(TOPm1s)) {
1940 bool auvok = SvUOK(TOPm1s);
1941 bool buvok = SvUOK(TOPs);
1943 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1944 /* Casting IV to UV before comparison isn't going to matter
1945 on 2s complement. On 1s complement or sign&magnitude
1946 (if we have any of them) it could make negative zero
1947 differ from normal zero. As I understand it. (Need to
1948 check - is negative zero implementation defined behaviour
1950 UV buv = SvUVX(POPs);
1951 UV auv = SvUVX(TOPs);
1953 SETs(boolSV(auv != buv));
1956 { /* ## Mixed IV,UV ## */
1960 /* != is commutative so swap if needed (save code) */
1962 /* swap. top of stack (b) is the iv */
1966 /* As (a) is a UV, it's >0, so it cannot be == */
1975 /* As (b) is a UV, it's >0, so it cannot be == */
1979 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1981 SETs(boolSV((UV)iv != uv));
1989 SETs(boolSV(TOPn != value));
1996 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1997 #ifndef NV_PRESERVES_UV
1998 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1999 UV right = PTR2UV(SvRV(POPs));
2000 UV left = PTR2UV(SvRV(TOPs));
2001 SETi((left > right) - (left < right));
2005 #ifdef PERL_PRESERVE_IVUV
2006 /* Fortunately it seems NaN isn't IOK */
2009 SvIV_please(TOPm1s);
2010 if (SvIOK(TOPm1s)) {
2011 bool leftuvok = SvUOK(TOPm1s);
2012 bool rightuvok = SvUOK(TOPs);
2014 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2015 IV leftiv = SvIVX(TOPm1s);
2016 IV rightiv = SvIVX(TOPs);
2018 if (leftiv > rightiv)
2020 else if (leftiv < rightiv)
2024 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2025 UV leftuv = SvUVX(TOPm1s);
2026 UV rightuv = SvUVX(TOPs);
2028 if (leftuv > rightuv)
2030 else if (leftuv < rightuv)
2034 } else if (leftuvok) { /* ## UV <=> IV ## */
2038 rightiv = SvIVX(TOPs);
2040 /* As (a) is a UV, it's >=0, so it cannot be < */
2043 leftuv = SvUVX(TOPm1s);
2044 if (leftuv > (UV)rightiv) {
2046 } else if (leftuv < (UV)rightiv) {
2052 } else { /* ## IV <=> UV ## */
2056 leftiv = SvIVX(TOPm1s);
2058 /* As (b) is a UV, it's >=0, so it must be < */
2061 rightuv = SvUVX(TOPs);
2062 if ((UV)leftiv > rightuv) {
2064 } else if ((UV)leftiv < rightuv) {
2082 if (Perl_isnan(left) || Perl_isnan(right)) {
2086 value = (left > right) - (left < right);
2090 else if (left < right)
2092 else if (left > right)
2106 dSP; tryAMAGICbinSET(slt,0);
2109 int cmp = (IN_LOCALE_RUNTIME
2110 ? sv_cmp_locale(left, right)
2111 : sv_cmp(left, right));
2112 SETs(boolSV(cmp < 0));
2119 dSP; tryAMAGICbinSET(sgt,0);
2122 int cmp = (IN_LOCALE_RUNTIME
2123 ? sv_cmp_locale(left, right)
2124 : sv_cmp(left, right));
2125 SETs(boolSV(cmp > 0));
2132 dSP; tryAMAGICbinSET(sle,0);
2135 int cmp = (IN_LOCALE_RUNTIME
2136 ? sv_cmp_locale(left, right)
2137 : sv_cmp(left, right));
2138 SETs(boolSV(cmp <= 0));
2145 dSP; tryAMAGICbinSET(sge,0);
2148 int cmp = (IN_LOCALE_RUNTIME
2149 ? sv_cmp_locale(left, right)
2150 : sv_cmp(left, right));
2151 SETs(boolSV(cmp >= 0));
2158 dSP; tryAMAGICbinSET(seq,0);
2161 SETs(boolSV(sv_eq(left, right)));
2168 dSP; tryAMAGICbinSET(sne,0);
2171 SETs(boolSV(!sv_eq(left, right)));
2178 dSP; dTARGET; tryAMAGICbin(scmp,0);
2181 int cmp = (IN_LOCALE_RUNTIME
2182 ? sv_cmp_locale(left, right)
2183 : sv_cmp(left, right));
2191 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2194 if (SvNIOKp(left) || SvNIOKp(right)) {
2195 if (PL_op->op_private & HINT_INTEGER) {
2196 IV i = SvIV(left) & SvIV(right);
2200 UV u = SvUV(left) & SvUV(right);
2205 do_vop(PL_op->op_type, TARG, left, right);
2214 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2217 if (SvNIOKp(left) || SvNIOKp(right)) {
2218 if (PL_op->op_private & HINT_INTEGER) {
2219 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2223 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2228 do_vop(PL_op->op_type, TARG, left, right);
2237 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2240 if (SvNIOKp(left) || SvNIOKp(right)) {
2241 if (PL_op->op_private & HINT_INTEGER) {
2242 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2246 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2251 do_vop(PL_op->op_type, TARG, left, right);
2260 dSP; dTARGET; tryAMAGICun(neg);
2263 int flags = SvFLAGS(sv);
2266 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2267 /* It's publicly an integer, or privately an integer-not-float */
2270 if (SvIVX(sv) == IV_MIN) {
2271 /* 2s complement assumption. */
2272 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2275 else if (SvUVX(sv) <= IV_MAX) {
2280 else if (SvIVX(sv) != IV_MIN) {
2284 #ifdef PERL_PRESERVE_IVUV
2293 else if (SvPOKp(sv)) {
2295 char *s = SvPV(sv, len);
2296 if (isIDFIRST(*s)) {
2297 sv_setpvn(TARG, "-", 1);
2300 else if (*s == '+' || *s == '-') {
2302 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2304 else if (DO_UTF8(sv)) {
2307 goto oops_its_an_int;
2309 sv_setnv(TARG, -SvNV(sv));
2311 sv_setpvn(TARG, "-", 1);
2318 goto oops_its_an_int;
2319 sv_setnv(TARG, -SvNV(sv));
2331 dSP; tryAMAGICunSET(not);
2332 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2338 dSP; dTARGET; tryAMAGICun(compl);
2342 if (PL_op->op_private & HINT_INTEGER) {
2357 tmps = (U8*)SvPV_force(TARG, len);
2360 /* Calculate exact length, let's not estimate. */
2369 while (tmps < send) {
2370 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2371 tmps += UTF8SKIP(tmps);
2372 targlen += UNISKIP(~c);
2378 /* Now rewind strings and write them. */
2382 Newz(0, result, targlen + 1, U8);
2383 while (tmps < send) {
2384 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2385 tmps += UTF8SKIP(tmps);
2386 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2390 sv_setpvn(TARG, (char*)result, targlen);
2394 Newz(0, result, nchar + 1, U8);
2395 while (tmps < send) {
2396 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2397 tmps += UTF8SKIP(tmps);
2402 sv_setpvn(TARG, (char*)result, nchar);
2410 register long *tmpl;
2411 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2414 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2419 for ( ; anum > 0; anum--, tmps++)
2428 /* integer versions of some of the above */
2432 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2435 SETi( left * right );
2442 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2446 DIE(aTHX_ "Illegal division by zero");
2447 value = POPi / value;
2455 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2459 DIE(aTHX_ "Illegal modulus zero");
2460 SETi( left % right );
2467 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2470 SETi( left + right );
2477 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2480 SETi( left - right );
2487 dSP; tryAMAGICbinSET(lt,0);
2490 SETs(boolSV(left < right));
2497 dSP; tryAMAGICbinSET(gt,0);
2500 SETs(boolSV(left > right));
2507 dSP; tryAMAGICbinSET(le,0);
2510 SETs(boolSV(left <= right));
2517 dSP; tryAMAGICbinSET(ge,0);
2520 SETs(boolSV(left >= right));
2527 dSP; tryAMAGICbinSET(eq,0);
2530 SETs(boolSV(left == right));
2537 dSP; tryAMAGICbinSET(ne,0);
2540 SETs(boolSV(left != right));
2547 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2554 else if (left < right)
2565 dSP; dTARGET; tryAMAGICun(neg);
2570 /* High falutin' math. */
2574 dSP; dTARGET; tryAMAGICbin(atan2,0);
2577 SETn(Perl_atan2(left, right));
2584 dSP; dTARGET; tryAMAGICun(sin);
2588 value = Perl_sin(value);
2596 dSP; dTARGET; tryAMAGICun(cos);
2600 value = Perl_cos(value);
2606 /* Support Configure command-line overrides for rand() functions.
2607 After 5.005, perhaps we should replace this by Configure support
2608 for drand48(), random(), or rand(). For 5.005, though, maintain
2609 compatibility by calling rand() but allow the user to override it.
2610 See INSTALL for details. --Andy Dougherty 15 July 1998
2612 /* Now it's after 5.005, and Configure supports drand48() and random(),
2613 in addition to rand(). So the overrides should not be needed any more.
2614 --Jarkko Hietaniemi 27 September 1998
2617 #ifndef HAS_DRAND48_PROTO
2618 extern double drand48 (void);
2631 if (!PL_srand_called) {
2632 (void)seedDrand01((Rand_seed_t)seed());
2633 PL_srand_called = TRUE;
2648 (void)seedDrand01((Rand_seed_t)anum);
2649 PL_srand_called = TRUE;
2658 * This is really just a quick hack which grabs various garbage
2659 * values. It really should be a real hash algorithm which
2660 * spreads the effect of every input bit onto every output bit,
2661 * if someone who knows about such things would bother to write it.
2662 * Might be a good idea to add that function to CORE as well.
2663 * No numbers below come from careful analysis or anything here,
2664 * except they are primes and SEED_C1 > 1E6 to get a full-width
2665 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2666 * probably be bigger too.
2669 # define SEED_C1 1000003
2670 #define SEED_C4 73819
2672 # define SEED_C1 25747
2673 #define SEED_C4 20639
2677 #define SEED_C5 26107
2679 #ifndef PERL_NO_DEV_RANDOM
2684 # include <starlet.h>
2685 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2686 * in 100-ns units, typically incremented ever 10 ms. */
2687 unsigned int when[2];
2689 # ifdef HAS_GETTIMEOFDAY
2690 struct timeval when;
2696 /* This test is an escape hatch, this symbol isn't set by Configure. */
2697 #ifndef PERL_NO_DEV_RANDOM
2698 #ifndef PERL_RANDOM_DEVICE
2699 /* /dev/random isn't used by default because reads from it will block
2700 * if there isn't enough entropy available. You can compile with
2701 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2702 * is enough real entropy to fill the seed. */
2703 # define PERL_RANDOM_DEVICE "/dev/urandom"
2705 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2707 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2716 _ckvmssts(sys$gettim(when));
2717 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2719 # ifdef HAS_GETTIMEOFDAY
2720 PerlProc_gettimeofday(&when,NULL);
2721 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2724 u = (U32)SEED_C1 * when;
2727 u += SEED_C3 * (U32)PerlProc_getpid();
2728 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2729 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2730 u += SEED_C5 * (U32)PTR2UV(&when);
2737 dSP; dTARGET; tryAMAGICun(exp);
2741 value = Perl_exp(value);
2749 dSP; dTARGET; tryAMAGICun(log);
2754 SET_NUMERIC_STANDARD();
2755 DIE(aTHX_ "Can't take log of %"NVgf, value);
2757 value = Perl_log(value);
2765 dSP; dTARGET; tryAMAGICun(sqrt);
2770 SET_NUMERIC_STANDARD();
2771 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2773 value = Perl_sqrt(value);
2780 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2781 * These need to be revisited when a newer toolchain becomes available.
2783 #if defined(__sparc64__) && defined(__GNUC__)
2784 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2785 # undef SPARC64_MODF_WORKAROUND
2786 # define SPARC64_MODF_WORKAROUND 1
2790 #if defined(SPARC64_MODF_WORKAROUND)
2792 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2795 ret = Perl_modf(theVal, &res);
2803 dSP; dTARGET; tryAMAGICun(int);
2806 IV iv = TOPi; /* attempt to convert to IV if possible. */
2807 /* XXX it's arguable that compiler casting to IV might be subtly
2808 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2809 else preferring IV has introduced a subtle behaviour change bug. OTOH
2810 relying on floating point to be accurate is a bug. */
2821 if (value < (NV)UV_MAX + 0.5) {
2824 #if defined(SPARC64_MODF_WORKAROUND)
2825 (void)sparc64_workaround_modf(value, &value);
2827 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2828 # ifdef HAS_MODFL_POW32_BUG
2829 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2831 NV offset = Perl_modf(value, &value);
2832 (void)Perl_modf(offset, &offset);
2836 (void)Perl_modf(value, &value);
2839 double tmp = (double)value;
2840 (void)Perl_modf(tmp, &tmp);
2848 if (value > (NV)IV_MIN - 0.5) {
2851 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2852 # ifdef HAS_MODFL_POW32_BUG
2853 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2855 NV offset = Perl_modf(-value, &value);
2856 (void)Perl_modf(offset, &offset);
2860 (void)Perl_modf(-value, &value);
2864 double tmp = (double)value;
2865 (void)Perl_modf(-tmp, &tmp);
2878 dSP; dTARGET; tryAMAGICun(abs);
2880 /* This will cache the NV value if string isn't actually integer */
2884 /* IVX is precise */
2886 SETu(TOPu); /* force it to be numeric only */
2894 /* 2s complement assumption. Also, not really needed as
2895 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2915 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2921 tmps = (SvPVx(sv, len));
2923 /* If Unicode, try to downgrade
2924 * If not possible, croak. */
2925 SV* tsv = sv_2mortal(newSVsv(sv));
2928 sv_utf8_downgrade(tsv, FALSE);
2931 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2932 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2945 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2951 tmps = (SvPVx(sv, len));
2953 /* If Unicode, try to downgrade
2954 * If not possible, croak. */
2955 SV* tsv = sv_2mortal(newSVsv(sv));
2958 sv_utf8_downgrade(tsv, FALSE);
2961 while (*tmps && len && isSPACE(*tmps))
2966 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2967 else if (*tmps == 'b')
2968 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2970 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2972 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2989 SETi(sv_len_utf8(sv));
3005 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3007 I32 arybase = PL_curcop->cop_arybase;
3011 int num_args = PL_op->op_private & 7;
3012 bool repl_need_utf8_upgrade = FALSE;
3013 bool repl_is_utf8 = FALSE;
3015 SvTAINTED_off(TARG); /* decontaminate */
3016 SvUTF8_off(TARG); /* decontaminate */
3020 repl = SvPV(repl_sv, repl_len);
3021 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3031 sv_utf8_upgrade(sv);
3033 else if (DO_UTF8(sv))
3034 repl_need_utf8_upgrade = TRUE;
3036 tmps = SvPV(sv, curlen);
3038 utf8_curlen = sv_len_utf8(sv);
3039 if (utf8_curlen == curlen)
3042 curlen = utf8_curlen;
3047 if (pos >= arybase) {
3065 else if (len >= 0) {
3067 if (rem > (I32)curlen)
3082 Perl_croak(aTHX_ "substr outside of string");
3083 if (ckWARN(WARN_SUBSTR))
3084 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3091 sv_pos_u2b(sv, &pos, &rem);
3093 sv_setpvn(TARG, tmps, rem);
3094 #ifdef USE_LOCALE_COLLATE
3095 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3100 SV* repl_sv_copy = NULL;
3102 if (repl_need_utf8_upgrade) {
3103 repl_sv_copy = newSVsv(repl_sv);
3104 sv_utf8_upgrade(repl_sv_copy);
3105 repl = SvPV(repl_sv_copy, repl_len);
3106 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3108 sv_insert(sv, pos, rem, repl, repl_len);
3112 SvREFCNT_dec(repl_sv_copy);
3114 else if (lvalue) { /* it's an lvalue! */
3115 if (!SvGMAGICAL(sv)) {
3119 if (ckWARN(WARN_SUBSTR))
3120 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3121 "Attempt to use reference as lvalue in substr");
3123 if (SvOK(sv)) /* is it defined ? */
3124 (void)SvPOK_only_UTF8(sv);
3126 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3129 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3130 TARG = sv_newmortal();
3131 if (SvTYPE(TARG) < SVt_PVLV) {
3132 sv_upgrade(TARG, SVt_PVLV);
3133 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3137 if (LvTARG(TARG) != sv) {
3139 SvREFCNT_dec(LvTARG(TARG));
3140 LvTARG(TARG) = SvREFCNT_inc(sv);
3142 LvTARGOFF(TARG) = upos;
3143 LvTARGLEN(TARG) = urem;
3147 PUSHs(TARG); /* avoid SvSETMAGIC here */
3154 register IV size = POPi;
3155 register IV offset = POPi;
3156 register SV *src = POPs;
3157 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3159 SvTAINTED_off(TARG); /* decontaminate */
3160 if (lvalue) { /* it's an lvalue! */
3161 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3162 TARG = sv_newmortal();
3163 if (SvTYPE(TARG) < SVt_PVLV) {
3164 sv_upgrade(TARG, SVt_PVLV);
3165 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3168 if (LvTARG(TARG) != src) {
3170 SvREFCNT_dec(LvTARG(TARG));
3171 LvTARG(TARG) = SvREFCNT_inc(src);
3173 LvTARGOFF(TARG) = offset;
3174 LvTARGLEN(TARG) = size;
3177 sv_setuv(TARG, do_vecget(src, offset, size));
3192 I32 arybase = PL_curcop->cop_arybase;
3197 offset = POPi - arybase;
3200 tmps = SvPV(big, biglen);
3201 if (offset > 0 && DO_UTF8(big))
3202 sv_pos_u2b(big, &offset, 0);
3205 else if (offset > (I32)biglen)
3207 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3208 (unsigned char*)tmps + biglen, little, 0)))
3211 retval = tmps2 - tmps;
3212 if (retval > 0 && DO_UTF8(big))
3213 sv_pos_b2u(big, &retval);
3214 PUSHi(retval + arybase);
3229 I32 arybase = PL_curcop->cop_arybase;
3235 tmps2 = SvPV(little, llen);
3236 tmps = SvPV(big, blen);
3240 if (offset > 0 && DO_UTF8(big))
3241 sv_pos_u2b(big, &offset, 0);
3242 offset = offset - arybase + llen;
3246 else if (offset > (I32)blen)
3248 if (!(tmps2 = rninstr(tmps, tmps + offset,
3249 tmps2, tmps2 + llen)))
3252 retval = tmps2 - tmps;
3253 if (retval > 0 && DO_UTF8(big))
3254 sv_pos_b2u(big, &retval);
3255 PUSHi(retval + arybase);
3261 dSP; dMARK; dORIGMARK; dTARGET;
3262 do_sprintf(TARG, SP-MARK, MARK+1);
3263 TAINT_IF(SvTAINTED(TARG));
3264 if (DO_UTF8(*(MARK+1)))
3276 U8 *s = (U8*)SvPVx(argsv, len);
3279 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3280 tmpsv = sv_2mortal(newSVsv(argsv));
3281 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3285 XPUSHu(DO_UTF8(argsv) ?
3286 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3298 (void)SvUPGRADE(TARG,SVt_PV);
3300 if (value > 255 && !IN_BYTES) {
3301 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3302 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3303 SvCUR_set(TARG, tmps - SvPVX(TARG));
3305 (void)SvPOK_only(TARG);
3314 *tmps++ = (char)value;
3316 (void)SvPOK_only(TARG);
3317 if (PL_encoding && !IN_BYTES) {
3318 sv_recode_to_utf8(TARG, PL_encoding);
3320 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3321 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3324 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3325 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3341 char *tmps = SvPV(left, len);
3343 if (DO_UTF8(left)) {
3344 /* If Unicode, try to downgrade.
3345 * If not possible, croak.
3346 * Yes, we made this up. */
3347 SV* tsv = sv_2mortal(newSVsv(left));
3350 sv_utf8_downgrade(tsv, FALSE);
3354 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3356 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3362 "The crypt() function is unimplemented due to excessive paranoia.");
3375 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3376 UTF8_IS_START(*s)) {
3377 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3381 utf8_to_uvchr(s, &ulen);
3382 toTITLE_utf8(s, tmpbuf, &tculen);
3383 utf8_to_uvchr(tmpbuf, 0);
3385 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3387 /* slen is the byte length of the whole SV.
3388 * ulen is the byte length of the original Unicode character
3389 * stored as UTF-8 at s.
3390 * tculen is the byte length of the freshly titlecased
3391 * Unicode character stored as UTF-8 at tmpbuf.
3392 * We first set the result to be the titlecased character,
3393 * and then append the rest of the SV data. */
3394 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3396 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3401 s = (U8*)SvPV_force_nomg(sv, slen);
3402 Copy(tmpbuf, s, tculen, U8);
3406 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3408 SvUTF8_off(TARG); /* decontaminate */
3409 sv_setsv_nomg(TARG, sv);
3413 s = (U8*)SvPV_force_nomg(sv, slen);
3415 if (IN_LOCALE_RUNTIME) {
3418 *s = toUPPER_LC(*s);
3437 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3438 UTF8_IS_START(*s)) {
3440 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3444 toLOWER_utf8(s, tmpbuf, &ulen);
3445 uv = utf8_to_uvchr(tmpbuf, 0);
3446 tend = uvchr_to_utf8(tmpbuf, uv);
3448 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3450 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3452 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3457 s = (U8*)SvPV_force_nomg(sv, slen);
3458 Copy(tmpbuf, s, ulen, U8);
3462 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3464 SvUTF8_off(TARG); /* decontaminate */
3465 sv_setsv_nomg(TARG, sv);
3469 s = (U8*)SvPV_force_nomg(sv, slen);
3471 if (IN_LOCALE_RUNTIME) {
3474 *s = toLOWER_LC(*s);
3497 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3499 s = (U8*)SvPV_nomg(sv,len);
3501 SvUTF8_off(TARG); /* decontaminate */
3502 sv_setpvn(TARG, "", 0);
3506 STRLEN nchar = utf8_length(s, s + len);
3508 (void)SvUPGRADE(TARG, SVt_PV);
3509 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3510 (void)SvPOK_only(TARG);
3511 d = (U8*)SvPVX(TARG);
3514 toUPPER_utf8(s, tmpbuf, &ulen);
3515 Copy(tmpbuf, d, ulen, U8);
3521 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3526 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3528 SvUTF8_off(TARG); /* decontaminate */
3529 sv_setsv_nomg(TARG, sv);
3533 s = (U8*)SvPV_force_nomg(sv, len);
3535 register U8 *send = s + len;
3537 if (IN_LOCALE_RUNTIME) {
3540 for (; s < send; s++)
3541 *s = toUPPER_LC(*s);
3544 for (; s < send; s++)
3566 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3568 s = (U8*)SvPV_nomg(sv,len);
3570 SvUTF8_off(TARG); /* decontaminate */
3571 sv_setpvn(TARG, "", 0);
3575 STRLEN nchar = utf8_length(s, s + len);
3577 (void)SvUPGRADE(TARG, SVt_PV);
3578 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3579 (void)SvPOK_only(TARG);
3580 d = (U8*)SvPVX(TARG);
3583 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3584 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3585 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3587 * Now if the sigma is NOT followed by
3588 * /$ignorable_sequence$cased_letter/;
3589 * and it IS preceded by
3590 * /$cased_letter$ignorable_sequence/;
3591 * where $ignorable_sequence is
3592 * [\x{2010}\x{AD}\p{Mn}]*
3593 * and $cased_letter is
3594 * [\p{Ll}\p{Lo}\p{Lt}]
3595 * then it should be mapped to 0x03C2,
3596 * (GREEK SMALL LETTER FINAL SIGMA),
3597 * instead of staying 0x03A3.
3598 * See lib/unicore/SpecCase.txt.
3601 Copy(tmpbuf, d, ulen, U8);
3607 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3612 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3614 SvUTF8_off(TARG); /* decontaminate */
3615 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 = toLOWER_LC(*s);
3631 for (; s < send; s++)
3645 register char *s = SvPV(sv,len);
3648 SvUTF8_off(TARG); /* decontaminate */
3650 (void)SvUPGRADE(TARG, SVt_PV);
3651 SvGROW(TARG, (len * 2) + 1);
3655 if (UTF8_IS_CONTINUED(*s)) {
3656 STRLEN ulen = UTF8SKIP(s);
3680 SvCUR_set(TARG, d - SvPVX(TARG));
3681 (void)SvPOK_only_UTF8(TARG);
3684 sv_setpvn(TARG, s, len);
3686 if (SvSMAGICAL(TARG))
3695 dSP; dMARK; dORIGMARK;
3697 register AV* av = (AV*)POPs;
3698 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3699 I32 arybase = PL_curcop->cop_arybase;
3702 if (SvTYPE(av) == SVt_PVAV) {
3703 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3705 for (svp = MARK + 1; svp <= SP; svp++) {
3710 if (max > AvMAX(av))
3713 while (++MARK <= SP) {
3714 elem = SvIVx(*MARK);
3718 svp = av_fetch(av, elem, lval);
3720 if (!svp || *svp == &PL_sv_undef)
3721 DIE(aTHX_ PL_no_aelem, elem);
3722 if (PL_op->op_private & OPpLVAL_INTRO)
3723 save_aelem(av, elem, svp);
3725 *MARK = svp ? *svp : &PL_sv_undef;
3728 if (GIMME != G_ARRAY) {
3736 /* Associative arrays. */
3741 HV *hash = (HV*)POPs;
3743 I32 gimme = GIMME_V;
3746 /* might clobber stack_sp */
3747 entry = hv_iternext(hash);
3752 SV* sv = hv_iterkeysv(entry);
3753 PUSHs(sv); /* won't clobber stack_sp */
3754 if (gimme == G_ARRAY) {
3757 /* might clobber stack_sp */
3758 val = hv_iterval(hash, entry);
3763 else if (gimme == G_SCALAR)
3782 I32 gimme = GIMME_V;
3783 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3787 if (PL_op->op_private & OPpSLICE) {
3791 hvtype = SvTYPE(hv);
3792 if (hvtype == SVt_PVHV) { /* hash element */
3793 while (++MARK <= SP) {
3794 sv = hv_delete_ent(hv, *MARK, discard, 0);
3795 *MARK = sv ? sv : &PL_sv_undef;
3798 else if (hvtype == SVt_PVAV) { /* array element */
3799 if (PL_op->op_flags & OPf_SPECIAL) {
3800 while (++MARK <= SP) {
3801 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3802 *MARK = sv ? sv : &PL_sv_undef;
3807 DIE(aTHX_ "Not a HASH reference");
3810 else if (gimme == G_SCALAR) {
3819 if (SvTYPE(hv) == SVt_PVHV)
3820 sv = hv_delete_ent(hv, keysv, discard, 0);
3821 else if (SvTYPE(hv) == SVt_PVAV) {
3822 if (PL_op->op_flags & OPf_SPECIAL)
3823 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3825 DIE(aTHX_ "panic: avhv_delete no longer supported");
3828 DIE(aTHX_ "Not a HASH reference");
3843 if (PL_op->op_private & OPpEXISTS_SUB) {
3847 cv = sv_2cv(sv, &hv, &gv, FALSE);
3850 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3856 if (SvTYPE(hv) == SVt_PVHV) {
3857 if (hv_exists_ent(hv, tmpsv, 0))
3860 else if (SvTYPE(hv) == SVt_PVAV) {
3861 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3862 if (av_exists((AV*)hv, SvIV(tmpsv)))
3867 DIE(aTHX_ "Not a HASH reference");
3874 dSP; dMARK; dORIGMARK;
3875 register HV *hv = (HV*)POPs;
3876 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3877 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3878 bool other_magic = FALSE;
3884 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3885 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3886 /* Try to preserve the existenceness of a tied hash
3887 * element by using EXISTS and DELETE if possible.
3888 * Fallback to FETCH and STORE otherwise */
3889 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3890 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3891 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3894 while (++MARK <= SP) {
3898 bool preeminent = FALSE;
3901 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3902 hv_exists_ent(hv, keysv, 0);
3905 he = hv_fetch_ent(hv, keysv, lval, 0);
3906 svp = he ? &HeVAL(he) : 0;
3909 if (!svp || *svp == &PL_sv_undef) {
3911 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3915 save_helem(hv, keysv, svp);
3918 char *key = SvPV(keysv, keylen);
3919 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3923 *MARK = svp ? *svp : &PL_sv_undef;
3925 if (GIMME != G_ARRAY) {
3933 /* List operators. */
3938 if (GIMME != G_ARRAY) {
3940 *MARK = *SP; /* unwanted list, return last item */
3942 *MARK = &PL_sv_undef;
3951 SV **lastrelem = PL_stack_sp;
3952 SV **lastlelem = PL_stack_base + POPMARK;
3953 SV **firstlelem = PL_stack_base + POPMARK + 1;
3954 register SV **firstrelem = lastlelem + 1;
3955 I32 arybase = PL_curcop->cop_arybase;
3956 I32 lval = PL_op->op_flags & OPf_MOD;
3957 I32 is_something_there = lval;
3959 register I32 max = lastrelem - lastlelem;
3960 register SV **lelem;
3963 if (GIMME != G_ARRAY) {
3964 ix = SvIVx(*lastlelem);
3969 if (ix < 0 || ix >= max)
3970 *firstlelem = &PL_sv_undef;
3972 *firstlelem = firstrelem[ix];
3978 SP = firstlelem - 1;
3982 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3988 if (ix < 0 || ix >= max)
3989 *lelem = &PL_sv_undef;
3991 is_something_there = TRUE;
3992 if (!(*lelem = firstrelem[ix]))
3993 *lelem = &PL_sv_undef;
3996 if (is_something_there)
3999 SP = firstlelem - 1;
4005 dSP; dMARK; dORIGMARK;
4006 I32 items = SP - MARK;
4007 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4008 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4015 dSP; dMARK; dORIGMARK;
4016 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4020 SV *val = NEWSV(46, 0);
4022 sv_setsv(val, *++MARK);
4023 else if (ckWARN(WARN_MISC))
4024 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4025 (void)hv_store_ent(hv,key,val,0);
4034 dSP; dMARK; dORIGMARK;
4035 register AV *ary = (AV*)*++MARK;
4039 register I32 offset;
4040 register I32 length;
4047 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4048 *MARK-- = SvTIED_obj((SV*)ary, mg);
4052 call_method("SPLICE",GIMME_V);
4061 offset = i = SvIVx(*MARK);
4063 offset += AvFILLp(ary) + 1;
4065 offset -= PL_curcop->cop_arybase;
4067 DIE(aTHX_ PL_no_aelem, i);
4069 length = SvIVx(*MARK++);
4071 length += AvFILLp(ary) - offset + 1;
4077 length = AvMAX(ary) + 1; /* close enough to infinity */
4081 length = AvMAX(ary) + 1;
4083 if (offset > AvFILLp(ary) + 1) {
4084 if (ckWARN(WARN_MISC))
4085 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4086 offset = AvFILLp(ary) + 1;
4088 after = AvFILLp(ary) + 1 - (offset + length);
4089 if (after < 0) { /* not that much array */
4090 length += after; /* offset+length now in array */
4096 /* At this point, MARK .. SP-1 is our new LIST */
4099 diff = newlen - length;
4100 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4103 if (diff < 0) { /* shrinking the area */
4105 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4106 Copy(MARK, tmparyval, newlen, SV*);
4109 MARK = ORIGMARK + 1;
4110 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4111 MEXTEND(MARK, length);
4112 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4114 EXTEND_MORTAL(length);
4115 for (i = length, dst = MARK; i; i--) {
4116 sv_2mortal(*dst); /* free them eventualy */
4123 *MARK = AvARRAY(ary)[offset+length-1];
4126 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4127 SvREFCNT_dec(*dst++); /* free them now */
4130 AvFILLp(ary) += diff;
4132 /* pull up or down? */
4134 if (offset < after) { /* easier to pull up */
4135 if (offset) { /* esp. if nothing to pull */
4136 src = &AvARRAY(ary)[offset-1];
4137 dst = src - diff; /* diff is negative */
4138 for (i = offset; i > 0; i--) /* can't trust Copy */
4142 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4146 if (after) { /* anything to pull down? */
4147 src = AvARRAY(ary) + offset + length;
4148 dst = src + diff; /* diff is negative */
4149 Move(src, dst, after, SV*);
4151 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4152 /* avoid later double free */
4156 dst[--i] = &PL_sv_undef;
4159 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4161 *dst = NEWSV(46, 0);
4162 sv_setsv(*dst++, *src++);
4164 Safefree(tmparyval);
4167 else { /* no, expanding (or same) */
4169 New(452, tmparyval, length, SV*); /* so remember deletion */
4170 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4173 if (diff > 0) { /* expanding */
4175 /* push up or down? */
4177 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4181 Move(src, dst, offset, SV*);
4183 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4185 AvFILLp(ary) += diff;
4188 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4189 av_extend(ary, AvFILLp(ary) + diff);
4190 AvFILLp(ary) += diff;
4193 dst = AvARRAY(ary) + AvFILLp(ary);
4195 for (i = after; i; i--) {
4202 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4203 *dst = NEWSV(46, 0);
4204 sv_setsv(*dst++, *src++);
4206 MARK = ORIGMARK + 1;
4207 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4209 Copy(tmparyval, MARK, length, SV*);
4211 EXTEND_MORTAL(length);
4212 for (i = length, dst = MARK; i; i--) {
4213 sv_2mortal(*dst); /* free them eventualy */
4217 Safefree(tmparyval);
4221 else if (length--) {
4222 *MARK = tmparyval[length];
4225 while (length-- > 0)
4226 SvREFCNT_dec(tmparyval[length]);
4228 Safefree(tmparyval);
4231 *MARK = &PL_sv_undef;
4239 dSP; dMARK; dORIGMARK; dTARGET;
4240 register AV *ary = (AV*)*++MARK;
4241 register SV *sv = &PL_sv_undef;
4244 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4245 *MARK-- = SvTIED_obj((SV*)ary, mg);
4249 call_method("PUSH",G_SCALAR|G_DISCARD);
4254 /* Why no pre-extend of ary here ? */
4255 for (++MARK; MARK <= SP; MARK++) {
4258 sv_setsv(sv, *MARK);
4263 PUSHi( AvFILL(ary) + 1 );
4271 SV *sv = av_pop(av);
4273 (void)sv_2mortal(sv);
4282 SV *sv = av_shift(av);
4287 (void)sv_2mortal(sv);
4294 dSP; dMARK; dORIGMARK; dTARGET;
4295 register AV *ary = (AV*)*++MARK;
4300 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4301 *MARK-- = SvTIED_obj((SV*)ary, mg);
4305 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4310 av_unshift(ary, SP - MARK);
4313 sv_setsv(sv, *++MARK);
4314 (void)av_store(ary, i++, sv);
4318 PUSHi( AvFILL(ary) + 1 );
4328 if (GIMME == G_ARRAY) {
4335 /* safe as long as stack cannot get extended in the above */
4340 register char *down;
4345 SvUTF8_off(TARG); /* decontaminate */
4347 do_join(TARG, &PL_sv_no, MARK, SP);
4349 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4350 up = SvPV_force(TARG, len);
4352 if (DO_UTF8(TARG)) { /* first reverse each character */
4353 U8* s = (U8*)SvPVX(TARG);
4354 U8* send = (U8*)(s + len);
4356 if (UTF8_IS_INVARIANT(*s)) {
4361 if (!utf8_to_uvchr(s, 0))
4365 down = (char*)(s - 1);
4366 /* reverse this character */
4370 *down-- = (char)tmp;
4376 down = SvPVX(TARG) + len - 1;
4380 *down-- = (char)tmp;
4382 (void)SvPOK_only_UTF8(TARG);
4394 register IV limit = POPi; /* note, negative is forever */
4397 register char *s = SvPV(sv, len);
4398 bool do_utf8 = DO_UTF8(sv);
4399 char *strend = s + len;
4401 register REGEXP *rx;
4405 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4406 I32 maxiters = slen + 10;
4409 I32 origlimit = limit;
4412 AV *oldstack = PL_curstack;
4413 I32 gimme = GIMME_V;
4414 I32 oldsave = PL_savestack_ix;
4415 I32 make_mortal = 1;
4416 MAGIC *mg = (MAGIC *) NULL;
4419 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4424 DIE(aTHX_ "panic: pp_split");
4427 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4428 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4430 RX_MATCH_UTF8_set(rx, do_utf8);
4432 if (pm->op_pmreplroot) {
4434 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4436 ary = GvAVn((GV*)pm->op_pmreplroot);
4439 else if (gimme != G_ARRAY)
4440 ary = GvAVn(PL_defgv);
4443 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4449 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4451 XPUSHs(SvTIED_obj((SV*)ary, mg));
4457 for (i = AvFILLp(ary); i >= 0; i--)
4458 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4460 /* temporarily switch stacks */
4461 SWITCHSTACK(PL_curstack, ary);
4462 PL_curstackinfo->si_stack = ary;
4466 base = SP - PL_stack_base;
4468 if (pm->op_pmflags & PMf_SKIPWHITE) {
4469 if (pm->op_pmflags & PMf_LOCALE) {
4470 while (isSPACE_LC(*s))
4478 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4479 SAVEINT(PL_multiline);
4480 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4484 limit = maxiters + 2;
4485 if (pm->op_pmflags & PMf_WHITE) {
4488 while (m < strend &&
4489 !((pm->op_pmflags & PMf_LOCALE)
4490 ? isSPACE_LC(*m) : isSPACE(*m)))
4495 dstr = NEWSV(30, m-s);
4496 sv_setpvn(dstr, s, m-s);
4500 (void)SvUTF8_on(dstr);
4504 while (s < strend &&
4505 ((pm->op_pmflags & PMf_LOCALE)
4506 ? isSPACE_LC(*s) : isSPACE(*s)))
4510 else if (strEQ("^", rx->precomp)) {
4513 for (m = s; m < strend && *m != '\n'; m++) ;
4517 dstr = NEWSV(30, m-s);
4518 sv_setpvn(dstr, s, m-s);
4522 (void)SvUTF8_on(dstr);
4527 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4528 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4529 && (rx->reganch & ROPT_CHECK_ALL)
4530 && !(rx->reganch & ROPT_ANCH)) {
4531 int tail = (rx->reganch & RE_INTUIT_TAIL);
4532 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4535 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4537 char c = *SvPV(csv, n_a);
4540 for (m = s; m < strend && *m != c; m++) ;
4543 dstr = NEWSV(30, m-s);
4544 sv_setpvn(dstr, s, m-s);
4548 (void)SvUTF8_on(dstr);
4550 /* The rx->minlen is in characters but we want to step
4551 * s ahead by bytes. */
4553 s = (char*)utf8_hop((U8*)m, len);
4555 s = m + len; /* Fake \n at the end */
4560 while (s < strend && --limit &&
4561 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4562 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4565 dstr = NEWSV(31, m-s);
4566 sv_setpvn(dstr, s, m-s);
4570 (void)SvUTF8_on(dstr);
4572 /* The rx->minlen is in characters but we want to step
4573 * s ahead by bytes. */
4575 s = (char*)utf8_hop((U8*)m, len);
4577 s = m + len; /* Fake \n at the end */
4582 maxiters += slen * rx->nparens;
4583 while (s < strend && --limit
4584 /* && (!rx->check_substr
4585 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4587 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4588 1 /* minend */, sv, NULL, 0))
4590 TAINT_IF(RX_MATCH_TAINTED(rx));
4591 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4596 strend = s + (strend - m);
4598 m = rx->startp[0] + orig;
4599 dstr = NEWSV(32, m-s);
4600 sv_setpvn(dstr, s, m-s);
4604 (void)SvUTF8_on(dstr);
4607 for (i = 1; i <= (I32)rx->nparens; i++) {
4608 s = rx->startp[i] + orig;
4609 m = rx->endp[i] + orig;
4611 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4612 parens that didn't match -- they should be set to
4613 undef, not the empty string */
4614 if (m >= orig && s >= orig) {
4615 dstr = NEWSV(33, m-s);
4616 sv_setpvn(dstr, s, m-s);
4619 dstr = &PL_sv_undef; /* undef, not "" */
4623 (void)SvUTF8_on(dstr);
4627 s = rx->endp[0] + orig;
4631 LEAVE_SCOPE(oldsave);
4632 iters = (SP - PL_stack_base) - base;
4633 if (iters > maxiters)
4634 DIE(aTHX_ "Split loop");
4636 /* keep field after final delim? */
4637 if (s < strend || (iters && origlimit)) {
4638 STRLEN l = strend - s;
4639 dstr = NEWSV(34, l);
4640 sv_setpvn(dstr, s, l);
4644 (void)SvUTF8_on(dstr);
4648 else if (!origlimit) {
4649 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4650 if (TOPs && !make_mortal)
4659 SWITCHSTACK(ary, oldstack);
4660 PL_curstackinfo->si_stack = oldstack;
4661 if (SvSMAGICAL(ary)) {
4666 if (gimme == G_ARRAY) {
4668 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4676 call_method("PUSH",G_SCALAR|G_DISCARD);
4679 if (gimme == G_ARRAY) {
4680 /* EXTEND should not be needed - we just popped them */
4682 for (i=0; i < iters; i++) {
4683 SV **svp = av_fetch(ary, i, FALSE);
4684 PUSHs((svp) ? *svp : &PL_sv_undef);
4691 if (gimme == G_ARRAY)
4694 if (iters || !pm->op_pmreplroot) {
4708 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4709 || SvTYPE(retsv) == SVt_PVCV) {
4710 retsv = refto(retsv);
4718 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");