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. */
882 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
883 #ifdef PERL_PRESERVE_IVUV
884 /* ** is implemented with pow. pow is floating point. Perl programmers
885 write 2 ** 31 and expect it to be 2147483648
886 pow never made any guarantee to deliver a result to 53 (or whatever)
887 bits of accuracy. Which is unfortunate, as perl programmers expect it
888 to, and on some platforms (eg Irix with long doubles) it doesn't in
889 a very visible case. (2 ** 31, which a regression test uses)
890 So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
895 bool baseuok = SvUOK(TOPm1s);
899 baseuv = SvUVX(TOPm1s);
901 IV iv = SvIVX(TOPm1s);
904 baseuok = TRUE; /* effectively it's a UV now */
906 baseuv = -iv; /* abs, baseuok == false records sign */
920 goto float_it; /* Can't do negative powers this way. */
923 /* now we have integer ** positive integer.
924 foo & (foo - 1) is zero only for a power of 2. */
925 if (!(baseuv & (baseuv - 1))) {
926 /* We are raising power-of-2 to postive integer.
927 The logic here will work for any base (even non-integer
928 bases) but it can be less accurate than
929 pow (base,power) or exp (power * log (base)) when the
930 intermediate values start to spill out of the mantissa.
931 With powers of 2 we know this can't happen.
932 And powers of 2 are the favourite thing for perl
933 programmers to notice ** not doing what they mean. */
935 NV base = baseuok ? baseuv : -(NV)baseuv;
938 /* The logic is this.
939 x ** n === x ** m1 * x ** m2 where n = m1 + m2
940 so as 42 is 32 + 8 + 2
941 x ** 42 can be written as
942 x ** 32 * x ** 8 * x ** 2
943 I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
944 x ** 2n is x ** n * x ** n
945 So I loop round, squaring x each time
946 (x, x ** 2, x ** 4, x ** 8) and multiply the result
947 by the x-value whenever that bit is set in the power.
948 To finish as soon as possible I zero bits in the power
949 when I've done them, so that power becomes zero when
950 I clear the last bit (no more to do), and the loop
952 for (; power; base *= base, n++) {
953 /* Do I look like I trust gcc with long longs here?
955 UV bit = (UV)1 << (UV)n;
958 /* Only bother to clear the bit if it is set. */
960 /* Avoid squaring base again if we're done. */
961 if (power == 0) break;
975 SETn( Perl_pow( left, right) );
982 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
983 #ifdef PERL_PRESERVE_IVUV
986 /* Unless the left argument is integer in range we are going to have to
987 use NV maths. Hence only attempt to coerce the right argument if
988 we know the left is integer. */
989 /* Left operand is defined, so is it IV? */
992 bool auvok = SvUOK(TOPm1s);
993 bool buvok = SvUOK(TOPs);
994 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
995 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1002 alow = SvUVX(TOPm1s);
1004 IV aiv = SvIVX(TOPm1s);
1007 auvok = TRUE; /* effectively it's a UV now */
1009 alow = -aiv; /* abs, auvok == false records sign */
1015 IV biv = SvIVX(TOPs);
1018 buvok = TRUE; /* effectively it's a UV now */
1020 blow = -biv; /* abs, buvok == false records sign */
1024 /* If this does sign extension on unsigned it's time for plan B */
1025 ahigh = alow >> (4 * sizeof (UV));
1027 bhigh = blow >> (4 * sizeof (UV));
1029 if (ahigh && bhigh) {
1030 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1031 which is overflow. Drop to NVs below. */
1032 } else if (!ahigh && !bhigh) {
1033 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1034 so the unsigned multiply cannot overflow. */
1035 UV product = alow * blow;
1036 if (auvok == buvok) {
1037 /* -ve * -ve or +ve * +ve gives a +ve result. */
1041 } else if (product <= (UV)IV_MIN) {
1042 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1043 /* -ve result, which could overflow an IV */
1045 SETi( -(IV)product );
1047 } /* else drop to NVs below. */
1049 /* One operand is large, 1 small */
1052 /* swap the operands */
1054 bhigh = blow; /* bhigh now the temp var for the swap */
1058 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1059 multiplies can't overflow. shift can, add can, -ve can. */
1060 product_middle = ahigh * blow;
1061 if (!(product_middle & topmask)) {
1062 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1064 product_middle <<= (4 * sizeof (UV));
1065 product_low = alow * blow;
1067 /* as for pp_add, UV + something mustn't get smaller.
1068 IIRC ANSI mandates this wrapping *behaviour* for
1069 unsigned whatever the actual representation*/
1070 product_low += product_middle;
1071 if (product_low >= product_middle) {
1072 /* didn't overflow */
1073 if (auvok == buvok) {
1074 /* -ve * -ve or +ve * +ve gives a +ve result. */
1076 SETu( product_low );
1078 } else if (product_low <= (UV)IV_MIN) {
1079 /* 2s complement assumption again */
1080 /* -ve result, which could overflow an IV */
1082 SETi( -(IV)product_low );
1084 } /* else drop to NVs below. */
1086 } /* product_middle too large */
1087 } /* ahigh && bhigh */
1088 } /* SvIOK(TOPm1s) */
1093 SETn( left * right );
1100 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1101 /* Only try to do UV divide first
1102 if ((SLOPPYDIVIDE is true) or
1103 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1105 The assumption is that it is better to use floating point divide
1106 whenever possible, only doing integer divide first if we can't be sure.
1107 If NV_PRESERVES_UV is true then we know at compile time that no UV
1108 can be too large to preserve, so don't need to compile the code to
1109 test the size of UVs. */
1112 # define PERL_TRY_UV_DIVIDE
1113 /* ensure that 20./5. == 4. */
1115 # ifdef PERL_PRESERVE_IVUV
1116 # ifndef NV_PRESERVES_UV
1117 # define PERL_TRY_UV_DIVIDE
1122 #ifdef PERL_TRY_UV_DIVIDE
1125 SvIV_please(TOPm1s);
1126 if (SvIOK(TOPm1s)) {
1127 bool left_non_neg = SvUOK(TOPm1s);
1128 bool right_non_neg = SvUOK(TOPs);
1132 if (right_non_neg) {
1133 right = SvUVX(TOPs);
1136 IV biv = SvIVX(TOPs);
1139 right_non_neg = TRUE; /* effectively it's a UV now */
1145 /* historically undef()/0 gives a "Use of uninitialized value"
1146 warning before dieing, hence this test goes here.
1147 If it were immediately before the second SvIV_please, then
1148 DIE() would be invoked before left was even inspected, so
1149 no inpsection would give no warning. */
1151 DIE(aTHX_ "Illegal division by zero");
1154 left = SvUVX(TOPm1s);
1157 IV aiv = SvIVX(TOPm1s);
1160 left_non_neg = TRUE; /* effectively it's a UV now */
1169 /* For sloppy divide we always attempt integer division. */
1171 /* Otherwise we only attempt it if either or both operands
1172 would not be preserved by an NV. If both fit in NVs
1173 we fall through to the NV divide code below. However,
1174 as left >= right to ensure integer result here, we know that
1175 we can skip the test on the right operand - right big
1176 enough not to be preserved can't get here unless left is
1179 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1182 /* Integer division can't overflow, but it can be imprecise. */
1183 UV result = left / right;
1184 if (result * right == left) {
1185 SP--; /* result is valid */
1186 if (left_non_neg == right_non_neg) {
1187 /* signs identical, result is positive. */
1191 /* 2s complement assumption */
1192 if (result <= (UV)IV_MIN)
1193 SETi( -(IV)result );
1195 /* It's exact but too negative for IV. */
1196 SETn( -(NV)result );
1199 } /* tried integer divide but it was not an integer result */
1200 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1201 } /* left wasn't SvIOK */
1202 } /* right wasn't SvIOK */
1203 #endif /* PERL_TRY_UV_DIVIDE */
1207 DIE(aTHX_ "Illegal division by zero");
1208 PUSHn( left / right );
1215 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1219 bool left_neg = FALSE;
1220 bool right_neg = FALSE;
1221 bool use_double = FALSE;
1222 bool dright_valid = FALSE;
1228 right_neg = !SvUOK(TOPs);
1230 right = SvUVX(POPs);
1232 IV biv = SvIVX(POPs);
1235 right_neg = FALSE; /* effectively it's a UV now */
1243 right_neg = dright < 0;
1246 if (dright < UV_MAX_P1) {
1247 right = U_V(dright);
1248 dright_valid = TRUE; /* In case we need to use double below. */
1254 /* At this point use_double is only true if right is out of range for
1255 a UV. In range NV has been rounded down to nearest UV and
1256 use_double false. */
1258 if (!use_double && SvIOK(TOPs)) {
1260 left_neg = !SvUOK(TOPs);
1264 IV aiv = SvIVX(POPs);
1267 left_neg = FALSE; /* effectively it's a UV now */
1276 left_neg = dleft < 0;
1280 /* This should be exactly the 5.6 behaviour - if left and right are
1281 both in range for UV then use U_V() rather than floor. */
1283 if (dleft < UV_MAX_P1) {
1284 /* right was in range, so is dleft, so use UVs not double.
1288 /* left is out of range for UV, right was in range, so promote
1289 right (back) to double. */
1291 /* The +0.5 is used in 5.6 even though it is not strictly
1292 consistent with the implicit +0 floor in the U_V()
1293 inside the #if 1. */
1294 dleft = Perl_floor(dleft + 0.5);
1297 dright = Perl_floor(dright + 0.5);
1307 DIE(aTHX_ "Illegal modulus zero");
1309 dans = Perl_fmod(dleft, dright);
1310 if ((left_neg != right_neg) && dans)
1311 dans = dright - dans;
1314 sv_setnv(TARG, dans);
1320 DIE(aTHX_ "Illegal modulus zero");
1323 if ((left_neg != right_neg) && ans)
1326 /* XXX may warn: unary minus operator applied to unsigned type */
1327 /* could change -foo to be (~foo)+1 instead */
1328 if (ans <= ~((UV)IV_MAX)+1)
1329 sv_setiv(TARG, ~ans+1);
1331 sv_setnv(TARG, -(NV)ans);
1334 sv_setuv(TARG, ans);
1343 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1345 register IV count = POPi;
1346 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1348 I32 items = SP - MARK;
1351 max = items * count;
1356 /* This code was intended to fix 20010809.028:
1359 for (($x =~ /./g) x 2) {
1360 print chop; # "abcdabcd" expected as output.
1363 * but that change (#11635) broke this code:
1365 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1367 * I can't think of a better fix that doesn't introduce
1368 * an efficiency hit by copying the SVs. The stack isn't
1369 * refcounted, and mortalisation obviously doesn't
1370 * Do The Right Thing when the stack has more than
1371 * one pointer to the same mortal value.
1375 *SP = sv_2mortal(newSVsv(*SP));
1385 repeatcpy((char*)(MARK + items), (char*)MARK,
1386 items * sizeof(SV*), count - 1);
1389 else if (count <= 0)
1392 else { /* Note: mark already snarfed by pp_list */
1397 SvSetSV(TARG, tmpstr);
1398 SvPV_force(TARG, len);
1399 isutf = DO_UTF8(TARG);
1404 SvGROW(TARG, (count * len) + 1);
1405 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1406 SvCUR(TARG) *= count;
1408 *SvEND(TARG) = '\0';
1411 (void)SvPOK_only_UTF8(TARG);
1413 (void)SvPOK_only(TARG);
1415 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1416 /* The parser saw this as a list repeat, and there
1417 are probably several items on the stack. But we're
1418 in scalar context, and there's no pp_list to save us
1419 now. So drop the rest of the items -- robin@kitsite.com
1432 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1433 useleft = USE_LEFT(TOPm1s);
1434 #ifdef PERL_PRESERVE_IVUV
1435 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1436 "bad things" happen if you rely on signed integers wrapping. */
1439 /* Unless the left argument is integer in range we are going to have to
1440 use NV maths. Hence only attempt to coerce the right argument if
1441 we know the left is integer. */
1442 register UV auv = 0;
1448 a_valid = auvok = 1;
1449 /* left operand is undef, treat as zero. */
1451 /* Left operand is defined, so is it IV? */
1452 SvIV_please(TOPm1s);
1453 if (SvIOK(TOPm1s)) {
1454 if ((auvok = SvUOK(TOPm1s)))
1455 auv = SvUVX(TOPm1s);
1457 register IV aiv = SvIVX(TOPm1s);
1460 auvok = 1; /* Now acting as a sign flag. */
1461 } else { /* 2s complement assumption for IV_MIN */
1469 bool result_good = 0;
1472 bool buvok = SvUOK(TOPs);
1477 register IV biv = SvIVX(TOPs);
1484 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1485 else "IV" now, independent of how it came in.
1486 if a, b represents positive, A, B negative, a maps to -A etc
1491 all UV maths. negate result if A negative.
1492 subtract if signs same, add if signs differ. */
1494 if (auvok ^ buvok) {
1503 /* Must get smaller */
1508 if (result <= buv) {
1509 /* result really should be -(auv-buv). as its negation
1510 of true value, need to swap our result flag */
1522 if (result <= (UV)IV_MIN)
1523 SETi( -(IV)result );
1525 /* result valid, but out of range for IV. */
1526 SETn( -(NV)result );
1530 } /* Overflow, drop through to NVs. */
1534 useleft = USE_LEFT(TOPm1s);
1538 /* left operand is undef, treat as zero - value */
1542 SETn( TOPn - value );
1549 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1552 if (PL_op->op_private & HINT_INTEGER) {
1566 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1569 if (PL_op->op_private & HINT_INTEGER) {
1583 dSP; tryAMAGICbinSET(lt,0);
1584 #ifdef PERL_PRESERVE_IVUV
1587 SvIV_please(TOPm1s);
1588 if (SvIOK(TOPm1s)) {
1589 bool auvok = SvUOK(TOPm1s);
1590 bool buvok = SvUOK(TOPs);
1592 if (!auvok && !buvok) { /* ## IV < IV ## */
1593 IV aiv = SvIVX(TOPm1s);
1594 IV biv = SvIVX(TOPs);
1597 SETs(boolSV(aiv < biv));
1600 if (auvok && buvok) { /* ## UV < UV ## */
1601 UV auv = SvUVX(TOPm1s);
1602 UV buv = SvUVX(TOPs);
1605 SETs(boolSV(auv < buv));
1608 if (auvok) { /* ## UV < IV ## */
1615 /* As (a) is a UV, it's >=0, so it cannot be < */
1620 SETs(boolSV(auv < (UV)biv));
1623 { /* ## IV < UV ## */
1627 aiv = SvIVX(TOPm1s);
1629 /* As (b) is a UV, it's >=0, so it must be < */
1636 SETs(boolSV((UV)aiv < buv));
1642 #ifndef NV_PRESERVES_UV
1643 #ifdef PERL_PRESERVE_IVUV
1646 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1648 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1654 SETs(boolSV(TOPn < value));
1661 dSP; tryAMAGICbinSET(gt,0);
1662 #ifdef PERL_PRESERVE_IVUV
1665 SvIV_please(TOPm1s);
1666 if (SvIOK(TOPm1s)) {
1667 bool auvok = SvUOK(TOPm1s);
1668 bool buvok = SvUOK(TOPs);
1670 if (!auvok && !buvok) { /* ## IV > IV ## */
1671 IV aiv = SvIVX(TOPm1s);
1672 IV biv = SvIVX(TOPs);
1675 SETs(boolSV(aiv > biv));
1678 if (auvok && buvok) { /* ## UV > UV ## */
1679 UV auv = SvUVX(TOPm1s);
1680 UV buv = SvUVX(TOPs);
1683 SETs(boolSV(auv > buv));
1686 if (auvok) { /* ## UV > IV ## */
1693 /* As (a) is a UV, it's >=0, so it must be > */
1698 SETs(boolSV(auv > (UV)biv));
1701 { /* ## IV > UV ## */
1705 aiv = SvIVX(TOPm1s);
1707 /* As (b) is a UV, it's >=0, so it cannot be > */
1714 SETs(boolSV((UV)aiv > buv));
1720 #ifndef NV_PRESERVES_UV
1721 #ifdef PERL_PRESERVE_IVUV
1724 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1726 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1732 SETs(boolSV(TOPn > value));
1739 dSP; tryAMAGICbinSET(le,0);
1740 #ifdef PERL_PRESERVE_IVUV
1743 SvIV_please(TOPm1s);
1744 if (SvIOK(TOPm1s)) {
1745 bool auvok = SvUOK(TOPm1s);
1746 bool buvok = SvUOK(TOPs);
1748 if (!auvok && !buvok) { /* ## IV <= IV ## */
1749 IV aiv = SvIVX(TOPm1s);
1750 IV biv = SvIVX(TOPs);
1753 SETs(boolSV(aiv <= biv));
1756 if (auvok && buvok) { /* ## UV <= UV ## */
1757 UV auv = SvUVX(TOPm1s);
1758 UV buv = SvUVX(TOPs);
1761 SETs(boolSV(auv <= buv));
1764 if (auvok) { /* ## UV <= IV ## */
1771 /* As (a) is a UV, it's >=0, so a cannot be <= */
1776 SETs(boolSV(auv <= (UV)biv));
1779 { /* ## IV <= UV ## */
1783 aiv = SvIVX(TOPm1s);
1785 /* As (b) is a UV, it's >=0, so a must be <= */
1792 SETs(boolSV((UV)aiv <= buv));
1798 #ifndef NV_PRESERVES_UV
1799 #ifdef PERL_PRESERVE_IVUV
1802 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1804 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1810 SETs(boolSV(TOPn <= value));
1817 dSP; tryAMAGICbinSET(ge,0);
1818 #ifdef PERL_PRESERVE_IVUV
1821 SvIV_please(TOPm1s);
1822 if (SvIOK(TOPm1s)) {
1823 bool auvok = SvUOK(TOPm1s);
1824 bool buvok = SvUOK(TOPs);
1826 if (!auvok && !buvok) { /* ## IV >= IV ## */
1827 IV aiv = SvIVX(TOPm1s);
1828 IV biv = SvIVX(TOPs);
1831 SETs(boolSV(aiv >= biv));
1834 if (auvok && buvok) { /* ## UV >= UV ## */
1835 UV auv = SvUVX(TOPm1s);
1836 UV buv = SvUVX(TOPs);
1839 SETs(boolSV(auv >= buv));
1842 if (auvok) { /* ## UV >= IV ## */
1849 /* As (a) is a UV, it's >=0, so it must be >= */
1854 SETs(boolSV(auv >= (UV)biv));
1857 { /* ## IV >= UV ## */
1861 aiv = SvIVX(TOPm1s);
1863 /* As (b) is a UV, it's >=0, so a cannot be >= */
1870 SETs(boolSV((UV)aiv >= buv));
1876 #ifndef NV_PRESERVES_UV
1877 #ifdef PERL_PRESERVE_IVUV
1880 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1882 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1888 SETs(boolSV(TOPn >= value));
1895 dSP; tryAMAGICbinSET(ne,0);
1896 #ifndef NV_PRESERVES_UV
1897 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1899 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1903 #ifdef PERL_PRESERVE_IVUV
1906 SvIV_please(TOPm1s);
1907 if (SvIOK(TOPm1s)) {
1908 bool auvok = SvUOK(TOPm1s);
1909 bool buvok = SvUOK(TOPs);
1911 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1912 /* Casting IV to UV before comparison isn't going to matter
1913 on 2s complement. On 1s complement or sign&magnitude
1914 (if we have any of them) it could make negative zero
1915 differ from normal zero. As I understand it. (Need to
1916 check - is negative zero implementation defined behaviour
1918 UV buv = SvUVX(POPs);
1919 UV auv = SvUVX(TOPs);
1921 SETs(boolSV(auv != buv));
1924 { /* ## Mixed IV,UV ## */
1928 /* != is commutative so swap if needed (save code) */
1930 /* swap. top of stack (b) is the iv */
1934 /* As (a) is a UV, it's >0, so it cannot be == */
1943 /* As (b) is a UV, it's >0, so it cannot be == */
1947 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1949 SETs(boolSV((UV)iv != uv));
1957 SETs(boolSV(TOPn != value));
1964 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1965 #ifndef NV_PRESERVES_UV
1966 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1967 UV right = PTR2UV(SvRV(POPs));
1968 UV left = PTR2UV(SvRV(TOPs));
1969 SETi((left > right) - (left < right));
1973 #ifdef PERL_PRESERVE_IVUV
1974 /* Fortunately it seems NaN isn't IOK */
1977 SvIV_please(TOPm1s);
1978 if (SvIOK(TOPm1s)) {
1979 bool leftuvok = SvUOK(TOPm1s);
1980 bool rightuvok = SvUOK(TOPs);
1982 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1983 IV leftiv = SvIVX(TOPm1s);
1984 IV rightiv = SvIVX(TOPs);
1986 if (leftiv > rightiv)
1988 else if (leftiv < rightiv)
1992 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1993 UV leftuv = SvUVX(TOPm1s);
1994 UV rightuv = SvUVX(TOPs);
1996 if (leftuv > rightuv)
1998 else if (leftuv < rightuv)
2002 } else if (leftuvok) { /* ## UV <=> IV ## */
2006 rightiv = SvIVX(TOPs);
2008 /* As (a) is a UV, it's >=0, so it cannot be < */
2011 leftuv = SvUVX(TOPm1s);
2012 if (leftuv > (UV)rightiv) {
2014 } else if (leftuv < (UV)rightiv) {
2020 } else { /* ## IV <=> UV ## */
2024 leftiv = SvIVX(TOPm1s);
2026 /* As (b) is a UV, it's >=0, so it must be < */
2029 rightuv = SvUVX(TOPs);
2030 if ((UV)leftiv > rightuv) {
2032 } else if ((UV)leftiv < rightuv) {
2050 if (Perl_isnan(left) || Perl_isnan(right)) {
2054 value = (left > right) - (left < right);
2058 else if (left < right)
2060 else if (left > right)
2074 dSP; tryAMAGICbinSET(slt,0);
2077 int cmp = (IN_LOCALE_RUNTIME
2078 ? sv_cmp_locale(left, right)
2079 : sv_cmp(left, right));
2080 SETs(boolSV(cmp < 0));
2087 dSP; tryAMAGICbinSET(sgt,0);
2090 int cmp = (IN_LOCALE_RUNTIME
2091 ? sv_cmp_locale(left, right)
2092 : sv_cmp(left, right));
2093 SETs(boolSV(cmp > 0));
2100 dSP; tryAMAGICbinSET(sle,0);
2103 int cmp = (IN_LOCALE_RUNTIME
2104 ? sv_cmp_locale(left, right)
2105 : sv_cmp(left, right));
2106 SETs(boolSV(cmp <= 0));
2113 dSP; tryAMAGICbinSET(sge,0);
2116 int cmp = (IN_LOCALE_RUNTIME
2117 ? sv_cmp_locale(left, right)
2118 : sv_cmp(left, right));
2119 SETs(boolSV(cmp >= 0));
2126 dSP; tryAMAGICbinSET(seq,0);
2129 SETs(boolSV(sv_eq(left, right)));
2136 dSP; tryAMAGICbinSET(sne,0);
2139 SETs(boolSV(!sv_eq(left, right)));
2146 dSP; dTARGET; tryAMAGICbin(scmp,0);
2149 int cmp = (IN_LOCALE_RUNTIME
2150 ? sv_cmp_locale(left, right)
2151 : sv_cmp(left, right));
2159 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2162 if (SvNIOKp(left) || SvNIOKp(right)) {
2163 if (PL_op->op_private & HINT_INTEGER) {
2164 IV i = SvIV(left) & SvIV(right);
2168 UV u = SvUV(left) & SvUV(right);
2173 do_vop(PL_op->op_type, TARG, left, right);
2182 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2185 if (SvNIOKp(left) || SvNIOKp(right)) {
2186 if (PL_op->op_private & HINT_INTEGER) {
2187 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2191 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2196 do_vop(PL_op->op_type, TARG, left, right);
2205 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2208 if (SvNIOKp(left) || SvNIOKp(right)) {
2209 if (PL_op->op_private & HINT_INTEGER) {
2210 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2214 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2219 do_vop(PL_op->op_type, TARG, left, right);
2228 dSP; dTARGET; tryAMAGICun(neg);
2231 int flags = SvFLAGS(sv);
2234 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2235 /* It's publicly an integer, or privately an integer-not-float */
2238 if (SvIVX(sv) == IV_MIN) {
2239 /* 2s complement assumption. */
2240 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2243 else if (SvUVX(sv) <= IV_MAX) {
2248 else if (SvIVX(sv) != IV_MIN) {
2252 #ifdef PERL_PRESERVE_IVUV
2261 else if (SvPOKp(sv)) {
2263 char *s = SvPV(sv, len);
2264 if (isIDFIRST(*s)) {
2265 sv_setpvn(TARG, "-", 1);
2268 else if (*s == '+' || *s == '-') {
2270 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2272 else if (DO_UTF8(sv)) {
2275 goto oops_its_an_int;
2277 sv_setnv(TARG, -SvNV(sv));
2279 sv_setpvn(TARG, "-", 1);
2286 goto oops_its_an_int;
2287 sv_setnv(TARG, -SvNV(sv));
2299 dSP; tryAMAGICunSET(not);
2300 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2306 dSP; dTARGET; tryAMAGICun(compl);
2310 if (PL_op->op_private & HINT_INTEGER) {
2325 tmps = (U8*)SvPV_force(TARG, len);
2328 /* Calculate exact length, let's not estimate. */
2337 while (tmps < send) {
2338 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2339 tmps += UTF8SKIP(tmps);
2340 targlen += UNISKIP(~c);
2346 /* Now rewind strings and write them. */
2350 Newz(0, result, targlen + 1, U8);
2351 while (tmps < send) {
2352 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2353 tmps += UTF8SKIP(tmps);
2354 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2358 sv_setpvn(TARG, (char*)result, targlen);
2362 Newz(0, result, nchar + 1, U8);
2363 while (tmps < send) {
2364 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2365 tmps += UTF8SKIP(tmps);
2370 sv_setpvn(TARG, (char*)result, nchar);
2378 register long *tmpl;
2379 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2382 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2387 for ( ; anum > 0; anum--, tmps++)
2396 /* integer versions of some of the above */
2400 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2403 SETi( left * right );
2410 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2414 DIE(aTHX_ "Illegal division by zero");
2415 value = POPi / value;
2423 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2427 DIE(aTHX_ "Illegal modulus zero");
2428 SETi( left % right );
2435 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2438 SETi( left + right );
2445 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2448 SETi( left - right );
2455 dSP; tryAMAGICbinSET(lt,0);
2458 SETs(boolSV(left < right));
2465 dSP; tryAMAGICbinSET(gt,0);
2468 SETs(boolSV(left > right));
2475 dSP; tryAMAGICbinSET(le,0);
2478 SETs(boolSV(left <= right));
2485 dSP; tryAMAGICbinSET(ge,0);
2488 SETs(boolSV(left >= right));
2495 dSP; tryAMAGICbinSET(eq,0);
2498 SETs(boolSV(left == right));
2505 dSP; tryAMAGICbinSET(ne,0);
2508 SETs(boolSV(left != right));
2515 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2522 else if (left < right)
2533 dSP; dTARGET; tryAMAGICun(neg);
2538 /* High falutin' math. */
2542 dSP; dTARGET; tryAMAGICbin(atan2,0);
2545 SETn(Perl_atan2(left, right));
2552 dSP; dTARGET; tryAMAGICun(sin);
2556 value = Perl_sin(value);
2564 dSP; dTARGET; tryAMAGICun(cos);
2568 value = Perl_cos(value);
2574 /* Support Configure command-line overrides for rand() functions.
2575 After 5.005, perhaps we should replace this by Configure support
2576 for drand48(), random(), or rand(). For 5.005, though, maintain
2577 compatibility by calling rand() but allow the user to override it.
2578 See INSTALL for details. --Andy Dougherty 15 July 1998
2580 /* Now it's after 5.005, and Configure supports drand48() and random(),
2581 in addition to rand(). So the overrides should not be needed any more.
2582 --Jarkko Hietaniemi 27 September 1998
2585 #ifndef HAS_DRAND48_PROTO
2586 extern double drand48 (void);
2599 if (!PL_srand_called) {
2600 (void)seedDrand01((Rand_seed_t)seed());
2601 PL_srand_called = TRUE;
2616 (void)seedDrand01((Rand_seed_t)anum);
2617 PL_srand_called = TRUE;
2626 * This is really just a quick hack which grabs various garbage
2627 * values. It really should be a real hash algorithm which
2628 * spreads the effect of every input bit onto every output bit,
2629 * if someone who knows about such things would bother to write it.
2630 * Might be a good idea to add that function to CORE as well.
2631 * No numbers below come from careful analysis or anything here,
2632 * except they are primes and SEED_C1 > 1E6 to get a full-width
2633 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2634 * probably be bigger too.
2637 # define SEED_C1 1000003
2638 #define SEED_C4 73819
2640 # define SEED_C1 25747
2641 #define SEED_C4 20639
2645 #define SEED_C5 26107
2647 #ifndef PERL_NO_DEV_RANDOM
2652 # include <starlet.h>
2653 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2654 * in 100-ns units, typically incremented ever 10 ms. */
2655 unsigned int when[2];
2657 # ifdef HAS_GETTIMEOFDAY
2658 struct timeval when;
2664 /* This test is an escape hatch, this symbol isn't set by Configure. */
2665 #ifndef PERL_NO_DEV_RANDOM
2666 #ifndef PERL_RANDOM_DEVICE
2667 /* /dev/random isn't used by default because reads from it will block
2668 * if there isn't enough entropy available. You can compile with
2669 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2670 * is enough real entropy to fill the seed. */
2671 # define PERL_RANDOM_DEVICE "/dev/urandom"
2673 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2675 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2684 _ckvmssts(sys$gettim(when));
2685 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2687 # ifdef HAS_GETTIMEOFDAY
2688 PerlProc_gettimeofday(&when,NULL);
2689 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2692 u = (U32)SEED_C1 * when;
2695 u += SEED_C3 * (U32)PerlProc_getpid();
2696 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2697 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2698 u += SEED_C5 * (U32)PTR2UV(&when);
2705 dSP; dTARGET; tryAMAGICun(exp);
2709 value = Perl_exp(value);
2717 dSP; dTARGET; tryAMAGICun(log);
2722 SET_NUMERIC_STANDARD();
2723 DIE(aTHX_ "Can't take log of %"NVgf, value);
2725 value = Perl_log(value);
2733 dSP; dTARGET; tryAMAGICun(sqrt);
2738 SET_NUMERIC_STANDARD();
2739 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2741 value = Perl_sqrt(value);
2748 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2749 * These need to be revisited when a newer toolchain becomes available.
2751 #if defined(__sparc64__) && defined(__GNUC__)
2752 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2753 # undef SPARC64_MODF_WORKAROUND
2754 # define SPARC64_MODF_WORKAROUND 1
2758 #if defined(SPARC64_MODF_WORKAROUND)
2760 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2763 ret = Perl_modf(theVal, &res);
2771 dSP; dTARGET; tryAMAGICun(int);
2774 IV iv = TOPi; /* attempt to convert to IV if possible. */
2775 /* XXX it's arguable that compiler casting to IV might be subtly
2776 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2777 else preferring IV has introduced a subtle behaviour change bug. OTOH
2778 relying on floating point to be accurate is a bug. */
2789 if (value < (NV)UV_MAX + 0.5) {
2792 #if defined(SPARC64_MODF_WORKAROUND)
2793 (void)sparc64_workaround_modf(value, &value);
2795 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2796 # ifdef HAS_MODFL_POW32_BUG
2797 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2799 NV offset = Perl_modf(value, &value);
2800 (void)Perl_modf(offset, &offset);
2804 (void)Perl_modf(value, &value);
2807 double tmp = (double)value;
2808 (void)Perl_modf(tmp, &tmp);
2816 if (value > (NV)IV_MIN - 0.5) {
2819 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2820 # ifdef HAS_MODFL_POW32_BUG
2821 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2823 NV offset = Perl_modf(-value, &value);
2824 (void)Perl_modf(offset, &offset);
2828 (void)Perl_modf(-value, &value);
2832 double tmp = (double)value;
2833 (void)Perl_modf(-tmp, &tmp);
2846 dSP; dTARGET; tryAMAGICun(abs);
2848 /* This will cache the NV value if string isn't actually integer */
2852 /* IVX is precise */
2854 SETu(TOPu); /* force it to be numeric only */
2862 /* 2s complement assumption. Also, not really needed as
2863 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2883 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2889 tmps = (SvPVx(sv, len));
2891 /* If Unicode, try to downgrade
2892 * If not possible, croak. */
2893 SV* tsv = sv_2mortal(newSVsv(sv));
2896 sv_utf8_downgrade(tsv, FALSE);
2899 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2900 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2913 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2919 tmps = (SvPVx(sv, len));
2921 /* If Unicode, try to downgrade
2922 * If not possible, croak. */
2923 SV* tsv = sv_2mortal(newSVsv(sv));
2926 sv_utf8_downgrade(tsv, FALSE);
2929 while (*tmps && len && isSPACE(*tmps))
2934 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2935 else if (*tmps == 'b')
2936 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2938 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2940 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2957 SETi(sv_len_utf8(sv));
2973 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2975 I32 arybase = PL_curcop->cop_arybase;
2979 int num_args = PL_op->op_private & 7;
2980 bool repl_need_utf8_upgrade = FALSE;
2981 bool repl_is_utf8 = FALSE;
2983 SvTAINTED_off(TARG); /* decontaminate */
2984 SvUTF8_off(TARG); /* decontaminate */
2988 repl = SvPV(repl_sv, repl_len);
2989 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2999 sv_utf8_upgrade(sv);
3001 else if (DO_UTF8(sv))
3002 repl_need_utf8_upgrade = TRUE;
3004 tmps = SvPV(sv, curlen);
3006 utf8_curlen = sv_len_utf8(sv);
3007 if (utf8_curlen == curlen)
3010 curlen = utf8_curlen;
3015 if (pos >= arybase) {
3033 else if (len >= 0) {
3035 if (rem > (I32)curlen)
3050 Perl_croak(aTHX_ "substr outside of string");
3051 if (ckWARN(WARN_SUBSTR))
3052 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3059 sv_pos_u2b(sv, &pos, &rem);
3061 sv_setpvn(TARG, tmps, rem);
3062 #ifdef USE_LOCALE_COLLATE
3063 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3068 SV* repl_sv_copy = NULL;
3070 if (repl_need_utf8_upgrade) {
3071 repl_sv_copy = newSVsv(repl_sv);
3072 sv_utf8_upgrade(repl_sv_copy);
3073 repl = SvPV(repl_sv_copy, repl_len);
3074 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3076 sv_insert(sv, pos, rem, repl, repl_len);
3080 SvREFCNT_dec(repl_sv_copy);
3082 else if (lvalue) { /* it's an lvalue! */
3083 if (!SvGMAGICAL(sv)) {
3087 if (ckWARN(WARN_SUBSTR))
3088 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3089 "Attempt to use reference as lvalue in substr");
3091 if (SvOK(sv)) /* is it defined ? */
3092 (void)SvPOK_only_UTF8(sv);
3094 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3097 if (SvTYPE(TARG) < SVt_PVLV) {
3098 sv_upgrade(TARG, SVt_PVLV);
3099 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3103 if (LvTARG(TARG) != sv) {
3105 SvREFCNT_dec(LvTARG(TARG));
3106 LvTARG(TARG) = SvREFCNT_inc(sv);
3108 LvTARGOFF(TARG) = upos;
3109 LvTARGLEN(TARG) = urem;
3113 PUSHs(TARG); /* avoid SvSETMAGIC here */
3120 register IV size = POPi;
3121 register IV offset = POPi;
3122 register SV *src = POPs;
3123 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3125 SvTAINTED_off(TARG); /* decontaminate */
3126 if (lvalue) { /* it's an lvalue! */
3127 if (SvTYPE(TARG) < SVt_PVLV) {
3128 sv_upgrade(TARG, SVt_PVLV);
3129 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3132 if (LvTARG(TARG) != src) {
3134 SvREFCNT_dec(LvTARG(TARG));
3135 LvTARG(TARG) = SvREFCNT_inc(src);
3137 LvTARGOFF(TARG) = offset;
3138 LvTARGLEN(TARG) = size;
3141 sv_setuv(TARG, do_vecget(src, offset, size));
3156 I32 arybase = PL_curcop->cop_arybase;
3161 offset = POPi - arybase;
3164 tmps = SvPV(big, biglen);
3165 if (offset > 0 && DO_UTF8(big))
3166 sv_pos_u2b(big, &offset, 0);
3169 else if (offset > (I32)biglen)
3171 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3172 (unsigned char*)tmps + biglen, little, 0)))
3175 retval = tmps2 - tmps;
3176 if (retval > 0 && DO_UTF8(big))
3177 sv_pos_b2u(big, &retval);
3178 PUSHi(retval + arybase);
3193 I32 arybase = PL_curcop->cop_arybase;
3199 tmps2 = SvPV(little, llen);
3200 tmps = SvPV(big, blen);
3204 if (offset > 0 && DO_UTF8(big))
3205 sv_pos_u2b(big, &offset, 0);
3206 offset = offset - arybase + llen;
3210 else if (offset > (I32)blen)
3212 if (!(tmps2 = rninstr(tmps, tmps + offset,
3213 tmps2, tmps2 + llen)))
3216 retval = tmps2 - tmps;
3217 if (retval > 0 && DO_UTF8(big))
3218 sv_pos_b2u(big, &retval);
3219 PUSHi(retval + arybase);
3225 dSP; dMARK; dORIGMARK; dTARGET;
3226 do_sprintf(TARG, SP-MARK, MARK+1);
3227 TAINT_IF(SvTAINTED(TARG));
3228 if (DO_UTF8(*(MARK+1)))
3240 U8 *s = (U8*)SvPVx(argsv, len);
3243 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3244 tmpsv = sv_2mortal(newSVsv(argsv));
3245 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3249 XPUSHu(DO_UTF8(argsv) ?
3250 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3262 (void)SvUPGRADE(TARG,SVt_PV);
3264 if (value > 255 && !IN_BYTES) {
3265 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3266 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3267 SvCUR_set(TARG, tmps - SvPVX(TARG));
3269 (void)SvPOK_only(TARG);
3278 *tmps++ = (char)value;
3280 (void)SvPOK_only(TARG);
3282 sv_recode_to_utf8(TARG, PL_encoding);
3294 char *tmps = SvPV(left, len);
3296 if (DO_UTF8(left)) {
3297 /* If Unicode, try to downgrade.
3298 * If not possible, croak.
3299 * Yes, we made this up. */
3300 SV* tsv = sv_2mortal(newSVsv(left));
3303 sv_utf8_downgrade(tsv, FALSE);
3307 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3309 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3315 "The crypt() function is unimplemented due to excessive paranoia.");
3328 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3329 UTF8_IS_START(*s)) {
3330 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3334 utf8_to_uvchr(s, &ulen);
3335 toTITLE_utf8(s, tmpbuf, &tculen);
3336 utf8_to_uvchr(tmpbuf, 0);
3338 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3340 /* slen is the byte length of the whole SV.
3341 * ulen is the byte length of the original Unicode character
3342 * stored as UTF-8 at s.
3343 * tculen is the byte length of the freshly titlecased
3344 * Unicode character stored as UTF-8 at tmpbuf.
3345 * We first set the result to be the titlecased character,
3346 * and then append the rest of the SV data. */
3347 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3349 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3354 s = (U8*)SvPV_force_nomg(sv, slen);
3355 Copy(tmpbuf, s, tculen, U8);
3359 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3361 SvUTF8_off(TARG); /* decontaminate */
3362 sv_setsv_nomg(TARG, sv);
3366 s = (U8*)SvPV_force_nomg(sv, slen);
3368 if (IN_LOCALE_RUNTIME) {
3371 *s = toUPPER_LC(*s);
3390 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3391 UTF8_IS_START(*s)) {
3393 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3397 toLOWER_utf8(s, tmpbuf, &ulen);
3398 uv = utf8_to_uvchr(tmpbuf, 0);
3399 tend = uvchr_to_utf8(tmpbuf, uv);
3401 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3403 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3405 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3410 s = (U8*)SvPV_force_nomg(sv, slen);
3411 Copy(tmpbuf, s, ulen, U8);
3415 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3417 SvUTF8_off(TARG); /* decontaminate */
3418 sv_setsv_nomg(TARG, sv);
3422 s = (U8*)SvPV_force_nomg(sv, slen);
3424 if (IN_LOCALE_RUNTIME) {
3427 *s = toLOWER_LC(*s);
3450 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3452 s = (U8*)SvPV_nomg(sv,len);
3454 SvUTF8_off(TARG); /* decontaminate */
3455 sv_setpvn(TARG, "", 0);
3459 STRLEN nchar = utf8_length(s, s + len);
3461 (void)SvUPGRADE(TARG, SVt_PV);
3462 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3463 (void)SvPOK_only(TARG);
3464 d = (U8*)SvPVX(TARG);
3467 toUPPER_utf8(s, tmpbuf, &ulen);
3468 Copy(tmpbuf, d, ulen, U8);
3474 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3479 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3481 SvUTF8_off(TARG); /* decontaminate */
3482 sv_setsv_nomg(TARG, sv);
3486 s = (U8*)SvPV_force_nomg(sv, len);
3488 register U8 *send = s + len;
3490 if (IN_LOCALE_RUNTIME) {
3493 for (; s < send; s++)
3494 *s = toUPPER_LC(*s);
3497 for (; s < send; s++)
3519 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3521 s = (U8*)SvPV_nomg(sv,len);
3523 SvUTF8_off(TARG); /* decontaminate */
3524 sv_setpvn(TARG, "", 0);
3528 STRLEN nchar = utf8_length(s, s + len);
3530 (void)SvUPGRADE(TARG, SVt_PV);
3531 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3532 (void)SvPOK_only(TARG);
3533 d = (U8*)SvPVX(TARG);
3536 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3537 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3538 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3540 * Now if the sigma is NOT followed by
3541 * /$ignorable_sequence$cased_letter/;
3542 * and it IS preceded by
3543 * /$cased_letter$ignorable_sequence/;
3544 * where $ignorable_sequence is
3545 * [\x{2010}\x{AD}\p{Mn}]*
3546 * and $cased_letter is
3547 * [\p{Ll}\p{Lo}\p{Lt}]
3548 * then it should be mapped to 0x03C2,
3549 * (GREEK SMALL LETTER FINAL SIGMA),
3550 * instead of staying 0x03A3.
3551 * See lib/unicore/SpecCase.txt.
3554 Copy(tmpbuf, d, ulen, U8);
3560 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3565 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3567 SvUTF8_off(TARG); /* decontaminate */
3568 sv_setsv_nomg(TARG, sv);
3573 s = (U8*)SvPV_force_nomg(sv, len);
3575 register U8 *send = s + len;
3577 if (IN_LOCALE_RUNTIME) {
3580 for (; s < send; s++)
3581 *s = toLOWER_LC(*s);
3584 for (; s < send; s++)
3598 register char *s = SvPV(sv,len);
3601 SvUTF8_off(TARG); /* decontaminate */
3603 (void)SvUPGRADE(TARG, SVt_PV);
3604 SvGROW(TARG, (len * 2) + 1);
3608 if (UTF8_IS_CONTINUED(*s)) {
3609 STRLEN ulen = UTF8SKIP(s);
3633 SvCUR_set(TARG, d - SvPVX(TARG));
3634 (void)SvPOK_only_UTF8(TARG);
3637 sv_setpvn(TARG, s, len);
3639 if (SvSMAGICAL(TARG))
3648 dSP; dMARK; dORIGMARK;
3650 register AV* av = (AV*)POPs;
3651 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3652 I32 arybase = PL_curcop->cop_arybase;
3655 if (SvTYPE(av) == SVt_PVAV) {
3656 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3658 for (svp = MARK + 1; svp <= SP; svp++) {
3663 if (max > AvMAX(av))
3666 while (++MARK <= SP) {
3667 elem = SvIVx(*MARK);
3671 svp = av_fetch(av, elem, lval);
3673 if (!svp || *svp == &PL_sv_undef)
3674 DIE(aTHX_ PL_no_aelem, elem);
3675 if (PL_op->op_private & OPpLVAL_INTRO)
3676 save_aelem(av, elem, svp);
3678 *MARK = svp ? *svp : &PL_sv_undef;
3681 if (GIMME != G_ARRAY) {
3689 /* Associative arrays. */
3694 HV *hash = (HV*)POPs;
3696 I32 gimme = GIMME_V;
3699 /* might clobber stack_sp */
3700 entry = hv_iternext(hash);
3705 SV* sv = hv_iterkeysv(entry);
3706 PUSHs(sv); /* won't clobber stack_sp */
3707 if (gimme == G_ARRAY) {
3710 /* might clobber stack_sp */
3711 val = hv_iterval(hash, entry);
3716 else if (gimme == G_SCALAR)
3735 I32 gimme = GIMME_V;
3736 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3740 if (PL_op->op_private & OPpSLICE) {
3744 hvtype = SvTYPE(hv);
3745 if (hvtype == SVt_PVHV) { /* hash element */
3746 while (++MARK <= SP) {
3747 sv = hv_delete_ent(hv, *MARK, discard, 0);
3748 *MARK = sv ? sv : &PL_sv_undef;
3751 else if (hvtype == SVt_PVAV) { /* array element */
3752 if (PL_op->op_flags & OPf_SPECIAL) {
3753 while (++MARK <= SP) {
3754 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3755 *MARK = sv ? sv : &PL_sv_undef;
3760 DIE(aTHX_ "Not a HASH reference");
3763 else if (gimme == G_SCALAR) {
3772 if (SvTYPE(hv) == SVt_PVHV)
3773 sv = hv_delete_ent(hv, keysv, discard, 0);
3774 else if (SvTYPE(hv) == SVt_PVAV) {
3775 if (PL_op->op_flags & OPf_SPECIAL)
3776 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3778 DIE(aTHX_ "panic: avhv_delete no longer supported");
3781 DIE(aTHX_ "Not a HASH reference");
3796 if (PL_op->op_private & OPpEXISTS_SUB) {
3800 cv = sv_2cv(sv, &hv, &gv, FALSE);
3803 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3809 if (SvTYPE(hv) == SVt_PVHV) {
3810 if (hv_exists_ent(hv, tmpsv, 0))
3813 else if (SvTYPE(hv) == SVt_PVAV) {
3814 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3815 if (av_exists((AV*)hv, SvIV(tmpsv)))
3820 DIE(aTHX_ "Not a HASH reference");
3827 dSP; dMARK; dORIGMARK;
3828 register HV *hv = (HV*)POPs;
3829 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3830 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3831 bool other_magic = FALSE;
3837 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3838 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3839 /* Try to preserve the existenceness of a tied hash
3840 * element by using EXISTS and DELETE if possible.
3841 * Fallback to FETCH and STORE otherwise */
3842 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3843 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3844 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3847 while (++MARK <= SP) {
3851 bool preeminent = FALSE;
3854 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3855 hv_exists_ent(hv, keysv, 0);
3858 he = hv_fetch_ent(hv, keysv, lval, 0);
3859 svp = he ? &HeVAL(he) : 0;
3862 if (!svp || *svp == &PL_sv_undef) {
3864 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3868 save_helem(hv, keysv, svp);
3871 char *key = SvPV(keysv, keylen);
3872 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3876 *MARK = svp ? *svp : &PL_sv_undef;
3878 if (GIMME != G_ARRAY) {
3886 /* List operators. */
3891 if (GIMME != G_ARRAY) {
3893 *MARK = *SP; /* unwanted list, return last item */
3895 *MARK = &PL_sv_undef;
3904 SV **lastrelem = PL_stack_sp;
3905 SV **lastlelem = PL_stack_base + POPMARK;
3906 SV **firstlelem = PL_stack_base + POPMARK + 1;
3907 register SV **firstrelem = lastlelem + 1;
3908 I32 arybase = PL_curcop->cop_arybase;
3909 I32 lval = PL_op->op_flags & OPf_MOD;
3910 I32 is_something_there = lval;
3912 register I32 max = lastrelem - lastlelem;
3913 register SV **lelem;
3916 if (GIMME != G_ARRAY) {
3917 ix = SvIVx(*lastlelem);
3922 if (ix < 0 || ix >= max)
3923 *firstlelem = &PL_sv_undef;
3925 *firstlelem = firstrelem[ix];
3931 SP = firstlelem - 1;
3935 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3941 if (ix < 0 || ix >= max)
3942 *lelem = &PL_sv_undef;
3944 is_something_there = TRUE;
3945 if (!(*lelem = firstrelem[ix]))
3946 *lelem = &PL_sv_undef;
3949 if (is_something_there)
3952 SP = firstlelem - 1;
3958 dSP; dMARK; dORIGMARK;
3959 I32 items = SP - MARK;
3960 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3961 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3968 dSP; dMARK; dORIGMARK;
3969 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3973 SV *val = NEWSV(46, 0);
3975 sv_setsv(val, *++MARK);
3976 else if (ckWARN(WARN_MISC))
3977 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3978 (void)hv_store_ent(hv,key,val,0);
3987 dSP; dMARK; dORIGMARK;
3988 register AV *ary = (AV*)*++MARK;
3992 register I32 offset;
3993 register I32 length;
4000 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4001 *MARK-- = SvTIED_obj((SV*)ary, mg);
4005 call_method("SPLICE",GIMME_V);
4014 offset = i = SvIVx(*MARK);
4016 offset += AvFILLp(ary) + 1;
4018 offset -= PL_curcop->cop_arybase;
4020 DIE(aTHX_ PL_no_aelem, i);
4022 length = SvIVx(*MARK++);
4024 length += AvFILLp(ary) - offset + 1;
4030 length = AvMAX(ary) + 1; /* close enough to infinity */
4034 length = AvMAX(ary) + 1;
4036 if (offset > AvFILLp(ary) + 1) {
4037 if (ckWARN(WARN_MISC))
4038 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4039 offset = AvFILLp(ary) + 1;
4041 after = AvFILLp(ary) + 1 - (offset + length);
4042 if (after < 0) { /* not that much array */
4043 length += after; /* offset+length now in array */
4049 /* At this point, MARK .. SP-1 is our new LIST */
4052 diff = newlen - length;
4053 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4056 if (diff < 0) { /* shrinking the area */
4058 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4059 Copy(MARK, tmparyval, newlen, SV*);
4062 MARK = ORIGMARK + 1;
4063 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4064 MEXTEND(MARK, length);
4065 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4067 EXTEND_MORTAL(length);
4068 for (i = length, dst = MARK; i; i--) {
4069 sv_2mortal(*dst); /* free them eventualy */
4076 *MARK = AvARRAY(ary)[offset+length-1];
4079 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4080 SvREFCNT_dec(*dst++); /* free them now */
4083 AvFILLp(ary) += diff;
4085 /* pull up or down? */
4087 if (offset < after) { /* easier to pull up */
4088 if (offset) { /* esp. if nothing to pull */
4089 src = &AvARRAY(ary)[offset-1];
4090 dst = src - diff; /* diff is negative */
4091 for (i = offset; i > 0; i--) /* can't trust Copy */
4095 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4099 if (after) { /* anything to pull down? */
4100 src = AvARRAY(ary) + offset + length;
4101 dst = src + diff; /* diff is negative */
4102 Move(src, dst, after, SV*);
4104 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4105 /* avoid later double free */
4109 dst[--i] = &PL_sv_undef;
4112 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4114 *dst = NEWSV(46, 0);
4115 sv_setsv(*dst++, *src++);
4117 Safefree(tmparyval);
4120 else { /* no, expanding (or same) */
4122 New(452, tmparyval, length, SV*); /* so remember deletion */
4123 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4126 if (diff > 0) { /* expanding */
4128 /* push up or down? */
4130 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4134 Move(src, dst, offset, SV*);
4136 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4138 AvFILLp(ary) += diff;
4141 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4142 av_extend(ary, AvFILLp(ary) + diff);
4143 AvFILLp(ary) += diff;
4146 dst = AvARRAY(ary) + AvFILLp(ary);
4148 for (i = after; i; i--) {
4155 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4156 *dst = NEWSV(46, 0);
4157 sv_setsv(*dst++, *src++);
4159 MARK = ORIGMARK + 1;
4160 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4162 Copy(tmparyval, MARK, length, SV*);
4164 EXTEND_MORTAL(length);
4165 for (i = length, dst = MARK; i; i--) {
4166 sv_2mortal(*dst); /* free them eventualy */
4170 Safefree(tmparyval);
4174 else if (length--) {
4175 *MARK = tmparyval[length];
4178 while (length-- > 0)
4179 SvREFCNT_dec(tmparyval[length]);
4181 Safefree(tmparyval);
4184 *MARK = &PL_sv_undef;
4192 dSP; dMARK; dORIGMARK; dTARGET;
4193 register AV *ary = (AV*)*++MARK;
4194 register SV *sv = &PL_sv_undef;
4197 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4198 *MARK-- = SvTIED_obj((SV*)ary, mg);
4202 call_method("PUSH",G_SCALAR|G_DISCARD);
4207 /* Why no pre-extend of ary here ? */
4208 for (++MARK; MARK <= SP; MARK++) {
4211 sv_setsv(sv, *MARK);
4216 PUSHi( AvFILL(ary) + 1 );
4224 SV *sv = av_pop(av);
4226 (void)sv_2mortal(sv);
4235 SV *sv = av_shift(av);
4240 (void)sv_2mortal(sv);
4247 dSP; dMARK; dORIGMARK; dTARGET;
4248 register AV *ary = (AV*)*++MARK;
4253 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4254 *MARK-- = SvTIED_obj((SV*)ary, mg);
4258 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4263 av_unshift(ary, SP - MARK);
4266 sv_setsv(sv, *++MARK);
4267 (void)av_store(ary, i++, sv);
4271 PUSHi( AvFILL(ary) + 1 );
4281 if (GIMME == G_ARRAY) {
4288 /* safe as long as stack cannot get extended in the above */
4293 register char *down;
4298 SvUTF8_off(TARG); /* decontaminate */
4300 do_join(TARG, &PL_sv_no, MARK, SP);
4302 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4303 up = SvPV_force(TARG, len);
4305 if (DO_UTF8(TARG)) { /* first reverse each character */
4306 U8* s = (U8*)SvPVX(TARG);
4307 U8* send = (U8*)(s + len);
4309 if (UTF8_IS_INVARIANT(*s)) {
4314 if (!utf8_to_uvchr(s, 0))
4318 down = (char*)(s - 1);
4319 /* reverse this character */
4323 *down-- = (char)tmp;
4329 down = SvPVX(TARG) + len - 1;
4333 *down-- = (char)tmp;
4335 (void)SvPOK_only_UTF8(TARG);
4347 register IV limit = POPi; /* note, negative is forever */
4350 register char *s = SvPV(sv, len);
4351 bool do_utf8 = DO_UTF8(sv);
4352 char *strend = s + len;
4354 register REGEXP *rx;
4358 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4359 I32 maxiters = slen + 10;
4362 I32 origlimit = limit;
4365 AV *oldstack = PL_curstack;
4366 I32 gimme = GIMME_V;
4367 I32 oldsave = PL_savestack_ix;
4368 I32 make_mortal = 1;
4369 MAGIC *mg = (MAGIC *) NULL;
4372 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4377 DIE(aTHX_ "panic: pp_split");
4380 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4381 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4383 PL_reg_match_utf8 = do_utf8;
4385 if (pm->op_pmreplroot) {
4387 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4389 ary = GvAVn((GV*)pm->op_pmreplroot);
4392 else if (gimme != G_ARRAY)
4393 ary = GvAVn(PL_defgv);
4396 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4402 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4404 XPUSHs(SvTIED_obj((SV*)ary, mg));
4410 for (i = AvFILLp(ary); i >= 0; i--)
4411 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4413 /* temporarily switch stacks */
4414 SWITCHSTACK(PL_curstack, ary);
4418 base = SP - PL_stack_base;
4420 if (pm->op_pmflags & PMf_SKIPWHITE) {
4421 if (pm->op_pmflags & PMf_LOCALE) {
4422 while (isSPACE_LC(*s))
4430 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4431 SAVEINT(PL_multiline);
4432 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4436 limit = maxiters + 2;
4437 if (pm->op_pmflags & PMf_WHITE) {
4440 while (m < strend &&
4441 !((pm->op_pmflags & PMf_LOCALE)
4442 ? isSPACE_LC(*m) : isSPACE(*m)))
4447 dstr = NEWSV(30, m-s);
4448 sv_setpvn(dstr, s, m-s);
4452 (void)SvUTF8_on(dstr);
4456 while (s < strend &&
4457 ((pm->op_pmflags & PMf_LOCALE)
4458 ? isSPACE_LC(*s) : isSPACE(*s)))
4462 else if (strEQ("^", rx->precomp)) {
4465 for (m = s; m < strend && *m != '\n'; m++) ;
4469 dstr = NEWSV(30, m-s);
4470 sv_setpvn(dstr, s, m-s);
4474 (void)SvUTF8_on(dstr);
4479 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4480 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4481 && (rx->reganch & ROPT_CHECK_ALL)
4482 && !(rx->reganch & ROPT_ANCH)) {
4483 int tail = (rx->reganch & RE_INTUIT_TAIL);
4484 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4487 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4489 char c = *SvPV(csv, n_a);
4492 for (m = s; m < strend && *m != c; m++) ;
4495 dstr = NEWSV(30, m-s);
4496 sv_setpvn(dstr, s, m-s);
4500 (void)SvUTF8_on(dstr);
4502 /* The rx->minlen is in characters but we want to step
4503 * s ahead by bytes. */
4505 s = (char*)utf8_hop((U8*)m, len);
4507 s = m + len; /* Fake \n at the end */
4512 while (s < strend && --limit &&
4513 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4514 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4517 dstr = NEWSV(31, m-s);
4518 sv_setpvn(dstr, s, m-s);
4522 (void)SvUTF8_on(dstr);
4524 /* The rx->minlen is in characters but we want to step
4525 * s ahead by bytes. */
4527 s = (char*)utf8_hop((U8*)m, len);
4529 s = m + len; /* Fake \n at the end */
4534 maxiters += slen * rx->nparens;
4535 while (s < strend && --limit
4536 /* && (!rx->check_substr
4537 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4539 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4540 1 /* minend */, sv, NULL, 0))
4542 TAINT_IF(RX_MATCH_TAINTED(rx));
4543 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4548 strend = s + (strend - m);
4550 m = rx->startp[0] + orig;
4551 dstr = NEWSV(32, m-s);
4552 sv_setpvn(dstr, s, m-s);
4556 (void)SvUTF8_on(dstr);
4559 for (i = 1; i <= (I32)rx->nparens; i++) {
4560 s = rx->startp[i] + orig;
4561 m = rx->endp[i] + orig;
4563 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4564 parens that didn't match -- they should be set to
4565 undef, not the empty string */
4566 if (m >= orig && s >= orig) {
4567 dstr = NEWSV(33, m-s);
4568 sv_setpvn(dstr, s, m-s);
4571 dstr = &PL_sv_undef; /* undef, not "" */
4575 (void)SvUTF8_on(dstr);
4579 s = rx->endp[0] + orig;
4583 LEAVE_SCOPE(oldsave);
4584 iters = (SP - PL_stack_base) - base;
4585 if (iters > maxiters)
4586 DIE(aTHX_ "Split loop");
4588 /* keep field after final delim? */
4589 if (s < strend || (iters && origlimit)) {
4590 STRLEN l = strend - s;
4591 dstr = NEWSV(34, l);
4592 sv_setpvn(dstr, s, l);
4596 (void)SvUTF8_on(dstr);
4600 else if (!origlimit) {
4601 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4602 if (TOPs && !make_mortal)
4611 SWITCHSTACK(ary, oldstack);
4612 if (SvSMAGICAL(ary)) {
4617 if (gimme == G_ARRAY) {
4619 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4627 call_method("PUSH",G_SCALAR|G_DISCARD);
4630 if (gimme == G_ARRAY) {
4631 /* EXTEND should not be needed - we just popped them */
4633 for (i=0; i < iters; i++) {
4634 SV **svp = av_fetch(ary, i, FALSE);
4635 PUSHs((svp) ? *svp : &PL_sv_undef);
4642 if (gimme == G_ARRAY)
4645 if (iters || !pm->op_pmreplroot) {
4659 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4660 || SvTYPE(retsv) == SVt_PVCV) {
4661 retsv = refto(retsv);
4669 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");