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.");
3327 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3331 s = (U8*)SvPV(sv, slen);
3332 utf8_to_uvchr(s, &ulen);
3334 toTITLE_utf8(s, tmpbuf, &tculen);
3335 utf8_to_uvchr(tmpbuf, 0);
3337 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3339 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3340 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3345 s = (U8*)SvPV_force(sv, slen);
3346 Copy(tmpbuf, s, tculen, U8);
3350 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3352 SvUTF8_off(TARG); /* decontaminate */
3357 s = (U8*)SvPV_force(sv, slen);
3359 if (IN_LOCALE_RUNTIME) {
3362 *s = toUPPER_LC(*s);
3380 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3382 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3386 toLOWER_utf8(s, tmpbuf, &ulen);
3387 uv = utf8_to_uvchr(tmpbuf, 0);
3389 tend = uvchr_to_utf8(tmpbuf, uv);
3391 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3393 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3394 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3399 s = (U8*)SvPV_force(sv, slen);
3400 Copy(tmpbuf, s, ulen, U8);
3404 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3406 SvUTF8_off(TARG); /* decontaminate */
3411 s = (U8*)SvPV_force(sv, slen);
3413 if (IN_LOCALE_RUNTIME) {
3416 *s = toLOWER_LC(*s);
3439 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3441 s = (U8*)SvPV(sv,len);
3443 SvUTF8_off(TARG); /* decontaminate */
3444 sv_setpvn(TARG, "", 0);
3448 STRLEN nchar = utf8_length(s, s + len);
3450 (void)SvUPGRADE(TARG, SVt_PV);
3451 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3452 (void)SvPOK_only(TARG);
3453 d = (U8*)SvPVX(TARG);
3456 toUPPER_utf8(s, tmpbuf, &ulen);
3457 Copy(tmpbuf, d, ulen, U8);
3463 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3468 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3470 SvUTF8_off(TARG); /* decontaminate */
3475 s = (U8*)SvPV_force(sv, len);
3477 register U8 *send = s + len;
3479 if (IN_LOCALE_RUNTIME) {
3482 for (; s < send; s++)
3483 *s = toUPPER_LC(*s);
3486 for (; s < send; s++)
3508 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3510 s = (U8*)SvPV(sv,len);
3512 SvUTF8_off(TARG); /* decontaminate */
3513 sv_setpvn(TARG, "", 0);
3517 STRLEN nchar = utf8_length(s, s + len);
3519 (void)SvUPGRADE(TARG, SVt_PV);
3520 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3521 (void)SvPOK_only(TARG);
3522 d = (U8*)SvPVX(TARG);
3525 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3526 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3527 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3529 * Now if the sigma is NOT followed by
3530 * /$ignorable_sequence$cased_letter/;
3531 * and it IS preceded by
3532 * /$cased_letter$ignorable_sequence/;
3533 * where $ignorable_sequence is
3534 * [\x{2010}\x{AD}\p{Mn}]*
3535 * and $cased_letter is
3536 * [\p{Ll}\p{Lo}\p{Lt}]
3537 * then it should be mapped to 0x03C2,
3538 * (GREEK SMALL LETTER FINAL SIGMA),
3539 * instead of staying 0x03A3.
3540 * See lib/unicore/SpecCase.txt.
3543 Copy(tmpbuf, d, ulen, U8);
3549 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3554 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3556 SvUTF8_off(TARG); /* decontaminate */
3562 s = (U8*)SvPV_force(sv, len);
3564 register U8 *send = s + len;
3566 if (IN_LOCALE_RUNTIME) {
3569 for (; s < send; s++)
3570 *s = toLOWER_LC(*s);
3573 for (; s < send; s++)
3588 register char *s = SvPV(sv,len);
3591 SvUTF8_off(TARG); /* decontaminate */
3593 (void)SvUPGRADE(TARG, SVt_PV);
3594 SvGROW(TARG, (len * 2) + 1);
3598 if (UTF8_IS_CONTINUED(*s)) {
3599 STRLEN ulen = UTF8SKIP(s);
3623 SvCUR_set(TARG, d - SvPVX(TARG));
3624 (void)SvPOK_only_UTF8(TARG);
3627 sv_setpvn(TARG, s, len);
3629 if (SvSMAGICAL(TARG))
3638 dSP; dMARK; dORIGMARK;
3640 register AV* av = (AV*)POPs;
3641 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3642 I32 arybase = PL_curcop->cop_arybase;
3645 if (SvTYPE(av) == SVt_PVAV) {
3646 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3648 for (svp = MARK + 1; svp <= SP; svp++) {
3653 if (max > AvMAX(av))
3656 while (++MARK <= SP) {
3657 elem = SvIVx(*MARK);
3661 svp = av_fetch(av, elem, lval);
3663 if (!svp || *svp == &PL_sv_undef)
3664 DIE(aTHX_ PL_no_aelem, elem);
3665 if (PL_op->op_private & OPpLVAL_INTRO)
3666 save_aelem(av, elem, svp);
3668 *MARK = svp ? *svp : &PL_sv_undef;
3671 if (GIMME != G_ARRAY) {
3679 /* Associative arrays. */
3684 HV *hash = (HV*)POPs;
3686 I32 gimme = GIMME_V;
3689 /* might clobber stack_sp */
3690 entry = hv_iternext(hash);
3695 SV* sv = hv_iterkeysv(entry);
3696 PUSHs(sv); /* won't clobber stack_sp */
3697 if (gimme == G_ARRAY) {
3700 /* might clobber stack_sp */
3701 val = hv_iterval(hash, entry);
3706 else if (gimme == G_SCALAR)
3725 I32 gimme = GIMME_V;
3726 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3730 if (PL_op->op_private & OPpSLICE) {
3734 hvtype = SvTYPE(hv);
3735 if (hvtype == SVt_PVHV) { /* hash element */
3736 while (++MARK <= SP) {
3737 sv = hv_delete_ent(hv, *MARK, discard, 0);
3738 *MARK = sv ? sv : &PL_sv_undef;
3741 else if (hvtype == SVt_PVAV) { /* array element */
3742 if (PL_op->op_flags & OPf_SPECIAL) {
3743 while (++MARK <= SP) {
3744 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3745 *MARK = sv ? sv : &PL_sv_undef;
3750 DIE(aTHX_ "Not a HASH reference");
3753 else if (gimme == G_SCALAR) {
3762 if (SvTYPE(hv) == SVt_PVHV)
3763 sv = hv_delete_ent(hv, keysv, discard, 0);
3764 else if (SvTYPE(hv) == SVt_PVAV) {
3765 if (PL_op->op_flags & OPf_SPECIAL)
3766 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3768 DIE(aTHX_ "panic: avhv_delete no longer supported");
3771 DIE(aTHX_ "Not a HASH reference");
3786 if (PL_op->op_private & OPpEXISTS_SUB) {
3790 cv = sv_2cv(sv, &hv, &gv, FALSE);
3793 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3799 if (SvTYPE(hv) == SVt_PVHV) {
3800 if (hv_exists_ent(hv, tmpsv, 0))
3803 else if (SvTYPE(hv) == SVt_PVAV) {
3804 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3805 if (av_exists((AV*)hv, SvIV(tmpsv)))
3810 DIE(aTHX_ "Not a HASH reference");
3817 dSP; dMARK; dORIGMARK;
3818 register HV *hv = (HV*)POPs;
3819 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3820 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3821 bool other_magic = FALSE;
3827 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3828 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3829 /* Try to preserve the existenceness of a tied hash
3830 * element by using EXISTS and DELETE if possible.
3831 * Fallback to FETCH and STORE otherwise */
3832 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3833 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3834 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3837 while (++MARK <= SP) {
3841 bool preeminent = FALSE;
3844 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3845 hv_exists_ent(hv, keysv, 0);
3848 he = hv_fetch_ent(hv, keysv, lval, 0);
3849 svp = he ? &HeVAL(he) : 0;
3852 if (!svp || *svp == &PL_sv_undef) {
3854 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3858 save_helem(hv, keysv, svp);
3861 char *key = SvPV(keysv, keylen);
3862 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3866 *MARK = svp ? *svp : &PL_sv_undef;
3868 if (GIMME != G_ARRAY) {
3876 /* List operators. */
3881 if (GIMME != G_ARRAY) {
3883 *MARK = *SP; /* unwanted list, return last item */
3885 *MARK = &PL_sv_undef;
3894 SV **lastrelem = PL_stack_sp;
3895 SV **lastlelem = PL_stack_base + POPMARK;
3896 SV **firstlelem = PL_stack_base + POPMARK + 1;
3897 register SV **firstrelem = lastlelem + 1;
3898 I32 arybase = PL_curcop->cop_arybase;
3899 I32 lval = PL_op->op_flags & OPf_MOD;
3900 I32 is_something_there = lval;
3902 register I32 max = lastrelem - lastlelem;
3903 register SV **lelem;
3906 if (GIMME != G_ARRAY) {
3907 ix = SvIVx(*lastlelem);
3912 if (ix < 0 || ix >= max)
3913 *firstlelem = &PL_sv_undef;
3915 *firstlelem = firstrelem[ix];
3921 SP = firstlelem - 1;
3925 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3931 if (ix < 0 || ix >= max)
3932 *lelem = &PL_sv_undef;
3934 is_something_there = TRUE;
3935 if (!(*lelem = firstrelem[ix]))
3936 *lelem = &PL_sv_undef;
3939 if (is_something_there)
3942 SP = firstlelem - 1;
3948 dSP; dMARK; dORIGMARK;
3949 I32 items = SP - MARK;
3950 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3951 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3958 dSP; dMARK; dORIGMARK;
3959 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3963 SV *val = NEWSV(46, 0);
3965 sv_setsv(val, *++MARK);
3966 else if (ckWARN(WARN_MISC))
3967 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3968 (void)hv_store_ent(hv,key,val,0);
3977 dSP; dMARK; dORIGMARK;
3978 register AV *ary = (AV*)*++MARK;
3982 register I32 offset;
3983 register I32 length;
3990 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3991 *MARK-- = SvTIED_obj((SV*)ary, mg);
3995 call_method("SPLICE",GIMME_V);
4004 offset = i = SvIVx(*MARK);
4006 offset += AvFILLp(ary) + 1;
4008 offset -= PL_curcop->cop_arybase;
4010 DIE(aTHX_ PL_no_aelem, i);
4012 length = SvIVx(*MARK++);
4014 length += AvFILLp(ary) - offset + 1;
4020 length = AvMAX(ary) + 1; /* close enough to infinity */
4024 length = AvMAX(ary) + 1;
4026 if (offset > AvFILLp(ary) + 1) {
4027 if (ckWARN(WARN_MISC))
4028 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4029 offset = AvFILLp(ary) + 1;
4031 after = AvFILLp(ary) + 1 - (offset + length);
4032 if (after < 0) { /* not that much array */
4033 length += after; /* offset+length now in array */
4039 /* At this point, MARK .. SP-1 is our new LIST */
4042 diff = newlen - length;
4043 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4046 if (diff < 0) { /* shrinking the area */
4048 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4049 Copy(MARK, tmparyval, newlen, SV*);
4052 MARK = ORIGMARK + 1;
4053 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4054 MEXTEND(MARK, length);
4055 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4057 EXTEND_MORTAL(length);
4058 for (i = length, dst = MARK; i; i--) {
4059 sv_2mortal(*dst); /* free them eventualy */
4066 *MARK = AvARRAY(ary)[offset+length-1];
4069 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4070 SvREFCNT_dec(*dst++); /* free them now */
4073 AvFILLp(ary) += diff;
4075 /* pull up or down? */
4077 if (offset < after) { /* easier to pull up */
4078 if (offset) { /* esp. if nothing to pull */
4079 src = &AvARRAY(ary)[offset-1];
4080 dst = src - diff; /* diff is negative */
4081 for (i = offset; i > 0; i--) /* can't trust Copy */
4085 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4089 if (after) { /* anything to pull down? */
4090 src = AvARRAY(ary) + offset + length;
4091 dst = src + diff; /* diff is negative */
4092 Move(src, dst, after, SV*);
4094 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4095 /* avoid later double free */
4099 dst[--i] = &PL_sv_undef;
4102 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4104 *dst = NEWSV(46, 0);
4105 sv_setsv(*dst++, *src++);
4107 Safefree(tmparyval);
4110 else { /* no, expanding (or same) */
4112 New(452, tmparyval, length, SV*); /* so remember deletion */
4113 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4116 if (diff > 0) { /* expanding */
4118 /* push up or down? */
4120 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4124 Move(src, dst, offset, SV*);
4126 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4128 AvFILLp(ary) += diff;
4131 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4132 av_extend(ary, AvFILLp(ary) + diff);
4133 AvFILLp(ary) += diff;
4136 dst = AvARRAY(ary) + AvFILLp(ary);
4138 for (i = after; i; i--) {
4145 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4146 *dst = NEWSV(46, 0);
4147 sv_setsv(*dst++, *src++);
4149 MARK = ORIGMARK + 1;
4150 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4152 Copy(tmparyval, MARK, length, SV*);
4154 EXTEND_MORTAL(length);
4155 for (i = length, dst = MARK; i; i--) {
4156 sv_2mortal(*dst); /* free them eventualy */
4160 Safefree(tmparyval);
4164 else if (length--) {
4165 *MARK = tmparyval[length];
4168 while (length-- > 0)
4169 SvREFCNT_dec(tmparyval[length]);
4171 Safefree(tmparyval);
4174 *MARK = &PL_sv_undef;
4182 dSP; dMARK; dORIGMARK; dTARGET;
4183 register AV *ary = (AV*)*++MARK;
4184 register SV *sv = &PL_sv_undef;
4187 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4188 *MARK-- = SvTIED_obj((SV*)ary, mg);
4192 call_method("PUSH",G_SCALAR|G_DISCARD);
4197 /* Why no pre-extend of ary here ? */
4198 for (++MARK; MARK <= SP; MARK++) {
4201 sv_setsv(sv, *MARK);
4206 PUSHi( AvFILL(ary) + 1 );
4214 SV *sv = av_pop(av);
4216 (void)sv_2mortal(sv);
4225 SV *sv = av_shift(av);
4230 (void)sv_2mortal(sv);
4237 dSP; dMARK; dORIGMARK; dTARGET;
4238 register AV *ary = (AV*)*++MARK;
4243 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4244 *MARK-- = SvTIED_obj((SV*)ary, mg);
4248 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4253 av_unshift(ary, SP - MARK);
4256 sv_setsv(sv, *++MARK);
4257 (void)av_store(ary, i++, sv);
4261 PUSHi( AvFILL(ary) + 1 );
4271 if (GIMME == G_ARRAY) {
4278 /* safe as long as stack cannot get extended in the above */
4283 register char *down;
4288 SvUTF8_off(TARG); /* decontaminate */
4290 do_join(TARG, &PL_sv_no, MARK, SP);
4292 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4293 up = SvPV_force(TARG, len);
4295 if (DO_UTF8(TARG)) { /* first reverse each character */
4296 U8* s = (U8*)SvPVX(TARG);
4297 U8* send = (U8*)(s + len);
4299 if (UTF8_IS_INVARIANT(*s)) {
4304 if (!utf8_to_uvchr(s, 0))
4308 down = (char*)(s - 1);
4309 /* reverse this character */
4313 *down-- = (char)tmp;
4319 down = SvPVX(TARG) + len - 1;
4323 *down-- = (char)tmp;
4325 (void)SvPOK_only_UTF8(TARG);
4337 register IV limit = POPi; /* note, negative is forever */
4340 register char *s = SvPV(sv, len);
4341 bool do_utf8 = DO_UTF8(sv);
4342 char *strend = s + len;
4344 register REGEXP *rx;
4348 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4349 I32 maxiters = slen + 10;
4352 I32 origlimit = limit;
4355 AV *oldstack = PL_curstack;
4356 I32 gimme = GIMME_V;
4357 I32 oldsave = PL_savestack_ix;
4358 I32 make_mortal = 1;
4359 MAGIC *mg = (MAGIC *) NULL;
4362 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4367 DIE(aTHX_ "panic: pp_split");
4370 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4371 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4373 PL_reg_match_utf8 = do_utf8;
4375 if (pm->op_pmreplroot) {
4377 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4379 ary = GvAVn((GV*)pm->op_pmreplroot);
4382 else if (gimme != G_ARRAY)
4383 ary = GvAVn(PL_defgv);
4386 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4392 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4394 XPUSHs(SvTIED_obj((SV*)ary, mg));
4400 for (i = AvFILLp(ary); i >= 0; i--)
4401 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4403 /* temporarily switch stacks */
4404 SWITCHSTACK(PL_curstack, ary);
4408 base = SP - PL_stack_base;
4410 if (pm->op_pmflags & PMf_SKIPWHITE) {
4411 if (pm->op_pmflags & PMf_LOCALE) {
4412 while (isSPACE_LC(*s))
4420 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4421 SAVEINT(PL_multiline);
4422 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4426 limit = maxiters + 2;
4427 if (pm->op_pmflags & PMf_WHITE) {
4430 while (m < strend &&
4431 !((pm->op_pmflags & PMf_LOCALE)
4432 ? isSPACE_LC(*m) : isSPACE(*m)))
4437 dstr = NEWSV(30, m-s);
4438 sv_setpvn(dstr, s, m-s);
4442 (void)SvUTF8_on(dstr);
4446 while (s < strend &&
4447 ((pm->op_pmflags & PMf_LOCALE)
4448 ? isSPACE_LC(*s) : isSPACE(*s)))
4452 else if (strEQ("^", rx->precomp)) {
4455 for (m = s; m < strend && *m != '\n'; m++) ;
4459 dstr = NEWSV(30, m-s);
4460 sv_setpvn(dstr, s, m-s);
4464 (void)SvUTF8_on(dstr);
4469 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4470 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4471 && (rx->reganch & ROPT_CHECK_ALL)
4472 && !(rx->reganch & ROPT_ANCH)) {
4473 int tail = (rx->reganch & RE_INTUIT_TAIL);
4474 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4477 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4479 char c = *SvPV(csv, n_a);
4482 for (m = s; m < strend && *m != c; m++) ;
4485 dstr = NEWSV(30, m-s);
4486 sv_setpvn(dstr, s, m-s);
4490 (void)SvUTF8_on(dstr);
4492 /* The rx->minlen is in characters but we want to step
4493 * s ahead by bytes. */
4495 s = (char*)utf8_hop((U8*)m, len);
4497 s = m + len; /* Fake \n at the end */
4502 while (s < strend && --limit &&
4503 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4504 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4507 dstr = NEWSV(31, m-s);
4508 sv_setpvn(dstr, s, m-s);
4512 (void)SvUTF8_on(dstr);
4514 /* The rx->minlen is in characters but we want to step
4515 * s ahead by bytes. */
4517 s = (char*)utf8_hop((U8*)m, len);
4519 s = m + len; /* Fake \n at the end */
4524 maxiters += slen * rx->nparens;
4525 while (s < strend && --limit
4526 /* && (!rx->check_substr
4527 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4529 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4530 1 /* minend */, sv, NULL, 0))
4532 TAINT_IF(RX_MATCH_TAINTED(rx));
4533 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4538 strend = s + (strend - m);
4540 m = rx->startp[0] + orig;
4541 dstr = NEWSV(32, m-s);
4542 sv_setpvn(dstr, s, m-s);
4546 (void)SvUTF8_on(dstr);
4549 for (i = 1; i <= (I32)rx->nparens; i++) {
4550 s = rx->startp[i] + orig;
4551 m = rx->endp[i] + orig;
4553 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4554 parens that didn't match -- they should be set to
4555 undef, not the empty string */
4556 if (m >= orig && s >= orig) {
4557 dstr = NEWSV(33, m-s);
4558 sv_setpvn(dstr, s, m-s);
4561 dstr = &PL_sv_undef; /* undef, not "" */
4565 (void)SvUTF8_on(dstr);
4569 s = rx->endp[0] + orig;
4573 LEAVE_SCOPE(oldsave);
4574 iters = (SP - PL_stack_base) - base;
4575 if (iters > maxiters)
4576 DIE(aTHX_ "Split loop");
4578 /* keep field after final delim? */
4579 if (s < strend || (iters && origlimit)) {
4580 STRLEN l = strend - s;
4581 dstr = NEWSV(34, l);
4582 sv_setpvn(dstr, s, l);
4586 (void)SvUTF8_on(dstr);
4590 else if (!origlimit) {
4591 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4592 if (TOPs && !make_mortal)
4601 SWITCHSTACK(ary, oldstack);
4602 if (SvSMAGICAL(ary)) {
4607 if (gimme == G_ARRAY) {
4609 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4617 call_method("PUSH",G_SCALAR|G_DISCARD);
4620 if (gimme == G_ARRAY) {
4621 /* EXTEND should not be needed - we just popped them */
4623 for (i=0; i < iters; i++) {
4624 SV **svp = av_fetch(ary, i, FALSE);
4625 PUSHs((svp) ? *svp : &PL_sv_undef);
4632 if (gimme == G_ARRAY)
4635 if (iters || !pm->op_pmreplroot) {
4649 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4650 || SvTYPE(retsv) == SVt_PVCV) {
4651 retsv = refto(retsv);
4659 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");