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
20 /* variations on pp_null */
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);
33 if (GIMME_V == G_SCALAR)
48 if (PL_op->op_private & OPpLVAL_INTRO)
49 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
51 if (PL_op->op_flags & OPf_REF) {
55 if (GIMME == G_SCALAR)
56 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
60 if (GIMME == G_ARRAY) {
61 I32 maxarg = AvFILL((AV*)TARG) + 1;
63 if (SvMAGICAL(TARG)) {
65 for (i=0; i < (U32)maxarg; i++) {
66 SV **svp = av_fetch((AV*)TARG, i, FALSE);
67 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
71 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
76 SV* sv = sv_newmortal();
77 I32 maxarg = AvFILL((AV*)TARG) + 1;
90 if (PL_op->op_private & OPpLVAL_INTRO)
91 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
92 if (PL_op->op_flags & OPf_REF)
95 if (GIMME == G_SCALAR)
96 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
100 if (gimme == G_ARRAY) {
103 else if (gimme == G_SCALAR) {
104 SV* sv = sv_newmortal();
105 if (HvFILL((HV*)TARG))
106 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
107 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
117 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
128 tryAMAGICunDEREF(to_gv);
131 if (SvTYPE(sv) == SVt_PVIO) {
132 GV *gv = (GV*) sv_newmortal();
133 gv_init(gv, 0, "", 0, 0);
134 GvIOp(gv) = (IO *)sv;
135 (void)SvREFCNT_inc(sv);
138 else if (SvTYPE(sv) != SVt_PVGV)
139 DIE(aTHX_ "Not a GLOB reference");
142 if (SvTYPE(sv) != SVt_PVGV) {
146 if (SvGMAGICAL(sv)) {
151 if (!SvOK(sv) && sv != &PL_sv_undef) {
152 /* If this is a 'my' scalar and flag is set then vivify
155 if (PL_op->op_private & OPpDEREF) {
158 if (cUNOP->op_targ) {
160 SV *namesv = PL_curpad[cUNOP->op_targ];
161 name = SvPV(namesv, len);
162 gv = (GV*)NEWSV(0,0);
163 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
166 name = CopSTASHPV(PL_curcop);
169 if (SvTYPE(sv) < SVt_RV)
170 sv_upgrade(sv, SVt_RV);
176 if (PL_op->op_flags & OPf_REF ||
177 PL_op->op_private & HINT_STRICT_REFS)
178 DIE(aTHX_ PL_no_usym, "a symbol");
179 if (ckWARN(WARN_UNINITIALIZED))
184 if ((PL_op->op_flags & OPf_SPECIAL) &&
185 !(PL_op->op_flags & OPf_MOD))
187 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
189 && (!is_gv_magical(sym,len,0)
190 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
196 if (PL_op->op_private & HINT_STRICT_REFS)
197 DIE(aTHX_ PL_no_symref, sym, "a symbol");
198 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
202 if (PL_op->op_private & OPpLVAL_INTRO)
203 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
214 tryAMAGICunDEREF(to_sv);
217 switch (SvTYPE(sv)) {
221 DIE(aTHX_ "Not a SCALAR reference");
229 if (SvTYPE(gv) != SVt_PVGV) {
230 if (SvGMAGICAL(sv)) {
236 if (PL_op->op_flags & OPf_REF ||
237 PL_op->op_private & HINT_STRICT_REFS)
238 DIE(aTHX_ PL_no_usym, "a SCALAR");
239 if (ckWARN(WARN_UNINITIALIZED))
244 if ((PL_op->op_flags & OPf_SPECIAL) &&
245 !(PL_op->op_flags & OPf_MOD))
247 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
249 && (!is_gv_magical(sym,len,0)
250 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
256 if (PL_op->op_private & HINT_STRICT_REFS)
257 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
258 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
263 if (PL_op->op_flags & OPf_MOD) {
264 if (PL_op->op_private & OPpLVAL_INTRO)
265 sv = save_scalar((GV*)TOPs);
266 else if (PL_op->op_private & OPpDEREF)
267 vivify_ref(sv, PL_op->op_private & OPpDEREF);
277 SV *sv = AvARYLEN(av);
279 AvARYLEN(av) = sv = NEWSV(0,0);
280 sv_upgrade(sv, SVt_IV);
281 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
289 dSP; dTARGET; dPOPss;
291 if (PL_op->op_flags & OPf_MOD || LVRET) {
292 if (SvTYPE(TARG) < SVt_PVLV) {
293 sv_upgrade(TARG, SVt_PVLV);
294 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
298 if (LvTARG(TARG) != sv) {
300 SvREFCNT_dec(LvTARG(TARG));
301 LvTARG(TARG) = SvREFCNT_inc(sv);
303 PUSHs(TARG); /* no SvSETMAGIC */
309 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
310 mg = mg_find(sv, PERL_MAGIC_regex_global);
311 if (mg && mg->mg_len >= 0) {
315 PUSHi(i + PL_curcop->cop_arybase);
329 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
330 /* (But not in defined().) */
331 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
334 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
335 if ((PL_op->op_private & OPpLVAL_INTRO)) {
336 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
339 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
343 cv = (CV*)&PL_sv_undef;
357 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
358 char *s = SvPVX(TOPs);
359 if (strnEQ(s, "CORE::", 6)) {
362 code = keyword(s + 6, SvCUR(TOPs) - 6);
363 if (code < 0) { /* Overridable. */
364 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
365 int i = 0, n = 0, seen_question = 0;
367 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
369 if (code == -KEY_chop || code == -KEY_chomp)
371 while (i < MAXO) { /* The slow way. */
372 if (strEQ(s + 6, PL_op_name[i])
373 || strEQ(s + 6, PL_op_desc[i]))
379 goto nonesuch; /* Should not happen... */
381 oa = PL_opargs[i] >> OASHIFT;
383 if (oa & OA_OPTIONAL && !seen_question) {
387 else if (n && str[0] == ';' && seen_question)
388 goto set; /* XXXX system, exec */
389 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
390 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
391 /* But globs are already references (kinda) */
392 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
396 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
400 ret = sv_2mortal(newSVpvn(str, n - 1));
402 else if (code) /* Non-Overridable */
404 else { /* None such */
406 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
410 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
412 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
421 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
423 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
439 if (GIMME != G_ARRAY) {
443 *MARK = &PL_sv_undef;
444 *MARK = refto(*MARK);
448 EXTEND_MORTAL(SP - MARK);
450 *MARK = refto(*MARK);
455 S_refto(pTHX_ SV *sv)
459 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
462 if (!(sv = LvTARG(sv)))
465 (void)SvREFCNT_inc(sv);
467 else if (SvTYPE(sv) == SVt_PVAV) {
468 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
471 (void)SvREFCNT_inc(sv);
473 else if (SvPADTMP(sv) && !IS_PADGV(sv))
477 (void)SvREFCNT_inc(sv);
480 sv_upgrade(rv, SVt_RV);
494 if (sv && SvGMAGICAL(sv))
497 if (!sv || !SvROK(sv))
501 pv = sv_reftype(sv,TRUE);
502 PUSHp(pv, strlen(pv));
512 stash = CopSTASH(PL_curcop);
518 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
519 Perl_croak(aTHX_ "Attempt to bless into a reference");
521 if (ckWARN(WARN_MISC) && len == 0)
522 Perl_warner(aTHX_ packWARN(WARN_MISC),
523 "Explicit blessing to '' (assuming package main)");
524 stash = gv_stashpvn(ptr, len, TRUE);
527 (void)sv_bless(TOPs, stash);
541 elem = SvPV(sv, n_a);
545 switch (elem ? *elem : '\0')
548 if (strEQ(elem, "ARRAY"))
549 tmpRef = (SV*)GvAV(gv);
552 if (strEQ(elem, "CODE"))
553 tmpRef = (SV*)GvCVu(gv);
556 if (strEQ(elem, "FILEHANDLE")) {
557 /* finally deprecated in 5.8.0 */
558 deprecate("*glob{FILEHANDLE}");
559 tmpRef = (SV*)GvIOp(gv);
562 if (strEQ(elem, "FORMAT"))
563 tmpRef = (SV*)GvFORM(gv);
566 if (strEQ(elem, "GLOB"))
570 if (strEQ(elem, "HASH"))
571 tmpRef = (SV*)GvHV(gv);
574 if (strEQ(elem, "IO"))
575 tmpRef = (SV*)GvIOp(gv);
578 if (strEQ(elem, "NAME"))
579 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
582 if (strEQ(elem, "PACKAGE"))
583 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
586 if (strEQ(elem, "SCALAR"))
600 /* Pattern matching */
605 register unsigned char *s;
608 register I32 *sfirst;
612 if (sv == PL_lastscream) {
618 SvSCREAM_off(PL_lastscream);
619 SvREFCNT_dec(PL_lastscream);
621 PL_lastscream = SvREFCNT_inc(sv);
624 s = (unsigned char*)(SvPV(sv, len));
628 if (pos > PL_maxscream) {
629 if (PL_maxscream < 0) {
630 PL_maxscream = pos + 80;
631 New(301, PL_screamfirst, 256, I32);
632 New(302, PL_screamnext, PL_maxscream, I32);
635 PL_maxscream = pos + pos / 4;
636 Renew(PL_screamnext, PL_maxscream, I32);
640 sfirst = PL_screamfirst;
641 snext = PL_screamnext;
643 if (!sfirst || !snext)
644 DIE(aTHX_ "do_study: out of memory");
646 for (ch = 256; ch; --ch)
653 snext[pos] = sfirst[ch] - pos;
660 /* piggyback on m//g magic */
661 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
670 if (PL_op->op_flags & OPf_STACKED)
676 TARG = sv_newmortal();
681 /* Lvalue operators. */
693 dSP; dMARK; dTARGET; dORIGMARK;
695 do_chop(TARG, *++MARK);
704 SETi(do_chomp(TOPs));
711 register I32 count = 0;
714 count += do_chomp(POPs);
725 if (!sv || !SvANY(sv))
727 switch (SvTYPE(sv)) {
729 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
730 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
734 if (HvARRAY(sv) || SvGMAGICAL(sv)
735 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
739 if (CvROOT(sv) || CvXSUB(sv))
756 if (!PL_op->op_private) {
765 if (SvTHINKFIRST(sv))
768 switch (SvTYPE(sv)) {
778 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
779 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
780 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
784 /* let user-undef'd sub keep its identity */
785 GV* gv = CvGV((CV*)sv);
792 SvSetMagicSV(sv, &PL_sv_undef);
796 Newz(602, gp, 1, GP);
797 GvGP(sv) = gp_ref(gp);
798 GvSV(sv) = NEWSV(72,0);
799 GvLINE(sv) = CopLINE(PL_curcop);
805 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
808 SvPV_set(sv, Nullch);
821 if (SvTYPE(TOPs) > SVt_PVLV)
822 DIE(aTHX_ PL_no_modify);
823 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
824 && SvIVX(TOPs) != IV_MIN)
827 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
838 if (SvTYPE(TOPs) > SVt_PVLV)
839 DIE(aTHX_ PL_no_modify);
840 sv_setsv(TARG, TOPs);
841 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
842 && SvIVX(TOPs) != IV_MAX)
845 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
859 if (SvTYPE(TOPs) > SVt_PVLV)
860 DIE(aTHX_ PL_no_modify);
861 sv_setsv(TARG, TOPs);
862 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
863 && SvIVX(TOPs) != IV_MIN)
866 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
875 /* Ordinary operators. */
879 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
880 #ifdef PERL_PRESERVE_IVUV
881 /* ** is implemented with pow. pow is floating point. Perl programmers
882 write 2 ** 31 and expect it to be 2147483648
883 pow never made any guarantee to deliver a result to 53 (or whatever)
884 bits of accuracy. Which is unfortunate, as perl programmers expect it
885 to, and on some platforms (eg Irix with long doubles) it doesn't in
886 a very visible case. (2 ** 31, which a regression test uses)
887 So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
892 bool baseuok = SvUOK(TOPm1s);
896 baseuv = SvUVX(TOPm1s);
898 IV iv = SvIVX(TOPm1s);
901 baseuok = TRUE; /* effectively it's a UV now */
903 baseuv = -iv; /* abs, baseuok == false records sign */
917 goto float_it; /* Can't do negative powers this way. */
920 /* now we have integer ** positive integer.
921 foo & (foo - 1) is zero only for a power of 2. */
922 if (!(baseuv & (baseuv - 1))) {
923 /* We are raising power-of-2 to postive integer.
924 The logic here will work for any base (even non-integer
925 bases) but it can be less accurate than
926 pow (base,power) or exp (power * log (base)) when the
927 intermediate values start to spill out of the mantissa.
928 With powers of 2 we know this can't happen.
929 And powers of 2 are the favourite thing for perl
930 programmers to notice ** not doing what they mean. */
932 NV base = baseuok ? baseuv : -(NV)baseuv;
935 /* The logic is this.
936 x ** n === x ** m1 * x ** m2 where n = m1 + m2
937 so as 42 is 32 + 8 + 2
938 x ** 42 can be written as
939 x ** 32 * x ** 8 * x ** 2
940 I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
941 x ** 2n is x ** n * x ** n
942 So I loop round, squaring x each time
943 (x, x ** 2, x ** 4, x ** 8) and multiply the result
944 by the x-value whenever that bit is set in the power.
945 To finish as soon as possible I zero bits in the power
946 when I've done them, so that power becomes zero when
947 I clear the last bit (no more to do), and the loop
949 for (; power; base *= base, n++) {
950 /* Do I look like I trust gcc with long longs here?
952 UV bit = (UV)1 << (UV)n;
955 /* Only bother to clear the bit if it is set. */
970 SETn( Perl_pow( left, right) );
977 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
978 #ifdef PERL_PRESERVE_IVUV
981 /* Unless the left argument is integer in range we are going to have to
982 use NV maths. Hence only attempt to coerce the right argument if
983 we know the left is integer. */
984 /* Left operand is defined, so is it IV? */
987 bool auvok = SvUOK(TOPm1s);
988 bool buvok = SvUOK(TOPs);
989 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
990 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
997 alow = SvUVX(TOPm1s);
999 IV aiv = SvIVX(TOPm1s);
1002 auvok = TRUE; /* effectively it's a UV now */
1004 alow = -aiv; /* abs, auvok == false records sign */
1010 IV biv = SvIVX(TOPs);
1013 buvok = TRUE; /* effectively it's a UV now */
1015 blow = -biv; /* abs, buvok == false records sign */
1019 /* If this does sign extension on unsigned it's time for plan B */
1020 ahigh = alow >> (4 * sizeof (UV));
1022 bhigh = blow >> (4 * sizeof (UV));
1024 if (ahigh && bhigh) {
1025 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1026 which is overflow. Drop to NVs below. */
1027 } else if (!ahigh && !bhigh) {
1028 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1029 so the unsigned multiply cannot overflow. */
1030 UV product = alow * blow;
1031 if (auvok == buvok) {
1032 /* -ve * -ve or +ve * +ve gives a +ve result. */
1036 } else if (product <= (UV)IV_MIN) {
1037 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1038 /* -ve result, which could overflow an IV */
1040 SETi( -(IV)product );
1042 } /* else drop to NVs below. */
1044 /* One operand is large, 1 small */
1047 /* swap the operands */
1049 bhigh = blow; /* bhigh now the temp var for the swap */
1053 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1054 multiplies can't overflow. shift can, add can, -ve can. */
1055 product_middle = ahigh * blow;
1056 if (!(product_middle & topmask)) {
1057 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1059 product_middle <<= (4 * sizeof (UV));
1060 product_low = alow * blow;
1062 /* as for pp_add, UV + something mustn't get smaller.
1063 IIRC ANSI mandates this wrapping *behaviour* for
1064 unsigned whatever the actual representation*/
1065 product_low += product_middle;
1066 if (product_low >= product_middle) {
1067 /* didn't overflow */
1068 if (auvok == buvok) {
1069 /* -ve * -ve or +ve * +ve gives a +ve result. */
1071 SETu( product_low );
1073 } else if (product_low <= (UV)IV_MIN) {
1074 /* 2s complement assumption again */
1075 /* -ve result, which could overflow an IV */
1077 SETi( -(IV)product_low );
1079 } /* else drop to NVs below. */
1081 } /* product_middle too large */
1082 } /* ahigh && bhigh */
1083 } /* SvIOK(TOPm1s) */
1088 SETn( left * right );
1095 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1096 /* Only try to do UV divide first
1097 if ((SLOPPYDIVIDE is true) or
1098 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1100 The assumption is that it is better to use floating point divide
1101 whenever possible, only doing integer divide first if we can't be sure.
1102 If NV_PRESERVES_UV is true then we know at compile time that no UV
1103 can be too large to preserve, so don't need to compile the code to
1104 test the size of UVs. */
1107 # define PERL_TRY_UV_DIVIDE
1108 /* ensure that 20./5. == 4. */
1110 # ifdef PERL_PRESERVE_IVUV
1111 # ifndef NV_PRESERVES_UV
1112 # define PERL_TRY_UV_DIVIDE
1117 #ifdef PERL_TRY_UV_DIVIDE
1120 SvIV_please(TOPm1s);
1121 if (SvIOK(TOPm1s)) {
1122 bool left_non_neg = SvUOK(TOPm1s);
1123 bool right_non_neg = SvUOK(TOPs);
1127 if (right_non_neg) {
1128 right = SvUVX(TOPs);
1131 IV biv = SvIVX(TOPs);
1134 right_non_neg = TRUE; /* effectively it's a UV now */
1140 /* historically undef()/0 gives a "Use of uninitialized value"
1141 warning before dieing, hence this test goes here.
1142 If it were immediately before the second SvIV_please, then
1143 DIE() would be invoked before left was even inspected, so
1144 no inpsection would give no warning. */
1146 DIE(aTHX_ "Illegal division by zero");
1149 left = SvUVX(TOPm1s);
1152 IV aiv = SvIVX(TOPm1s);
1155 left_non_neg = TRUE; /* effectively it's a UV now */
1164 /* For sloppy divide we always attempt integer division. */
1166 /* Otherwise we only attempt it if either or both operands
1167 would not be preserved by an NV. If both fit in NVs
1168 we fall through to the NV divide code below. However,
1169 as left >= right to ensure integer result here, we know that
1170 we can skip the test on the right operand - right big
1171 enough not to be preserved can't get here unless left is
1174 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1177 /* Integer division can't overflow, but it can be imprecise. */
1178 UV result = left / right;
1179 if (result * right == left) {
1180 SP--; /* result is valid */
1181 if (left_non_neg == right_non_neg) {
1182 /* signs identical, result is positive. */
1186 /* 2s complement assumption */
1187 if (result <= (UV)IV_MIN)
1188 SETi( -(IV)result );
1190 /* It's exact but too negative for IV. */
1191 SETn( -(NV)result );
1194 } /* tried integer divide but it was not an integer result */
1195 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1196 } /* left wasn't SvIOK */
1197 } /* right wasn't SvIOK */
1198 #endif /* PERL_TRY_UV_DIVIDE */
1202 DIE(aTHX_ "Illegal division by zero");
1203 PUSHn( left / right );
1210 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1214 bool left_neg = FALSE;
1215 bool right_neg = FALSE;
1216 bool use_double = FALSE;
1217 bool dright_valid = FALSE;
1223 right_neg = !SvUOK(TOPs);
1225 right = SvUVX(POPs);
1227 IV biv = SvIVX(POPs);
1230 right_neg = FALSE; /* effectively it's a UV now */
1238 right_neg = dright < 0;
1241 if (dright < UV_MAX_P1) {
1242 right = U_V(dright);
1243 dright_valid = TRUE; /* In case we need to use double below. */
1249 /* At this point use_double is only true if right is out of range for
1250 a UV. In range NV has been rounded down to nearest UV and
1251 use_double false. */
1253 if (!use_double && SvIOK(TOPs)) {
1255 left_neg = !SvUOK(TOPs);
1259 IV aiv = SvIVX(POPs);
1262 left_neg = FALSE; /* effectively it's a UV now */
1271 left_neg = dleft < 0;
1275 /* This should be exactly the 5.6 behaviour - if left and right are
1276 both in range for UV then use U_V() rather than floor. */
1278 if (dleft < UV_MAX_P1) {
1279 /* right was in range, so is dleft, so use UVs not double.
1283 /* left is out of range for UV, right was in range, so promote
1284 right (back) to double. */
1286 /* The +0.5 is used in 5.6 even though it is not strictly
1287 consistent with the implicit +0 floor in the U_V()
1288 inside the #if 1. */
1289 dleft = Perl_floor(dleft + 0.5);
1292 dright = Perl_floor(dright + 0.5);
1302 DIE(aTHX_ "Illegal modulus zero");
1304 dans = Perl_fmod(dleft, dright);
1305 if ((left_neg != right_neg) && dans)
1306 dans = dright - dans;
1309 sv_setnv(TARG, dans);
1315 DIE(aTHX_ "Illegal modulus zero");
1318 if ((left_neg != right_neg) && ans)
1321 /* XXX may warn: unary minus operator applied to unsigned type */
1322 /* could change -foo to be (~foo)+1 instead */
1323 if (ans <= ~((UV)IV_MAX)+1)
1324 sv_setiv(TARG, ~ans+1);
1326 sv_setnv(TARG, -(NV)ans);
1329 sv_setuv(TARG, ans);
1338 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1340 register IV count = POPi;
1341 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1343 I32 items = SP - MARK;
1346 max = items * count;
1351 /* This code was intended to fix 20010809.028:
1354 for (($x =~ /./g) x 2) {
1355 print chop; # "abcdabcd" expected as output.
1358 * but that change (#11635) broke this code:
1360 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1362 * I can't think of a better fix that doesn't introduce
1363 * an efficiency hit by copying the SVs. The stack isn't
1364 * refcounted, and mortalisation obviously doesn't
1365 * Do The Right Thing when the stack has more than
1366 * one pointer to the same mortal value.
1370 *SP = sv_2mortal(newSVsv(*SP));
1380 repeatcpy((char*)(MARK + items), (char*)MARK,
1381 items * sizeof(SV*), count - 1);
1384 else if (count <= 0)
1387 else { /* Note: mark already snarfed by pp_list */
1392 SvSetSV(TARG, tmpstr);
1393 SvPV_force(TARG, len);
1394 isutf = DO_UTF8(TARG);
1399 SvGROW(TARG, (count * len) + 1);
1400 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1401 SvCUR(TARG) *= count;
1403 *SvEND(TARG) = '\0';
1406 (void)SvPOK_only_UTF8(TARG);
1408 (void)SvPOK_only(TARG);
1410 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1411 /* The parser saw this as a list repeat, and there
1412 are probably several items on the stack. But we're
1413 in scalar context, and there's no pp_list to save us
1414 now. So drop the rest of the items -- robin@kitsite.com
1427 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1428 useleft = USE_LEFT(TOPm1s);
1429 #ifdef PERL_PRESERVE_IVUV
1430 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1431 "bad things" happen if you rely on signed integers wrapping. */
1434 /* Unless the left argument is integer in range we are going to have to
1435 use NV maths. Hence only attempt to coerce the right argument if
1436 we know the left is integer. */
1437 register UV auv = 0;
1443 a_valid = auvok = 1;
1444 /* left operand is undef, treat as zero. */
1446 /* Left operand is defined, so is it IV? */
1447 SvIV_please(TOPm1s);
1448 if (SvIOK(TOPm1s)) {
1449 if ((auvok = SvUOK(TOPm1s)))
1450 auv = SvUVX(TOPm1s);
1452 register IV aiv = SvIVX(TOPm1s);
1455 auvok = 1; /* Now acting as a sign flag. */
1456 } else { /* 2s complement assumption for IV_MIN */
1464 bool result_good = 0;
1467 bool buvok = SvUOK(TOPs);
1472 register IV biv = SvIVX(TOPs);
1479 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1480 else "IV" now, independent of how it came in.
1481 if a, b represents positive, A, B negative, a maps to -A etc
1486 all UV maths. negate result if A negative.
1487 subtract if signs same, add if signs differ. */
1489 if (auvok ^ buvok) {
1498 /* Must get smaller */
1503 if (result <= buv) {
1504 /* result really should be -(auv-buv). as its negation
1505 of true value, need to swap our result flag */
1517 if (result <= (UV)IV_MIN)
1518 SETi( -(IV)result );
1520 /* result valid, but out of range for IV. */
1521 SETn( -(NV)result );
1525 } /* Overflow, drop through to NVs. */
1529 useleft = USE_LEFT(TOPm1s);
1533 /* left operand is undef, treat as zero - value */
1537 SETn( TOPn - value );
1544 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1547 if (PL_op->op_private & HINT_INTEGER) {
1561 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1564 if (PL_op->op_private & HINT_INTEGER) {
1578 dSP; tryAMAGICbinSET(lt,0);
1579 #ifdef PERL_PRESERVE_IVUV
1582 SvIV_please(TOPm1s);
1583 if (SvIOK(TOPm1s)) {
1584 bool auvok = SvUOK(TOPm1s);
1585 bool buvok = SvUOK(TOPs);
1587 if (!auvok && !buvok) { /* ## IV < IV ## */
1588 IV aiv = SvIVX(TOPm1s);
1589 IV biv = SvIVX(TOPs);
1592 SETs(boolSV(aiv < biv));
1595 if (auvok && buvok) { /* ## UV < UV ## */
1596 UV auv = SvUVX(TOPm1s);
1597 UV buv = SvUVX(TOPs);
1600 SETs(boolSV(auv < buv));
1603 if (auvok) { /* ## UV < IV ## */
1610 /* As (a) is a UV, it's >=0, so it cannot be < */
1615 SETs(boolSV(auv < (UV)biv));
1618 { /* ## IV < UV ## */
1622 aiv = SvIVX(TOPm1s);
1624 /* As (b) is a UV, it's >=0, so it must be < */
1631 SETs(boolSV((UV)aiv < buv));
1637 #ifndef NV_PRESERVES_UV
1638 #ifdef PERL_PRESERVE_IVUV
1641 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1643 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1649 SETs(boolSV(TOPn < value));
1656 dSP; tryAMAGICbinSET(gt,0);
1657 #ifdef PERL_PRESERVE_IVUV
1660 SvIV_please(TOPm1s);
1661 if (SvIOK(TOPm1s)) {
1662 bool auvok = SvUOK(TOPm1s);
1663 bool buvok = SvUOK(TOPs);
1665 if (!auvok && !buvok) { /* ## IV > IV ## */
1666 IV aiv = SvIVX(TOPm1s);
1667 IV biv = SvIVX(TOPs);
1670 SETs(boolSV(aiv > biv));
1673 if (auvok && buvok) { /* ## UV > UV ## */
1674 UV auv = SvUVX(TOPm1s);
1675 UV buv = SvUVX(TOPs);
1678 SETs(boolSV(auv > buv));
1681 if (auvok) { /* ## UV > IV ## */
1688 /* As (a) is a UV, it's >=0, so it must be > */
1693 SETs(boolSV(auv > (UV)biv));
1696 { /* ## IV > UV ## */
1700 aiv = SvIVX(TOPm1s);
1702 /* As (b) is a UV, it's >=0, so it cannot be > */
1709 SETs(boolSV((UV)aiv > buv));
1715 #ifndef NV_PRESERVES_UV
1716 #ifdef PERL_PRESERVE_IVUV
1719 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1721 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1727 SETs(boolSV(TOPn > value));
1734 dSP; tryAMAGICbinSET(le,0);
1735 #ifdef PERL_PRESERVE_IVUV
1738 SvIV_please(TOPm1s);
1739 if (SvIOK(TOPm1s)) {
1740 bool auvok = SvUOK(TOPm1s);
1741 bool buvok = SvUOK(TOPs);
1743 if (!auvok && !buvok) { /* ## IV <= IV ## */
1744 IV aiv = SvIVX(TOPm1s);
1745 IV biv = SvIVX(TOPs);
1748 SETs(boolSV(aiv <= biv));
1751 if (auvok && buvok) { /* ## UV <= UV ## */
1752 UV auv = SvUVX(TOPm1s);
1753 UV buv = SvUVX(TOPs);
1756 SETs(boolSV(auv <= buv));
1759 if (auvok) { /* ## UV <= IV ## */
1766 /* As (a) is a UV, it's >=0, so a cannot be <= */
1771 SETs(boolSV(auv <= (UV)biv));
1774 { /* ## IV <= UV ## */
1778 aiv = SvIVX(TOPm1s);
1780 /* As (b) is a UV, it's >=0, so a must be <= */
1787 SETs(boolSV((UV)aiv <= buv));
1793 #ifndef NV_PRESERVES_UV
1794 #ifdef PERL_PRESERVE_IVUV
1797 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1799 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1805 SETs(boolSV(TOPn <= value));
1812 dSP; tryAMAGICbinSET(ge,0);
1813 #ifdef PERL_PRESERVE_IVUV
1816 SvIV_please(TOPm1s);
1817 if (SvIOK(TOPm1s)) {
1818 bool auvok = SvUOK(TOPm1s);
1819 bool buvok = SvUOK(TOPs);
1821 if (!auvok && !buvok) { /* ## IV >= IV ## */
1822 IV aiv = SvIVX(TOPm1s);
1823 IV biv = SvIVX(TOPs);
1826 SETs(boolSV(aiv >= biv));
1829 if (auvok && buvok) { /* ## UV >= UV ## */
1830 UV auv = SvUVX(TOPm1s);
1831 UV buv = SvUVX(TOPs);
1834 SETs(boolSV(auv >= buv));
1837 if (auvok) { /* ## UV >= IV ## */
1844 /* As (a) is a UV, it's >=0, so it must be >= */
1849 SETs(boolSV(auv >= (UV)biv));
1852 { /* ## IV >= UV ## */
1856 aiv = SvIVX(TOPm1s);
1858 /* As (b) is a UV, it's >=0, so a cannot be >= */
1865 SETs(boolSV((UV)aiv >= buv));
1871 #ifndef NV_PRESERVES_UV
1872 #ifdef PERL_PRESERVE_IVUV
1875 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1877 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1883 SETs(boolSV(TOPn >= value));
1890 dSP; tryAMAGICbinSET(ne,0);
1891 #ifndef NV_PRESERVES_UV
1892 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1894 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1898 #ifdef PERL_PRESERVE_IVUV
1901 SvIV_please(TOPm1s);
1902 if (SvIOK(TOPm1s)) {
1903 bool auvok = SvUOK(TOPm1s);
1904 bool buvok = SvUOK(TOPs);
1906 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1907 /* Casting IV to UV before comparison isn't going to matter
1908 on 2s complement. On 1s complement or sign&magnitude
1909 (if we have any of them) it could make negative zero
1910 differ from normal zero. As I understand it. (Need to
1911 check - is negative zero implementation defined behaviour
1913 UV buv = SvUVX(POPs);
1914 UV auv = SvUVX(TOPs);
1916 SETs(boolSV(auv != buv));
1919 { /* ## Mixed IV,UV ## */
1923 /* != is commutative so swap if needed (save code) */
1925 /* swap. top of stack (b) is the iv */
1929 /* As (a) is a UV, it's >0, so it cannot be == */
1938 /* As (b) is a UV, it's >0, so it cannot be == */
1942 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1944 SETs(boolSV((UV)iv != uv));
1952 SETs(boolSV(TOPn != value));
1959 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1960 #ifndef NV_PRESERVES_UV
1961 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1962 UV right = PTR2UV(SvRV(POPs));
1963 UV left = PTR2UV(SvRV(TOPs));
1964 SETi((left > right) - (left < right));
1968 #ifdef PERL_PRESERVE_IVUV
1969 /* Fortunately it seems NaN isn't IOK */
1972 SvIV_please(TOPm1s);
1973 if (SvIOK(TOPm1s)) {
1974 bool leftuvok = SvUOK(TOPm1s);
1975 bool rightuvok = SvUOK(TOPs);
1977 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1978 IV leftiv = SvIVX(TOPm1s);
1979 IV rightiv = SvIVX(TOPs);
1981 if (leftiv > rightiv)
1983 else if (leftiv < rightiv)
1987 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1988 UV leftuv = SvUVX(TOPm1s);
1989 UV rightuv = SvUVX(TOPs);
1991 if (leftuv > rightuv)
1993 else if (leftuv < rightuv)
1997 } else if (leftuvok) { /* ## UV <=> IV ## */
2001 rightiv = SvIVX(TOPs);
2003 /* As (a) is a UV, it's >=0, so it cannot be < */
2006 leftuv = SvUVX(TOPm1s);
2007 if (leftuv > (UV)rightiv) {
2009 } else if (leftuv < (UV)rightiv) {
2015 } else { /* ## IV <=> UV ## */
2019 leftiv = SvIVX(TOPm1s);
2021 /* As (b) is a UV, it's >=0, so it must be < */
2024 rightuv = SvUVX(TOPs);
2025 if ((UV)leftiv > rightuv) {
2027 } else if ((UV)leftiv < rightuv) {
2045 if (Perl_isnan(left) || Perl_isnan(right)) {
2049 value = (left > right) - (left < right);
2053 else if (left < right)
2055 else if (left > right)
2069 dSP; tryAMAGICbinSET(slt,0);
2072 int cmp = (IN_LOCALE_RUNTIME
2073 ? sv_cmp_locale(left, right)
2074 : sv_cmp(left, right));
2075 SETs(boolSV(cmp < 0));
2082 dSP; tryAMAGICbinSET(sgt,0);
2085 int cmp = (IN_LOCALE_RUNTIME
2086 ? sv_cmp_locale(left, right)
2087 : sv_cmp(left, right));
2088 SETs(boolSV(cmp > 0));
2095 dSP; tryAMAGICbinSET(sle,0);
2098 int cmp = (IN_LOCALE_RUNTIME
2099 ? sv_cmp_locale(left, right)
2100 : sv_cmp(left, right));
2101 SETs(boolSV(cmp <= 0));
2108 dSP; tryAMAGICbinSET(sge,0);
2111 int cmp = (IN_LOCALE_RUNTIME
2112 ? sv_cmp_locale(left, right)
2113 : sv_cmp(left, right));
2114 SETs(boolSV(cmp >= 0));
2121 dSP; tryAMAGICbinSET(seq,0);
2124 SETs(boolSV(sv_eq(left, right)));
2131 dSP; tryAMAGICbinSET(sne,0);
2134 SETs(boolSV(!sv_eq(left, right)));
2141 dSP; dTARGET; tryAMAGICbin(scmp,0);
2144 int cmp = (IN_LOCALE_RUNTIME
2145 ? sv_cmp_locale(left, right)
2146 : sv_cmp(left, right));
2154 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2157 if (SvNIOKp(left) || SvNIOKp(right)) {
2158 if (PL_op->op_private & HINT_INTEGER) {
2159 IV i = SvIV(left) & SvIV(right);
2163 UV u = SvUV(left) & SvUV(right);
2168 do_vop(PL_op->op_type, TARG, left, right);
2177 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2180 if (SvNIOKp(left) || SvNIOKp(right)) {
2181 if (PL_op->op_private & HINT_INTEGER) {
2182 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2186 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2191 do_vop(PL_op->op_type, TARG, left, right);
2200 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2203 if (SvNIOKp(left) || SvNIOKp(right)) {
2204 if (PL_op->op_private & HINT_INTEGER) {
2205 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2209 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2214 do_vop(PL_op->op_type, TARG, left, right);
2223 dSP; dTARGET; tryAMAGICun(neg);
2226 int flags = SvFLAGS(sv);
2229 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2230 /* It's publicly an integer, or privately an integer-not-float */
2233 if (SvIVX(sv) == IV_MIN) {
2234 /* 2s complement assumption. */
2235 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2238 else if (SvUVX(sv) <= IV_MAX) {
2243 else if (SvIVX(sv) != IV_MIN) {
2247 #ifdef PERL_PRESERVE_IVUV
2256 else if (SvPOKp(sv)) {
2258 char *s = SvPV(sv, len);
2259 if (isIDFIRST(*s)) {
2260 sv_setpvn(TARG, "-", 1);
2263 else if (*s == '+' || *s == '-') {
2265 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2267 else if (DO_UTF8(sv)) {
2270 goto oops_its_an_int;
2272 sv_setnv(TARG, -SvNV(sv));
2274 sv_setpvn(TARG, "-", 1);
2281 goto oops_its_an_int;
2282 sv_setnv(TARG, -SvNV(sv));
2294 dSP; tryAMAGICunSET(not);
2295 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2301 dSP; dTARGET; tryAMAGICun(compl);
2305 if (PL_op->op_private & HINT_INTEGER) {
2320 tmps = (U8*)SvPV_force(TARG, len);
2323 /* Calculate exact length, let's not estimate. */
2332 while (tmps < send) {
2333 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2334 tmps += UTF8SKIP(tmps);
2335 targlen += UNISKIP(~c);
2341 /* Now rewind strings and write them. */
2345 Newz(0, result, targlen + 1, U8);
2346 while (tmps < send) {
2347 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2348 tmps += UTF8SKIP(tmps);
2349 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2353 sv_setpvn(TARG, (char*)result, targlen);
2357 Newz(0, result, nchar + 1, U8);
2358 while (tmps < send) {
2359 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2360 tmps += UTF8SKIP(tmps);
2365 sv_setpvn(TARG, (char*)result, nchar);
2373 register long *tmpl;
2374 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2377 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2382 for ( ; anum > 0; anum--, tmps++)
2391 /* integer versions of some of the above */
2395 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2398 SETi( left * right );
2405 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2409 DIE(aTHX_ "Illegal division by zero");
2410 value = POPi / value;
2418 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2422 DIE(aTHX_ "Illegal modulus zero");
2423 SETi( left % right );
2430 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2433 SETi( left + right );
2440 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2443 SETi( left - right );
2450 dSP; tryAMAGICbinSET(lt,0);
2453 SETs(boolSV(left < right));
2460 dSP; tryAMAGICbinSET(gt,0);
2463 SETs(boolSV(left > right));
2470 dSP; tryAMAGICbinSET(le,0);
2473 SETs(boolSV(left <= right));
2480 dSP; tryAMAGICbinSET(ge,0);
2483 SETs(boolSV(left >= right));
2490 dSP; tryAMAGICbinSET(eq,0);
2493 SETs(boolSV(left == right));
2500 dSP; tryAMAGICbinSET(ne,0);
2503 SETs(boolSV(left != right));
2510 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2517 else if (left < right)
2528 dSP; dTARGET; tryAMAGICun(neg);
2533 /* High falutin' math. */
2537 dSP; dTARGET; tryAMAGICbin(atan2,0);
2540 SETn(Perl_atan2(left, right));
2547 dSP; dTARGET; tryAMAGICun(sin);
2551 value = Perl_sin(value);
2559 dSP; dTARGET; tryAMAGICun(cos);
2563 value = Perl_cos(value);
2569 /* Support Configure command-line overrides for rand() functions.
2570 After 5.005, perhaps we should replace this by Configure support
2571 for drand48(), random(), or rand(). For 5.005, though, maintain
2572 compatibility by calling rand() but allow the user to override it.
2573 See INSTALL for details. --Andy Dougherty 15 July 1998
2575 /* Now it's after 5.005, and Configure supports drand48() and random(),
2576 in addition to rand(). So the overrides should not be needed any more.
2577 --Jarkko Hietaniemi 27 September 1998
2580 #ifndef HAS_DRAND48_PROTO
2581 extern double drand48 (void);
2594 if (!PL_srand_called) {
2595 (void)seedDrand01((Rand_seed_t)seed());
2596 PL_srand_called = TRUE;
2611 (void)seedDrand01((Rand_seed_t)anum);
2612 PL_srand_called = TRUE;
2621 * This is really just a quick hack which grabs various garbage
2622 * values. It really should be a real hash algorithm which
2623 * spreads the effect of every input bit onto every output bit,
2624 * if someone who knows about such things would bother to write it.
2625 * Might be a good idea to add that function to CORE as well.
2626 * No numbers below come from careful analysis or anything here,
2627 * except they are primes and SEED_C1 > 1E6 to get a full-width
2628 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2629 * probably be bigger too.
2632 # define SEED_C1 1000003
2633 #define SEED_C4 73819
2635 # define SEED_C1 25747
2636 #define SEED_C4 20639
2640 #define SEED_C5 26107
2642 #ifndef PERL_NO_DEV_RANDOM
2647 # include <starlet.h>
2648 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2649 * in 100-ns units, typically incremented ever 10 ms. */
2650 unsigned int when[2];
2652 # ifdef HAS_GETTIMEOFDAY
2653 struct timeval when;
2659 /* This test is an escape hatch, this symbol isn't set by Configure. */
2660 #ifndef PERL_NO_DEV_RANDOM
2661 #ifndef PERL_RANDOM_DEVICE
2662 /* /dev/random isn't used by default because reads from it will block
2663 * if there isn't enough entropy available. You can compile with
2664 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2665 * is enough real entropy to fill the seed. */
2666 # define PERL_RANDOM_DEVICE "/dev/urandom"
2668 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2670 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2679 _ckvmssts(sys$gettim(when));
2680 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2682 # ifdef HAS_GETTIMEOFDAY
2683 gettimeofday(&when,(struct timezone *) 0);
2684 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2687 u = (U32)SEED_C1 * when;
2690 u += SEED_C3 * (U32)PerlProc_getpid();
2691 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2692 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2693 u += SEED_C5 * (U32)PTR2UV(&when);
2700 dSP; dTARGET; tryAMAGICun(exp);
2704 value = Perl_exp(value);
2712 dSP; dTARGET; tryAMAGICun(log);
2717 SET_NUMERIC_STANDARD();
2718 DIE(aTHX_ "Can't take log of %"NVgf, value);
2720 value = Perl_log(value);
2728 dSP; dTARGET; tryAMAGICun(sqrt);
2733 SET_NUMERIC_STANDARD();
2734 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2736 value = Perl_sqrt(value);
2743 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2744 * These need to be revisited when a newer toolchain becomes available.
2746 #if defined(__sparc64__) && defined(__GNUC__)
2747 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2748 # undef SPARC64_MODF_WORKAROUND
2749 # define SPARC64_MODF_WORKAROUND 1
2753 #if defined(SPARC64_MODF_WORKAROUND)
2755 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2758 ret = Perl_modf(theVal, &res);
2766 dSP; dTARGET; tryAMAGICun(int);
2769 IV iv = TOPi; /* attempt to convert to IV if possible. */
2770 /* XXX it's arguable that compiler casting to IV might be subtly
2771 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2772 else preferring IV has introduced a subtle behaviour change bug. OTOH
2773 relying on floating point to be accurate is a bug. */
2784 if (value < (NV)UV_MAX + 0.5) {
2787 #if defined(SPARC64_MODF_WORKAROUND)
2788 (void)sparc64_workaround_modf(value, &value);
2790 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2791 # ifdef HAS_MODFL_POW32_BUG
2792 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2794 NV offset = Perl_modf(value, &value);
2795 (void)Perl_modf(offset, &offset);
2799 (void)Perl_modf(value, &value);
2802 double tmp = (double)value;
2803 (void)Perl_modf(tmp, &tmp);
2811 if (value > (NV)IV_MIN - 0.5) {
2814 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2815 # ifdef HAS_MODFL_POW32_BUG
2816 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2818 NV offset = Perl_modf(-value, &value);
2819 (void)Perl_modf(offset, &offset);
2823 (void)Perl_modf(-value, &value);
2827 double tmp = (double)value;
2828 (void)Perl_modf(-tmp, &tmp);
2841 dSP; dTARGET; tryAMAGICun(abs);
2843 /* This will cache the NV value if string isn't actually integer */
2847 /* IVX is precise */
2849 SETu(TOPu); /* force it to be numeric only */
2857 /* 2s complement assumption. Also, not really needed as
2858 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2878 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2884 tmps = (SvPVx(sv, len));
2886 /* If Unicode, try to downgrade
2887 * If not possible, croak. */
2888 SV* tsv = sv_2mortal(newSVsv(sv));
2891 sv_utf8_downgrade(tsv, FALSE);
2894 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2895 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2908 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2914 tmps = (SvPVx(sv, len));
2916 /* If Unicode, try to downgrade
2917 * If not possible, croak. */
2918 SV* tsv = sv_2mortal(newSVsv(sv));
2921 sv_utf8_downgrade(tsv, FALSE);
2924 while (*tmps && len && isSPACE(*tmps))
2929 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2930 else if (*tmps == 'b')
2931 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2933 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2935 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2952 SETi(sv_len_utf8(sv));
2968 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2970 I32 arybase = PL_curcop->cop_arybase;
2974 int num_args = PL_op->op_private & 7;
2975 bool repl_need_utf8_upgrade = FALSE;
2976 bool repl_is_utf8 = FALSE;
2978 SvTAINTED_off(TARG); /* decontaminate */
2979 SvUTF8_off(TARG); /* decontaminate */
2983 repl = SvPV(repl_sv, repl_len);
2984 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2994 sv_utf8_upgrade(sv);
2996 else if (DO_UTF8(sv))
2997 repl_need_utf8_upgrade = TRUE;
2999 tmps = SvPV(sv, curlen);
3001 utf8_curlen = sv_len_utf8(sv);
3002 if (utf8_curlen == curlen)
3005 curlen = utf8_curlen;
3010 if (pos >= arybase) {
3028 else if (len >= 0) {
3030 if (rem > (I32)curlen)
3045 Perl_croak(aTHX_ "substr outside of string");
3046 if (ckWARN(WARN_SUBSTR))
3047 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3054 sv_pos_u2b(sv, &pos, &rem);
3056 sv_setpvn(TARG, tmps, rem);
3057 #ifdef USE_LOCALE_COLLATE
3058 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3063 SV* repl_sv_copy = NULL;
3065 if (repl_need_utf8_upgrade) {
3066 repl_sv_copy = newSVsv(repl_sv);
3067 sv_utf8_upgrade(repl_sv_copy);
3068 repl = SvPV(repl_sv_copy, repl_len);
3069 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3071 sv_insert(sv, pos, rem, repl, repl_len);
3075 SvREFCNT_dec(repl_sv_copy);
3077 else if (lvalue) { /* it's an lvalue! */
3078 if (!SvGMAGICAL(sv)) {
3082 if (ckWARN(WARN_SUBSTR))
3083 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3084 "Attempt to use reference as lvalue in substr");
3086 if (SvOK(sv)) /* is it defined ? */
3087 (void)SvPOK_only_UTF8(sv);
3089 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3092 if (SvTYPE(TARG) < SVt_PVLV) {
3093 sv_upgrade(TARG, SVt_PVLV);
3094 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3098 if (LvTARG(TARG) != sv) {
3100 SvREFCNT_dec(LvTARG(TARG));
3101 LvTARG(TARG) = SvREFCNT_inc(sv);
3103 LvTARGOFF(TARG) = upos;
3104 LvTARGLEN(TARG) = urem;
3108 PUSHs(TARG); /* avoid SvSETMAGIC here */
3115 register IV size = POPi;
3116 register IV offset = POPi;
3117 register SV *src = POPs;
3118 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3120 SvTAINTED_off(TARG); /* decontaminate */
3121 if (lvalue) { /* it's an lvalue! */
3122 if (SvTYPE(TARG) < SVt_PVLV) {
3123 sv_upgrade(TARG, SVt_PVLV);
3124 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3127 if (LvTARG(TARG) != src) {
3129 SvREFCNT_dec(LvTARG(TARG));
3130 LvTARG(TARG) = SvREFCNT_inc(src);
3132 LvTARGOFF(TARG) = offset;
3133 LvTARGLEN(TARG) = size;
3136 sv_setuv(TARG, do_vecget(src, offset, size));
3151 I32 arybase = PL_curcop->cop_arybase;
3156 offset = POPi - arybase;
3159 tmps = SvPV(big, biglen);
3160 if (offset > 0 && DO_UTF8(big))
3161 sv_pos_u2b(big, &offset, 0);
3164 else if (offset > (I32)biglen)
3166 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3167 (unsigned char*)tmps + biglen, little, 0)))
3170 retval = tmps2 - tmps;
3171 if (retval > 0 && DO_UTF8(big))
3172 sv_pos_b2u(big, &retval);
3173 PUSHi(retval + arybase);
3188 I32 arybase = PL_curcop->cop_arybase;
3194 tmps2 = SvPV(little, llen);
3195 tmps = SvPV(big, blen);
3199 if (offset > 0 && DO_UTF8(big))
3200 sv_pos_u2b(big, &offset, 0);
3201 offset = offset - arybase + llen;
3205 else if (offset > (I32)blen)
3207 if (!(tmps2 = rninstr(tmps, tmps + offset,
3208 tmps2, tmps2 + llen)))
3211 retval = tmps2 - tmps;
3212 if (retval > 0 && DO_UTF8(big))
3213 sv_pos_b2u(big, &retval);
3214 PUSHi(retval + arybase);
3220 dSP; dMARK; dORIGMARK; dTARGET;
3221 do_sprintf(TARG, SP-MARK, MARK+1);
3222 TAINT_IF(SvTAINTED(TARG));
3223 if (DO_UTF8(*(MARK+1)))
3235 U8 *s = (U8*)SvPVx(argsv, len);
3238 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3239 tmpsv = sv_2mortal(newSVsv(argsv));
3240 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3244 XPUSHu(DO_UTF8(argsv) ?
3245 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3257 (void)SvUPGRADE(TARG,SVt_PV);
3259 if (value > 255 && !IN_BYTES) {
3260 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3261 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3262 SvCUR_set(TARG, tmps - SvPVX(TARG));
3264 (void)SvPOK_only(TARG);
3273 *tmps++ = (char)value;
3275 (void)SvPOK_only(TARG);
3277 sv_recode_to_utf8(TARG, PL_encoding);
3289 char *tmps = SvPV(left, len);
3291 if (DO_UTF8(left)) {
3292 /* If Unicode, try to downgrade.
3293 * If not possible, croak.
3294 * Yes, we made this up. */
3295 SV* tsv = sv_2mortal(newSVsv(left));
3298 sv_utf8_downgrade(tsv, FALSE);
3302 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3304 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3308 "The crypt() function is unimplemented due to excessive paranoia.");
3322 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3326 s = (U8*)SvPV(sv, slen);
3327 utf8_to_uvchr(s, &ulen);
3329 toTITLE_utf8(s, tmpbuf, &tculen);
3330 utf8_to_uvchr(tmpbuf, 0);
3332 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3334 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3335 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3340 s = (U8*)SvPV_force(sv, slen);
3341 Copy(tmpbuf, s, tculen, U8);
3345 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3347 SvUTF8_off(TARG); /* decontaminate */
3352 s = (U8*)SvPV_force(sv, slen);
3354 if (IN_LOCALE_RUNTIME) {
3357 *s = toUPPER_LC(*s);
3375 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3377 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3381 toLOWER_utf8(s, tmpbuf, &ulen);
3382 uv = utf8_to_uvchr(tmpbuf, 0);
3384 tend = uvchr_to_utf8(tmpbuf, uv);
3386 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3388 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3389 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3394 s = (U8*)SvPV_force(sv, slen);
3395 Copy(tmpbuf, s, ulen, U8);
3399 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3401 SvUTF8_off(TARG); /* decontaminate */
3406 s = (U8*)SvPV_force(sv, slen);
3408 if (IN_LOCALE_RUNTIME) {
3411 *s = toLOWER_LC(*s);
3434 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3436 s = (U8*)SvPV(sv,len);
3438 SvUTF8_off(TARG); /* decontaminate */
3439 sv_setpvn(TARG, "", 0);
3443 STRLEN nchar = utf8_length(s, s + len);
3445 (void)SvUPGRADE(TARG, SVt_PV);
3446 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3447 (void)SvPOK_only(TARG);
3448 d = (U8*)SvPVX(TARG);
3451 toUPPER_utf8(s, tmpbuf, &ulen);
3452 Copy(tmpbuf, d, ulen, U8);
3458 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3463 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3465 SvUTF8_off(TARG); /* decontaminate */
3470 s = (U8*)SvPV_force(sv, len);
3472 register U8 *send = s + len;
3474 if (IN_LOCALE_RUNTIME) {
3477 for (; s < send; s++)
3478 *s = toUPPER_LC(*s);
3481 for (; s < send; s++)
3503 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3505 s = (U8*)SvPV(sv,len);
3507 SvUTF8_off(TARG); /* decontaminate */
3508 sv_setpvn(TARG, "", 0);
3512 STRLEN nchar = utf8_length(s, s + len);
3514 (void)SvUPGRADE(TARG, SVt_PV);
3515 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3516 (void)SvPOK_only(TARG);
3517 d = (U8*)SvPVX(TARG);
3520 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3521 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3522 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3524 * Now if the sigma is NOT followed by
3525 * /$ignorable_sequence$cased_letter/;
3526 * and it IS preceded by
3527 * /$cased_letter$ignorable_sequence/;
3528 * where $ignorable_sequence is
3529 * [\x{2010}\x{AD}\p{Mn}]*
3530 * and $cased_letter is
3531 * [\p{Ll}\p{Lo}\p{Lt}]
3532 * then it should be mapped to 0x03C2,
3533 * (GREEK SMALL LETTER FINAL SIGMA),
3534 * instead of staying 0x03A3.
3535 * See lib/unicore/SpecCase.txt.
3538 Copy(tmpbuf, d, ulen, U8);
3544 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3549 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3551 SvUTF8_off(TARG); /* decontaminate */
3557 s = (U8*)SvPV_force(sv, len);
3559 register U8 *send = s + len;
3561 if (IN_LOCALE_RUNTIME) {
3564 for (; s < send; s++)
3565 *s = toLOWER_LC(*s);
3568 for (; s < send; s++)
3583 register char *s = SvPV(sv,len);
3586 SvUTF8_off(TARG); /* decontaminate */
3588 (void)SvUPGRADE(TARG, SVt_PV);
3589 SvGROW(TARG, (len * 2) + 1);
3593 if (UTF8_IS_CONTINUED(*s)) {
3594 STRLEN ulen = UTF8SKIP(s);
3618 SvCUR_set(TARG, d - SvPVX(TARG));
3619 (void)SvPOK_only_UTF8(TARG);
3622 sv_setpvn(TARG, s, len);
3624 if (SvSMAGICAL(TARG))
3633 dSP; dMARK; dORIGMARK;
3635 register AV* av = (AV*)POPs;
3636 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3637 I32 arybase = PL_curcop->cop_arybase;
3640 if (SvTYPE(av) == SVt_PVAV) {
3641 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3643 for (svp = MARK + 1; svp <= SP; svp++) {
3648 if (max > AvMAX(av))
3651 while (++MARK <= SP) {
3652 elem = SvIVx(*MARK);
3656 svp = av_fetch(av, elem, lval);
3658 if (!svp || *svp == &PL_sv_undef)
3659 DIE(aTHX_ PL_no_aelem, elem);
3660 if (PL_op->op_private & OPpLVAL_INTRO)
3661 save_aelem(av, elem, svp);
3663 *MARK = svp ? *svp : &PL_sv_undef;
3666 if (GIMME != G_ARRAY) {
3674 /* Associative arrays. */
3679 HV *hash = (HV*)POPs;
3681 I32 gimme = GIMME_V;
3682 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3685 /* might clobber stack_sp */
3686 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3691 SV* sv = hv_iterkeysv(entry);
3692 PUSHs(sv); /* won't clobber stack_sp */
3693 if (gimme == G_ARRAY) {
3696 /* might clobber stack_sp */
3698 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3703 else if (gimme == G_SCALAR)
3722 I32 gimme = GIMME_V;
3723 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3727 if (PL_op->op_private & OPpSLICE) {
3731 hvtype = SvTYPE(hv);
3732 if (hvtype == SVt_PVHV) { /* hash element */
3733 while (++MARK <= SP) {
3734 sv = hv_delete_ent(hv, *MARK, discard, 0);
3735 *MARK = sv ? sv : &PL_sv_undef;
3738 else if (hvtype == SVt_PVAV) {
3739 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3740 while (++MARK <= SP) {
3741 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3742 *MARK = sv ? sv : &PL_sv_undef;
3745 else { /* pseudo-hash element */
3746 while (++MARK <= SP) {
3747 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3748 *MARK = sv ? sv : &PL_sv_undef;
3753 DIE(aTHX_ "Not a HASH reference");
3756 else if (gimme == G_SCALAR) {
3765 if (SvTYPE(hv) == SVt_PVHV)
3766 sv = hv_delete_ent(hv, keysv, discard, 0);
3767 else if (SvTYPE(hv) == SVt_PVAV) {
3768 if (PL_op->op_flags & OPf_SPECIAL)
3769 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3771 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3774 DIE(aTHX_ "Not a HASH reference");
3789 if (PL_op->op_private & OPpEXISTS_SUB) {
3793 cv = sv_2cv(sv, &hv, &gv, FALSE);
3796 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3802 if (SvTYPE(hv) == SVt_PVHV) {
3803 if (hv_exists_ent(hv, tmpsv, 0))
3806 else if (SvTYPE(hv) == SVt_PVAV) {
3807 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3808 if (av_exists((AV*)hv, SvIV(tmpsv)))
3811 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3815 DIE(aTHX_ "Not a HASH reference");
3822 dSP; dMARK; dORIGMARK;
3823 register HV *hv = (HV*)POPs;
3824 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3825 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3827 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3828 DIE(aTHX_ "Can't localize pseudo-hash element");
3830 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3831 while (++MARK <= SP) {
3834 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3835 realhv ? hv_exists_ent(hv, keysv, 0)
3836 : avhv_exists_ent((AV*)hv, keysv, 0);
3838 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3839 svp = he ? &HeVAL(he) : 0;
3842 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3845 if (!svp || *svp == &PL_sv_undef) {
3847 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3849 if (PL_op->op_private & OPpLVAL_INTRO) {
3851 save_helem(hv, keysv, svp);
3854 char *key = SvPV(keysv, keylen);
3855 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3859 *MARK = svp ? *svp : &PL_sv_undef;
3862 if (GIMME != G_ARRAY) {
3870 /* List operators. */
3875 if (GIMME != G_ARRAY) {
3877 *MARK = *SP; /* unwanted list, return last item */
3879 *MARK = &PL_sv_undef;
3888 SV **lastrelem = PL_stack_sp;
3889 SV **lastlelem = PL_stack_base + POPMARK;
3890 SV **firstlelem = PL_stack_base + POPMARK + 1;
3891 register SV **firstrelem = lastlelem + 1;
3892 I32 arybase = PL_curcop->cop_arybase;
3893 I32 lval = PL_op->op_flags & OPf_MOD;
3894 I32 is_something_there = lval;
3896 register I32 max = lastrelem - lastlelem;
3897 register SV **lelem;
3900 if (GIMME != G_ARRAY) {
3901 ix = SvIVx(*lastlelem);
3906 if (ix < 0 || ix >= max)
3907 *firstlelem = &PL_sv_undef;
3909 *firstlelem = firstrelem[ix];
3915 SP = firstlelem - 1;
3919 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3925 if (ix < 0 || ix >= max)
3926 *lelem = &PL_sv_undef;
3928 is_something_there = TRUE;
3929 if (!(*lelem = firstrelem[ix]))
3930 *lelem = &PL_sv_undef;
3933 if (is_something_there)
3936 SP = firstlelem - 1;
3942 dSP; dMARK; dORIGMARK;
3943 I32 items = SP - MARK;
3944 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3945 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3952 dSP; dMARK; dORIGMARK;
3953 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3957 SV *val = NEWSV(46, 0);
3959 sv_setsv(val, *++MARK);
3960 else if (ckWARN(WARN_MISC))
3961 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3962 (void)hv_store_ent(hv,key,val,0);
3971 dSP; dMARK; dORIGMARK;
3972 register AV *ary = (AV*)*++MARK;
3976 register I32 offset;
3977 register I32 length;
3984 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3985 *MARK-- = SvTIED_obj((SV*)ary, mg);
3989 call_method("SPLICE",GIMME_V);
3998 offset = i = SvIVx(*MARK);
4000 offset += AvFILLp(ary) + 1;
4002 offset -= PL_curcop->cop_arybase;
4004 DIE(aTHX_ PL_no_aelem, i);
4006 length = SvIVx(*MARK++);
4008 length += AvFILLp(ary) - offset + 1;
4014 length = AvMAX(ary) + 1; /* close enough to infinity */
4018 length = AvMAX(ary) + 1;
4020 if (offset > AvFILLp(ary) + 1) {
4021 if (ckWARN(WARN_MISC))
4022 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4023 offset = AvFILLp(ary) + 1;
4025 after = AvFILLp(ary) + 1 - (offset + length);
4026 if (after < 0) { /* not that much array */
4027 length += after; /* offset+length now in array */
4033 /* At this point, MARK .. SP-1 is our new LIST */
4036 diff = newlen - length;
4037 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4040 if (diff < 0) { /* shrinking the area */
4042 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4043 Copy(MARK, tmparyval, newlen, SV*);
4046 MARK = ORIGMARK + 1;
4047 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4048 MEXTEND(MARK, length);
4049 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4051 EXTEND_MORTAL(length);
4052 for (i = length, dst = MARK; i; i--) {
4053 sv_2mortal(*dst); /* free them eventualy */
4060 *MARK = AvARRAY(ary)[offset+length-1];
4063 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4064 SvREFCNT_dec(*dst++); /* free them now */
4067 AvFILLp(ary) += diff;
4069 /* pull up or down? */
4071 if (offset < after) { /* easier to pull up */
4072 if (offset) { /* esp. if nothing to pull */
4073 src = &AvARRAY(ary)[offset-1];
4074 dst = src - diff; /* diff is negative */
4075 for (i = offset; i > 0; i--) /* can't trust Copy */
4079 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4083 if (after) { /* anything to pull down? */
4084 src = AvARRAY(ary) + offset + length;
4085 dst = src + diff; /* diff is negative */
4086 Move(src, dst, after, SV*);
4088 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4089 /* avoid later double free */
4093 dst[--i] = &PL_sv_undef;
4096 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4098 *dst = NEWSV(46, 0);
4099 sv_setsv(*dst++, *src++);
4101 Safefree(tmparyval);
4104 else { /* no, expanding (or same) */
4106 New(452, tmparyval, length, SV*); /* so remember deletion */
4107 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4110 if (diff > 0) { /* expanding */
4112 /* push up or down? */
4114 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4118 Move(src, dst, offset, SV*);
4120 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4122 AvFILLp(ary) += diff;
4125 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4126 av_extend(ary, AvFILLp(ary) + diff);
4127 AvFILLp(ary) += diff;
4130 dst = AvARRAY(ary) + AvFILLp(ary);
4132 for (i = after; i; i--) {
4139 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4140 *dst = NEWSV(46, 0);
4141 sv_setsv(*dst++, *src++);
4143 MARK = ORIGMARK + 1;
4144 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4146 Copy(tmparyval, MARK, length, SV*);
4148 EXTEND_MORTAL(length);
4149 for (i = length, dst = MARK; i; i--) {
4150 sv_2mortal(*dst); /* free them eventualy */
4154 Safefree(tmparyval);
4158 else if (length--) {
4159 *MARK = tmparyval[length];
4162 while (length-- > 0)
4163 SvREFCNT_dec(tmparyval[length]);
4165 Safefree(tmparyval);
4168 *MARK = &PL_sv_undef;
4176 dSP; dMARK; dORIGMARK; dTARGET;
4177 register AV *ary = (AV*)*++MARK;
4178 register SV *sv = &PL_sv_undef;
4181 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4182 *MARK-- = SvTIED_obj((SV*)ary, mg);
4186 call_method("PUSH",G_SCALAR|G_DISCARD);
4191 /* Why no pre-extend of ary here ? */
4192 for (++MARK; MARK <= SP; MARK++) {
4195 sv_setsv(sv, *MARK);
4200 PUSHi( AvFILL(ary) + 1 );
4208 SV *sv = av_pop(av);
4210 (void)sv_2mortal(sv);
4219 SV *sv = av_shift(av);
4224 (void)sv_2mortal(sv);
4231 dSP; dMARK; dORIGMARK; dTARGET;
4232 register AV *ary = (AV*)*++MARK;
4237 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4238 *MARK-- = SvTIED_obj((SV*)ary, mg);
4242 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4247 av_unshift(ary, SP - MARK);
4250 sv_setsv(sv, *++MARK);
4251 (void)av_store(ary, i++, sv);
4255 PUSHi( AvFILL(ary) + 1 );
4265 if (GIMME == G_ARRAY) {
4272 /* safe as long as stack cannot get extended in the above */
4277 register char *down;
4282 SvUTF8_off(TARG); /* decontaminate */
4284 do_join(TARG, &PL_sv_no, MARK, SP);
4286 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4287 up = SvPV_force(TARG, len);
4289 if (DO_UTF8(TARG)) { /* first reverse each character */
4290 U8* s = (U8*)SvPVX(TARG);
4291 U8* send = (U8*)(s + len);
4293 if (UTF8_IS_INVARIANT(*s)) {
4298 if (!utf8_to_uvchr(s, 0))
4302 down = (char*)(s - 1);
4303 /* reverse this character */
4307 *down-- = (char)tmp;
4313 down = SvPVX(TARG) + len - 1;
4317 *down-- = (char)tmp;
4319 (void)SvPOK_only_UTF8(TARG);
4331 register IV limit = POPi; /* note, negative is forever */
4334 register char *s = SvPV(sv, len);
4335 bool do_utf8 = DO_UTF8(sv);
4336 char *strend = s + len;
4338 register REGEXP *rx;
4342 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4343 I32 maxiters = slen + 10;
4346 I32 origlimit = limit;
4349 AV *oldstack = PL_curstack;
4350 I32 gimme = GIMME_V;
4351 I32 oldsave = PL_savestack_ix;
4352 I32 make_mortal = 1;
4353 MAGIC *mg = (MAGIC *) NULL;
4356 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4361 DIE(aTHX_ "panic: pp_split");
4364 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4365 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4367 PL_reg_match_utf8 = do_utf8;
4369 if (pm->op_pmreplroot) {
4371 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4373 ary = GvAVn((GV*)pm->op_pmreplroot);
4376 else if (gimme != G_ARRAY)
4377 #ifdef USE_5005THREADS
4378 ary = (AV*)PL_curpad[0];
4380 ary = GvAVn(PL_defgv);
4381 #endif /* USE_5005THREADS */
4384 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4390 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4392 XPUSHs(SvTIED_obj((SV*)ary, mg));
4398 for (i = AvFILLp(ary); i >= 0; i--)
4399 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4401 /* temporarily switch stacks */
4402 SWITCHSTACK(PL_curstack, ary);
4406 base = SP - PL_stack_base;
4408 if (pm->op_pmflags & PMf_SKIPWHITE) {
4409 if (pm->op_pmflags & PMf_LOCALE) {
4410 while (isSPACE_LC(*s))
4418 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4419 SAVEINT(PL_multiline);
4420 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4424 limit = maxiters + 2;
4425 if (pm->op_pmflags & PMf_WHITE) {
4428 while (m < strend &&
4429 !((pm->op_pmflags & PMf_LOCALE)
4430 ? isSPACE_LC(*m) : isSPACE(*m)))
4435 dstr = NEWSV(30, m-s);
4436 sv_setpvn(dstr, s, m-s);
4440 (void)SvUTF8_on(dstr);
4444 while (s < strend &&
4445 ((pm->op_pmflags & PMf_LOCALE)
4446 ? isSPACE_LC(*s) : isSPACE(*s)))
4450 else if (strEQ("^", rx->precomp)) {
4453 for (m = s; m < strend && *m != '\n'; m++) ;
4457 dstr = NEWSV(30, m-s);
4458 sv_setpvn(dstr, s, m-s);
4462 (void)SvUTF8_on(dstr);
4467 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4468 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4469 && (rx->reganch & ROPT_CHECK_ALL)
4470 && !(rx->reganch & ROPT_ANCH)) {
4471 int tail = (rx->reganch & RE_INTUIT_TAIL);
4472 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4475 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4477 char c = *SvPV(csv, n_a);
4480 for (m = s; m < strend && *m != c; m++) ;
4483 dstr = NEWSV(30, m-s);
4484 sv_setpvn(dstr, s, m-s);
4488 (void)SvUTF8_on(dstr);
4490 /* The rx->minlen is in characters but we want to step
4491 * s ahead by bytes. */
4493 s = (char*)utf8_hop((U8*)m, len);
4495 s = m + len; /* Fake \n at the end */
4500 while (s < strend && --limit &&
4501 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4502 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4505 dstr = NEWSV(31, m-s);
4506 sv_setpvn(dstr, s, m-s);
4510 (void)SvUTF8_on(dstr);
4512 /* The rx->minlen is in characters but we want to step
4513 * s ahead by bytes. */
4515 s = (char*)utf8_hop((U8*)m, len);
4517 s = m + len; /* Fake \n at the end */
4522 maxiters += slen * rx->nparens;
4523 while (s < strend && --limit
4524 /* && (!rx->check_substr
4525 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4527 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4528 1 /* minend */, sv, NULL, 0))
4530 TAINT_IF(RX_MATCH_TAINTED(rx));
4531 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4536 strend = s + (strend - m);
4538 m = rx->startp[0] + orig;
4539 dstr = NEWSV(32, m-s);
4540 sv_setpvn(dstr, s, m-s);
4544 (void)SvUTF8_on(dstr);
4547 for (i = 1; i <= (I32)rx->nparens; i++) {
4548 s = rx->startp[i] + orig;
4549 m = rx->endp[i] + orig;
4551 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4552 parens that didn't match -- they should be set to
4553 undef, not the empty string */
4554 if (m >= orig && s >= orig) {
4555 dstr = NEWSV(33, m-s);
4556 sv_setpvn(dstr, s, m-s);
4559 dstr = &PL_sv_undef; /* undef, not "" */
4563 (void)SvUTF8_on(dstr);
4567 s = rx->endp[0] + orig;
4571 LEAVE_SCOPE(oldsave);
4572 iters = (SP - PL_stack_base) - base;
4573 if (iters > maxiters)
4574 DIE(aTHX_ "Split loop");
4576 /* keep field after final delim? */
4577 if (s < strend || (iters && origlimit)) {
4578 STRLEN l = strend - s;
4579 dstr = NEWSV(34, l);
4580 sv_setpvn(dstr, s, l);
4584 (void)SvUTF8_on(dstr);
4588 else if (!origlimit) {
4589 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4595 SWITCHSTACK(ary, oldstack);
4596 if (SvSMAGICAL(ary)) {
4601 if (gimme == G_ARRAY) {
4603 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4611 call_method("PUSH",G_SCALAR|G_DISCARD);
4614 if (gimme == G_ARRAY) {
4615 /* EXTEND should not be needed - we just popped them */
4617 for (i=0; i < iters; i++) {
4618 SV **svp = av_fetch(ary, i, FALSE);
4619 PUSHs((svp) ? *svp : &PL_sv_undef);
4626 if (gimme == G_ARRAY)
4629 if (iters || !pm->op_pmreplroot) {
4637 #ifdef USE_5005THREADS
4639 Perl_unlock_condpair(pTHX_ void *svv)
4641 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4644 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4645 MUTEX_LOCK(MgMUTEXP(mg));
4646 if (MgOWNER(mg) != thr)
4647 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4649 COND_SIGNAL(MgOWNERCONDP(mg));
4650 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4651 PTR2UV(thr), PTR2UV(svv)));
4652 MUTEX_UNLOCK(MgMUTEXP(mg));
4654 #endif /* USE_5005THREADS */
4662 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4663 || SvTYPE(retsv) == SVt_PVCV) {
4664 retsv = refto(retsv);
4672 #ifdef USE_5005THREADS
4675 if (PL_op->op_private & OPpLVAL_INTRO)
4676 PUSHs(*save_threadsv(PL_op->op_targ));
4678 PUSHs(THREADSV(PL_op->op_targ));
4681 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4682 #endif /* USE_5005THREADS */