3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
22 /* variations on pp_null */
24 /* XXX I can't imagine anyone who doesn't have this actually _needs_
25 it, since pid_t is an integral type.
28 #ifdef NEED_GETPID_PROTO
29 extern Pid_t getpid (void);
35 if (GIMME_V == G_SCALAR)
50 if (PL_op->op_private & OPpLVAL_INTRO)
51 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
53 if (PL_op->op_flags & OPf_REF) {
57 if (GIMME == G_SCALAR)
58 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
62 if (GIMME == G_ARRAY) {
63 I32 maxarg = AvFILL((AV*)TARG) + 1;
65 if (SvMAGICAL(TARG)) {
67 for (i=0; i < (U32)maxarg; i++) {
68 SV **svp = av_fetch((AV*)TARG, i, FALSE);
69 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
73 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
78 SV* sv = sv_newmortal();
79 I32 maxarg = AvFILL((AV*)TARG) + 1;
92 if (PL_op->op_private & OPpLVAL_INTRO)
93 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
94 if (PL_op->op_flags & OPf_REF)
97 if (GIMME == G_SCALAR)
98 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
102 if (gimme == G_ARRAY) {
105 else if (gimme == G_SCALAR) {
106 SV* sv = sv_newmortal();
107 if (HvFILL((HV*)TARG))
108 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
109 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
119 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
130 tryAMAGICunDEREF(to_gv);
133 if (SvTYPE(sv) == SVt_PVIO) {
134 GV *gv = (GV*) sv_newmortal();
135 gv_init(gv, 0, "", 0, 0);
136 GvIOp(gv) = (IO *)sv;
137 (void)SvREFCNT_inc(sv);
140 else if (SvTYPE(sv) != SVt_PVGV)
141 DIE(aTHX_ "Not a GLOB reference");
144 if (SvTYPE(sv) != SVt_PVGV) {
148 if (SvGMAGICAL(sv)) {
153 if (!SvOK(sv) && sv != &PL_sv_undef) {
154 /* If this is a 'my' scalar and flag is set then vivify
157 if (PL_op->op_private & OPpDEREF) {
160 if (cUNOP->op_targ) {
162 SV *namesv = PL_curpad[cUNOP->op_targ];
163 name = SvPV(namesv, len);
164 gv = (GV*)NEWSV(0,0);
165 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
168 name = CopSTASHPV(PL_curcop);
171 if (SvTYPE(sv) < SVt_RV)
172 sv_upgrade(sv, SVt_RV);
178 if (PL_op->op_flags & OPf_REF ||
179 PL_op->op_private & HINT_STRICT_REFS)
180 DIE(aTHX_ PL_no_usym, "a symbol");
181 if (ckWARN(WARN_UNINITIALIZED))
186 if ((PL_op->op_flags & OPf_SPECIAL) &&
187 !(PL_op->op_flags & OPf_MOD))
189 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
191 && (!is_gv_magical(sym,len,0)
192 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
198 if (PL_op->op_private & HINT_STRICT_REFS)
199 DIE(aTHX_ PL_no_symref, sym, "a symbol");
200 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
204 if (PL_op->op_private & OPpLVAL_INTRO)
205 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
216 tryAMAGICunDEREF(to_sv);
219 switch (SvTYPE(sv)) {
223 DIE(aTHX_ "Not a SCALAR reference");
231 if (SvTYPE(gv) != SVt_PVGV) {
232 if (SvGMAGICAL(sv)) {
238 if (PL_op->op_flags & OPf_REF ||
239 PL_op->op_private & HINT_STRICT_REFS)
240 DIE(aTHX_ PL_no_usym, "a SCALAR");
241 if (ckWARN(WARN_UNINITIALIZED))
246 if ((PL_op->op_flags & OPf_SPECIAL) &&
247 !(PL_op->op_flags & OPf_MOD))
249 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
251 && (!is_gv_magical(sym,len,0)
252 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
258 if (PL_op->op_private & HINT_STRICT_REFS)
259 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
260 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
265 if (PL_op->op_flags & OPf_MOD) {
266 if (PL_op->op_private & OPpLVAL_INTRO)
267 sv = save_scalar((GV*)TOPs);
268 else if (PL_op->op_private & OPpDEREF)
269 vivify_ref(sv, PL_op->op_private & OPpDEREF);
279 SV *sv = AvARYLEN(av);
281 AvARYLEN(av) = sv = NEWSV(0,0);
282 sv_upgrade(sv, SVt_IV);
283 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
291 dSP; dTARGET; dPOPss;
293 if (PL_op->op_flags & OPf_MOD || LVRET) {
294 if (SvTYPE(TARG) < SVt_PVLV) {
295 sv_upgrade(TARG, SVt_PVLV);
296 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
300 if (LvTARG(TARG) != sv) {
302 SvREFCNT_dec(LvTARG(TARG));
303 LvTARG(TARG) = SvREFCNT_inc(sv);
305 PUSHs(TARG); /* no SvSETMAGIC */
311 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
312 mg = mg_find(sv, PERL_MAGIC_regex_global);
313 if (mg && mg->mg_len >= 0) {
317 PUSHi(i + PL_curcop->cop_arybase);
331 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
332 /* (But not in defined().) */
333 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
336 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
337 if ((PL_op->op_private & OPpLVAL_INTRO)) {
338 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
341 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
345 cv = (CV*)&PL_sv_undef;
359 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
360 char *s = SvPVX(TOPs);
361 if (strnEQ(s, "CORE::", 6)) {
364 code = keyword(s + 6, SvCUR(TOPs) - 6);
365 if (code < 0) { /* Overridable. */
366 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
367 int i = 0, n = 0, seen_question = 0;
369 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
371 if (code == -KEY_chop || code == -KEY_chomp)
373 while (i < MAXO) { /* The slow way. */
374 if (strEQ(s + 6, PL_op_name[i])
375 || strEQ(s + 6, PL_op_desc[i]))
381 goto nonesuch; /* Should not happen... */
383 oa = PL_opargs[i] >> OASHIFT;
385 if (oa & OA_OPTIONAL && !seen_question) {
389 else if (n && str[0] == ';' && seen_question)
390 goto set; /* XXXX system, exec */
391 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
392 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
393 /* But globs are already references (kinda) */
394 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
398 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
402 ret = sv_2mortal(newSVpvn(str, n - 1));
404 else if (code) /* Non-Overridable */
406 else { /* None such */
408 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
412 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
414 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
423 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
425 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
441 if (GIMME != G_ARRAY) {
445 *MARK = &PL_sv_undef;
446 *MARK = refto(*MARK);
450 EXTEND_MORTAL(SP - MARK);
452 *MARK = refto(*MARK);
457 S_refto(pTHX_ SV *sv)
461 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
464 if (!(sv = LvTARG(sv)))
467 (void)SvREFCNT_inc(sv);
469 else if (SvTYPE(sv) == SVt_PVAV) {
470 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
473 (void)SvREFCNT_inc(sv);
475 else if (SvPADTMP(sv) && !IS_PADGV(sv))
479 (void)SvREFCNT_inc(sv);
482 sv_upgrade(rv, SVt_RV);
496 if (sv && SvGMAGICAL(sv))
499 if (!sv || !SvROK(sv))
503 pv = sv_reftype(sv,TRUE);
504 PUSHp(pv, strlen(pv));
514 stash = CopSTASH(PL_curcop);
520 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
521 Perl_croak(aTHX_ "Attempt to bless into a reference");
523 if (ckWARN(WARN_MISC) && len == 0)
524 Perl_warner(aTHX_ packWARN(WARN_MISC),
525 "Explicit blessing to '' (assuming package main)");
526 stash = gv_stashpvn(ptr, len, TRUE);
529 (void)sv_bless(TOPs, stash);
543 elem = SvPV(sv, n_a);
547 switch (elem ? *elem : '\0')
550 if (strEQ(elem, "ARRAY"))
551 tmpRef = (SV*)GvAV(gv);
554 if (strEQ(elem, "CODE"))
555 tmpRef = (SV*)GvCVu(gv);
558 if (strEQ(elem, "FILEHANDLE")) {
559 /* finally deprecated in 5.8.0 */
560 deprecate("*glob{FILEHANDLE}");
561 tmpRef = (SV*)GvIOp(gv);
564 if (strEQ(elem, "FORMAT"))
565 tmpRef = (SV*)GvFORM(gv);
568 if (strEQ(elem, "GLOB"))
572 if (strEQ(elem, "HASH"))
573 tmpRef = (SV*)GvHV(gv);
576 if (strEQ(elem, "IO"))
577 tmpRef = (SV*)GvIOp(gv);
580 if (strEQ(elem, "NAME"))
581 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
584 if (strEQ(elem, "PACKAGE"))
585 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
588 if (strEQ(elem, "SCALAR"))
602 /* Pattern matching */
607 register unsigned char *s;
610 register I32 *sfirst;
614 if (sv == PL_lastscream) {
620 SvSCREAM_off(PL_lastscream);
621 SvREFCNT_dec(PL_lastscream);
623 PL_lastscream = SvREFCNT_inc(sv);
626 s = (unsigned char*)(SvPV(sv, len));
630 if (pos > PL_maxscream) {
631 if (PL_maxscream < 0) {
632 PL_maxscream = pos + 80;
633 New(301, PL_screamfirst, 256, I32);
634 New(302, PL_screamnext, PL_maxscream, I32);
637 PL_maxscream = pos + pos / 4;
638 Renew(PL_screamnext, PL_maxscream, I32);
642 sfirst = PL_screamfirst;
643 snext = PL_screamnext;
645 if (!sfirst || !snext)
646 DIE(aTHX_ "do_study: out of memory");
648 for (ch = 256; ch; --ch)
655 snext[pos] = sfirst[ch] - pos;
662 /* piggyback on m//g magic */
663 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
672 if (PL_op->op_flags & OPf_STACKED)
678 TARG = sv_newmortal();
683 /* Lvalue operators. */
695 dSP; dMARK; dTARGET; dORIGMARK;
697 do_chop(TARG, *++MARK);
706 SETi(do_chomp(TOPs));
713 register I32 count = 0;
716 count += do_chomp(POPs);
727 if (!sv || !SvANY(sv))
729 switch (SvTYPE(sv)) {
731 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
732 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
736 if (HvARRAY(sv) || SvGMAGICAL(sv)
737 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
741 if (CvROOT(sv) || CvXSUB(sv))
758 if (!PL_op->op_private) {
767 SV_CHECK_THINKFIRST_COW_DROP(sv);
769 switch (SvTYPE(sv)) {
779 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
780 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
781 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
785 /* let user-undef'd sub keep its identity */
786 GV* gv = CvGV((CV*)sv);
793 SvSetMagicSV(sv, &PL_sv_undef);
797 Newz(602, gp, 1, GP);
798 GvGP(sv) = gp_ref(gp);
799 GvSV(sv) = NEWSV(72,0);
800 GvLINE(sv) = CopLINE(PL_curcop);
806 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
809 SvPV_set(sv, Nullch);
822 if (SvTYPE(TOPs) > SVt_PVLV)
823 DIE(aTHX_ PL_no_modify);
824 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
825 && SvIVX(TOPs) != IV_MIN)
828 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
839 if (SvTYPE(TOPs) > SVt_PVLV)
840 DIE(aTHX_ PL_no_modify);
841 sv_setsv(TARG, TOPs);
842 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
843 && SvIVX(TOPs) != IV_MAX)
846 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
860 if (SvTYPE(TOPs) > SVt_PVLV)
861 DIE(aTHX_ PL_no_modify);
862 sv_setsv(TARG, TOPs);
863 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
864 && SvIVX(TOPs) != IV_MIN)
867 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
876 /* Ordinary operators. */
880 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
881 #ifdef PERL_PRESERVE_IVUV
882 /* ** is implemented with pow. pow is floating point. Perl programmers
883 write 2 ** 31 and expect it to be 2147483648
884 pow never made any guarantee to deliver a result to 53 (or whatever)
885 bits of accuracy. Which is unfortunate, as perl programmers expect it
886 to, and on some platforms (eg Irix with long doubles) it doesn't in
887 a very visible case. (2 ** 31, which a regression test uses)
888 So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
893 bool baseuok = SvUOK(TOPm1s);
897 baseuv = SvUVX(TOPm1s);
899 IV iv = SvIVX(TOPm1s);
902 baseuok = TRUE; /* effectively it's a UV now */
904 baseuv = -iv; /* abs, baseuok == false records sign */
918 goto float_it; /* Can't do negative powers this way. */
921 /* now we have integer ** positive integer.
922 foo & (foo - 1) is zero only for a power of 2. */
923 if (!(baseuv & (baseuv - 1))) {
924 /* We are raising power-of-2 to postive integer.
925 The logic here will work for any base (even non-integer
926 bases) but it can be less accurate than
927 pow (base,power) or exp (power * log (base)) when the
928 intermediate values start to spill out of the mantissa.
929 With powers of 2 we know this can't happen.
930 And powers of 2 are the favourite thing for perl
931 programmers to notice ** not doing what they mean. */
933 NV base = baseuok ? baseuv : -(NV)baseuv;
936 /* The logic is this.
937 x ** n === x ** m1 * x ** m2 where n = m1 + m2
938 so as 42 is 32 + 8 + 2
939 x ** 42 can be written as
940 x ** 32 * x ** 8 * x ** 2
941 I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
942 x ** 2n is x ** n * x ** n
943 So I loop round, squaring x each time
944 (x, x ** 2, x ** 4, x ** 8) and multiply the result
945 by the x-value whenever that bit is set in the power.
946 To finish as soon as possible I zero bits in the power
947 when I've done them, so that power becomes zero when
948 I clear the last bit (no more to do), and the loop
950 for (; power; base *= base, n++) {
951 /* Do I look like I trust gcc with long longs here?
953 UV bit = (UV)1 << (UV)n;
956 /* Only bother to clear the bit if it is set. */
958 /* Avoid squaring base again if we're done. */
959 if (power == 0) break;
973 SETn( Perl_pow( left, right) );
980 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
981 #ifdef PERL_PRESERVE_IVUV
984 /* Unless the left argument is integer in range we are going to have to
985 use NV maths. Hence only attempt to coerce the right argument if
986 we know the left is integer. */
987 /* Left operand is defined, so is it IV? */
990 bool auvok = SvUOK(TOPm1s);
991 bool buvok = SvUOK(TOPs);
992 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
993 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1000 alow = SvUVX(TOPm1s);
1002 IV aiv = SvIVX(TOPm1s);
1005 auvok = TRUE; /* effectively it's a UV now */
1007 alow = -aiv; /* abs, auvok == false records sign */
1013 IV biv = SvIVX(TOPs);
1016 buvok = TRUE; /* effectively it's a UV now */
1018 blow = -biv; /* abs, buvok == false records sign */
1022 /* If this does sign extension on unsigned it's time for plan B */
1023 ahigh = alow >> (4 * sizeof (UV));
1025 bhigh = blow >> (4 * sizeof (UV));
1027 if (ahigh && bhigh) {
1028 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1029 which is overflow. Drop to NVs below. */
1030 } else if (!ahigh && !bhigh) {
1031 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1032 so the unsigned multiply cannot overflow. */
1033 UV product = alow * blow;
1034 if (auvok == buvok) {
1035 /* -ve * -ve or +ve * +ve gives a +ve result. */
1039 } else if (product <= (UV)IV_MIN) {
1040 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1041 /* -ve result, which could overflow an IV */
1043 SETi( -(IV)product );
1045 } /* else drop to NVs below. */
1047 /* One operand is large, 1 small */
1050 /* swap the operands */
1052 bhigh = blow; /* bhigh now the temp var for the swap */
1056 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1057 multiplies can't overflow. shift can, add can, -ve can. */
1058 product_middle = ahigh * blow;
1059 if (!(product_middle & topmask)) {
1060 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1062 product_middle <<= (4 * sizeof (UV));
1063 product_low = alow * blow;
1065 /* as for pp_add, UV + something mustn't get smaller.
1066 IIRC ANSI mandates this wrapping *behaviour* for
1067 unsigned whatever the actual representation*/
1068 product_low += product_middle;
1069 if (product_low >= product_middle) {
1070 /* didn't overflow */
1071 if (auvok == buvok) {
1072 /* -ve * -ve or +ve * +ve gives a +ve result. */
1074 SETu( product_low );
1076 } else if (product_low <= (UV)IV_MIN) {
1077 /* 2s complement assumption again */
1078 /* -ve result, which could overflow an IV */
1080 SETi( -(IV)product_low );
1082 } /* else drop to NVs below. */
1084 } /* product_middle too large */
1085 } /* ahigh && bhigh */
1086 } /* SvIOK(TOPm1s) */
1091 SETn( left * right );
1098 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1099 /* Only try to do UV divide first
1100 if ((SLOPPYDIVIDE is true) or
1101 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1103 The assumption is that it is better to use floating point divide
1104 whenever possible, only doing integer divide first if we can't be sure.
1105 If NV_PRESERVES_UV is true then we know at compile time that no UV
1106 can be too large to preserve, so don't need to compile the code to
1107 test the size of UVs. */
1110 # define PERL_TRY_UV_DIVIDE
1111 /* ensure that 20./5. == 4. */
1113 # ifdef PERL_PRESERVE_IVUV
1114 # ifndef NV_PRESERVES_UV
1115 # define PERL_TRY_UV_DIVIDE
1120 #ifdef PERL_TRY_UV_DIVIDE
1123 SvIV_please(TOPm1s);
1124 if (SvIOK(TOPm1s)) {
1125 bool left_non_neg = SvUOK(TOPm1s);
1126 bool right_non_neg = SvUOK(TOPs);
1130 if (right_non_neg) {
1131 right = SvUVX(TOPs);
1134 IV biv = SvIVX(TOPs);
1137 right_non_neg = TRUE; /* effectively it's a UV now */
1143 /* historically undef()/0 gives a "Use of uninitialized value"
1144 warning before dieing, hence this test goes here.
1145 If it were immediately before the second SvIV_please, then
1146 DIE() would be invoked before left was even inspected, so
1147 no inpsection would give no warning. */
1149 DIE(aTHX_ "Illegal division by zero");
1152 left = SvUVX(TOPm1s);
1155 IV aiv = SvIVX(TOPm1s);
1158 left_non_neg = TRUE; /* effectively it's a UV now */
1167 /* For sloppy divide we always attempt integer division. */
1169 /* Otherwise we only attempt it if either or both operands
1170 would not be preserved by an NV. If both fit in NVs
1171 we fall through to the NV divide code below. However,
1172 as left >= right to ensure integer result here, we know that
1173 we can skip the test on the right operand - right big
1174 enough not to be preserved can't get here unless left is
1177 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1180 /* Integer division can't overflow, but it can be imprecise. */
1181 UV result = left / right;
1182 if (result * right == left) {
1183 SP--; /* result is valid */
1184 if (left_non_neg == right_non_neg) {
1185 /* signs identical, result is positive. */
1189 /* 2s complement assumption */
1190 if (result <= (UV)IV_MIN)
1191 SETi( -(IV)result );
1193 /* It's exact but too negative for IV. */
1194 SETn( -(NV)result );
1197 } /* tried integer divide but it was not an integer result */
1198 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1199 } /* left wasn't SvIOK */
1200 } /* right wasn't SvIOK */
1201 #endif /* PERL_TRY_UV_DIVIDE */
1205 DIE(aTHX_ "Illegal division by zero");
1206 PUSHn( left / right );
1213 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1217 bool left_neg = FALSE;
1218 bool right_neg = FALSE;
1219 bool use_double = FALSE;
1220 bool dright_valid = FALSE;
1226 right_neg = !SvUOK(TOPs);
1228 right = SvUVX(POPs);
1230 IV biv = SvIVX(POPs);
1233 right_neg = FALSE; /* effectively it's a UV now */
1241 right_neg = dright < 0;
1244 if (dright < UV_MAX_P1) {
1245 right = U_V(dright);
1246 dright_valid = TRUE; /* In case we need to use double below. */
1252 /* At this point use_double is only true if right is out of range for
1253 a UV. In range NV has been rounded down to nearest UV and
1254 use_double false. */
1256 if (!use_double && SvIOK(TOPs)) {
1258 left_neg = !SvUOK(TOPs);
1262 IV aiv = SvIVX(POPs);
1265 left_neg = FALSE; /* effectively it's a UV now */
1274 left_neg = dleft < 0;
1278 /* This should be exactly the 5.6 behaviour - if left and right are
1279 both in range for UV then use U_V() rather than floor. */
1281 if (dleft < UV_MAX_P1) {
1282 /* right was in range, so is dleft, so use UVs not double.
1286 /* left is out of range for UV, right was in range, so promote
1287 right (back) to double. */
1289 /* The +0.5 is used in 5.6 even though it is not strictly
1290 consistent with the implicit +0 floor in the U_V()
1291 inside the #if 1. */
1292 dleft = Perl_floor(dleft + 0.5);
1295 dright = Perl_floor(dright + 0.5);
1305 DIE(aTHX_ "Illegal modulus zero");
1307 dans = Perl_fmod(dleft, dright);
1308 if ((left_neg != right_neg) && dans)
1309 dans = dright - dans;
1312 sv_setnv(TARG, dans);
1318 DIE(aTHX_ "Illegal modulus zero");
1321 if ((left_neg != right_neg) && ans)
1324 /* XXX may warn: unary minus operator applied to unsigned type */
1325 /* could change -foo to be (~foo)+1 instead */
1326 if (ans <= ~((UV)IV_MAX)+1)
1327 sv_setiv(TARG, ~ans+1);
1329 sv_setnv(TARG, -(NV)ans);
1332 sv_setuv(TARG, ans);
1341 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1343 register IV count = POPi;
1344 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1346 I32 items = SP - MARK;
1349 max = items * count;
1354 /* This code was intended to fix 20010809.028:
1357 for (($x =~ /./g) x 2) {
1358 print chop; # "abcdabcd" expected as output.
1361 * but that change (#11635) broke this code:
1363 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1365 * I can't think of a better fix that doesn't introduce
1366 * an efficiency hit by copying the SVs. The stack isn't
1367 * refcounted, and mortalisation obviously doesn't
1368 * Do The Right Thing when the stack has more than
1369 * one pointer to the same mortal value.
1373 *SP = sv_2mortal(newSVsv(*SP));
1383 repeatcpy((char*)(MARK + items), (char*)MARK,
1384 items * sizeof(SV*), count - 1);
1387 else if (count <= 0)
1390 else { /* Note: mark already snarfed by pp_list */
1395 SvSetSV(TARG, tmpstr);
1396 SvPV_force(TARG, len);
1397 isutf = DO_UTF8(TARG);
1402 SvGROW(TARG, (count * len) + 1);
1403 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1404 SvCUR(TARG) *= count;
1406 *SvEND(TARG) = '\0';
1409 (void)SvPOK_only_UTF8(TARG);
1411 (void)SvPOK_only(TARG);
1413 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1414 /* The parser saw this as a list repeat, and there
1415 are probably several items on the stack. But we're
1416 in scalar context, and there's no pp_list to save us
1417 now. So drop the rest of the items -- robin@kitsite.com
1430 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1431 useleft = USE_LEFT(TOPm1s);
1432 #ifdef PERL_PRESERVE_IVUV
1433 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1434 "bad things" happen if you rely on signed integers wrapping. */
1437 /* Unless the left argument is integer in range we are going to have to
1438 use NV maths. Hence only attempt to coerce the right argument if
1439 we know the left is integer. */
1440 register UV auv = 0;
1446 a_valid = auvok = 1;
1447 /* left operand is undef, treat as zero. */
1449 /* Left operand is defined, so is it IV? */
1450 SvIV_please(TOPm1s);
1451 if (SvIOK(TOPm1s)) {
1452 if ((auvok = SvUOK(TOPm1s)))
1453 auv = SvUVX(TOPm1s);
1455 register IV aiv = SvIVX(TOPm1s);
1458 auvok = 1; /* Now acting as a sign flag. */
1459 } else { /* 2s complement assumption for IV_MIN */
1467 bool result_good = 0;
1470 bool buvok = SvUOK(TOPs);
1475 register IV biv = SvIVX(TOPs);
1482 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1483 else "IV" now, independent of how it came in.
1484 if a, b represents positive, A, B negative, a maps to -A etc
1489 all UV maths. negate result if A negative.
1490 subtract if signs same, add if signs differ. */
1492 if (auvok ^ buvok) {
1501 /* Must get smaller */
1506 if (result <= buv) {
1507 /* result really should be -(auv-buv). as its negation
1508 of true value, need to swap our result flag */
1520 if (result <= (UV)IV_MIN)
1521 SETi( -(IV)result );
1523 /* result valid, but out of range for IV. */
1524 SETn( -(NV)result );
1528 } /* Overflow, drop through to NVs. */
1532 useleft = USE_LEFT(TOPm1s);
1536 /* left operand is undef, treat as zero - value */
1540 SETn( TOPn - value );
1547 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1550 if (PL_op->op_private & HINT_INTEGER) {
1564 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1567 if (PL_op->op_private & HINT_INTEGER) {
1581 dSP; tryAMAGICbinSET(lt,0);
1582 #ifdef PERL_PRESERVE_IVUV
1585 SvIV_please(TOPm1s);
1586 if (SvIOK(TOPm1s)) {
1587 bool auvok = SvUOK(TOPm1s);
1588 bool buvok = SvUOK(TOPs);
1590 if (!auvok && !buvok) { /* ## IV < IV ## */
1591 IV aiv = SvIVX(TOPm1s);
1592 IV biv = SvIVX(TOPs);
1595 SETs(boolSV(aiv < biv));
1598 if (auvok && buvok) { /* ## UV < UV ## */
1599 UV auv = SvUVX(TOPm1s);
1600 UV buv = SvUVX(TOPs);
1603 SETs(boolSV(auv < buv));
1606 if (auvok) { /* ## UV < IV ## */
1613 /* As (a) is a UV, it's >=0, so it cannot be < */
1618 SETs(boolSV(auv < (UV)biv));
1621 { /* ## IV < UV ## */
1625 aiv = SvIVX(TOPm1s);
1627 /* As (b) is a UV, it's >=0, so it must be < */
1634 SETs(boolSV((UV)aiv < buv));
1640 #ifndef NV_PRESERVES_UV
1641 #ifdef PERL_PRESERVE_IVUV
1644 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1646 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1652 SETs(boolSV(TOPn < value));
1659 dSP; tryAMAGICbinSET(gt,0);
1660 #ifdef PERL_PRESERVE_IVUV
1663 SvIV_please(TOPm1s);
1664 if (SvIOK(TOPm1s)) {
1665 bool auvok = SvUOK(TOPm1s);
1666 bool buvok = SvUOK(TOPs);
1668 if (!auvok && !buvok) { /* ## IV > IV ## */
1669 IV aiv = SvIVX(TOPm1s);
1670 IV biv = SvIVX(TOPs);
1673 SETs(boolSV(aiv > biv));
1676 if (auvok && buvok) { /* ## UV > UV ## */
1677 UV auv = SvUVX(TOPm1s);
1678 UV buv = SvUVX(TOPs);
1681 SETs(boolSV(auv > buv));
1684 if (auvok) { /* ## UV > IV ## */
1691 /* As (a) is a UV, it's >=0, so it must be > */
1696 SETs(boolSV(auv > (UV)biv));
1699 { /* ## IV > UV ## */
1703 aiv = SvIVX(TOPm1s);
1705 /* As (b) is a UV, it's >=0, so it cannot be > */
1712 SETs(boolSV((UV)aiv > buv));
1718 #ifndef NV_PRESERVES_UV
1719 #ifdef PERL_PRESERVE_IVUV
1722 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1724 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1730 SETs(boolSV(TOPn > value));
1737 dSP; tryAMAGICbinSET(le,0);
1738 #ifdef PERL_PRESERVE_IVUV
1741 SvIV_please(TOPm1s);
1742 if (SvIOK(TOPm1s)) {
1743 bool auvok = SvUOK(TOPm1s);
1744 bool buvok = SvUOK(TOPs);
1746 if (!auvok && !buvok) { /* ## IV <= IV ## */
1747 IV aiv = SvIVX(TOPm1s);
1748 IV biv = SvIVX(TOPs);
1751 SETs(boolSV(aiv <= biv));
1754 if (auvok && buvok) { /* ## UV <= UV ## */
1755 UV auv = SvUVX(TOPm1s);
1756 UV buv = SvUVX(TOPs);
1759 SETs(boolSV(auv <= buv));
1762 if (auvok) { /* ## UV <= IV ## */
1769 /* As (a) is a UV, it's >=0, so a cannot be <= */
1774 SETs(boolSV(auv <= (UV)biv));
1777 { /* ## IV <= UV ## */
1781 aiv = SvIVX(TOPm1s);
1783 /* As (b) is a UV, it's >=0, so a must be <= */
1790 SETs(boolSV((UV)aiv <= buv));
1796 #ifndef NV_PRESERVES_UV
1797 #ifdef PERL_PRESERVE_IVUV
1800 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1802 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1808 SETs(boolSV(TOPn <= value));
1815 dSP; tryAMAGICbinSET(ge,0);
1816 #ifdef PERL_PRESERVE_IVUV
1819 SvIV_please(TOPm1s);
1820 if (SvIOK(TOPm1s)) {
1821 bool auvok = SvUOK(TOPm1s);
1822 bool buvok = SvUOK(TOPs);
1824 if (!auvok && !buvok) { /* ## IV >= IV ## */
1825 IV aiv = SvIVX(TOPm1s);
1826 IV biv = SvIVX(TOPs);
1829 SETs(boolSV(aiv >= biv));
1832 if (auvok && buvok) { /* ## UV >= UV ## */
1833 UV auv = SvUVX(TOPm1s);
1834 UV buv = SvUVX(TOPs);
1837 SETs(boolSV(auv >= buv));
1840 if (auvok) { /* ## UV >= IV ## */
1847 /* As (a) is a UV, it's >=0, so it must be >= */
1852 SETs(boolSV(auv >= (UV)biv));
1855 { /* ## IV >= UV ## */
1859 aiv = SvIVX(TOPm1s);
1861 /* As (b) is a UV, it's >=0, so a cannot be >= */
1868 SETs(boolSV((UV)aiv >= buv));
1874 #ifndef NV_PRESERVES_UV
1875 #ifdef PERL_PRESERVE_IVUV
1878 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1880 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1886 SETs(boolSV(TOPn >= value));
1893 dSP; tryAMAGICbinSET(ne,0);
1894 #ifndef NV_PRESERVES_UV
1895 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1897 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1901 #ifdef PERL_PRESERVE_IVUV
1904 SvIV_please(TOPm1s);
1905 if (SvIOK(TOPm1s)) {
1906 bool auvok = SvUOK(TOPm1s);
1907 bool buvok = SvUOK(TOPs);
1909 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1910 /* Casting IV to UV before comparison isn't going to matter
1911 on 2s complement. On 1s complement or sign&magnitude
1912 (if we have any of them) it could make negative zero
1913 differ from normal zero. As I understand it. (Need to
1914 check - is negative zero implementation defined behaviour
1916 UV buv = SvUVX(POPs);
1917 UV auv = SvUVX(TOPs);
1919 SETs(boolSV(auv != buv));
1922 { /* ## Mixed IV,UV ## */
1926 /* != is commutative so swap if needed (save code) */
1928 /* swap. top of stack (b) is the iv */
1932 /* As (a) is a UV, it's >0, so it cannot be == */
1941 /* As (b) is a UV, it's >0, so it cannot be == */
1945 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1947 SETs(boolSV((UV)iv != uv));
1955 SETs(boolSV(TOPn != value));
1962 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1963 #ifndef NV_PRESERVES_UV
1964 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1965 UV right = PTR2UV(SvRV(POPs));
1966 UV left = PTR2UV(SvRV(TOPs));
1967 SETi((left > right) - (left < right));
1971 #ifdef PERL_PRESERVE_IVUV
1972 /* Fortunately it seems NaN isn't IOK */
1975 SvIV_please(TOPm1s);
1976 if (SvIOK(TOPm1s)) {
1977 bool leftuvok = SvUOK(TOPm1s);
1978 bool rightuvok = SvUOK(TOPs);
1980 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1981 IV leftiv = SvIVX(TOPm1s);
1982 IV rightiv = SvIVX(TOPs);
1984 if (leftiv > rightiv)
1986 else if (leftiv < rightiv)
1990 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1991 UV leftuv = SvUVX(TOPm1s);
1992 UV rightuv = SvUVX(TOPs);
1994 if (leftuv > rightuv)
1996 else if (leftuv < rightuv)
2000 } else if (leftuvok) { /* ## UV <=> IV ## */
2004 rightiv = SvIVX(TOPs);
2006 /* As (a) is a UV, it's >=0, so it cannot be < */
2009 leftuv = SvUVX(TOPm1s);
2010 if (leftuv > (UV)rightiv) {
2012 } else if (leftuv < (UV)rightiv) {
2018 } else { /* ## IV <=> UV ## */
2022 leftiv = SvIVX(TOPm1s);
2024 /* As (b) is a UV, it's >=0, so it must be < */
2027 rightuv = SvUVX(TOPs);
2028 if ((UV)leftiv > rightuv) {
2030 } else if ((UV)leftiv < rightuv) {
2048 if (Perl_isnan(left) || Perl_isnan(right)) {
2052 value = (left > right) - (left < right);
2056 else if (left < right)
2058 else if (left > right)
2072 dSP; tryAMAGICbinSET(slt,0);
2075 int cmp = (IN_LOCALE_RUNTIME
2076 ? sv_cmp_locale(left, right)
2077 : sv_cmp(left, right));
2078 SETs(boolSV(cmp < 0));
2085 dSP; tryAMAGICbinSET(sgt,0);
2088 int cmp = (IN_LOCALE_RUNTIME
2089 ? sv_cmp_locale(left, right)
2090 : sv_cmp(left, right));
2091 SETs(boolSV(cmp > 0));
2098 dSP; tryAMAGICbinSET(sle,0);
2101 int cmp = (IN_LOCALE_RUNTIME
2102 ? sv_cmp_locale(left, right)
2103 : sv_cmp(left, right));
2104 SETs(boolSV(cmp <= 0));
2111 dSP; tryAMAGICbinSET(sge,0);
2114 int cmp = (IN_LOCALE_RUNTIME
2115 ? sv_cmp_locale(left, right)
2116 : sv_cmp(left, right));
2117 SETs(boolSV(cmp >= 0));
2124 dSP; tryAMAGICbinSET(seq,0);
2127 SETs(boolSV(sv_eq(left, right)));
2134 dSP; tryAMAGICbinSET(sne,0);
2137 SETs(boolSV(!sv_eq(left, right)));
2144 dSP; dTARGET; tryAMAGICbin(scmp,0);
2147 int cmp = (IN_LOCALE_RUNTIME
2148 ? sv_cmp_locale(left, right)
2149 : sv_cmp(left, right));
2157 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2160 if (SvNIOKp(left) || SvNIOKp(right)) {
2161 if (PL_op->op_private & HINT_INTEGER) {
2162 IV i = SvIV(left) & SvIV(right);
2166 UV u = SvUV(left) & SvUV(right);
2171 do_vop(PL_op->op_type, TARG, left, right);
2180 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2183 if (SvNIOKp(left) || SvNIOKp(right)) {
2184 if (PL_op->op_private & HINT_INTEGER) {
2185 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2189 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2194 do_vop(PL_op->op_type, TARG, left, right);
2203 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2206 if (SvNIOKp(left) || SvNIOKp(right)) {
2207 if (PL_op->op_private & HINT_INTEGER) {
2208 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2212 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2217 do_vop(PL_op->op_type, TARG, left, right);
2226 dSP; dTARGET; tryAMAGICun(neg);
2229 int flags = SvFLAGS(sv);
2232 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2233 /* It's publicly an integer, or privately an integer-not-float */
2236 if (SvIVX(sv) == IV_MIN) {
2237 /* 2s complement assumption. */
2238 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2241 else if (SvUVX(sv) <= IV_MAX) {
2246 else if (SvIVX(sv) != IV_MIN) {
2250 #ifdef PERL_PRESERVE_IVUV
2259 else if (SvPOKp(sv)) {
2261 char *s = SvPV(sv, len);
2262 if (isIDFIRST(*s)) {
2263 sv_setpvn(TARG, "-", 1);
2266 else if (*s == '+' || *s == '-') {
2268 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2270 else if (DO_UTF8(sv)) {
2273 goto oops_its_an_int;
2275 sv_setnv(TARG, -SvNV(sv));
2277 sv_setpvn(TARG, "-", 1);
2284 goto oops_its_an_int;
2285 sv_setnv(TARG, -SvNV(sv));
2297 dSP; tryAMAGICunSET(not);
2298 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2304 dSP; dTARGET; tryAMAGICun(compl);
2308 if (PL_op->op_private & HINT_INTEGER) {
2323 tmps = (U8*)SvPV_force(TARG, len);
2326 /* Calculate exact length, let's not estimate. */
2335 while (tmps < send) {
2336 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2337 tmps += UTF8SKIP(tmps);
2338 targlen += UNISKIP(~c);
2344 /* Now rewind strings and write them. */
2348 Newz(0, result, targlen + 1, U8);
2349 while (tmps < send) {
2350 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2351 tmps += UTF8SKIP(tmps);
2352 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2356 sv_setpvn(TARG, (char*)result, targlen);
2360 Newz(0, result, nchar + 1, U8);
2361 while (tmps < send) {
2362 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2363 tmps += UTF8SKIP(tmps);
2368 sv_setpvn(TARG, (char*)result, nchar);
2376 register long *tmpl;
2377 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2380 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2385 for ( ; anum > 0; anum--, tmps++)
2394 /* integer versions of some of the above */
2398 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2401 SETi( left * right );
2408 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2412 DIE(aTHX_ "Illegal division by zero");
2413 value = POPi / value;
2421 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2425 DIE(aTHX_ "Illegal modulus zero");
2426 SETi( left % right );
2433 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2436 SETi( left + right );
2443 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2446 SETi( left - right );
2453 dSP; tryAMAGICbinSET(lt,0);
2456 SETs(boolSV(left < right));
2463 dSP; tryAMAGICbinSET(gt,0);
2466 SETs(boolSV(left > right));
2473 dSP; tryAMAGICbinSET(le,0);
2476 SETs(boolSV(left <= right));
2483 dSP; tryAMAGICbinSET(ge,0);
2486 SETs(boolSV(left >= right));
2493 dSP; tryAMAGICbinSET(eq,0);
2496 SETs(boolSV(left == right));
2503 dSP; tryAMAGICbinSET(ne,0);
2506 SETs(boolSV(left != right));
2513 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2520 else if (left < right)
2531 dSP; dTARGET; tryAMAGICun(neg);
2536 /* High falutin' math. */
2540 dSP; dTARGET; tryAMAGICbin(atan2,0);
2543 SETn(Perl_atan2(left, right));
2550 dSP; dTARGET; tryAMAGICun(sin);
2554 value = Perl_sin(value);
2562 dSP; dTARGET; tryAMAGICun(cos);
2566 value = Perl_cos(value);
2572 /* Support Configure command-line overrides for rand() functions.
2573 After 5.005, perhaps we should replace this by Configure support
2574 for drand48(), random(), or rand(). For 5.005, though, maintain
2575 compatibility by calling rand() but allow the user to override it.
2576 See INSTALL for details. --Andy Dougherty 15 July 1998
2578 /* Now it's after 5.005, and Configure supports drand48() and random(),
2579 in addition to rand(). So the overrides should not be needed any more.
2580 --Jarkko Hietaniemi 27 September 1998
2583 #ifndef HAS_DRAND48_PROTO
2584 extern double drand48 (void);
2597 if (!PL_srand_called) {
2598 (void)seedDrand01((Rand_seed_t)seed());
2599 PL_srand_called = TRUE;
2614 (void)seedDrand01((Rand_seed_t)anum);
2615 PL_srand_called = TRUE;
2624 * This is really just a quick hack which grabs various garbage
2625 * values. It really should be a real hash algorithm which
2626 * spreads the effect of every input bit onto every output bit,
2627 * if someone who knows about such things would bother to write it.
2628 * Might be a good idea to add that function to CORE as well.
2629 * No numbers below come from careful analysis or anything here,
2630 * except they are primes and SEED_C1 > 1E6 to get a full-width
2631 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2632 * probably be bigger too.
2635 # define SEED_C1 1000003
2636 #define SEED_C4 73819
2638 # define SEED_C1 25747
2639 #define SEED_C4 20639
2643 #define SEED_C5 26107
2645 #ifndef PERL_NO_DEV_RANDOM
2650 # include <starlet.h>
2651 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2652 * in 100-ns units, typically incremented ever 10 ms. */
2653 unsigned int when[2];
2655 # ifdef HAS_GETTIMEOFDAY
2656 struct timeval when;
2662 /* This test is an escape hatch, this symbol isn't set by Configure. */
2663 #ifndef PERL_NO_DEV_RANDOM
2664 #ifndef PERL_RANDOM_DEVICE
2665 /* /dev/random isn't used by default because reads from it will block
2666 * if there isn't enough entropy available. You can compile with
2667 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2668 * is enough real entropy to fill the seed. */
2669 # define PERL_RANDOM_DEVICE "/dev/urandom"
2671 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2673 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2682 _ckvmssts(sys$gettim(when));
2683 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2685 # ifdef HAS_GETTIMEOFDAY
2686 PerlProc_gettimeofday(&when,NULL);
2687 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2690 u = (U32)SEED_C1 * when;
2693 u += SEED_C3 * (U32)PerlProc_getpid();
2694 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2695 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2696 u += SEED_C5 * (U32)PTR2UV(&when);
2703 dSP; dTARGET; tryAMAGICun(exp);
2707 value = Perl_exp(value);
2715 dSP; dTARGET; tryAMAGICun(log);
2720 SET_NUMERIC_STANDARD();
2721 DIE(aTHX_ "Can't take log of %"NVgf, value);
2723 value = Perl_log(value);
2731 dSP; dTARGET; tryAMAGICun(sqrt);
2736 SET_NUMERIC_STANDARD();
2737 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2739 value = Perl_sqrt(value);
2746 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2747 * These need to be revisited when a newer toolchain becomes available.
2749 #if defined(__sparc64__) && defined(__GNUC__)
2750 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2751 # undef SPARC64_MODF_WORKAROUND
2752 # define SPARC64_MODF_WORKAROUND 1
2756 #if defined(SPARC64_MODF_WORKAROUND)
2758 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2761 ret = Perl_modf(theVal, &res);
2769 dSP; dTARGET; tryAMAGICun(int);
2772 IV iv = TOPi; /* attempt to convert to IV if possible. */
2773 /* XXX it's arguable that compiler casting to IV might be subtly
2774 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2775 else preferring IV has introduced a subtle behaviour change bug. OTOH
2776 relying on floating point to be accurate is a bug. */
2787 if (value < (NV)UV_MAX + 0.5) {
2790 #if defined(SPARC64_MODF_WORKAROUND)
2791 (void)sparc64_workaround_modf(value, &value);
2793 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2794 # ifdef HAS_MODFL_POW32_BUG
2795 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2797 NV offset = Perl_modf(value, &value);
2798 (void)Perl_modf(offset, &offset);
2802 (void)Perl_modf(value, &value);
2805 double tmp = (double)value;
2806 (void)Perl_modf(tmp, &tmp);
2814 if (value > (NV)IV_MIN - 0.5) {
2817 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2818 # ifdef HAS_MODFL_POW32_BUG
2819 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2821 NV offset = Perl_modf(-value, &value);
2822 (void)Perl_modf(offset, &offset);
2826 (void)Perl_modf(-value, &value);
2830 double tmp = (double)value;
2831 (void)Perl_modf(-tmp, &tmp);
2844 dSP; dTARGET; tryAMAGICun(abs);
2846 /* This will cache the NV value if string isn't actually integer */
2850 /* IVX is precise */
2852 SETu(TOPu); /* force it to be numeric only */
2860 /* 2s complement assumption. Also, not really needed as
2861 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2881 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2887 tmps = (SvPVx(sv, len));
2889 /* If Unicode, try to downgrade
2890 * If not possible, croak. */
2891 SV* tsv = sv_2mortal(newSVsv(sv));
2894 sv_utf8_downgrade(tsv, FALSE);
2897 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2898 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2911 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2917 tmps = (SvPVx(sv, len));
2919 /* If Unicode, try to downgrade
2920 * If not possible, croak. */
2921 SV* tsv = sv_2mortal(newSVsv(sv));
2924 sv_utf8_downgrade(tsv, FALSE);
2927 while (*tmps && len && isSPACE(*tmps))
2932 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2933 else if (*tmps == 'b')
2934 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2936 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2938 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2955 SETi(sv_len_utf8(sv));
2971 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2973 I32 arybase = PL_curcop->cop_arybase;
2977 int num_args = PL_op->op_private & 7;
2978 bool repl_need_utf8_upgrade = FALSE;
2979 bool repl_is_utf8 = FALSE;
2981 SvTAINTED_off(TARG); /* decontaminate */
2982 SvUTF8_off(TARG); /* decontaminate */
2986 repl = SvPV(repl_sv, repl_len);
2987 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2997 sv_utf8_upgrade(sv);
2999 else if (DO_UTF8(sv))
3000 repl_need_utf8_upgrade = TRUE;
3002 tmps = SvPV(sv, curlen);
3004 utf8_curlen = sv_len_utf8(sv);
3005 if (utf8_curlen == curlen)
3008 curlen = utf8_curlen;
3013 if (pos >= arybase) {
3031 else if (len >= 0) {
3033 if (rem > (I32)curlen)
3048 Perl_croak(aTHX_ "substr outside of string");
3049 if (ckWARN(WARN_SUBSTR))
3050 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3057 sv_pos_u2b(sv, &pos, &rem);
3059 sv_setpvn(TARG, tmps, rem);
3060 #ifdef USE_LOCALE_COLLATE
3061 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3066 SV* repl_sv_copy = NULL;
3068 if (repl_need_utf8_upgrade) {
3069 repl_sv_copy = newSVsv(repl_sv);
3070 sv_utf8_upgrade(repl_sv_copy);
3071 repl = SvPV(repl_sv_copy, repl_len);
3072 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3074 sv_insert(sv, pos, rem, repl, repl_len);
3078 SvREFCNT_dec(repl_sv_copy);
3080 else if (lvalue) { /* it's an lvalue! */
3081 if (!SvGMAGICAL(sv)) {
3085 if (ckWARN(WARN_SUBSTR))
3086 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3087 "Attempt to use reference as lvalue in substr");
3089 if (SvOK(sv)) /* is it defined ? */
3090 (void)SvPOK_only_UTF8(sv);
3092 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3095 if (SvTYPE(TARG) < SVt_PVLV) {
3096 sv_upgrade(TARG, SVt_PVLV);
3097 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3101 if (LvTARG(TARG) != sv) {
3103 SvREFCNT_dec(LvTARG(TARG));
3104 LvTARG(TARG) = SvREFCNT_inc(sv);
3106 LvTARGOFF(TARG) = upos;
3107 LvTARGLEN(TARG) = urem;
3111 PUSHs(TARG); /* avoid SvSETMAGIC here */
3118 register IV size = POPi;
3119 register IV offset = POPi;
3120 register SV *src = POPs;
3121 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3123 SvTAINTED_off(TARG); /* decontaminate */
3124 if (lvalue) { /* it's an lvalue! */
3125 if (SvTYPE(TARG) < SVt_PVLV) {
3126 sv_upgrade(TARG, SVt_PVLV);
3127 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3130 if (LvTARG(TARG) != src) {
3132 SvREFCNT_dec(LvTARG(TARG));
3133 LvTARG(TARG) = SvREFCNT_inc(src);
3135 LvTARGOFF(TARG) = offset;
3136 LvTARGLEN(TARG) = size;
3139 sv_setuv(TARG, do_vecget(src, offset, size));
3154 I32 arybase = PL_curcop->cop_arybase;
3159 offset = POPi - arybase;
3162 tmps = SvPV(big, biglen);
3163 if (offset > 0 && DO_UTF8(big))
3164 sv_pos_u2b(big, &offset, 0);
3167 else if (offset > (I32)biglen)
3169 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3170 (unsigned char*)tmps + biglen, little, 0)))
3173 retval = tmps2 - tmps;
3174 if (retval > 0 && DO_UTF8(big))
3175 sv_pos_b2u(big, &retval);
3176 PUSHi(retval + arybase);
3191 I32 arybase = PL_curcop->cop_arybase;
3197 tmps2 = SvPV(little, llen);
3198 tmps = SvPV(big, blen);
3202 if (offset > 0 && DO_UTF8(big))
3203 sv_pos_u2b(big, &offset, 0);
3204 offset = offset - arybase + llen;
3208 else if (offset > (I32)blen)
3210 if (!(tmps2 = rninstr(tmps, tmps + offset,
3211 tmps2, tmps2 + llen)))
3214 retval = tmps2 - tmps;
3215 if (retval > 0 && DO_UTF8(big))
3216 sv_pos_b2u(big, &retval);
3217 PUSHi(retval + arybase);
3223 dSP; dMARK; dORIGMARK; dTARGET;
3224 do_sprintf(TARG, SP-MARK, MARK+1);
3225 TAINT_IF(SvTAINTED(TARG));
3226 if (DO_UTF8(*(MARK+1)))
3238 U8 *s = (U8*)SvPVx(argsv, len);
3241 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3242 tmpsv = sv_2mortal(newSVsv(argsv));
3243 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3247 XPUSHu(DO_UTF8(argsv) ?
3248 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3260 (void)SvUPGRADE(TARG,SVt_PV);
3262 if (value > 255 && !IN_BYTES) {
3263 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3264 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3265 SvCUR_set(TARG, tmps - SvPVX(TARG));
3267 (void)SvPOK_only(TARG);
3276 *tmps++ = (char)value;
3278 (void)SvPOK_only(TARG);
3280 sv_recode_to_utf8(TARG, PL_encoding);
3292 char *tmps = SvPV(left, len);
3294 if (DO_UTF8(left)) {
3295 /* If Unicode, try to downgrade.
3296 * If not possible, croak.
3297 * Yes, we made this up. */
3298 SV* tsv = sv_2mortal(newSVsv(left));
3301 sv_utf8_downgrade(tsv, FALSE);
3305 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3307 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3313 "The crypt() function is unimplemented due to excessive paranoia.");
3325 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3329 s = (U8*)SvPV(sv, slen);
3330 utf8_to_uvchr(s, &ulen);
3332 toTITLE_utf8(s, tmpbuf, &tculen);
3333 utf8_to_uvchr(tmpbuf, 0);
3335 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3337 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3338 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3343 s = (U8*)SvPV_force(sv, slen);
3344 Copy(tmpbuf, s, tculen, U8);
3348 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3350 SvUTF8_off(TARG); /* decontaminate */
3355 s = (U8*)SvPV_force(sv, slen);
3357 if (IN_LOCALE_RUNTIME) {
3360 *s = toUPPER_LC(*s);
3378 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3380 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3384 toLOWER_utf8(s, tmpbuf, &ulen);
3385 uv = utf8_to_uvchr(tmpbuf, 0);
3387 tend = uvchr_to_utf8(tmpbuf, uv);
3389 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3391 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3392 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3397 s = (U8*)SvPV_force(sv, slen);
3398 Copy(tmpbuf, s, ulen, U8);
3402 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3404 SvUTF8_off(TARG); /* decontaminate */
3409 s = (U8*)SvPV_force(sv, slen);
3411 if (IN_LOCALE_RUNTIME) {
3414 *s = toLOWER_LC(*s);
3437 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3439 s = (U8*)SvPV(sv,len);
3441 SvUTF8_off(TARG); /* decontaminate */
3442 sv_setpvn(TARG, "", 0);
3446 STRLEN nchar = utf8_length(s, s + len);
3448 (void)SvUPGRADE(TARG, SVt_PV);
3449 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3450 (void)SvPOK_only(TARG);
3451 d = (U8*)SvPVX(TARG);
3454 toUPPER_utf8(s, tmpbuf, &ulen);
3455 Copy(tmpbuf, d, ulen, U8);
3461 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3466 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3468 SvUTF8_off(TARG); /* decontaminate */
3473 s = (U8*)SvPV_force(sv, len);
3475 register U8 *send = s + len;
3477 if (IN_LOCALE_RUNTIME) {
3480 for (; s < send; s++)
3481 *s = toUPPER_LC(*s);
3484 for (; s < send; s++)
3506 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3508 s = (U8*)SvPV(sv,len);
3510 SvUTF8_off(TARG); /* decontaminate */
3511 sv_setpvn(TARG, "", 0);
3515 STRLEN nchar = utf8_length(s, s + len);
3517 (void)SvUPGRADE(TARG, SVt_PV);
3518 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3519 (void)SvPOK_only(TARG);
3520 d = (U8*)SvPVX(TARG);
3523 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3524 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3525 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3527 * Now if the sigma is NOT followed by
3528 * /$ignorable_sequence$cased_letter/;
3529 * and it IS preceded by
3530 * /$cased_letter$ignorable_sequence/;
3531 * where $ignorable_sequence is
3532 * [\x{2010}\x{AD}\p{Mn}]*
3533 * and $cased_letter is
3534 * [\p{Ll}\p{Lo}\p{Lt}]
3535 * then it should be mapped to 0x03C2,
3536 * (GREEK SMALL LETTER FINAL SIGMA),
3537 * instead of staying 0x03A3.
3538 * See lib/unicore/SpecCase.txt.
3541 Copy(tmpbuf, d, ulen, U8);
3547 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3552 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3554 SvUTF8_off(TARG); /* decontaminate */
3560 s = (U8*)SvPV_force(sv, len);
3562 register U8 *send = s + len;
3564 if (IN_LOCALE_RUNTIME) {
3567 for (; s < send; s++)
3568 *s = toLOWER_LC(*s);
3571 for (; s < send; s++)
3586 register char *s = SvPV(sv,len);
3589 SvUTF8_off(TARG); /* decontaminate */
3591 (void)SvUPGRADE(TARG, SVt_PV);
3592 SvGROW(TARG, (len * 2) + 1);
3596 if (UTF8_IS_CONTINUED(*s)) {
3597 STRLEN ulen = UTF8SKIP(s);
3621 SvCUR_set(TARG, d - SvPVX(TARG));
3622 (void)SvPOK_only_UTF8(TARG);
3625 sv_setpvn(TARG, s, len);
3627 if (SvSMAGICAL(TARG))
3636 dSP; dMARK; dORIGMARK;
3638 register AV* av = (AV*)POPs;
3639 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3640 I32 arybase = PL_curcop->cop_arybase;
3643 if (SvTYPE(av) == SVt_PVAV) {
3644 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3646 for (svp = MARK + 1; svp <= SP; svp++) {
3651 if (max > AvMAX(av))
3654 while (++MARK <= SP) {
3655 elem = SvIVx(*MARK);
3659 svp = av_fetch(av, elem, lval);
3661 if (!svp || *svp == &PL_sv_undef)
3662 DIE(aTHX_ PL_no_aelem, elem);
3663 if (PL_op->op_private & OPpLVAL_INTRO)
3664 save_aelem(av, elem, svp);
3666 *MARK = svp ? *svp : &PL_sv_undef;
3669 if (GIMME != G_ARRAY) {
3677 /* Associative arrays. */
3682 HV *hash = (HV*)POPs;
3684 I32 gimme = GIMME_V;
3687 /* might clobber stack_sp */
3688 entry = hv_iternext(hash);
3693 SV* sv = hv_iterkeysv(entry);
3694 PUSHs(sv); /* won't clobber stack_sp */
3695 if (gimme == G_ARRAY) {
3698 /* might clobber stack_sp */
3699 val = hv_iterval(hash, entry);
3704 else if (gimme == G_SCALAR)
3723 I32 gimme = GIMME_V;
3724 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3728 if (PL_op->op_private & OPpSLICE) {
3732 hvtype = SvTYPE(hv);
3733 if (hvtype == SVt_PVHV) { /* hash element */
3734 while (++MARK <= SP) {
3735 sv = hv_delete_ent(hv, *MARK, discard, 0);
3736 *MARK = sv ? sv : &PL_sv_undef;
3739 else if (hvtype == SVt_PVAV) { /* array element */
3740 if (PL_op->op_flags & OPf_SPECIAL) {
3741 while (++MARK <= SP) {
3742 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3743 *MARK = sv ? sv : &PL_sv_undef;
3748 DIE(aTHX_ "Not a HASH reference");
3751 else if (gimme == G_SCALAR) {
3760 if (SvTYPE(hv) == SVt_PVHV)
3761 sv = hv_delete_ent(hv, keysv, discard, 0);
3762 else if (SvTYPE(hv) == SVt_PVAV) {
3763 if (PL_op->op_flags & OPf_SPECIAL)
3764 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3766 DIE(aTHX_ "panic: avhv_delete no longer supported");
3769 DIE(aTHX_ "Not a HASH reference");
3784 if (PL_op->op_private & OPpEXISTS_SUB) {
3788 cv = sv_2cv(sv, &hv, &gv, FALSE);
3791 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3797 if (SvTYPE(hv) == SVt_PVHV) {
3798 if (hv_exists_ent(hv, tmpsv, 0))
3801 else if (SvTYPE(hv) == SVt_PVAV) {
3802 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3803 if (av_exists((AV*)hv, SvIV(tmpsv)))
3808 DIE(aTHX_ "Not a HASH reference");
3815 dSP; dMARK; dORIGMARK;
3816 register HV *hv = (HV*)POPs;
3817 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3818 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3819 bool other_magic = FALSE;
3825 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3826 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3827 /* Try to preserve the existenceness of a tied hash
3828 * element by using EXISTS and DELETE if possible.
3829 * Fallback to FETCH and STORE otherwise */
3830 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3831 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3832 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3835 while (++MARK <= SP) {
3839 bool preeminent = FALSE;
3842 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3843 hv_exists_ent(hv, keysv, 0);
3846 he = hv_fetch_ent(hv, keysv, lval, 0);
3847 svp = he ? &HeVAL(he) : 0;
3850 if (!svp || *svp == &PL_sv_undef) {
3852 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3856 save_helem(hv, keysv, svp);
3859 char *key = SvPV(keysv, keylen);
3860 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3864 *MARK = svp ? *svp : &PL_sv_undef;
3866 if (GIMME != G_ARRAY) {
3874 /* List operators. */
3879 if (GIMME != G_ARRAY) {
3881 *MARK = *SP; /* unwanted list, return last item */
3883 *MARK = &PL_sv_undef;
3892 SV **lastrelem = PL_stack_sp;
3893 SV **lastlelem = PL_stack_base + POPMARK;
3894 SV **firstlelem = PL_stack_base + POPMARK + 1;
3895 register SV **firstrelem = lastlelem + 1;
3896 I32 arybase = PL_curcop->cop_arybase;
3897 I32 lval = PL_op->op_flags & OPf_MOD;
3898 I32 is_something_there = lval;
3900 register I32 max = lastrelem - lastlelem;
3901 register SV **lelem;
3904 if (GIMME != G_ARRAY) {
3905 ix = SvIVx(*lastlelem);
3910 if (ix < 0 || ix >= max)
3911 *firstlelem = &PL_sv_undef;
3913 *firstlelem = firstrelem[ix];
3919 SP = firstlelem - 1;
3923 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3929 if (ix < 0 || ix >= max)
3930 *lelem = &PL_sv_undef;
3932 is_something_there = TRUE;
3933 if (!(*lelem = firstrelem[ix]))
3934 *lelem = &PL_sv_undef;
3937 if (is_something_there)
3940 SP = firstlelem - 1;
3946 dSP; dMARK; dORIGMARK;
3947 I32 items = SP - MARK;
3948 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3949 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3956 dSP; dMARK; dORIGMARK;
3957 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3961 SV *val = NEWSV(46, 0);
3963 sv_setsv(val, *++MARK);
3964 else if (ckWARN(WARN_MISC))
3965 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3966 (void)hv_store_ent(hv,key,val,0);
3975 dSP; dMARK; dORIGMARK;
3976 register AV *ary = (AV*)*++MARK;
3980 register I32 offset;
3981 register I32 length;
3988 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3989 *MARK-- = SvTIED_obj((SV*)ary, mg);
3993 call_method("SPLICE",GIMME_V);
4002 offset = i = SvIVx(*MARK);
4004 offset += AvFILLp(ary) + 1;
4006 offset -= PL_curcop->cop_arybase;
4008 DIE(aTHX_ PL_no_aelem, i);
4010 length = SvIVx(*MARK++);
4012 length += AvFILLp(ary) - offset + 1;
4018 length = AvMAX(ary) + 1; /* close enough to infinity */
4022 length = AvMAX(ary) + 1;
4024 if (offset > AvFILLp(ary) + 1) {
4025 if (ckWARN(WARN_MISC))
4026 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4027 offset = AvFILLp(ary) + 1;
4029 after = AvFILLp(ary) + 1 - (offset + length);
4030 if (after < 0) { /* not that much array */
4031 length += after; /* offset+length now in array */
4037 /* At this point, MARK .. SP-1 is our new LIST */
4040 diff = newlen - length;
4041 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4044 if (diff < 0) { /* shrinking the area */
4046 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4047 Copy(MARK, tmparyval, newlen, SV*);
4050 MARK = ORIGMARK + 1;
4051 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4052 MEXTEND(MARK, length);
4053 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4055 EXTEND_MORTAL(length);
4056 for (i = length, dst = MARK; i; i--) {
4057 sv_2mortal(*dst); /* free them eventualy */
4064 *MARK = AvARRAY(ary)[offset+length-1];
4067 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4068 SvREFCNT_dec(*dst++); /* free them now */
4071 AvFILLp(ary) += diff;
4073 /* pull up or down? */
4075 if (offset < after) { /* easier to pull up */
4076 if (offset) { /* esp. if nothing to pull */
4077 src = &AvARRAY(ary)[offset-1];
4078 dst = src - diff; /* diff is negative */
4079 for (i = offset; i > 0; i--) /* can't trust Copy */
4083 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4087 if (after) { /* anything to pull down? */
4088 src = AvARRAY(ary) + offset + length;
4089 dst = src + diff; /* diff is negative */
4090 Move(src, dst, after, SV*);
4092 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4093 /* avoid later double free */
4097 dst[--i] = &PL_sv_undef;
4100 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4102 *dst = NEWSV(46, 0);
4103 sv_setsv(*dst++, *src++);
4105 Safefree(tmparyval);
4108 else { /* no, expanding (or same) */
4110 New(452, tmparyval, length, SV*); /* so remember deletion */
4111 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4114 if (diff > 0) { /* expanding */
4116 /* push up or down? */
4118 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4122 Move(src, dst, offset, SV*);
4124 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4126 AvFILLp(ary) += diff;
4129 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4130 av_extend(ary, AvFILLp(ary) + diff);
4131 AvFILLp(ary) += diff;
4134 dst = AvARRAY(ary) + AvFILLp(ary);
4136 for (i = after; i; i--) {
4143 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4144 *dst = NEWSV(46, 0);
4145 sv_setsv(*dst++, *src++);
4147 MARK = ORIGMARK + 1;
4148 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4150 Copy(tmparyval, MARK, length, SV*);
4152 EXTEND_MORTAL(length);
4153 for (i = length, dst = MARK; i; i--) {
4154 sv_2mortal(*dst); /* free them eventualy */
4158 Safefree(tmparyval);
4162 else if (length--) {
4163 *MARK = tmparyval[length];
4166 while (length-- > 0)
4167 SvREFCNT_dec(tmparyval[length]);
4169 Safefree(tmparyval);
4172 *MARK = &PL_sv_undef;
4180 dSP; dMARK; dORIGMARK; dTARGET;
4181 register AV *ary = (AV*)*++MARK;
4182 register SV *sv = &PL_sv_undef;
4185 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4186 *MARK-- = SvTIED_obj((SV*)ary, mg);
4190 call_method("PUSH",G_SCALAR|G_DISCARD);
4195 /* Why no pre-extend of ary here ? */
4196 for (++MARK; MARK <= SP; MARK++) {
4199 sv_setsv(sv, *MARK);
4204 PUSHi( AvFILL(ary) + 1 );
4212 SV *sv = av_pop(av);
4214 (void)sv_2mortal(sv);
4223 SV *sv = av_shift(av);
4228 (void)sv_2mortal(sv);
4235 dSP; dMARK; dORIGMARK; dTARGET;
4236 register AV *ary = (AV*)*++MARK;
4241 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4242 *MARK-- = SvTIED_obj((SV*)ary, mg);
4246 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4251 av_unshift(ary, SP - MARK);
4254 sv_setsv(sv, *++MARK);
4255 (void)av_store(ary, i++, sv);
4259 PUSHi( AvFILL(ary) + 1 );
4269 if (GIMME == G_ARRAY) {
4276 /* safe as long as stack cannot get extended in the above */
4281 register char *down;
4286 SvUTF8_off(TARG); /* decontaminate */
4288 do_join(TARG, &PL_sv_no, MARK, SP);
4290 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4291 up = SvPV_force(TARG, len);
4293 if (DO_UTF8(TARG)) { /* first reverse each character */
4294 U8* s = (U8*)SvPVX(TARG);
4295 U8* send = (U8*)(s + len);
4297 if (UTF8_IS_INVARIANT(*s)) {
4302 if (!utf8_to_uvchr(s, 0))
4306 down = (char*)(s - 1);
4307 /* reverse this character */
4311 *down-- = (char)tmp;
4317 down = SvPVX(TARG) + len - 1;
4321 *down-- = (char)tmp;
4323 (void)SvPOK_only_UTF8(TARG);
4335 register IV limit = POPi; /* note, negative is forever */
4338 register char *s = SvPV(sv, len);
4339 bool do_utf8 = DO_UTF8(sv);
4340 char *strend = s + len;
4342 register REGEXP *rx;
4346 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4347 I32 maxiters = slen + 10;
4350 I32 origlimit = limit;
4353 AV *oldstack = PL_curstack;
4354 I32 gimme = GIMME_V;
4355 I32 oldsave = PL_savestack_ix;
4356 I32 make_mortal = 1;
4357 MAGIC *mg = (MAGIC *) NULL;
4360 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4365 DIE(aTHX_ "panic: pp_split");
4368 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4369 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4371 PL_reg_match_utf8 = do_utf8;
4373 if (pm->op_pmreplroot) {
4375 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4377 ary = GvAVn((GV*)pm->op_pmreplroot);
4380 else if (gimme != G_ARRAY)
4381 #ifdef USE_5005THREADS
4382 ary = (AV*)PL_curpad[0];
4384 ary = GvAVn(PL_defgv);
4385 #endif /* USE_5005THREADS */
4388 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4394 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4396 XPUSHs(SvTIED_obj((SV*)ary, mg));
4402 for (i = AvFILLp(ary); i >= 0; i--)
4403 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4405 /* temporarily switch stacks */
4406 SWITCHSTACK(PL_curstack, ary);
4410 base = SP - PL_stack_base;
4412 if (pm->op_pmflags & PMf_SKIPWHITE) {
4413 if (pm->op_pmflags & PMf_LOCALE) {
4414 while (isSPACE_LC(*s))
4422 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4423 SAVEINT(PL_multiline);
4424 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4428 limit = maxiters + 2;
4429 if (pm->op_pmflags & PMf_WHITE) {
4432 while (m < strend &&
4433 !((pm->op_pmflags & PMf_LOCALE)
4434 ? isSPACE_LC(*m) : isSPACE(*m)))
4439 dstr = NEWSV(30, m-s);
4440 sv_setpvn(dstr, s, m-s);
4444 (void)SvUTF8_on(dstr);
4448 while (s < strend &&
4449 ((pm->op_pmflags & PMf_LOCALE)
4450 ? isSPACE_LC(*s) : isSPACE(*s)))
4454 else if (strEQ("^", rx->precomp)) {
4457 for (m = s; m < strend && *m != '\n'; m++) ;
4461 dstr = NEWSV(30, m-s);
4462 sv_setpvn(dstr, s, m-s);
4466 (void)SvUTF8_on(dstr);
4471 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4472 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4473 && (rx->reganch & ROPT_CHECK_ALL)
4474 && !(rx->reganch & ROPT_ANCH)) {
4475 int tail = (rx->reganch & RE_INTUIT_TAIL);
4476 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4479 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4481 char c = *SvPV(csv, n_a);
4484 for (m = s; m < strend && *m != c; m++) ;
4487 dstr = NEWSV(30, m-s);
4488 sv_setpvn(dstr, s, m-s);
4492 (void)SvUTF8_on(dstr);
4494 /* The rx->minlen is in characters but we want to step
4495 * s ahead by bytes. */
4497 s = (char*)utf8_hop((U8*)m, len);
4499 s = m + len; /* Fake \n at the end */
4504 while (s < strend && --limit &&
4505 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4506 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4509 dstr = NEWSV(31, m-s);
4510 sv_setpvn(dstr, s, m-s);
4514 (void)SvUTF8_on(dstr);
4516 /* The rx->minlen is in characters but we want to step
4517 * s ahead by bytes. */
4519 s = (char*)utf8_hop((U8*)m, len);
4521 s = m + len; /* Fake \n at the end */
4526 maxiters += slen * rx->nparens;
4527 while (s < strend && --limit
4528 /* && (!rx->check_substr
4529 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4531 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4532 1 /* minend */, sv, NULL, 0))
4534 TAINT_IF(RX_MATCH_TAINTED(rx));
4535 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4540 strend = s + (strend - m);
4542 m = rx->startp[0] + orig;
4543 dstr = NEWSV(32, m-s);
4544 sv_setpvn(dstr, s, m-s);
4548 (void)SvUTF8_on(dstr);
4551 for (i = 1; i <= (I32)rx->nparens; i++) {
4552 s = rx->startp[i] + orig;
4553 m = rx->endp[i] + orig;
4555 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4556 parens that didn't match -- they should be set to
4557 undef, not the empty string */
4558 if (m >= orig && s >= orig) {
4559 dstr = NEWSV(33, m-s);
4560 sv_setpvn(dstr, s, m-s);
4563 dstr = &PL_sv_undef; /* undef, not "" */
4567 (void)SvUTF8_on(dstr);
4571 s = rx->endp[0] + orig;
4575 LEAVE_SCOPE(oldsave);
4576 iters = (SP - PL_stack_base) - base;
4577 if (iters > maxiters)
4578 DIE(aTHX_ "Split loop");
4580 /* keep field after final delim? */
4581 if (s < strend || (iters && origlimit)) {
4582 STRLEN l = strend - s;
4583 dstr = NEWSV(34, l);
4584 sv_setpvn(dstr, s, l);
4588 (void)SvUTF8_on(dstr);
4592 else if (!origlimit) {
4593 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4594 if (TOPs && !make_mortal)
4603 SWITCHSTACK(ary, oldstack);
4604 if (SvSMAGICAL(ary)) {
4609 if (gimme == G_ARRAY) {
4611 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4619 call_method("PUSH",G_SCALAR|G_DISCARD);
4622 if (gimme == G_ARRAY) {
4623 /* EXTEND should not be needed - we just popped them */
4625 for (i=0; i < iters; i++) {
4626 SV **svp = av_fetch(ary, i, FALSE);
4627 PUSHs((svp) ? *svp : &PL_sv_undef);
4634 if (gimme == G_ARRAY)
4637 if (iters || !pm->op_pmreplroot) {
4645 #ifdef USE_5005THREADS
4647 Perl_unlock_condpair(pTHX_ void *svv)
4649 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4652 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4653 MUTEX_LOCK(MgMUTEXP(mg));
4654 if (MgOWNER(mg) != thr)
4655 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4657 COND_SIGNAL(MgOWNERCONDP(mg));
4658 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4659 PTR2UV(thr), PTR2UV(svv)));
4660 MUTEX_UNLOCK(MgMUTEXP(mg));
4662 #endif /* USE_5005THREADS */
4670 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4671 || SvTYPE(retsv) == SVt_PVCV) {
4672 retsv = refto(retsv);
4680 #ifdef USE_5005THREADS
4683 if (PL_op->op_private & OPpLVAL_INTRO)
4684 PUSHs(*save_threadsv(PL_op->op_targ));
4686 PUSHs(THREADSV(PL_op->op_targ));
4689 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4690 #endif /* USE_5005THREADS */