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 < 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)
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 > 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 > 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) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3255 (void)SvUPGRADE(TARG,SVt_PV);
3257 if (value > 255 && !IN_BYTES) {
3258 SvGROW(TARG, UNISKIP(value)+1);
3259 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3260 SvCUR_set(TARG, tmps - SvPVX(TARG));
3262 (void)SvPOK_only(TARG);
3273 (void)SvPOK_only(TARG);
3275 sv_recode_to_utf8(TARG, PL_encoding);
3287 char *tmps = SvPV(left, len);
3289 if (DO_UTF8(left)) {
3290 /* If Unicode, try to downgrade.
3291 * If not possible, croak.
3292 * Yes, we made this up. */
3293 SV* tsv = sv_2mortal(newSVsv(left));
3296 sv_utf8_downgrade(tsv, FALSE);
3300 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3302 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3306 "The crypt() function is unimplemented due to excessive paranoia.");
3320 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3324 s = (U8*)SvPV(sv, slen);
3325 utf8_to_uvchr(s, &ulen);
3327 toTITLE_utf8(s, tmpbuf, &tculen);
3328 utf8_to_uvchr(tmpbuf, 0);
3330 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3332 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3333 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3338 s = (U8*)SvPV_force(sv, slen);
3339 Copy(tmpbuf, s, tculen, U8);
3343 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3345 SvUTF8_off(TARG); /* decontaminate */
3350 s = (U8*)SvPV_force(sv, slen);
3352 if (IN_LOCALE_RUNTIME) {
3355 *s = toUPPER_LC(*s);
3373 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3375 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3379 toLOWER_utf8(s, tmpbuf, &ulen);
3380 uv = utf8_to_uvchr(tmpbuf, 0);
3382 tend = uvchr_to_utf8(tmpbuf, uv);
3384 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3386 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3387 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3392 s = (U8*)SvPV_force(sv, slen);
3393 Copy(tmpbuf, s, ulen, U8);
3397 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3399 SvUTF8_off(TARG); /* decontaminate */
3404 s = (U8*)SvPV_force(sv, slen);
3406 if (IN_LOCALE_RUNTIME) {
3409 *s = toLOWER_LC(*s);
3432 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3434 s = (U8*)SvPV(sv,len);
3436 SvUTF8_off(TARG); /* decontaminate */
3437 sv_setpvn(TARG, "", 0);
3441 STRLEN nchar = utf8_length(s, s + len);
3443 (void)SvUPGRADE(TARG, SVt_PV);
3444 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3445 (void)SvPOK_only(TARG);
3446 d = (U8*)SvPVX(TARG);
3449 toUPPER_utf8(s, tmpbuf, &ulen);
3450 Copy(tmpbuf, d, ulen, U8);
3456 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3461 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3463 SvUTF8_off(TARG); /* decontaminate */
3468 s = (U8*)SvPV_force(sv, len);
3470 register U8 *send = s + len;
3472 if (IN_LOCALE_RUNTIME) {
3475 for (; s < send; s++)
3476 *s = toUPPER_LC(*s);
3479 for (; s < send; s++)
3501 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3503 s = (U8*)SvPV(sv,len);
3505 SvUTF8_off(TARG); /* decontaminate */
3506 sv_setpvn(TARG, "", 0);
3510 STRLEN nchar = utf8_length(s, s + len);
3512 (void)SvUPGRADE(TARG, SVt_PV);
3513 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3514 (void)SvPOK_only(TARG);
3515 d = (U8*)SvPVX(TARG);
3518 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3519 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3520 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3522 * Now if the sigma is NOT followed by
3523 * /$ignorable_sequence$cased_letter/;
3524 * and it IS preceded by
3525 * /$cased_letter$ignorable_sequence/;
3526 * where $ignorable_sequence is
3527 * [\x{2010}\x{AD}\p{Mn}]*
3528 * and $cased_letter is
3529 * [\p{Ll}\p{Lo}\p{Lt}]
3530 * then it should be mapped to 0x03C2,
3531 * (GREEK SMALL LETTER FINAL SIGMA),
3532 * instead of staying 0x03A3.
3533 * See lib/unicore/SpecCase.txt.
3536 Copy(tmpbuf, d, ulen, U8);
3542 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3547 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3549 SvUTF8_off(TARG); /* decontaminate */
3555 s = (U8*)SvPV_force(sv, len);
3557 register U8 *send = s + len;
3559 if (IN_LOCALE_RUNTIME) {
3562 for (; s < send; s++)
3563 *s = toLOWER_LC(*s);
3566 for (; s < send; s++)
3581 register char *s = SvPV(sv,len);
3584 SvUTF8_off(TARG); /* decontaminate */
3586 (void)SvUPGRADE(TARG, SVt_PV);
3587 SvGROW(TARG, (len * 2) + 1);
3591 if (UTF8_IS_CONTINUED(*s)) {
3592 STRLEN ulen = UTF8SKIP(s);
3616 SvCUR_set(TARG, d - SvPVX(TARG));
3617 (void)SvPOK_only_UTF8(TARG);
3620 sv_setpvn(TARG, s, len);
3622 if (SvSMAGICAL(TARG))
3631 dSP; dMARK; dORIGMARK;
3633 register AV* av = (AV*)POPs;
3634 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3635 I32 arybase = PL_curcop->cop_arybase;
3638 if (SvTYPE(av) == SVt_PVAV) {
3639 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3641 for (svp = MARK + 1; svp <= SP; svp++) {
3646 if (max > AvMAX(av))
3649 while (++MARK <= SP) {
3650 elem = SvIVx(*MARK);
3654 svp = av_fetch(av, elem, lval);
3656 if (!svp || *svp == &PL_sv_undef)
3657 DIE(aTHX_ PL_no_aelem, elem);
3658 if (PL_op->op_private & OPpLVAL_INTRO)
3659 save_aelem(av, elem, svp);
3661 *MARK = svp ? *svp : &PL_sv_undef;
3664 if (GIMME != G_ARRAY) {
3672 /* Associative arrays. */
3677 HV *hash = (HV*)POPs;
3679 I32 gimme = GIMME_V;
3680 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3683 /* might clobber stack_sp */
3684 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3689 SV* sv = hv_iterkeysv(entry);
3690 if (HvUTF8KEYS((SV*)hash) && !DO_UTF8(sv)) {
3692 char* s = SvPV(sv, len);
3693 for (i = 0; i < len && NATIVE_IS_INVARIANT(s[i]); i++);
3696 sv_utf8_upgrade(sv);
3699 PUSHs(sv); /* won't clobber stack_sp */
3700 if (gimme == G_ARRAY) {
3703 /* might clobber stack_sp */
3705 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3710 else if (gimme == G_SCALAR)
3729 I32 gimme = GIMME_V;
3730 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3734 if (PL_op->op_private & OPpSLICE) {
3738 hvtype = SvTYPE(hv);
3739 if (hvtype == SVt_PVHV) { /* hash element */
3740 while (++MARK <= SP) {
3741 sv = hv_delete_ent(hv, *MARK, discard, 0);
3742 *MARK = sv ? sv : &PL_sv_undef;
3745 else if (hvtype == SVt_PVAV) {
3746 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3747 while (++MARK <= SP) {
3748 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3749 *MARK = sv ? sv : &PL_sv_undef;
3752 else { /* pseudo-hash element */
3753 while (++MARK <= SP) {
3754 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3755 *MARK = sv ? sv : &PL_sv_undef;
3760 DIE(aTHX_ "Not a HASH reference");
3763 else if (gimme == G_SCALAR) {
3772 if (SvTYPE(hv) == SVt_PVHV)
3773 sv = hv_delete_ent(hv, keysv, discard, 0);
3774 else if (SvTYPE(hv) == SVt_PVAV) {
3775 if (PL_op->op_flags & OPf_SPECIAL)
3776 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3778 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3781 DIE(aTHX_ "Not a HASH reference");
3796 if (PL_op->op_private & OPpEXISTS_SUB) {
3800 cv = sv_2cv(sv, &hv, &gv, FALSE);
3803 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3809 if (SvTYPE(hv) == SVt_PVHV) {
3810 if (hv_exists_ent(hv, tmpsv, 0))
3813 else if (SvTYPE(hv) == SVt_PVAV) {
3814 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3815 if (av_exists((AV*)hv, SvIV(tmpsv)))
3818 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3822 DIE(aTHX_ "Not a HASH reference");
3829 dSP; dMARK; dORIGMARK;
3830 register HV *hv = (HV*)POPs;
3831 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3832 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3834 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3835 DIE(aTHX_ "Can't localize pseudo-hash element");
3837 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3838 while (++MARK <= SP) {
3841 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3842 realhv ? hv_exists_ent(hv, keysv, 0)
3843 : avhv_exists_ent((AV*)hv, keysv, 0);
3845 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3846 svp = he ? &HeVAL(he) : 0;
3849 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3852 if (!svp || *svp == &PL_sv_undef) {
3854 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3856 if (PL_op->op_private & OPpLVAL_INTRO) {
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;
3869 if (GIMME != G_ARRAY) {
3877 /* List operators. */
3882 if (GIMME != G_ARRAY) {
3884 *MARK = *SP; /* unwanted list, return last item */
3886 *MARK = &PL_sv_undef;
3895 SV **lastrelem = PL_stack_sp;
3896 SV **lastlelem = PL_stack_base + POPMARK;
3897 SV **firstlelem = PL_stack_base + POPMARK + 1;
3898 register SV **firstrelem = lastlelem + 1;
3899 I32 arybase = PL_curcop->cop_arybase;
3900 I32 lval = PL_op->op_flags & OPf_MOD;
3901 I32 is_something_there = lval;
3903 register I32 max = lastrelem - lastlelem;
3904 register SV **lelem;
3907 if (GIMME != G_ARRAY) {
3908 ix = SvIVx(*lastlelem);
3913 if (ix < 0 || ix >= max)
3914 *firstlelem = &PL_sv_undef;
3916 *firstlelem = firstrelem[ix];
3922 SP = firstlelem - 1;
3926 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3932 if (ix < 0 || ix >= max)
3933 *lelem = &PL_sv_undef;
3935 is_something_there = TRUE;
3936 if (!(*lelem = firstrelem[ix]))
3937 *lelem = &PL_sv_undef;
3940 if (is_something_there)
3943 SP = firstlelem - 1;
3949 dSP; dMARK; dORIGMARK;
3950 I32 items = SP - MARK;
3951 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3952 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3959 dSP; dMARK; dORIGMARK;
3960 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3964 SV *val = NEWSV(46, 0);
3966 sv_setsv(val, *++MARK);
3967 else if (ckWARN(WARN_MISC))
3968 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3969 (void)hv_store_ent(hv,key,val,0);
3978 dSP; dMARK; dORIGMARK;
3979 register AV *ary = (AV*)*++MARK;
3983 register I32 offset;
3984 register I32 length;
3991 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3992 *MARK-- = SvTIED_obj((SV*)ary, mg);
3996 call_method("SPLICE",GIMME_V);
4005 offset = i = SvIVx(*MARK);
4007 offset += AvFILLp(ary) + 1;
4009 offset -= PL_curcop->cop_arybase;
4011 DIE(aTHX_ PL_no_aelem, i);
4013 length = SvIVx(*MARK++);
4015 length += AvFILLp(ary) - offset + 1;
4021 length = AvMAX(ary) + 1; /* close enough to infinity */
4025 length = AvMAX(ary) + 1;
4027 if (offset > AvFILLp(ary) + 1) {
4028 if (ckWARN(WARN_MISC))
4029 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4030 offset = AvFILLp(ary) + 1;
4032 after = AvFILLp(ary) + 1 - (offset + length);
4033 if (after < 0) { /* not that much array */
4034 length += after; /* offset+length now in array */
4040 /* At this point, MARK .. SP-1 is our new LIST */
4043 diff = newlen - length;
4044 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4047 if (diff < 0) { /* shrinking the area */
4049 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4050 Copy(MARK, tmparyval, newlen, SV*);
4053 MARK = ORIGMARK + 1;
4054 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4055 MEXTEND(MARK, length);
4056 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4058 EXTEND_MORTAL(length);
4059 for (i = length, dst = MARK; i; i--) {
4060 sv_2mortal(*dst); /* free them eventualy */
4067 *MARK = AvARRAY(ary)[offset+length-1];
4070 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4071 SvREFCNT_dec(*dst++); /* free them now */
4074 AvFILLp(ary) += diff;
4076 /* pull up or down? */
4078 if (offset < after) { /* easier to pull up */
4079 if (offset) { /* esp. if nothing to pull */
4080 src = &AvARRAY(ary)[offset-1];
4081 dst = src - diff; /* diff is negative */
4082 for (i = offset; i > 0; i--) /* can't trust Copy */
4086 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4090 if (after) { /* anything to pull down? */
4091 src = AvARRAY(ary) + offset + length;
4092 dst = src + diff; /* diff is negative */
4093 Move(src, dst, after, SV*);
4095 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4096 /* avoid later double free */
4100 dst[--i] = &PL_sv_undef;
4103 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4105 *dst = NEWSV(46, 0);
4106 sv_setsv(*dst++, *src++);
4108 Safefree(tmparyval);
4111 else { /* no, expanding (or same) */
4113 New(452, tmparyval, length, SV*); /* so remember deletion */
4114 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4117 if (diff > 0) { /* expanding */
4119 /* push up or down? */
4121 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4125 Move(src, dst, offset, SV*);
4127 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4129 AvFILLp(ary) += diff;
4132 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4133 av_extend(ary, AvFILLp(ary) + diff);
4134 AvFILLp(ary) += diff;
4137 dst = AvARRAY(ary) + AvFILLp(ary);
4139 for (i = after; i; i--) {
4146 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4147 *dst = NEWSV(46, 0);
4148 sv_setsv(*dst++, *src++);
4150 MARK = ORIGMARK + 1;
4151 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4153 Copy(tmparyval, MARK, length, SV*);
4155 EXTEND_MORTAL(length);
4156 for (i = length, dst = MARK; i; i--) {
4157 sv_2mortal(*dst); /* free them eventualy */
4161 Safefree(tmparyval);
4165 else if (length--) {
4166 *MARK = tmparyval[length];
4169 while (length-- > 0)
4170 SvREFCNT_dec(tmparyval[length]);
4172 Safefree(tmparyval);
4175 *MARK = &PL_sv_undef;
4183 dSP; dMARK; dORIGMARK; dTARGET;
4184 register AV *ary = (AV*)*++MARK;
4185 register SV *sv = &PL_sv_undef;
4188 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4189 *MARK-- = SvTIED_obj((SV*)ary, mg);
4193 call_method("PUSH",G_SCALAR|G_DISCARD);
4198 /* Why no pre-extend of ary here ? */
4199 for (++MARK; MARK <= SP; MARK++) {
4202 sv_setsv(sv, *MARK);
4207 PUSHi( AvFILL(ary) + 1 );
4215 SV *sv = av_pop(av);
4217 (void)sv_2mortal(sv);
4226 SV *sv = av_shift(av);
4231 (void)sv_2mortal(sv);
4238 dSP; dMARK; dORIGMARK; dTARGET;
4239 register AV *ary = (AV*)*++MARK;
4244 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4245 *MARK-- = SvTIED_obj((SV*)ary, mg);
4249 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4254 av_unshift(ary, SP - MARK);
4257 sv_setsv(sv, *++MARK);
4258 (void)av_store(ary, i++, sv);
4262 PUSHi( AvFILL(ary) + 1 );
4272 if (GIMME == G_ARRAY) {
4279 /* safe as long as stack cannot get extended in the above */
4284 register char *down;
4289 SvUTF8_off(TARG); /* decontaminate */
4291 do_join(TARG, &PL_sv_no, MARK, SP);
4293 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4294 up = SvPV_force(TARG, len);
4296 if (DO_UTF8(TARG)) { /* first reverse each character */
4297 U8* s = (U8*)SvPVX(TARG);
4298 U8* send = (U8*)(s + len);
4300 if (UTF8_IS_INVARIANT(*s)) {
4305 if (!utf8_to_uvchr(s, 0))
4309 down = (char*)(s - 1);
4310 /* reverse this character */
4320 down = SvPVX(TARG) + len - 1;
4326 (void)SvPOK_only_UTF8(TARG);
4338 register IV limit = POPi; /* note, negative is forever */
4341 register char *s = SvPV(sv, len);
4342 bool do_utf8 = DO_UTF8(sv);
4343 char *strend = s + len;
4345 register REGEXP *rx;
4349 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4350 I32 maxiters = slen + 10;
4353 I32 origlimit = limit;
4356 AV *oldstack = PL_curstack;
4357 I32 gimme = GIMME_V;
4358 I32 oldsave = PL_savestack_ix;
4359 I32 make_mortal = 1;
4360 MAGIC *mg = (MAGIC *) NULL;
4363 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4368 DIE(aTHX_ "panic: pp_split");
4371 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4372 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4374 PL_reg_match_utf8 = do_utf8;
4376 if (pm->op_pmreplroot) {
4378 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4380 ary = GvAVn((GV*)pm->op_pmreplroot);
4383 else if (gimme != G_ARRAY)
4384 #ifdef USE_5005THREADS
4385 ary = (AV*)PL_curpad[0];
4387 ary = GvAVn(PL_defgv);
4388 #endif /* USE_5005THREADS */
4391 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4397 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4399 XPUSHs(SvTIED_obj((SV*)ary, mg));
4405 for (i = AvFILLp(ary); i >= 0; i--)
4406 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4408 /* temporarily switch stacks */
4409 SWITCHSTACK(PL_curstack, ary);
4413 base = SP - PL_stack_base;
4415 if (pm->op_pmflags & PMf_SKIPWHITE) {
4416 if (pm->op_pmflags & PMf_LOCALE) {
4417 while (isSPACE_LC(*s))
4425 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4426 SAVEINT(PL_multiline);
4427 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4431 limit = maxiters + 2;
4432 if (pm->op_pmflags & PMf_WHITE) {
4435 while (m < strend &&
4436 !((pm->op_pmflags & PMf_LOCALE)
4437 ? isSPACE_LC(*m) : isSPACE(*m)))
4442 dstr = NEWSV(30, m-s);
4443 sv_setpvn(dstr, s, m-s);
4447 (void)SvUTF8_on(dstr);
4451 while (s < strend &&
4452 ((pm->op_pmflags & PMf_LOCALE)
4453 ? isSPACE_LC(*s) : isSPACE(*s)))
4457 else if (strEQ("^", rx->precomp)) {
4460 for (m = s; m < strend && *m != '\n'; m++) ;
4464 dstr = NEWSV(30, m-s);
4465 sv_setpvn(dstr, s, m-s);
4469 (void)SvUTF8_on(dstr);
4474 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4475 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4476 && (rx->reganch & ROPT_CHECK_ALL)
4477 && !(rx->reganch & ROPT_ANCH)) {
4478 int tail = (rx->reganch & RE_INTUIT_TAIL);
4479 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4482 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4484 char c = *SvPV(csv, n_a);
4487 for (m = s; m < strend && *m != c; m++) ;
4490 dstr = NEWSV(30, m-s);
4491 sv_setpvn(dstr, s, m-s);
4495 (void)SvUTF8_on(dstr);
4497 /* The rx->minlen is in characters but we want to step
4498 * s ahead by bytes. */
4500 s = (char*)utf8_hop((U8*)m, len);
4502 s = m + len; /* Fake \n at the end */
4507 while (s < strend && --limit &&
4508 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4509 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4512 dstr = NEWSV(31, m-s);
4513 sv_setpvn(dstr, s, m-s);
4517 (void)SvUTF8_on(dstr);
4519 /* The rx->minlen is in characters but we want to step
4520 * s ahead by bytes. */
4522 s = (char*)utf8_hop((U8*)m, len);
4524 s = m + len; /* Fake \n at the end */
4529 maxiters += slen * rx->nparens;
4530 while (s < strend && --limit
4531 /* && (!rx->check_substr
4532 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4534 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4535 1 /* minend */, sv, NULL, 0))
4537 TAINT_IF(RX_MATCH_TAINTED(rx));
4538 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4543 strend = s + (strend - m);
4545 m = rx->startp[0] + orig;
4546 dstr = NEWSV(32, m-s);
4547 sv_setpvn(dstr, s, m-s);
4551 (void)SvUTF8_on(dstr);
4554 for (i = 1; i <= rx->nparens; i++) {
4555 s = rx->startp[i] + orig;
4556 m = rx->endp[i] + orig;
4558 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4559 parens that didn't match -- they should be set to
4560 undef, not the empty string */
4561 if (m >= orig && s >= orig) {
4562 dstr = NEWSV(33, m-s);
4563 sv_setpvn(dstr, s, m-s);
4566 dstr = &PL_sv_undef; /* undef, not "" */
4570 (void)SvUTF8_on(dstr);
4574 s = rx->endp[0] + orig;
4578 LEAVE_SCOPE(oldsave);
4579 iters = (SP - PL_stack_base) - base;
4580 if (iters > maxiters)
4581 DIE(aTHX_ "Split loop");
4583 /* keep field after final delim? */
4584 if (s < strend || (iters && origlimit)) {
4585 STRLEN l = strend - s;
4586 dstr = NEWSV(34, l);
4587 sv_setpvn(dstr, s, l);
4591 (void)SvUTF8_on(dstr);
4595 else if (!origlimit) {
4596 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4602 SWITCHSTACK(ary, oldstack);
4603 if (SvSMAGICAL(ary)) {
4608 if (gimme == G_ARRAY) {
4610 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4618 call_method("PUSH",G_SCALAR|G_DISCARD);
4621 if (gimme == G_ARRAY) {
4622 /* EXTEND should not be needed - we just popped them */
4624 for (i=0; i < iters; i++) {
4625 SV **svp = av_fetch(ary, i, FALSE);
4626 PUSHs((svp) ? *svp : &PL_sv_undef);
4633 if (gimme == G_ARRAY)
4636 if (iters || !pm->op_pmreplroot) {
4644 #ifdef USE_5005THREADS
4646 Perl_unlock_condpair(pTHX_ void *svv)
4648 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4651 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4652 MUTEX_LOCK(MgMUTEXP(mg));
4653 if (MgOWNER(mg) != thr)
4654 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4656 COND_SIGNAL(MgOWNERCONDP(mg));
4657 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4658 PTR2UV(thr), PTR2UV(svv)));
4659 MUTEX_UNLOCK(MgMUTEXP(mg));
4661 #endif /* USE_5005THREADS */
4669 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4670 || SvTYPE(retsv) == SVt_PVCV) {
4671 retsv = refto(retsv);
4679 #ifdef USE_5005THREADS
4682 if (PL_op->op_private & OPpLVAL_INTRO)
4683 PUSHs(*save_threadsv(PL_op->op_targ));
4685 PUSHs(THREADSV(PL_op->op_targ));
4688 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4689 #endif /* USE_5005THREADS */