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 (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3098 TARG = sv_newmortal();
3099 if (SvTYPE(TARG) < SVt_PVLV) {
3100 sv_upgrade(TARG, SVt_PVLV);
3101 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3105 if (LvTARG(TARG) != sv) {
3107 SvREFCNT_dec(LvTARG(TARG));
3108 LvTARG(TARG) = SvREFCNT_inc(sv);
3110 LvTARGOFF(TARG) = upos;
3111 LvTARGLEN(TARG) = urem;
3115 PUSHs(TARG); /* avoid SvSETMAGIC here */
3122 register IV size = POPi;
3123 register IV offset = POPi;
3124 register SV *src = POPs;
3125 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3127 SvTAINTED_off(TARG); /* decontaminate */
3128 if (lvalue) { /* it's an lvalue! */
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_vec, Nullch, 0);
3136 if (LvTARG(TARG) != src) {
3138 SvREFCNT_dec(LvTARG(TARG));
3139 LvTARG(TARG) = SvREFCNT_inc(src);
3141 LvTARGOFF(TARG) = offset;
3142 LvTARGLEN(TARG) = size;
3145 sv_setuv(TARG, do_vecget(src, offset, size));
3160 I32 arybase = PL_curcop->cop_arybase;
3165 offset = POPi - arybase;
3168 tmps = SvPV(big, biglen);
3169 if (offset > 0 && DO_UTF8(big))
3170 sv_pos_u2b(big, &offset, 0);
3173 else if (offset > (I32)biglen)
3175 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3176 (unsigned char*)tmps + biglen, little, 0)))
3179 retval = tmps2 - tmps;
3180 if (retval > 0 && DO_UTF8(big))
3181 sv_pos_b2u(big, &retval);
3182 PUSHi(retval + arybase);
3197 I32 arybase = PL_curcop->cop_arybase;
3203 tmps2 = SvPV(little, llen);
3204 tmps = SvPV(big, blen);
3208 if (offset > 0 && DO_UTF8(big))
3209 sv_pos_u2b(big, &offset, 0);
3210 offset = offset - arybase + llen;
3214 else if (offset > (I32)blen)
3216 if (!(tmps2 = rninstr(tmps, tmps + offset,
3217 tmps2, tmps2 + llen)))
3220 retval = tmps2 - tmps;
3221 if (retval > 0 && DO_UTF8(big))
3222 sv_pos_b2u(big, &retval);
3223 PUSHi(retval + arybase);
3229 dSP; dMARK; dORIGMARK; dTARGET;
3230 do_sprintf(TARG, SP-MARK, MARK+1);
3231 TAINT_IF(SvTAINTED(TARG));
3232 if (DO_UTF8(*(MARK+1)))
3244 U8 *s = (U8*)SvPVx(argsv, len);
3247 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3248 tmpsv = sv_2mortal(newSVsv(argsv));
3249 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3253 XPUSHu(DO_UTF8(argsv) ?
3254 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3266 (void)SvUPGRADE(TARG,SVt_PV);
3268 if (value > 255 && !IN_BYTES) {
3269 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3270 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3271 SvCUR_set(TARG, tmps - SvPVX(TARG));
3273 (void)SvPOK_only(TARG);
3282 *tmps++ = (char)value;
3284 (void)SvPOK_only(TARG);
3285 if (PL_encoding && !IN_BYTES) {
3286 sv_recode_to_utf8(TARG, PL_encoding);
3288 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3289 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3292 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3293 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3309 char *tmps = SvPV(left, len);
3311 if (DO_UTF8(left)) {
3312 /* If Unicode, try to downgrade.
3313 * If not possible, croak.
3314 * Yes, we made this up. */
3315 SV* tsv = sv_2mortal(newSVsv(left));
3318 sv_utf8_downgrade(tsv, FALSE);
3322 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3324 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3330 "The crypt() function is unimplemented due to excessive paranoia.");
3343 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3344 UTF8_IS_START(*s)) {
3345 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3349 utf8_to_uvchr(s, &ulen);
3350 toTITLE_utf8(s, tmpbuf, &tculen);
3351 utf8_to_uvchr(tmpbuf, 0);
3353 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3355 /* slen is the byte length of the whole SV.
3356 * ulen is the byte length of the original Unicode character
3357 * stored as UTF-8 at s.
3358 * tculen is the byte length of the freshly titlecased
3359 * Unicode character stored as UTF-8 at tmpbuf.
3360 * We first set the result to be the titlecased character,
3361 * and then append the rest of the SV data. */
3362 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3364 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3369 s = (U8*)SvPV_force_nomg(sv, slen);
3370 Copy(tmpbuf, s, tculen, U8);
3374 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3376 SvUTF8_off(TARG); /* decontaminate */
3377 sv_setsv_nomg(TARG, sv);
3381 s = (U8*)SvPV_force_nomg(sv, slen);
3383 if (IN_LOCALE_RUNTIME) {
3386 *s = toUPPER_LC(*s);
3405 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3406 UTF8_IS_START(*s)) {
3408 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3412 toLOWER_utf8(s, tmpbuf, &ulen);
3413 uv = utf8_to_uvchr(tmpbuf, 0);
3414 tend = uvchr_to_utf8(tmpbuf, uv);
3416 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3418 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3420 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3425 s = (U8*)SvPV_force_nomg(sv, slen);
3426 Copy(tmpbuf, s, ulen, U8);
3430 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3432 SvUTF8_off(TARG); /* decontaminate */
3433 sv_setsv_nomg(TARG, sv);
3437 s = (U8*)SvPV_force_nomg(sv, slen);
3439 if (IN_LOCALE_RUNTIME) {
3442 *s = toLOWER_LC(*s);
3465 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3467 s = (U8*)SvPV_nomg(sv,len);
3469 SvUTF8_off(TARG); /* decontaminate */
3470 sv_setpvn(TARG, "", 0);
3474 STRLEN nchar = utf8_length(s, s + len);
3476 (void)SvUPGRADE(TARG, SVt_PV);
3477 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3478 (void)SvPOK_only(TARG);
3479 d = (U8*)SvPVX(TARG);
3482 toUPPER_utf8(s, tmpbuf, &ulen);
3483 Copy(tmpbuf, d, ulen, U8);
3489 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3494 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3496 SvUTF8_off(TARG); /* decontaminate */
3497 sv_setsv_nomg(TARG, sv);
3501 s = (U8*)SvPV_force_nomg(sv, len);
3503 register U8 *send = s + len;
3505 if (IN_LOCALE_RUNTIME) {
3508 for (; s < send; s++)
3509 *s = toUPPER_LC(*s);
3512 for (; s < send; s++)
3534 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3536 s = (U8*)SvPV_nomg(sv,len);
3538 SvUTF8_off(TARG); /* decontaminate */
3539 sv_setpvn(TARG, "", 0);
3543 STRLEN nchar = utf8_length(s, s + len);
3545 (void)SvUPGRADE(TARG, SVt_PV);
3546 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3547 (void)SvPOK_only(TARG);
3548 d = (U8*)SvPVX(TARG);
3551 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3552 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3553 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3555 * Now if the sigma is NOT followed by
3556 * /$ignorable_sequence$cased_letter/;
3557 * and it IS preceded by
3558 * /$cased_letter$ignorable_sequence/;
3559 * where $ignorable_sequence is
3560 * [\x{2010}\x{AD}\p{Mn}]*
3561 * and $cased_letter is
3562 * [\p{Ll}\p{Lo}\p{Lt}]
3563 * then it should be mapped to 0x03C2,
3564 * (GREEK SMALL LETTER FINAL SIGMA),
3565 * instead of staying 0x03A3.
3566 * See lib/unicore/SpecCase.txt.
3569 Copy(tmpbuf, d, ulen, U8);
3575 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3580 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3582 SvUTF8_off(TARG); /* decontaminate */
3583 sv_setsv_nomg(TARG, sv);
3588 s = (U8*)SvPV_force_nomg(sv, len);
3590 register U8 *send = s + len;
3592 if (IN_LOCALE_RUNTIME) {
3595 for (; s < send; s++)
3596 *s = toLOWER_LC(*s);
3599 for (; s < send; s++)
3613 register char *s = SvPV(sv,len);
3616 SvUTF8_off(TARG); /* decontaminate */
3618 (void)SvUPGRADE(TARG, SVt_PV);
3619 SvGROW(TARG, (len * 2) + 1);
3623 if (UTF8_IS_CONTINUED(*s)) {
3624 STRLEN ulen = UTF8SKIP(s);
3648 SvCUR_set(TARG, d - SvPVX(TARG));
3649 (void)SvPOK_only_UTF8(TARG);
3652 sv_setpvn(TARG, s, len);
3654 if (SvSMAGICAL(TARG))
3663 dSP; dMARK; dORIGMARK;
3665 register AV* av = (AV*)POPs;
3666 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3667 I32 arybase = PL_curcop->cop_arybase;
3670 if (SvTYPE(av) == SVt_PVAV) {
3671 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3673 for (svp = MARK + 1; svp <= SP; svp++) {
3678 if (max > AvMAX(av))
3681 while (++MARK <= SP) {
3682 elem = SvIVx(*MARK);
3686 svp = av_fetch(av, elem, lval);
3688 if (!svp || *svp == &PL_sv_undef)
3689 DIE(aTHX_ PL_no_aelem, elem);
3690 if (PL_op->op_private & OPpLVAL_INTRO)
3691 save_aelem(av, elem, svp);
3693 *MARK = svp ? *svp : &PL_sv_undef;
3696 if (GIMME != G_ARRAY) {
3704 /* Associative arrays. */
3709 HV *hash = (HV*)POPs;
3711 I32 gimme = GIMME_V;
3714 /* might clobber stack_sp */
3715 entry = hv_iternext(hash);
3720 SV* sv = hv_iterkeysv(entry);
3721 PUSHs(sv); /* won't clobber stack_sp */
3722 if (gimme == G_ARRAY) {
3725 /* might clobber stack_sp */
3726 val = hv_iterval(hash, entry);
3731 else if (gimme == G_SCALAR)
3750 I32 gimme = GIMME_V;
3751 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3755 if (PL_op->op_private & OPpSLICE) {
3759 hvtype = SvTYPE(hv);
3760 if (hvtype == SVt_PVHV) { /* hash element */
3761 while (++MARK <= SP) {
3762 sv = hv_delete_ent(hv, *MARK, discard, 0);
3763 *MARK = sv ? sv : &PL_sv_undef;
3766 else if (hvtype == SVt_PVAV) { /* array element */
3767 if (PL_op->op_flags & OPf_SPECIAL) {
3768 while (++MARK <= SP) {
3769 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3770 *MARK = sv ? sv : &PL_sv_undef;
3775 DIE(aTHX_ "Not a HASH reference");
3778 else if (gimme == G_SCALAR) {
3787 if (SvTYPE(hv) == SVt_PVHV)
3788 sv = hv_delete_ent(hv, keysv, discard, 0);
3789 else if (SvTYPE(hv) == SVt_PVAV) {
3790 if (PL_op->op_flags & OPf_SPECIAL)
3791 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3793 DIE(aTHX_ "panic: avhv_delete no longer supported");
3796 DIE(aTHX_ "Not a HASH reference");
3811 if (PL_op->op_private & OPpEXISTS_SUB) {
3815 cv = sv_2cv(sv, &hv, &gv, FALSE);
3818 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3824 if (SvTYPE(hv) == SVt_PVHV) {
3825 if (hv_exists_ent(hv, tmpsv, 0))
3828 else if (SvTYPE(hv) == SVt_PVAV) {
3829 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3830 if (av_exists((AV*)hv, SvIV(tmpsv)))
3835 DIE(aTHX_ "Not a HASH reference");
3842 dSP; dMARK; dORIGMARK;
3843 register HV *hv = (HV*)POPs;
3844 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3845 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3846 bool other_magic = FALSE;
3852 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3853 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3854 /* Try to preserve the existenceness of a tied hash
3855 * element by using EXISTS and DELETE if possible.
3856 * Fallback to FETCH and STORE otherwise */
3857 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3858 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3859 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3862 while (++MARK <= SP) {
3866 bool preeminent = FALSE;
3869 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3870 hv_exists_ent(hv, keysv, 0);
3873 he = hv_fetch_ent(hv, keysv, lval, 0);
3874 svp = he ? &HeVAL(he) : 0;
3877 if (!svp || *svp == &PL_sv_undef) {
3879 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3883 save_helem(hv, keysv, svp);
3886 char *key = SvPV(keysv, keylen);
3887 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3891 *MARK = svp ? *svp : &PL_sv_undef;
3893 if (GIMME != G_ARRAY) {
3901 /* List operators. */
3906 if (GIMME != G_ARRAY) {
3908 *MARK = *SP; /* unwanted list, return last item */
3910 *MARK = &PL_sv_undef;
3919 SV **lastrelem = PL_stack_sp;
3920 SV **lastlelem = PL_stack_base + POPMARK;
3921 SV **firstlelem = PL_stack_base + POPMARK + 1;
3922 register SV **firstrelem = lastlelem + 1;
3923 I32 arybase = PL_curcop->cop_arybase;
3924 I32 lval = PL_op->op_flags & OPf_MOD;
3925 I32 is_something_there = lval;
3927 register I32 max = lastrelem - lastlelem;
3928 register SV **lelem;
3931 if (GIMME != G_ARRAY) {
3932 ix = SvIVx(*lastlelem);
3937 if (ix < 0 || ix >= max)
3938 *firstlelem = &PL_sv_undef;
3940 *firstlelem = firstrelem[ix];
3946 SP = firstlelem - 1;
3950 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3956 if (ix < 0 || ix >= max)
3957 *lelem = &PL_sv_undef;
3959 is_something_there = TRUE;
3960 if (!(*lelem = firstrelem[ix]))
3961 *lelem = &PL_sv_undef;
3964 if (is_something_there)
3967 SP = firstlelem - 1;
3973 dSP; dMARK; dORIGMARK;
3974 I32 items = SP - MARK;
3975 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3976 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3983 dSP; dMARK; dORIGMARK;
3984 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3988 SV *val = NEWSV(46, 0);
3990 sv_setsv(val, *++MARK);
3991 else if (ckWARN(WARN_MISC))
3992 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3993 (void)hv_store_ent(hv,key,val,0);
4002 dSP; dMARK; dORIGMARK;
4003 register AV *ary = (AV*)*++MARK;
4007 register I32 offset;
4008 register I32 length;
4015 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4016 *MARK-- = SvTIED_obj((SV*)ary, mg);
4020 call_method("SPLICE",GIMME_V);
4029 offset = i = SvIVx(*MARK);
4031 offset += AvFILLp(ary) + 1;
4033 offset -= PL_curcop->cop_arybase;
4035 DIE(aTHX_ PL_no_aelem, i);
4037 length = SvIVx(*MARK++);
4039 length += AvFILLp(ary) - offset + 1;
4045 length = AvMAX(ary) + 1; /* close enough to infinity */
4049 length = AvMAX(ary) + 1;
4051 if (offset > AvFILLp(ary) + 1) {
4052 if (ckWARN(WARN_MISC))
4053 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4054 offset = AvFILLp(ary) + 1;
4056 after = AvFILLp(ary) + 1 - (offset + length);
4057 if (after < 0) { /* not that much array */
4058 length += after; /* offset+length now in array */
4064 /* At this point, MARK .. SP-1 is our new LIST */
4067 diff = newlen - length;
4068 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4071 if (diff < 0) { /* shrinking the area */
4073 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4074 Copy(MARK, tmparyval, newlen, SV*);
4077 MARK = ORIGMARK + 1;
4078 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4079 MEXTEND(MARK, length);
4080 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4082 EXTEND_MORTAL(length);
4083 for (i = length, dst = MARK; i; i--) {
4084 sv_2mortal(*dst); /* free them eventualy */
4091 *MARK = AvARRAY(ary)[offset+length-1];
4094 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4095 SvREFCNT_dec(*dst++); /* free them now */
4098 AvFILLp(ary) += diff;
4100 /* pull up or down? */
4102 if (offset < after) { /* easier to pull up */
4103 if (offset) { /* esp. if nothing to pull */
4104 src = &AvARRAY(ary)[offset-1];
4105 dst = src - diff; /* diff is negative */
4106 for (i = offset; i > 0; i--) /* can't trust Copy */
4110 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4114 if (after) { /* anything to pull down? */
4115 src = AvARRAY(ary) + offset + length;
4116 dst = src + diff; /* diff is negative */
4117 Move(src, dst, after, SV*);
4119 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4120 /* avoid later double free */
4124 dst[--i] = &PL_sv_undef;
4127 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4129 *dst = NEWSV(46, 0);
4130 sv_setsv(*dst++, *src++);
4132 Safefree(tmparyval);
4135 else { /* no, expanding (or same) */
4137 New(452, tmparyval, length, SV*); /* so remember deletion */
4138 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4141 if (diff > 0) { /* expanding */
4143 /* push up or down? */
4145 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4149 Move(src, dst, offset, SV*);
4151 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4153 AvFILLp(ary) += diff;
4156 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4157 av_extend(ary, AvFILLp(ary) + diff);
4158 AvFILLp(ary) += diff;
4161 dst = AvARRAY(ary) + AvFILLp(ary);
4163 for (i = after; i; i--) {
4170 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4171 *dst = NEWSV(46, 0);
4172 sv_setsv(*dst++, *src++);
4174 MARK = ORIGMARK + 1;
4175 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4177 Copy(tmparyval, MARK, length, SV*);
4179 EXTEND_MORTAL(length);
4180 for (i = length, dst = MARK; i; i--) {
4181 sv_2mortal(*dst); /* free them eventualy */
4185 Safefree(tmparyval);
4189 else if (length--) {
4190 *MARK = tmparyval[length];
4193 while (length-- > 0)
4194 SvREFCNT_dec(tmparyval[length]);
4196 Safefree(tmparyval);
4199 *MARK = &PL_sv_undef;
4207 dSP; dMARK; dORIGMARK; dTARGET;
4208 register AV *ary = (AV*)*++MARK;
4209 register SV *sv = &PL_sv_undef;
4212 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4213 *MARK-- = SvTIED_obj((SV*)ary, mg);
4217 call_method("PUSH",G_SCALAR|G_DISCARD);
4222 /* Why no pre-extend of ary here ? */
4223 for (++MARK; MARK <= SP; MARK++) {
4226 sv_setsv(sv, *MARK);
4231 PUSHi( AvFILL(ary) + 1 );
4239 SV *sv = av_pop(av);
4241 (void)sv_2mortal(sv);
4250 SV *sv = av_shift(av);
4255 (void)sv_2mortal(sv);
4262 dSP; dMARK; dORIGMARK; dTARGET;
4263 register AV *ary = (AV*)*++MARK;
4268 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4269 *MARK-- = SvTIED_obj((SV*)ary, mg);
4273 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4278 av_unshift(ary, SP - MARK);
4281 sv_setsv(sv, *++MARK);
4282 (void)av_store(ary, i++, sv);
4286 PUSHi( AvFILL(ary) + 1 );
4296 if (GIMME == G_ARRAY) {
4303 /* safe as long as stack cannot get extended in the above */
4308 register char *down;
4313 SvUTF8_off(TARG); /* decontaminate */
4315 do_join(TARG, &PL_sv_no, MARK, SP);
4317 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4318 up = SvPV_force(TARG, len);
4320 if (DO_UTF8(TARG)) { /* first reverse each character */
4321 U8* s = (U8*)SvPVX(TARG);
4322 U8* send = (U8*)(s + len);
4324 if (UTF8_IS_INVARIANT(*s)) {
4329 if (!utf8_to_uvchr(s, 0))
4333 down = (char*)(s - 1);
4334 /* reverse this character */
4338 *down-- = (char)tmp;
4344 down = SvPVX(TARG) + len - 1;
4348 *down-- = (char)tmp;
4350 (void)SvPOK_only_UTF8(TARG);
4362 register IV limit = POPi; /* note, negative is forever */
4365 register char *s = SvPV(sv, len);
4366 bool do_utf8 = DO_UTF8(sv);
4367 char *strend = s + len;
4369 register REGEXP *rx;
4373 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4374 I32 maxiters = slen + 10;
4377 I32 origlimit = limit;
4380 AV *oldstack = PL_curstack;
4381 I32 gimme = GIMME_V;
4382 I32 oldsave = PL_savestack_ix;
4383 I32 make_mortal = 1;
4384 MAGIC *mg = (MAGIC *) NULL;
4387 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4392 DIE(aTHX_ "panic: pp_split");
4395 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4396 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4398 RX_MATCH_UTF8_set(rx, do_utf8);
4400 if (pm->op_pmreplroot) {
4402 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4404 ary = GvAVn((GV*)pm->op_pmreplroot);
4407 else if (gimme != G_ARRAY)
4408 ary = GvAVn(PL_defgv);
4411 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4417 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4419 XPUSHs(SvTIED_obj((SV*)ary, mg));
4425 for (i = AvFILLp(ary); i >= 0; i--)
4426 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4428 /* temporarily switch stacks */
4429 SWITCHSTACK(PL_curstack, ary);
4433 base = SP - PL_stack_base;
4435 if (pm->op_pmflags & PMf_SKIPWHITE) {
4436 if (pm->op_pmflags & PMf_LOCALE) {
4437 while (isSPACE_LC(*s))
4445 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4446 SAVEINT(PL_multiline);
4447 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4451 limit = maxiters + 2;
4452 if (pm->op_pmflags & PMf_WHITE) {
4455 while (m < strend &&
4456 !((pm->op_pmflags & PMf_LOCALE)
4457 ? isSPACE_LC(*m) : isSPACE(*m)))
4462 dstr = NEWSV(30, m-s);
4463 sv_setpvn(dstr, s, m-s);
4467 (void)SvUTF8_on(dstr);
4471 while (s < strend &&
4472 ((pm->op_pmflags & PMf_LOCALE)
4473 ? isSPACE_LC(*s) : isSPACE(*s)))
4477 else if (strEQ("^", rx->precomp)) {
4480 for (m = s; m < strend && *m != '\n'; m++) ;
4484 dstr = NEWSV(30, m-s);
4485 sv_setpvn(dstr, s, m-s);
4489 (void)SvUTF8_on(dstr);
4494 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4495 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4496 && (rx->reganch & ROPT_CHECK_ALL)
4497 && !(rx->reganch & ROPT_ANCH)) {
4498 int tail = (rx->reganch & RE_INTUIT_TAIL);
4499 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4502 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4504 char c = *SvPV(csv, n_a);
4507 for (m = s; m < strend && *m != c; m++) ;
4510 dstr = NEWSV(30, m-s);
4511 sv_setpvn(dstr, s, m-s);
4515 (void)SvUTF8_on(dstr);
4517 /* The rx->minlen is in characters but we want to step
4518 * s ahead by bytes. */
4520 s = (char*)utf8_hop((U8*)m, len);
4522 s = m + len; /* Fake \n at the end */
4527 while (s < strend && --limit &&
4528 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4529 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4532 dstr = NEWSV(31, m-s);
4533 sv_setpvn(dstr, s, m-s);
4537 (void)SvUTF8_on(dstr);
4539 /* The rx->minlen is in characters but we want to step
4540 * s ahead by bytes. */
4542 s = (char*)utf8_hop((U8*)m, len);
4544 s = m + len; /* Fake \n at the end */
4549 maxiters += slen * rx->nparens;
4550 while (s < strend && --limit
4551 /* && (!rx->check_substr
4552 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4554 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4555 1 /* minend */, sv, NULL, 0))
4557 TAINT_IF(RX_MATCH_TAINTED(rx));
4558 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4563 strend = s + (strend - m);
4565 m = rx->startp[0] + orig;
4566 dstr = NEWSV(32, m-s);
4567 sv_setpvn(dstr, s, m-s);
4571 (void)SvUTF8_on(dstr);
4574 for (i = 1; i <= (I32)rx->nparens; i++) {
4575 s = rx->startp[i] + orig;
4576 m = rx->endp[i] + orig;
4578 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4579 parens that didn't match -- they should be set to
4580 undef, not the empty string */
4581 if (m >= orig && s >= orig) {
4582 dstr = NEWSV(33, m-s);
4583 sv_setpvn(dstr, s, m-s);
4586 dstr = &PL_sv_undef; /* undef, not "" */
4590 (void)SvUTF8_on(dstr);
4594 s = rx->endp[0] + orig;
4598 LEAVE_SCOPE(oldsave);
4599 iters = (SP - PL_stack_base) - base;
4600 if (iters > maxiters)
4601 DIE(aTHX_ "Split loop");
4603 /* keep field after final delim? */
4604 if (s < strend || (iters && origlimit)) {
4605 STRLEN l = strend - s;
4606 dstr = NEWSV(34, l);
4607 sv_setpvn(dstr, s, l);
4611 (void)SvUTF8_on(dstr);
4615 else if (!origlimit) {
4616 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4617 if (TOPs && !make_mortal)
4626 SWITCHSTACK(ary, oldstack);
4627 if (SvSMAGICAL(ary)) {
4632 if (gimme == G_ARRAY) {
4634 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4642 call_method("PUSH",G_SCALAR|G_DISCARD);
4645 if (gimme == G_ARRAY) {
4646 /* EXTEND should not be needed - we just popped them */
4648 for (i=0; i < iters; i++) {
4649 SV **svp = av_fetch(ary, i, FALSE);
4650 PUSHs((svp) ? *svp : &PL_sv_undef);
4657 if (gimme == G_ARRAY)
4660 if (iters || !pm->op_pmreplroot) {
4674 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4675 || SvTYPE(retsv) == SVt_PVCV) {
4676 retsv = refto(retsv);
4684 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");