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 if (SvTHINKFIRST(sv))
770 switch (SvTYPE(sv)) {
780 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
781 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
782 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
786 /* let user-undef'd sub keep its identity */
787 GV* gv = CvGV((CV*)sv);
794 SvSetMagicSV(sv, &PL_sv_undef);
798 Newz(602, gp, 1, GP);
799 GvGP(sv) = gp_ref(gp);
800 GvSV(sv) = NEWSV(72,0);
801 GvLINE(sv) = CopLINE(PL_curcop);
807 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
810 SvPV_set(sv, Nullch);
823 if (SvTYPE(TOPs) > SVt_PVLV)
824 DIE(aTHX_ PL_no_modify);
825 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
826 && SvIVX(TOPs) != IV_MIN)
829 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
840 if (SvTYPE(TOPs) > SVt_PVLV)
841 DIE(aTHX_ PL_no_modify);
842 sv_setsv(TARG, TOPs);
843 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
844 && SvIVX(TOPs) != IV_MAX)
847 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
861 if (SvTYPE(TOPs) > SVt_PVLV)
862 DIE(aTHX_ PL_no_modify);
863 sv_setsv(TARG, TOPs);
864 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
865 && SvIVX(TOPs) != IV_MIN)
868 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
877 /* Ordinary operators. */
881 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
882 #ifdef PERL_PRESERVE_IVUV
883 /* ** is implemented with pow. pow is floating point. Perl programmers
884 write 2 ** 31 and expect it to be 2147483648
885 pow never made any guarantee to deliver a result to 53 (or whatever)
886 bits of accuracy. Which is unfortunate, as perl programmers expect it
887 to, and on some platforms (eg Irix with long doubles) it doesn't in
888 a very visible case. (2 ** 31, which a regression test uses)
889 So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
894 bool baseuok = SvUOK(TOPm1s);
898 baseuv = SvUVX(TOPm1s);
900 IV iv = SvIVX(TOPm1s);
903 baseuok = TRUE; /* effectively it's a UV now */
905 baseuv = -iv; /* abs, baseuok == false records sign */
919 goto float_it; /* Can't do negative powers this way. */
922 /* now we have integer ** positive integer.
923 foo & (foo - 1) is zero only for a power of 2. */
924 if (!(baseuv & (baseuv - 1))) {
925 /* We are raising power-of-2 to postive integer.
926 The logic here will work for any base (even non-integer
927 bases) but it can be less accurate than
928 pow (base,power) or exp (power * log (base)) when the
929 intermediate values start to spill out of the mantissa.
930 With powers of 2 we know this can't happen.
931 And powers of 2 are the favourite thing for perl
932 programmers to notice ** not doing what they mean. */
934 NV base = baseuok ? baseuv : -(NV)baseuv;
937 /* The logic is this.
938 x ** n === x ** m1 * x ** m2 where n = m1 + m2
939 so as 42 is 32 + 8 + 2
940 x ** 42 can be written as
941 x ** 32 * x ** 8 * x ** 2
942 I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
943 x ** 2n is x ** n * x ** n
944 So I loop round, squaring x each time
945 (x, x ** 2, x ** 4, x ** 8) and multiply the result
946 by the x-value whenever that bit is set in the power.
947 To finish as soon as possible I zero bits in the power
948 when I've done them, so that power becomes zero when
949 I clear the last bit (no more to do), and the loop
951 for (; power; base *= base, n++) {
952 /* Do I look like I trust gcc with long longs here?
954 UV bit = (UV)1 << (UV)n;
957 /* Only bother to clear the bit if it is set. */
959 /* Avoid squaring base again if we're done. */
960 if (power == 0) break;
974 SETn( Perl_pow( left, right) );
981 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
982 #ifdef PERL_PRESERVE_IVUV
985 /* Unless the left argument is integer in range we are going to have to
986 use NV maths. Hence only attempt to coerce the right argument if
987 we know the left is integer. */
988 /* Left operand is defined, so is it IV? */
991 bool auvok = SvUOK(TOPm1s);
992 bool buvok = SvUOK(TOPs);
993 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
994 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1001 alow = SvUVX(TOPm1s);
1003 IV aiv = SvIVX(TOPm1s);
1006 auvok = TRUE; /* effectively it's a UV now */
1008 alow = -aiv; /* abs, auvok == false records sign */
1014 IV biv = SvIVX(TOPs);
1017 buvok = TRUE; /* effectively it's a UV now */
1019 blow = -biv; /* abs, buvok == false records sign */
1023 /* If this does sign extension on unsigned it's time for plan B */
1024 ahigh = alow >> (4 * sizeof (UV));
1026 bhigh = blow >> (4 * sizeof (UV));
1028 if (ahigh && bhigh) {
1029 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1030 which is overflow. Drop to NVs below. */
1031 } else if (!ahigh && !bhigh) {
1032 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1033 so the unsigned multiply cannot overflow. */
1034 UV product = alow * blow;
1035 if (auvok == buvok) {
1036 /* -ve * -ve or +ve * +ve gives a +ve result. */
1040 } else if (product <= (UV)IV_MIN) {
1041 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1042 /* -ve result, which could overflow an IV */
1044 SETi( -(IV)product );
1046 } /* else drop to NVs below. */
1048 /* One operand is large, 1 small */
1051 /* swap the operands */
1053 bhigh = blow; /* bhigh now the temp var for the swap */
1057 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1058 multiplies can't overflow. shift can, add can, -ve can. */
1059 product_middle = ahigh * blow;
1060 if (!(product_middle & topmask)) {
1061 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1063 product_middle <<= (4 * sizeof (UV));
1064 product_low = alow * blow;
1066 /* as for pp_add, UV + something mustn't get smaller.
1067 IIRC ANSI mandates this wrapping *behaviour* for
1068 unsigned whatever the actual representation*/
1069 product_low += product_middle;
1070 if (product_low >= product_middle) {
1071 /* didn't overflow */
1072 if (auvok == buvok) {
1073 /* -ve * -ve or +ve * +ve gives a +ve result. */
1075 SETu( product_low );
1077 } else if (product_low <= (UV)IV_MIN) {
1078 /* 2s complement assumption again */
1079 /* -ve result, which could overflow an IV */
1081 SETi( -(IV)product_low );
1083 } /* else drop to NVs below. */
1085 } /* product_middle too large */
1086 } /* ahigh && bhigh */
1087 } /* SvIOK(TOPm1s) */
1092 SETn( left * right );
1099 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1100 /* Only try to do UV divide first
1101 if ((SLOPPYDIVIDE is true) or
1102 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1104 The assumption is that it is better to use floating point divide
1105 whenever possible, only doing integer divide first if we can't be sure.
1106 If NV_PRESERVES_UV is true then we know at compile time that no UV
1107 can be too large to preserve, so don't need to compile the code to
1108 test the size of UVs. */
1111 # define PERL_TRY_UV_DIVIDE
1112 /* ensure that 20./5. == 4. */
1114 # ifdef PERL_PRESERVE_IVUV
1115 # ifndef NV_PRESERVES_UV
1116 # define PERL_TRY_UV_DIVIDE
1121 #ifdef PERL_TRY_UV_DIVIDE
1124 SvIV_please(TOPm1s);
1125 if (SvIOK(TOPm1s)) {
1126 bool left_non_neg = SvUOK(TOPm1s);
1127 bool right_non_neg = SvUOK(TOPs);
1131 if (right_non_neg) {
1132 right = SvUVX(TOPs);
1135 IV biv = SvIVX(TOPs);
1138 right_non_neg = TRUE; /* effectively it's a UV now */
1144 /* historically undef()/0 gives a "Use of uninitialized value"
1145 warning before dieing, hence this test goes here.
1146 If it were immediately before the second SvIV_please, then
1147 DIE() would be invoked before left was even inspected, so
1148 no inpsection would give no warning. */
1150 DIE(aTHX_ "Illegal division by zero");
1153 left = SvUVX(TOPm1s);
1156 IV aiv = SvIVX(TOPm1s);
1159 left_non_neg = TRUE; /* effectively it's a UV now */
1168 /* For sloppy divide we always attempt integer division. */
1170 /* Otherwise we only attempt it if either or both operands
1171 would not be preserved by an NV. If both fit in NVs
1172 we fall through to the NV divide code below. However,
1173 as left >= right to ensure integer result here, we know that
1174 we can skip the test on the right operand - right big
1175 enough not to be preserved can't get here unless left is
1178 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1181 /* Integer division can't overflow, but it can be imprecise. */
1182 UV result = left / right;
1183 if (result * right == left) {
1184 SP--; /* result is valid */
1185 if (left_non_neg == right_non_neg) {
1186 /* signs identical, result is positive. */
1190 /* 2s complement assumption */
1191 if (result <= (UV)IV_MIN)
1192 SETi( -(IV)result );
1194 /* It's exact but too negative for IV. */
1195 SETn( -(NV)result );
1198 } /* tried integer divide but it was not an integer result */
1199 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1200 } /* left wasn't SvIOK */
1201 } /* right wasn't SvIOK */
1202 #endif /* PERL_TRY_UV_DIVIDE */
1206 DIE(aTHX_ "Illegal division by zero");
1207 PUSHn( left / right );
1214 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1218 bool left_neg = FALSE;
1219 bool right_neg = FALSE;
1220 bool use_double = FALSE;
1221 bool dright_valid = FALSE;
1227 right_neg = !SvUOK(TOPs);
1229 right = SvUVX(POPs);
1231 IV biv = SvIVX(POPs);
1234 right_neg = FALSE; /* effectively it's a UV now */
1242 right_neg = dright < 0;
1245 if (dright < UV_MAX_P1) {
1246 right = U_V(dright);
1247 dright_valid = TRUE; /* In case we need to use double below. */
1253 /* At this point use_double is only true if right is out of range for
1254 a UV. In range NV has been rounded down to nearest UV and
1255 use_double false. */
1257 if (!use_double && SvIOK(TOPs)) {
1259 left_neg = !SvUOK(TOPs);
1263 IV aiv = SvIVX(POPs);
1266 left_neg = FALSE; /* effectively it's a UV now */
1275 left_neg = dleft < 0;
1279 /* This should be exactly the 5.6 behaviour - if left and right are
1280 both in range for UV then use U_V() rather than floor. */
1282 if (dleft < UV_MAX_P1) {
1283 /* right was in range, so is dleft, so use UVs not double.
1287 /* left is out of range for UV, right was in range, so promote
1288 right (back) to double. */
1290 /* The +0.5 is used in 5.6 even though it is not strictly
1291 consistent with the implicit +0 floor in the U_V()
1292 inside the #if 1. */
1293 dleft = Perl_floor(dleft + 0.5);
1296 dright = Perl_floor(dright + 0.5);
1306 DIE(aTHX_ "Illegal modulus zero");
1308 dans = Perl_fmod(dleft, dright);
1309 if ((left_neg != right_neg) && dans)
1310 dans = dright - dans;
1313 sv_setnv(TARG, dans);
1319 DIE(aTHX_ "Illegal modulus zero");
1322 if ((left_neg != right_neg) && ans)
1325 /* XXX may warn: unary minus operator applied to unsigned type */
1326 /* could change -foo to be (~foo)+1 instead */
1327 if (ans <= ~((UV)IV_MAX)+1)
1328 sv_setiv(TARG, ~ans+1);
1330 sv_setnv(TARG, -(NV)ans);
1333 sv_setuv(TARG, ans);
1342 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1344 register IV count = POPi;
1345 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1347 I32 items = SP - MARK;
1350 max = items * count;
1355 /* This code was intended to fix 20010809.028:
1358 for (($x =~ /./g) x 2) {
1359 print chop; # "abcdabcd" expected as output.
1362 * but that change (#11635) broke this code:
1364 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1366 * I can't think of a better fix that doesn't introduce
1367 * an efficiency hit by copying the SVs. The stack isn't
1368 * refcounted, and mortalisation obviously doesn't
1369 * Do The Right Thing when the stack has more than
1370 * one pointer to the same mortal value.
1374 *SP = sv_2mortal(newSVsv(*SP));
1384 repeatcpy((char*)(MARK + items), (char*)MARK,
1385 items * sizeof(SV*), count - 1);
1388 else if (count <= 0)
1391 else { /* Note: mark already snarfed by pp_list */
1396 SvSetSV(TARG, tmpstr);
1397 SvPV_force(TARG, len);
1398 isutf = DO_UTF8(TARG);
1403 SvGROW(TARG, (count * len) + 1);
1404 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1405 SvCUR(TARG) *= count;
1407 *SvEND(TARG) = '\0';
1410 (void)SvPOK_only_UTF8(TARG);
1412 (void)SvPOK_only(TARG);
1414 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1415 /* The parser saw this as a list repeat, and there
1416 are probably several items on the stack. But we're
1417 in scalar context, and there's no pp_list to save us
1418 now. So drop the rest of the items -- robin@kitsite.com
1431 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1432 useleft = USE_LEFT(TOPm1s);
1433 #ifdef PERL_PRESERVE_IVUV
1434 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1435 "bad things" happen if you rely on signed integers wrapping. */
1438 /* Unless the left argument is integer in range we are going to have to
1439 use NV maths. Hence only attempt to coerce the right argument if
1440 we know the left is integer. */
1441 register UV auv = 0;
1447 a_valid = auvok = 1;
1448 /* left operand is undef, treat as zero. */
1450 /* Left operand is defined, so is it IV? */
1451 SvIV_please(TOPm1s);
1452 if (SvIOK(TOPm1s)) {
1453 if ((auvok = SvUOK(TOPm1s)))
1454 auv = SvUVX(TOPm1s);
1456 register IV aiv = SvIVX(TOPm1s);
1459 auvok = 1; /* Now acting as a sign flag. */
1460 } else { /* 2s complement assumption for IV_MIN */
1468 bool result_good = 0;
1471 bool buvok = SvUOK(TOPs);
1476 register IV biv = SvIVX(TOPs);
1483 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1484 else "IV" now, independent of how it came in.
1485 if a, b represents positive, A, B negative, a maps to -A etc
1490 all UV maths. negate result if A negative.
1491 subtract if signs same, add if signs differ. */
1493 if (auvok ^ buvok) {
1502 /* Must get smaller */
1507 if (result <= buv) {
1508 /* result really should be -(auv-buv). as its negation
1509 of true value, need to swap our result flag */
1521 if (result <= (UV)IV_MIN)
1522 SETi( -(IV)result );
1524 /* result valid, but out of range for IV. */
1525 SETn( -(NV)result );
1529 } /* Overflow, drop through to NVs. */
1533 useleft = USE_LEFT(TOPm1s);
1537 /* left operand is undef, treat as zero - value */
1541 SETn( TOPn - value );
1548 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1551 if (PL_op->op_private & HINT_INTEGER) {
1565 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1568 if (PL_op->op_private & HINT_INTEGER) {
1582 dSP; tryAMAGICbinSET(lt,0);
1583 #ifdef PERL_PRESERVE_IVUV
1586 SvIV_please(TOPm1s);
1587 if (SvIOK(TOPm1s)) {
1588 bool auvok = SvUOK(TOPm1s);
1589 bool buvok = SvUOK(TOPs);
1591 if (!auvok && !buvok) { /* ## IV < IV ## */
1592 IV aiv = SvIVX(TOPm1s);
1593 IV biv = SvIVX(TOPs);
1596 SETs(boolSV(aiv < biv));
1599 if (auvok && buvok) { /* ## UV < UV ## */
1600 UV auv = SvUVX(TOPm1s);
1601 UV buv = SvUVX(TOPs);
1604 SETs(boolSV(auv < buv));
1607 if (auvok) { /* ## UV < IV ## */
1614 /* As (a) is a UV, it's >=0, so it cannot be < */
1619 SETs(boolSV(auv < (UV)biv));
1622 { /* ## IV < UV ## */
1626 aiv = SvIVX(TOPm1s);
1628 /* As (b) is a UV, it's >=0, so it must be < */
1635 SETs(boolSV((UV)aiv < buv));
1641 #ifndef NV_PRESERVES_UV
1642 #ifdef PERL_PRESERVE_IVUV
1645 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1647 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1653 SETs(boolSV(TOPn < value));
1660 dSP; tryAMAGICbinSET(gt,0);
1661 #ifdef PERL_PRESERVE_IVUV
1664 SvIV_please(TOPm1s);
1665 if (SvIOK(TOPm1s)) {
1666 bool auvok = SvUOK(TOPm1s);
1667 bool buvok = SvUOK(TOPs);
1669 if (!auvok && !buvok) { /* ## IV > IV ## */
1670 IV aiv = SvIVX(TOPm1s);
1671 IV biv = SvIVX(TOPs);
1674 SETs(boolSV(aiv > biv));
1677 if (auvok && buvok) { /* ## UV > UV ## */
1678 UV auv = SvUVX(TOPm1s);
1679 UV buv = SvUVX(TOPs);
1682 SETs(boolSV(auv > buv));
1685 if (auvok) { /* ## UV > IV ## */
1692 /* As (a) is a UV, it's >=0, so it must be > */
1697 SETs(boolSV(auv > (UV)biv));
1700 { /* ## IV > UV ## */
1704 aiv = SvIVX(TOPm1s);
1706 /* As (b) is a UV, it's >=0, so it cannot be > */
1713 SETs(boolSV((UV)aiv > buv));
1719 #ifndef NV_PRESERVES_UV
1720 #ifdef PERL_PRESERVE_IVUV
1723 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1725 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1731 SETs(boolSV(TOPn > value));
1738 dSP; tryAMAGICbinSET(le,0);
1739 #ifdef PERL_PRESERVE_IVUV
1742 SvIV_please(TOPm1s);
1743 if (SvIOK(TOPm1s)) {
1744 bool auvok = SvUOK(TOPm1s);
1745 bool buvok = SvUOK(TOPs);
1747 if (!auvok && !buvok) { /* ## IV <= IV ## */
1748 IV aiv = SvIVX(TOPm1s);
1749 IV biv = SvIVX(TOPs);
1752 SETs(boolSV(aiv <= biv));
1755 if (auvok && buvok) { /* ## UV <= UV ## */
1756 UV auv = SvUVX(TOPm1s);
1757 UV buv = SvUVX(TOPs);
1760 SETs(boolSV(auv <= buv));
1763 if (auvok) { /* ## UV <= IV ## */
1770 /* As (a) is a UV, it's >=0, so a cannot be <= */
1775 SETs(boolSV(auv <= (UV)biv));
1778 { /* ## IV <= UV ## */
1782 aiv = SvIVX(TOPm1s);
1784 /* As (b) is a UV, it's >=0, so a must be <= */
1791 SETs(boolSV((UV)aiv <= buv));
1797 #ifndef NV_PRESERVES_UV
1798 #ifdef PERL_PRESERVE_IVUV
1801 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1803 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1809 SETs(boolSV(TOPn <= value));
1816 dSP; tryAMAGICbinSET(ge,0);
1817 #ifdef PERL_PRESERVE_IVUV
1820 SvIV_please(TOPm1s);
1821 if (SvIOK(TOPm1s)) {
1822 bool auvok = SvUOK(TOPm1s);
1823 bool buvok = SvUOK(TOPs);
1825 if (!auvok && !buvok) { /* ## IV >= IV ## */
1826 IV aiv = SvIVX(TOPm1s);
1827 IV biv = SvIVX(TOPs);
1830 SETs(boolSV(aiv >= biv));
1833 if (auvok && buvok) { /* ## UV >= UV ## */
1834 UV auv = SvUVX(TOPm1s);
1835 UV buv = SvUVX(TOPs);
1838 SETs(boolSV(auv >= buv));
1841 if (auvok) { /* ## UV >= IV ## */
1848 /* As (a) is a UV, it's >=0, so it must be >= */
1853 SETs(boolSV(auv >= (UV)biv));
1856 { /* ## IV >= UV ## */
1860 aiv = SvIVX(TOPm1s);
1862 /* As (b) is a UV, it's >=0, so a cannot be >= */
1869 SETs(boolSV((UV)aiv >= buv));
1875 #ifndef NV_PRESERVES_UV
1876 #ifdef PERL_PRESERVE_IVUV
1879 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1881 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1887 SETs(boolSV(TOPn >= value));
1894 dSP; tryAMAGICbinSET(ne,0);
1895 #ifndef NV_PRESERVES_UV
1896 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1898 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1902 #ifdef PERL_PRESERVE_IVUV
1905 SvIV_please(TOPm1s);
1906 if (SvIOK(TOPm1s)) {
1907 bool auvok = SvUOK(TOPm1s);
1908 bool buvok = SvUOK(TOPs);
1910 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1911 /* Casting IV to UV before comparison isn't going to matter
1912 on 2s complement. On 1s complement or sign&magnitude
1913 (if we have any of them) it could make negative zero
1914 differ from normal zero. As I understand it. (Need to
1915 check - is negative zero implementation defined behaviour
1917 UV buv = SvUVX(POPs);
1918 UV auv = SvUVX(TOPs);
1920 SETs(boolSV(auv != buv));
1923 { /* ## Mixed IV,UV ## */
1927 /* != is commutative so swap if needed (save code) */
1929 /* swap. top of stack (b) is the iv */
1933 /* As (a) is a UV, it's >0, so it cannot be == */
1942 /* As (b) is a UV, it's >0, so it cannot be == */
1946 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1948 SETs(boolSV((UV)iv != uv));
1956 SETs(boolSV(TOPn != value));
1963 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1964 #ifndef NV_PRESERVES_UV
1965 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1966 UV right = PTR2UV(SvRV(POPs));
1967 UV left = PTR2UV(SvRV(TOPs));
1968 SETi((left > right) - (left < right));
1972 #ifdef PERL_PRESERVE_IVUV
1973 /* Fortunately it seems NaN isn't IOK */
1976 SvIV_please(TOPm1s);
1977 if (SvIOK(TOPm1s)) {
1978 bool leftuvok = SvUOK(TOPm1s);
1979 bool rightuvok = SvUOK(TOPs);
1981 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1982 IV leftiv = SvIVX(TOPm1s);
1983 IV rightiv = SvIVX(TOPs);
1985 if (leftiv > rightiv)
1987 else if (leftiv < rightiv)
1991 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1992 UV leftuv = SvUVX(TOPm1s);
1993 UV rightuv = SvUVX(TOPs);
1995 if (leftuv > rightuv)
1997 else if (leftuv < rightuv)
2001 } else if (leftuvok) { /* ## UV <=> IV ## */
2005 rightiv = SvIVX(TOPs);
2007 /* As (a) is a UV, it's >=0, so it cannot be < */
2010 leftuv = SvUVX(TOPm1s);
2011 if (leftuv > (UV)rightiv) {
2013 } else if (leftuv < (UV)rightiv) {
2019 } else { /* ## IV <=> UV ## */
2023 leftiv = SvIVX(TOPm1s);
2025 /* As (b) is a UV, it's >=0, so it must be < */
2028 rightuv = SvUVX(TOPs);
2029 if ((UV)leftiv > rightuv) {
2031 } else if ((UV)leftiv < rightuv) {
2049 if (Perl_isnan(left) || Perl_isnan(right)) {
2053 value = (left > right) - (left < right);
2057 else if (left < right)
2059 else if (left > right)
2073 dSP; tryAMAGICbinSET(slt,0);
2076 int cmp = (IN_LOCALE_RUNTIME
2077 ? sv_cmp_locale(left, right)
2078 : sv_cmp(left, right));
2079 SETs(boolSV(cmp < 0));
2086 dSP; tryAMAGICbinSET(sgt,0);
2089 int cmp = (IN_LOCALE_RUNTIME
2090 ? sv_cmp_locale(left, right)
2091 : sv_cmp(left, right));
2092 SETs(boolSV(cmp > 0));
2099 dSP; tryAMAGICbinSET(sle,0);
2102 int cmp = (IN_LOCALE_RUNTIME
2103 ? sv_cmp_locale(left, right)
2104 : sv_cmp(left, right));
2105 SETs(boolSV(cmp <= 0));
2112 dSP; tryAMAGICbinSET(sge,0);
2115 int cmp = (IN_LOCALE_RUNTIME
2116 ? sv_cmp_locale(left, right)
2117 : sv_cmp(left, right));
2118 SETs(boolSV(cmp >= 0));
2125 dSP; tryAMAGICbinSET(seq,0);
2128 SETs(boolSV(sv_eq(left, right)));
2135 dSP; tryAMAGICbinSET(sne,0);
2138 SETs(boolSV(!sv_eq(left, right)));
2145 dSP; dTARGET; tryAMAGICbin(scmp,0);
2148 int cmp = (IN_LOCALE_RUNTIME
2149 ? sv_cmp_locale(left, right)
2150 : sv_cmp(left, right));
2158 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2161 if (SvNIOKp(left) || SvNIOKp(right)) {
2162 if (PL_op->op_private & HINT_INTEGER) {
2163 IV i = SvIV(left) & SvIV(right);
2167 UV u = SvUV(left) & SvUV(right);
2172 do_vop(PL_op->op_type, TARG, left, right);
2181 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2184 if (SvNIOKp(left) || SvNIOKp(right)) {
2185 if (PL_op->op_private & HINT_INTEGER) {
2186 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2190 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2195 do_vop(PL_op->op_type, TARG, left, right);
2204 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2207 if (SvNIOKp(left) || SvNIOKp(right)) {
2208 if (PL_op->op_private & HINT_INTEGER) {
2209 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2213 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2218 do_vop(PL_op->op_type, TARG, left, right);
2227 dSP; dTARGET; tryAMAGICun(neg);
2230 int flags = SvFLAGS(sv);
2233 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2234 /* It's publicly an integer, or privately an integer-not-float */
2237 if (SvIVX(sv) == IV_MIN) {
2238 /* 2s complement assumption. */
2239 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2242 else if (SvUVX(sv) <= IV_MAX) {
2247 else if (SvIVX(sv) != IV_MIN) {
2251 #ifdef PERL_PRESERVE_IVUV
2260 else if (SvPOKp(sv)) {
2262 char *s = SvPV(sv, len);
2263 if (isIDFIRST(*s)) {
2264 sv_setpvn(TARG, "-", 1);
2267 else if (*s == '+' || *s == '-') {
2269 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2271 else if (DO_UTF8(sv)) {
2274 goto oops_its_an_int;
2276 sv_setnv(TARG, -SvNV(sv));
2278 sv_setpvn(TARG, "-", 1);
2285 goto oops_its_an_int;
2286 sv_setnv(TARG, -SvNV(sv));
2298 dSP; tryAMAGICunSET(not);
2299 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2305 dSP; dTARGET; tryAMAGICun(compl);
2309 if (PL_op->op_private & HINT_INTEGER) {
2324 tmps = (U8*)SvPV_force(TARG, len);
2327 /* Calculate exact length, let's not estimate. */
2336 while (tmps < send) {
2337 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2338 tmps += UTF8SKIP(tmps);
2339 targlen += UNISKIP(~c);
2345 /* Now rewind strings and write them. */
2349 Newz(0, result, targlen + 1, U8);
2350 while (tmps < send) {
2351 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2352 tmps += UTF8SKIP(tmps);
2353 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2357 sv_setpvn(TARG, (char*)result, targlen);
2361 Newz(0, result, nchar + 1, U8);
2362 while (tmps < send) {
2363 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2364 tmps += UTF8SKIP(tmps);
2369 sv_setpvn(TARG, (char*)result, nchar);
2377 register long *tmpl;
2378 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2381 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2386 for ( ; anum > 0; anum--, tmps++)
2395 /* integer versions of some of the above */
2399 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2402 SETi( left * right );
2409 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2413 DIE(aTHX_ "Illegal division by zero");
2414 value = POPi / value;
2422 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2426 DIE(aTHX_ "Illegal modulus zero");
2427 SETi( left % right );
2434 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2437 SETi( left + right );
2444 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2447 SETi( left - right );
2454 dSP; tryAMAGICbinSET(lt,0);
2457 SETs(boolSV(left < right));
2464 dSP; tryAMAGICbinSET(gt,0);
2467 SETs(boolSV(left > right));
2474 dSP; tryAMAGICbinSET(le,0);
2477 SETs(boolSV(left <= right));
2484 dSP; tryAMAGICbinSET(ge,0);
2487 SETs(boolSV(left >= right));
2494 dSP; tryAMAGICbinSET(eq,0);
2497 SETs(boolSV(left == right));
2504 dSP; tryAMAGICbinSET(ne,0);
2507 SETs(boolSV(left != right));
2514 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2521 else if (left < right)
2532 dSP; dTARGET; tryAMAGICun(neg);
2537 /* High falutin' math. */
2541 dSP; dTARGET; tryAMAGICbin(atan2,0);
2544 SETn(Perl_atan2(left, right));
2551 dSP; dTARGET; tryAMAGICun(sin);
2555 value = Perl_sin(value);
2563 dSP; dTARGET; tryAMAGICun(cos);
2567 value = Perl_cos(value);
2573 /* Support Configure command-line overrides for rand() functions.
2574 After 5.005, perhaps we should replace this by Configure support
2575 for drand48(), random(), or rand(). For 5.005, though, maintain
2576 compatibility by calling rand() but allow the user to override it.
2577 See INSTALL for details. --Andy Dougherty 15 July 1998
2579 /* Now it's after 5.005, and Configure supports drand48() and random(),
2580 in addition to rand(). So the overrides should not be needed any more.
2581 --Jarkko Hietaniemi 27 September 1998
2584 #ifndef HAS_DRAND48_PROTO
2585 extern double drand48 (void);
2598 if (!PL_srand_called) {
2599 (void)seedDrand01((Rand_seed_t)seed());
2600 PL_srand_called = TRUE;
2615 (void)seedDrand01((Rand_seed_t)anum);
2616 PL_srand_called = TRUE;
2625 * This is really just a quick hack which grabs various garbage
2626 * values. It really should be a real hash algorithm which
2627 * spreads the effect of every input bit onto every output bit,
2628 * if someone who knows about such things would bother to write it.
2629 * Might be a good idea to add that function to CORE as well.
2630 * No numbers below come from careful analysis or anything here,
2631 * except they are primes and SEED_C1 > 1E6 to get a full-width
2632 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2633 * probably be bigger too.
2636 # define SEED_C1 1000003
2637 #define SEED_C4 73819
2639 # define SEED_C1 25747
2640 #define SEED_C4 20639
2644 #define SEED_C5 26107
2646 #ifndef PERL_NO_DEV_RANDOM
2651 # include <starlet.h>
2652 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2653 * in 100-ns units, typically incremented ever 10 ms. */
2654 unsigned int when[2];
2656 # ifdef HAS_GETTIMEOFDAY
2657 struct timeval when;
2663 /* This test is an escape hatch, this symbol isn't set by Configure. */
2664 #ifndef PERL_NO_DEV_RANDOM
2665 #ifndef PERL_RANDOM_DEVICE
2666 /* /dev/random isn't used by default because reads from it will block
2667 * if there isn't enough entropy available. You can compile with
2668 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2669 * is enough real entropy to fill the seed. */
2670 # define PERL_RANDOM_DEVICE "/dev/urandom"
2672 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2674 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2683 _ckvmssts(sys$gettim(when));
2684 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2686 # ifdef HAS_GETTIMEOFDAY
2687 PerlProc_gettimeofday(&when,NULL);
2688 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2691 u = (U32)SEED_C1 * when;
2694 u += SEED_C3 * (U32)PerlProc_getpid();
2695 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2696 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2697 u += SEED_C5 * (U32)PTR2UV(&when);
2704 dSP; dTARGET; tryAMAGICun(exp);
2708 value = Perl_exp(value);
2716 dSP; dTARGET; tryAMAGICun(log);
2721 SET_NUMERIC_STANDARD();
2722 DIE(aTHX_ "Can't take log of %"NVgf, value);
2724 value = Perl_log(value);
2732 dSP; dTARGET; tryAMAGICun(sqrt);
2737 SET_NUMERIC_STANDARD();
2738 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2740 value = Perl_sqrt(value);
2747 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2748 * These need to be revisited when a newer toolchain becomes available.
2750 #if defined(__sparc64__) && defined(__GNUC__)
2751 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2752 # undef SPARC64_MODF_WORKAROUND
2753 # define SPARC64_MODF_WORKAROUND 1
2757 #if defined(SPARC64_MODF_WORKAROUND)
2759 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2762 ret = Perl_modf(theVal, &res);
2770 dSP; dTARGET; tryAMAGICun(int);
2773 IV iv = TOPi; /* attempt to convert to IV if possible. */
2774 /* XXX it's arguable that compiler casting to IV might be subtly
2775 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2776 else preferring IV has introduced a subtle behaviour change bug. OTOH
2777 relying on floating point to be accurate is a bug. */
2788 if (value < (NV)UV_MAX + 0.5) {
2791 #if defined(SPARC64_MODF_WORKAROUND)
2792 (void)sparc64_workaround_modf(value, &value);
2794 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2795 # ifdef HAS_MODFL_POW32_BUG
2796 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2798 NV offset = Perl_modf(value, &value);
2799 (void)Perl_modf(offset, &offset);
2803 (void)Perl_modf(value, &value);
2806 double tmp = (double)value;
2807 (void)Perl_modf(tmp, &tmp);
2815 if (value > (NV)IV_MIN - 0.5) {
2818 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2819 # ifdef HAS_MODFL_POW32_BUG
2820 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2822 NV offset = Perl_modf(-value, &value);
2823 (void)Perl_modf(offset, &offset);
2827 (void)Perl_modf(-value, &value);
2831 double tmp = (double)value;
2832 (void)Perl_modf(-tmp, &tmp);
2845 dSP; dTARGET; tryAMAGICun(abs);
2847 /* This will cache the NV value if string isn't actually integer */
2851 /* IVX is precise */
2853 SETu(TOPu); /* force it to be numeric only */
2861 /* 2s complement assumption. Also, not really needed as
2862 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2882 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2888 tmps = (SvPVx(sv, len));
2890 /* If Unicode, try to downgrade
2891 * If not possible, croak. */
2892 SV* tsv = sv_2mortal(newSVsv(sv));
2895 sv_utf8_downgrade(tsv, FALSE);
2898 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2899 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2912 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2918 tmps = (SvPVx(sv, len));
2920 /* If Unicode, try to downgrade
2921 * If not possible, croak. */
2922 SV* tsv = sv_2mortal(newSVsv(sv));
2925 sv_utf8_downgrade(tsv, FALSE);
2928 while (*tmps && len && isSPACE(*tmps))
2933 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2934 else if (*tmps == 'b')
2935 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2937 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2939 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2956 SETi(sv_len_utf8(sv));
2972 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2974 I32 arybase = PL_curcop->cop_arybase;
2978 int num_args = PL_op->op_private & 7;
2979 bool repl_need_utf8_upgrade = FALSE;
2980 bool repl_is_utf8 = FALSE;
2982 SvTAINTED_off(TARG); /* decontaminate */
2983 SvUTF8_off(TARG); /* decontaminate */
2987 repl = SvPV(repl_sv, repl_len);
2988 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2998 sv_utf8_upgrade(sv);
3000 else if (DO_UTF8(sv))
3001 repl_need_utf8_upgrade = TRUE;
3003 tmps = SvPV(sv, curlen);
3005 utf8_curlen = sv_len_utf8(sv);
3006 if (utf8_curlen == curlen)
3009 curlen = utf8_curlen;
3014 if (pos >= arybase) {
3032 else if (len >= 0) {
3034 if (rem > (I32)curlen)
3049 Perl_croak(aTHX_ "substr outside of string");
3050 if (ckWARN(WARN_SUBSTR))
3051 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3058 sv_pos_u2b(sv, &pos, &rem);
3060 sv_setpvn(TARG, tmps, rem);
3061 #ifdef USE_LOCALE_COLLATE
3062 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3067 SV* repl_sv_copy = NULL;
3069 if (repl_need_utf8_upgrade) {
3070 repl_sv_copy = newSVsv(repl_sv);
3071 sv_utf8_upgrade(repl_sv_copy);
3072 repl = SvPV(repl_sv_copy, repl_len);
3073 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3075 sv_insert(sv, pos, rem, repl, repl_len);
3079 SvREFCNT_dec(repl_sv_copy);
3081 else if (lvalue) { /* it's an lvalue! */
3082 if (!SvGMAGICAL(sv)) {
3086 if (ckWARN(WARN_SUBSTR))
3087 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3088 "Attempt to use reference as lvalue in substr");
3090 if (SvOK(sv)) /* is it defined ? */
3091 (void)SvPOK_only_UTF8(sv);
3093 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3096 if (SvTYPE(TARG) < SVt_PVLV) {
3097 sv_upgrade(TARG, SVt_PVLV);
3098 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3102 if (LvTARG(TARG) != sv) {
3104 SvREFCNT_dec(LvTARG(TARG));
3105 LvTARG(TARG) = SvREFCNT_inc(sv);
3107 LvTARGOFF(TARG) = upos;
3108 LvTARGLEN(TARG) = urem;
3112 PUSHs(TARG); /* avoid SvSETMAGIC here */
3119 register IV size = POPi;
3120 register IV offset = POPi;
3121 register SV *src = POPs;
3122 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3124 SvTAINTED_off(TARG); /* decontaminate */
3125 if (lvalue) { /* it's an lvalue! */
3126 if (SvTYPE(TARG) < SVt_PVLV) {
3127 sv_upgrade(TARG, SVt_PVLV);
3128 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3131 if (LvTARG(TARG) != src) {
3133 SvREFCNT_dec(LvTARG(TARG));
3134 LvTARG(TARG) = SvREFCNT_inc(src);
3136 LvTARGOFF(TARG) = offset;
3137 LvTARGLEN(TARG) = size;
3140 sv_setuv(TARG, do_vecget(src, offset, size));
3155 I32 arybase = PL_curcop->cop_arybase;
3160 offset = POPi - arybase;
3163 tmps = SvPV(big, biglen);
3164 if (offset > 0 && DO_UTF8(big))
3165 sv_pos_u2b(big, &offset, 0);
3168 else if (offset > (I32)biglen)
3170 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3171 (unsigned char*)tmps + biglen, little, 0)))
3174 retval = tmps2 - tmps;
3175 if (retval > 0 && DO_UTF8(big))
3176 sv_pos_b2u(big, &retval);
3177 PUSHi(retval + arybase);
3192 I32 arybase = PL_curcop->cop_arybase;
3198 tmps2 = SvPV(little, llen);
3199 tmps = SvPV(big, blen);
3203 if (offset > 0 && DO_UTF8(big))
3204 sv_pos_u2b(big, &offset, 0);
3205 offset = offset - arybase + llen;
3209 else if (offset > (I32)blen)
3211 if (!(tmps2 = rninstr(tmps, tmps + offset,
3212 tmps2, tmps2 + llen)))
3215 retval = tmps2 - tmps;
3216 if (retval > 0 && DO_UTF8(big))
3217 sv_pos_b2u(big, &retval);
3218 PUSHi(retval + arybase);
3224 dSP; dMARK; dORIGMARK; dTARGET;
3225 do_sprintf(TARG, SP-MARK, MARK+1);
3226 TAINT_IF(SvTAINTED(TARG));
3227 if (DO_UTF8(*(MARK+1)))
3239 U8 *s = (U8*)SvPVx(argsv, len);
3242 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3243 tmpsv = sv_2mortal(newSVsv(argsv));
3244 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3248 XPUSHu(DO_UTF8(argsv) ?
3249 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3261 (void)SvUPGRADE(TARG,SVt_PV);
3263 if (value > 255 && !IN_BYTES) {
3264 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3265 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3266 SvCUR_set(TARG, tmps - SvPVX(TARG));
3268 (void)SvPOK_only(TARG);
3277 *tmps++ = (char)value;
3279 (void)SvPOK_only(TARG);
3281 sv_recode_to_utf8(TARG, PL_encoding);
3293 char *tmps = SvPV(left, len);
3295 if (DO_UTF8(left)) {
3296 /* If Unicode, try to downgrade.
3297 * If not possible, croak.
3298 * Yes, we made this up. */
3299 SV* tsv = sv_2mortal(newSVsv(left));
3302 sv_utf8_downgrade(tsv, FALSE);
3306 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3308 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3314 "The crypt() function is unimplemented due to excessive paranoia.");
3326 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3330 s = (U8*)SvPV(sv, slen);
3331 utf8_to_uvchr(s, &ulen);
3333 toTITLE_utf8(s, tmpbuf, &tculen);
3334 utf8_to_uvchr(tmpbuf, 0);
3336 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3338 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3339 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3344 s = (U8*)SvPV_force(sv, slen);
3345 Copy(tmpbuf, s, tculen, U8);
3349 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3351 SvUTF8_off(TARG); /* decontaminate */
3356 s = (U8*)SvPV_force(sv, slen);
3358 if (IN_LOCALE_RUNTIME) {
3361 *s = toUPPER_LC(*s);
3379 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3381 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3385 toLOWER_utf8(s, tmpbuf, &ulen);
3386 uv = utf8_to_uvchr(tmpbuf, 0);
3388 tend = uvchr_to_utf8(tmpbuf, uv);
3390 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3392 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3393 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3398 s = (U8*)SvPV_force(sv, slen);
3399 Copy(tmpbuf, s, ulen, U8);
3403 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3405 SvUTF8_off(TARG); /* decontaminate */
3410 s = (U8*)SvPV_force(sv, slen);
3412 if (IN_LOCALE_RUNTIME) {
3415 *s = toLOWER_LC(*s);
3438 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3440 s = (U8*)SvPV(sv,len);
3442 SvUTF8_off(TARG); /* decontaminate */
3443 sv_setpvn(TARG, "", 0);
3447 STRLEN nchar = utf8_length(s, s + len);
3449 (void)SvUPGRADE(TARG, SVt_PV);
3450 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3451 (void)SvPOK_only(TARG);
3452 d = (U8*)SvPVX(TARG);
3455 toUPPER_utf8(s, tmpbuf, &ulen);
3456 Copy(tmpbuf, d, ulen, U8);
3462 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3467 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3469 SvUTF8_off(TARG); /* decontaminate */
3474 s = (U8*)SvPV_force(sv, len);
3476 register U8 *send = s + len;
3478 if (IN_LOCALE_RUNTIME) {
3481 for (; s < send; s++)
3482 *s = toUPPER_LC(*s);
3485 for (; s < send; s++)
3507 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3509 s = (U8*)SvPV(sv,len);
3511 SvUTF8_off(TARG); /* decontaminate */
3512 sv_setpvn(TARG, "", 0);
3516 STRLEN nchar = utf8_length(s, s + len);
3518 (void)SvUPGRADE(TARG, SVt_PV);
3519 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3520 (void)SvPOK_only(TARG);
3521 d = (U8*)SvPVX(TARG);
3524 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3525 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3526 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3528 * Now if the sigma is NOT followed by
3529 * /$ignorable_sequence$cased_letter/;
3530 * and it IS preceded by
3531 * /$cased_letter$ignorable_sequence/;
3532 * where $ignorable_sequence is
3533 * [\x{2010}\x{AD}\p{Mn}]*
3534 * and $cased_letter is
3535 * [\p{Ll}\p{Lo}\p{Lt}]
3536 * then it should be mapped to 0x03C2,
3537 * (GREEK SMALL LETTER FINAL SIGMA),
3538 * instead of staying 0x03A3.
3539 * See lib/unicore/SpecCase.txt.
3542 Copy(tmpbuf, d, ulen, U8);
3548 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3553 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3555 SvUTF8_off(TARG); /* decontaminate */
3561 s = (U8*)SvPV_force(sv, len);
3563 register U8 *send = s + len;
3565 if (IN_LOCALE_RUNTIME) {
3568 for (; s < send; s++)
3569 *s = toLOWER_LC(*s);
3572 for (; s < send; s++)
3587 register char *s = SvPV(sv,len);
3590 SvUTF8_off(TARG); /* decontaminate */
3592 (void)SvUPGRADE(TARG, SVt_PV);
3593 SvGROW(TARG, (len * 2) + 1);
3597 if (UTF8_IS_CONTINUED(*s)) {
3598 STRLEN ulen = UTF8SKIP(s);
3622 SvCUR_set(TARG, d - SvPVX(TARG));
3623 (void)SvPOK_only_UTF8(TARG);
3626 sv_setpvn(TARG, s, len);
3628 if (SvSMAGICAL(TARG))
3637 dSP; dMARK; dORIGMARK;
3639 register AV* av = (AV*)POPs;
3640 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3641 I32 arybase = PL_curcop->cop_arybase;
3644 if (SvTYPE(av) == SVt_PVAV) {
3645 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3647 for (svp = MARK + 1; svp <= SP; svp++) {
3652 if (max > AvMAX(av))
3655 while (++MARK <= SP) {
3656 elem = SvIVx(*MARK);
3660 svp = av_fetch(av, elem, lval);
3662 if (!svp || *svp == &PL_sv_undef)
3663 DIE(aTHX_ PL_no_aelem, elem);
3664 if (PL_op->op_private & OPpLVAL_INTRO)
3665 save_aelem(av, elem, svp);
3667 *MARK = svp ? *svp : &PL_sv_undef;
3670 if (GIMME != G_ARRAY) {
3678 /* Associative arrays. */
3683 HV *hash = (HV*)POPs;
3685 I32 gimme = GIMME_V;
3688 /* might clobber stack_sp */
3689 entry = hv_iternext(hash);
3694 SV* sv = hv_iterkeysv(entry);
3695 PUSHs(sv); /* won't clobber stack_sp */
3696 if (gimme == G_ARRAY) {
3699 /* might clobber stack_sp */
3700 val = hv_iterval(hash, entry);
3705 else if (gimme == G_SCALAR)
3724 I32 gimme = GIMME_V;
3725 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3729 if (PL_op->op_private & OPpSLICE) {
3733 hvtype = SvTYPE(hv);
3734 if (hvtype == SVt_PVHV) { /* hash element */
3735 while (++MARK <= SP) {
3736 sv = hv_delete_ent(hv, *MARK, discard, 0);
3737 *MARK = sv ? sv : &PL_sv_undef;
3740 else if (hvtype == SVt_PVAV) { /* array element */
3741 if (PL_op->op_flags & OPf_SPECIAL) {
3742 while (++MARK <= SP) {
3743 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3744 *MARK = sv ? sv : &PL_sv_undef;
3749 DIE(aTHX_ "Not a HASH reference");
3752 else if (gimme == G_SCALAR) {
3761 if (SvTYPE(hv) == SVt_PVHV)
3762 sv = hv_delete_ent(hv, keysv, discard, 0);
3763 else if (SvTYPE(hv) == SVt_PVAV) {
3764 if (PL_op->op_flags & OPf_SPECIAL)
3765 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3768 DIE(aTHX_ "Not a HASH reference");
3783 if (PL_op->op_private & OPpEXISTS_SUB) {
3787 cv = sv_2cv(sv, &hv, &gv, FALSE);
3790 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3796 if (SvTYPE(hv) == SVt_PVHV) {
3797 if (hv_exists_ent(hv, tmpsv, 0))
3800 else if (SvTYPE(hv) == SVt_PVAV) {
3801 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3802 if (av_exists((AV*)hv, SvIV(tmpsv)))
3807 DIE(aTHX_ "Not a HASH reference");
3814 dSP; dMARK; dORIGMARK;
3815 register HV *hv = (HV*)POPs;
3816 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3817 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3818 bool other_magic = FALSE;
3824 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3825 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3826 /* Try to preserve the existenceness of a tied hash
3827 * element by using EXISTS and DELETE if possible.
3828 * Fallback to FETCH and STORE otherwise */
3829 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3830 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3831 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3834 while (++MARK <= SP) {
3838 bool preeminent = FALSE;
3841 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3842 hv_exists_ent(hv, keysv, 0);
3845 he = hv_fetch_ent(hv, keysv, lval, 0);
3846 svp = he ? &HeVAL(he) : 0;
3849 if (!svp || *svp == &PL_sv_undef) {
3851 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3855 save_helem(hv, keysv, svp);
3858 char *key = SvPV(keysv, keylen);
3859 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3863 *MARK = svp ? *svp : &PL_sv_undef;
3865 if (GIMME != G_ARRAY) {
3873 /* List operators. */
3878 if (GIMME != G_ARRAY) {
3880 *MARK = *SP; /* unwanted list, return last item */
3882 *MARK = &PL_sv_undef;
3891 SV **lastrelem = PL_stack_sp;
3892 SV **lastlelem = PL_stack_base + POPMARK;
3893 SV **firstlelem = PL_stack_base + POPMARK + 1;
3894 register SV **firstrelem = lastlelem + 1;
3895 I32 arybase = PL_curcop->cop_arybase;
3896 I32 lval = PL_op->op_flags & OPf_MOD;
3897 I32 is_something_there = lval;
3899 register I32 max = lastrelem - lastlelem;
3900 register SV **lelem;
3903 if (GIMME != G_ARRAY) {
3904 ix = SvIVx(*lastlelem);
3909 if (ix < 0 || ix >= max)
3910 *firstlelem = &PL_sv_undef;
3912 *firstlelem = firstrelem[ix];
3918 SP = firstlelem - 1;
3922 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3928 if (ix < 0 || ix >= max)
3929 *lelem = &PL_sv_undef;
3931 is_something_there = TRUE;
3932 if (!(*lelem = firstrelem[ix]))
3933 *lelem = &PL_sv_undef;
3936 if (is_something_there)
3939 SP = firstlelem - 1;
3945 dSP; dMARK; dORIGMARK;
3946 I32 items = SP - MARK;
3947 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3948 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3955 dSP; dMARK; dORIGMARK;
3956 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3960 SV *val = NEWSV(46, 0);
3962 sv_setsv(val, *++MARK);
3963 else if (ckWARN(WARN_MISC))
3964 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3965 (void)hv_store_ent(hv,key,val,0);
3974 dSP; dMARK; dORIGMARK;
3975 register AV *ary = (AV*)*++MARK;
3979 register I32 offset;
3980 register I32 length;
3987 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3988 *MARK-- = SvTIED_obj((SV*)ary, mg);
3992 call_method("SPLICE",GIMME_V);
4001 offset = i = SvIVx(*MARK);
4003 offset += AvFILLp(ary) + 1;
4005 offset -= PL_curcop->cop_arybase;
4007 DIE(aTHX_ PL_no_aelem, i);
4009 length = SvIVx(*MARK++);
4011 length += AvFILLp(ary) - offset + 1;
4017 length = AvMAX(ary) + 1; /* close enough to infinity */
4021 length = AvMAX(ary) + 1;
4023 if (offset > AvFILLp(ary) + 1) {
4024 if (ckWARN(WARN_MISC))
4025 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4026 offset = AvFILLp(ary) + 1;
4028 after = AvFILLp(ary) + 1 - (offset + length);
4029 if (after < 0) { /* not that much array */
4030 length += after; /* offset+length now in array */
4036 /* At this point, MARK .. SP-1 is our new LIST */
4039 diff = newlen - length;
4040 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4043 if (diff < 0) { /* shrinking the area */
4045 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4046 Copy(MARK, tmparyval, newlen, SV*);
4049 MARK = ORIGMARK + 1;
4050 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4051 MEXTEND(MARK, length);
4052 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4054 EXTEND_MORTAL(length);
4055 for (i = length, dst = MARK; i; i--) {
4056 sv_2mortal(*dst); /* free them eventualy */
4063 *MARK = AvARRAY(ary)[offset+length-1];
4066 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4067 SvREFCNT_dec(*dst++); /* free them now */
4070 AvFILLp(ary) += diff;
4072 /* pull up or down? */
4074 if (offset < after) { /* easier to pull up */
4075 if (offset) { /* esp. if nothing to pull */
4076 src = &AvARRAY(ary)[offset-1];
4077 dst = src - diff; /* diff is negative */
4078 for (i = offset; i > 0; i--) /* can't trust Copy */
4082 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4086 if (after) { /* anything to pull down? */
4087 src = AvARRAY(ary) + offset + length;
4088 dst = src + diff; /* diff is negative */
4089 Move(src, dst, after, SV*);
4091 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4092 /* avoid later double free */
4096 dst[--i] = &PL_sv_undef;
4099 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4101 *dst = NEWSV(46, 0);
4102 sv_setsv(*dst++, *src++);
4104 Safefree(tmparyval);
4107 else { /* no, expanding (or same) */
4109 New(452, tmparyval, length, SV*); /* so remember deletion */
4110 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4113 if (diff > 0) { /* expanding */
4115 /* push up or down? */
4117 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4121 Move(src, dst, offset, SV*);
4123 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4125 AvFILLp(ary) += diff;
4128 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4129 av_extend(ary, AvFILLp(ary) + diff);
4130 AvFILLp(ary) += diff;
4133 dst = AvARRAY(ary) + AvFILLp(ary);
4135 for (i = after; i; i--) {
4142 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4143 *dst = NEWSV(46, 0);
4144 sv_setsv(*dst++, *src++);
4146 MARK = ORIGMARK + 1;
4147 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4149 Copy(tmparyval, MARK, length, SV*);
4151 EXTEND_MORTAL(length);
4152 for (i = length, dst = MARK; i; i--) {
4153 sv_2mortal(*dst); /* free them eventualy */
4157 Safefree(tmparyval);
4161 else if (length--) {
4162 *MARK = tmparyval[length];
4165 while (length-- > 0)
4166 SvREFCNT_dec(tmparyval[length]);
4168 Safefree(tmparyval);
4171 *MARK = &PL_sv_undef;
4179 dSP; dMARK; dORIGMARK; dTARGET;
4180 register AV *ary = (AV*)*++MARK;
4181 register SV *sv = &PL_sv_undef;
4184 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4185 *MARK-- = SvTIED_obj((SV*)ary, mg);
4189 call_method("PUSH",G_SCALAR|G_DISCARD);
4194 /* Why no pre-extend of ary here ? */
4195 for (++MARK; MARK <= SP; MARK++) {
4198 sv_setsv(sv, *MARK);
4203 PUSHi( AvFILL(ary) + 1 );
4211 SV *sv = av_pop(av);
4213 (void)sv_2mortal(sv);
4222 SV *sv = av_shift(av);
4227 (void)sv_2mortal(sv);
4234 dSP; dMARK; dORIGMARK; dTARGET;
4235 register AV *ary = (AV*)*++MARK;
4240 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4241 *MARK-- = SvTIED_obj((SV*)ary, mg);
4245 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4250 av_unshift(ary, SP - MARK);
4253 sv_setsv(sv, *++MARK);
4254 (void)av_store(ary, i++, sv);
4258 PUSHi( AvFILL(ary) + 1 );
4268 if (GIMME == G_ARRAY) {
4275 /* safe as long as stack cannot get extended in the above */
4280 register char *down;
4285 SvUTF8_off(TARG); /* decontaminate */
4287 do_join(TARG, &PL_sv_no, MARK, SP);
4289 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4290 up = SvPV_force(TARG, len);
4292 if (DO_UTF8(TARG)) { /* first reverse each character */
4293 U8* s = (U8*)SvPVX(TARG);
4294 U8* send = (U8*)(s + len);
4296 if (UTF8_IS_INVARIANT(*s)) {
4301 if (!utf8_to_uvchr(s, 0))
4305 down = (char*)(s - 1);
4306 /* reverse this character */
4310 *down-- = (char)tmp;
4316 down = SvPVX(TARG) + len - 1;
4320 *down-- = (char)tmp;
4322 (void)SvPOK_only_UTF8(TARG);
4334 register IV limit = POPi; /* note, negative is forever */
4337 register char *s = SvPV(sv, len);
4338 bool do_utf8 = DO_UTF8(sv);
4339 char *strend = s + len;
4341 register REGEXP *rx;
4345 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4346 I32 maxiters = slen + 10;
4349 I32 origlimit = limit;
4352 AV *oldstack = PL_curstack;
4353 I32 gimme = GIMME_V;
4354 I32 oldsave = PL_savestack_ix;
4355 I32 make_mortal = 1;
4356 MAGIC *mg = (MAGIC *) NULL;
4359 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4364 DIE(aTHX_ "panic: pp_split");
4367 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4368 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4370 PL_reg_match_utf8 = do_utf8;
4372 if (pm->op_pmreplroot) {
4374 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4376 ary = GvAVn((GV*)pm->op_pmreplroot);
4379 else if (gimme != G_ARRAY)
4380 #ifdef USE_5005THREADS
4381 ary = (AV*)PL_curpad[0];
4383 ary = GvAVn(PL_defgv);
4384 #endif /* USE_5005THREADS */
4387 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4393 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4395 XPUSHs(SvTIED_obj((SV*)ary, mg));
4401 for (i = AvFILLp(ary); i >= 0; i--)
4402 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4404 /* temporarily switch stacks */
4405 SWITCHSTACK(PL_curstack, ary);
4409 base = SP - PL_stack_base;
4411 if (pm->op_pmflags & PMf_SKIPWHITE) {
4412 if (pm->op_pmflags & PMf_LOCALE) {
4413 while (isSPACE_LC(*s))
4421 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4422 SAVEINT(PL_multiline);
4423 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4427 limit = maxiters + 2;
4428 if (pm->op_pmflags & PMf_WHITE) {
4431 while (m < strend &&
4432 !((pm->op_pmflags & PMf_LOCALE)
4433 ? isSPACE_LC(*m) : isSPACE(*m)))
4438 dstr = NEWSV(30, m-s);
4439 sv_setpvn(dstr, s, m-s);
4443 (void)SvUTF8_on(dstr);
4447 while (s < strend &&
4448 ((pm->op_pmflags & PMf_LOCALE)
4449 ? isSPACE_LC(*s) : isSPACE(*s)))
4453 else if (strEQ("^", rx->precomp)) {
4456 for (m = s; m < strend && *m != '\n'; m++) ;
4460 dstr = NEWSV(30, m-s);
4461 sv_setpvn(dstr, s, m-s);
4465 (void)SvUTF8_on(dstr);
4470 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4471 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4472 && (rx->reganch & ROPT_CHECK_ALL)
4473 && !(rx->reganch & ROPT_ANCH)) {
4474 int tail = (rx->reganch & RE_INTUIT_TAIL);
4475 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4478 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4480 char c = *SvPV(csv, n_a);
4483 for (m = s; m < strend && *m != c; m++) ;
4486 dstr = NEWSV(30, m-s);
4487 sv_setpvn(dstr, s, m-s);
4491 (void)SvUTF8_on(dstr);
4493 /* The rx->minlen is in characters but we want to step
4494 * s ahead by bytes. */
4496 s = (char*)utf8_hop((U8*)m, len);
4498 s = m + len; /* Fake \n at the end */
4503 while (s < strend && --limit &&
4504 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4505 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4508 dstr = NEWSV(31, m-s);
4509 sv_setpvn(dstr, s, m-s);
4513 (void)SvUTF8_on(dstr);
4515 /* The rx->minlen is in characters but we want to step
4516 * s ahead by bytes. */
4518 s = (char*)utf8_hop((U8*)m, len);
4520 s = m + len; /* Fake \n at the end */
4525 maxiters += slen * rx->nparens;
4526 while (s < strend && --limit
4527 /* && (!rx->check_substr
4528 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4530 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4531 1 /* minend */, sv, NULL, 0))
4533 TAINT_IF(RX_MATCH_TAINTED(rx));
4534 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4539 strend = s + (strend - m);
4541 m = rx->startp[0] + orig;
4542 dstr = NEWSV(32, m-s);
4543 sv_setpvn(dstr, s, m-s);
4547 (void)SvUTF8_on(dstr);
4550 for (i = 1; i <= (I32)rx->nparens; i++) {
4551 s = rx->startp[i] + orig;
4552 m = rx->endp[i] + orig;
4554 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4555 parens that didn't match -- they should be set to
4556 undef, not the empty string */
4557 if (m >= orig && s >= orig) {
4558 dstr = NEWSV(33, m-s);
4559 sv_setpvn(dstr, s, m-s);
4562 dstr = &PL_sv_undef; /* undef, not "" */
4566 (void)SvUTF8_on(dstr);
4570 s = rx->endp[0] + orig;
4574 LEAVE_SCOPE(oldsave);
4575 iters = (SP - PL_stack_base) - base;
4576 if (iters > maxiters)
4577 DIE(aTHX_ "Split loop");
4579 /* keep field after final delim? */
4580 if (s < strend || (iters && origlimit)) {
4581 STRLEN l = strend - s;
4582 dstr = NEWSV(34, l);
4583 sv_setpvn(dstr, s, l);
4587 (void)SvUTF8_on(dstr);
4591 else if (!origlimit) {
4592 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4593 if (TOPs && !make_mortal)
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 */