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);
3767 DIE(aTHX_ "panic: avhv_delete no longer supported");
3770 DIE(aTHX_ "Not a HASH reference");
3785 if (PL_op->op_private & OPpEXISTS_SUB) {
3789 cv = sv_2cv(sv, &hv, &gv, FALSE);
3792 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3798 if (SvTYPE(hv) == SVt_PVHV) {
3799 if (hv_exists_ent(hv, tmpsv, 0))
3802 else if (SvTYPE(hv) == SVt_PVAV) {
3803 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3804 if (av_exists((AV*)hv, SvIV(tmpsv)))
3809 DIE(aTHX_ "Not a HASH reference");
3816 dSP; dMARK; dORIGMARK;
3817 register HV *hv = (HV*)POPs;
3818 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3819 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3820 bool other_magic = FALSE;
3826 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3827 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3828 /* Try to preserve the existenceness of a tied hash
3829 * element by using EXISTS and DELETE if possible.
3830 * Fallback to FETCH and STORE otherwise */
3831 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3832 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3833 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3836 while (++MARK <= SP) {
3840 bool preeminent = FALSE;
3843 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3844 hv_exists_ent(hv, keysv, 0);
3847 he = hv_fetch_ent(hv, keysv, lval, 0);
3848 svp = he ? &HeVAL(he) : 0;
3851 if (!svp || *svp == &PL_sv_undef) {
3853 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3857 save_helem(hv, keysv, svp);
3860 char *key = SvPV(keysv, keylen);
3861 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3865 *MARK = svp ? *svp : &PL_sv_undef;
3867 if (GIMME != G_ARRAY) {
3875 /* List operators. */
3880 if (GIMME != G_ARRAY) {
3882 *MARK = *SP; /* unwanted list, return last item */
3884 *MARK = &PL_sv_undef;
3893 SV **lastrelem = PL_stack_sp;
3894 SV **lastlelem = PL_stack_base + POPMARK;
3895 SV **firstlelem = PL_stack_base + POPMARK + 1;
3896 register SV **firstrelem = lastlelem + 1;
3897 I32 arybase = PL_curcop->cop_arybase;
3898 I32 lval = PL_op->op_flags & OPf_MOD;
3899 I32 is_something_there = lval;
3901 register I32 max = lastrelem - lastlelem;
3902 register SV **lelem;
3905 if (GIMME != G_ARRAY) {
3906 ix = SvIVx(*lastlelem);
3911 if (ix < 0 || ix >= max)
3912 *firstlelem = &PL_sv_undef;
3914 *firstlelem = firstrelem[ix];
3920 SP = firstlelem - 1;
3924 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3930 if (ix < 0 || ix >= max)
3931 *lelem = &PL_sv_undef;
3933 is_something_there = TRUE;
3934 if (!(*lelem = firstrelem[ix]))
3935 *lelem = &PL_sv_undef;
3938 if (is_something_there)
3941 SP = firstlelem - 1;
3947 dSP; dMARK; dORIGMARK;
3948 I32 items = SP - MARK;
3949 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3950 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3957 dSP; dMARK; dORIGMARK;
3958 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3962 SV *val = NEWSV(46, 0);
3964 sv_setsv(val, *++MARK);
3965 else if (ckWARN(WARN_MISC))
3966 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3967 (void)hv_store_ent(hv,key,val,0);
3976 dSP; dMARK; dORIGMARK;
3977 register AV *ary = (AV*)*++MARK;
3981 register I32 offset;
3982 register I32 length;
3989 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3990 *MARK-- = SvTIED_obj((SV*)ary, mg);
3994 call_method("SPLICE",GIMME_V);
4003 offset = i = SvIVx(*MARK);
4005 offset += AvFILLp(ary) + 1;
4007 offset -= PL_curcop->cop_arybase;
4009 DIE(aTHX_ PL_no_aelem, i);
4011 length = SvIVx(*MARK++);
4013 length += AvFILLp(ary) - offset + 1;
4019 length = AvMAX(ary) + 1; /* close enough to infinity */
4023 length = AvMAX(ary) + 1;
4025 if (offset > AvFILLp(ary) + 1) {
4026 if (ckWARN(WARN_MISC))
4027 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4028 offset = AvFILLp(ary) + 1;
4030 after = AvFILLp(ary) + 1 - (offset + length);
4031 if (after < 0) { /* not that much array */
4032 length += after; /* offset+length now in array */
4038 /* At this point, MARK .. SP-1 is our new LIST */
4041 diff = newlen - length;
4042 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4045 if (diff < 0) { /* shrinking the area */
4047 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4048 Copy(MARK, tmparyval, newlen, SV*);
4051 MARK = ORIGMARK + 1;
4052 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4053 MEXTEND(MARK, length);
4054 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4056 EXTEND_MORTAL(length);
4057 for (i = length, dst = MARK; i; i--) {
4058 sv_2mortal(*dst); /* free them eventualy */
4065 *MARK = AvARRAY(ary)[offset+length-1];
4068 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4069 SvREFCNT_dec(*dst++); /* free them now */
4072 AvFILLp(ary) += diff;
4074 /* pull up or down? */
4076 if (offset < after) { /* easier to pull up */
4077 if (offset) { /* esp. if nothing to pull */
4078 src = &AvARRAY(ary)[offset-1];
4079 dst = src - diff; /* diff is negative */
4080 for (i = offset; i > 0; i--) /* can't trust Copy */
4084 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4088 if (after) { /* anything to pull down? */
4089 src = AvARRAY(ary) + offset + length;
4090 dst = src + diff; /* diff is negative */
4091 Move(src, dst, after, SV*);
4093 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4094 /* avoid later double free */
4098 dst[--i] = &PL_sv_undef;
4101 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4103 *dst = NEWSV(46, 0);
4104 sv_setsv(*dst++, *src++);
4106 Safefree(tmparyval);
4109 else { /* no, expanding (or same) */
4111 New(452, tmparyval, length, SV*); /* so remember deletion */
4112 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4115 if (diff > 0) { /* expanding */
4117 /* push up or down? */
4119 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4123 Move(src, dst, offset, SV*);
4125 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4127 AvFILLp(ary) += diff;
4130 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4131 av_extend(ary, AvFILLp(ary) + diff);
4132 AvFILLp(ary) += diff;
4135 dst = AvARRAY(ary) + AvFILLp(ary);
4137 for (i = after; i; i--) {
4144 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4145 *dst = NEWSV(46, 0);
4146 sv_setsv(*dst++, *src++);
4148 MARK = ORIGMARK + 1;
4149 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4151 Copy(tmparyval, MARK, length, SV*);
4153 EXTEND_MORTAL(length);
4154 for (i = length, dst = MARK; i; i--) {
4155 sv_2mortal(*dst); /* free them eventualy */
4159 Safefree(tmparyval);
4163 else if (length--) {
4164 *MARK = tmparyval[length];
4167 while (length-- > 0)
4168 SvREFCNT_dec(tmparyval[length]);
4170 Safefree(tmparyval);
4173 *MARK = &PL_sv_undef;
4181 dSP; dMARK; dORIGMARK; dTARGET;
4182 register AV *ary = (AV*)*++MARK;
4183 register SV *sv = &PL_sv_undef;
4186 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4187 *MARK-- = SvTIED_obj((SV*)ary, mg);
4191 call_method("PUSH",G_SCALAR|G_DISCARD);
4196 /* Why no pre-extend of ary here ? */
4197 for (++MARK; MARK <= SP; MARK++) {
4200 sv_setsv(sv, *MARK);
4205 PUSHi( AvFILL(ary) + 1 );
4213 SV *sv = av_pop(av);
4215 (void)sv_2mortal(sv);
4224 SV *sv = av_shift(av);
4229 (void)sv_2mortal(sv);
4236 dSP; dMARK; dORIGMARK; dTARGET;
4237 register AV *ary = (AV*)*++MARK;
4242 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4243 *MARK-- = SvTIED_obj((SV*)ary, mg);
4247 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4252 av_unshift(ary, SP - MARK);
4255 sv_setsv(sv, *++MARK);
4256 (void)av_store(ary, i++, sv);
4260 PUSHi( AvFILL(ary) + 1 );
4270 if (GIMME == G_ARRAY) {
4277 /* safe as long as stack cannot get extended in the above */
4282 register char *down;
4287 SvUTF8_off(TARG); /* decontaminate */
4289 do_join(TARG, &PL_sv_no, MARK, SP);
4291 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4292 up = SvPV_force(TARG, len);
4294 if (DO_UTF8(TARG)) { /* first reverse each character */
4295 U8* s = (U8*)SvPVX(TARG);
4296 U8* send = (U8*)(s + len);
4298 if (UTF8_IS_INVARIANT(*s)) {
4303 if (!utf8_to_uvchr(s, 0))
4307 down = (char*)(s - 1);
4308 /* reverse this character */
4312 *down-- = (char)tmp;
4318 down = SvPVX(TARG) + len - 1;
4322 *down-- = (char)tmp;
4324 (void)SvPOK_only_UTF8(TARG);
4336 register IV limit = POPi; /* note, negative is forever */
4339 register char *s = SvPV(sv, len);
4340 bool do_utf8 = DO_UTF8(sv);
4341 char *strend = s + len;
4343 register REGEXP *rx;
4347 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4348 I32 maxiters = slen + 10;
4351 I32 origlimit = limit;
4354 AV *oldstack = PL_curstack;
4355 I32 gimme = GIMME_V;
4356 I32 oldsave = PL_savestack_ix;
4357 I32 make_mortal = 1;
4358 MAGIC *mg = (MAGIC *) NULL;
4361 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4366 DIE(aTHX_ "panic: pp_split");
4369 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4370 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4372 PL_reg_match_utf8 = do_utf8;
4374 if (pm->op_pmreplroot) {
4376 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
4378 ary = GvAVn((GV*)pm->op_pmreplroot);
4381 else if (gimme != G_ARRAY)
4382 #ifdef USE_5005THREADS
4383 ary = (AV*)PL_curpad[0];
4385 ary = GvAVn(PL_defgv);
4386 #endif /* USE_5005THREADS */
4389 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4395 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4397 XPUSHs(SvTIED_obj((SV*)ary, mg));
4403 for (i = AvFILLp(ary); i >= 0; i--)
4404 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4406 /* temporarily switch stacks */
4407 SWITCHSTACK(PL_curstack, ary);
4411 base = SP - PL_stack_base;
4413 if (pm->op_pmflags & PMf_SKIPWHITE) {
4414 if (pm->op_pmflags & PMf_LOCALE) {
4415 while (isSPACE_LC(*s))
4423 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4424 SAVEINT(PL_multiline);
4425 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4429 limit = maxiters + 2;
4430 if (pm->op_pmflags & PMf_WHITE) {
4433 while (m < strend &&
4434 !((pm->op_pmflags & PMf_LOCALE)
4435 ? isSPACE_LC(*m) : isSPACE(*m)))
4440 dstr = NEWSV(30, m-s);
4441 sv_setpvn(dstr, s, m-s);
4445 (void)SvUTF8_on(dstr);
4449 while (s < strend &&
4450 ((pm->op_pmflags & PMf_LOCALE)
4451 ? isSPACE_LC(*s) : isSPACE(*s)))
4455 else if (strEQ("^", rx->precomp)) {
4458 for (m = s; m < strend && *m != '\n'; m++) ;
4462 dstr = NEWSV(30, m-s);
4463 sv_setpvn(dstr, s, m-s);
4467 (void)SvUTF8_on(dstr);
4472 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4473 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4474 && (rx->reganch & ROPT_CHECK_ALL)
4475 && !(rx->reganch & ROPT_ANCH)) {
4476 int tail = (rx->reganch & RE_INTUIT_TAIL);
4477 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4480 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4482 char c = *SvPV(csv, n_a);
4485 for (m = s; m < strend && *m != c; m++) ;
4488 dstr = NEWSV(30, m-s);
4489 sv_setpvn(dstr, s, m-s);
4493 (void)SvUTF8_on(dstr);
4495 /* The rx->minlen is in characters but we want to step
4496 * s ahead by bytes. */
4498 s = (char*)utf8_hop((U8*)m, len);
4500 s = m + len; /* Fake \n at the end */
4505 while (s < strend && --limit &&
4506 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4507 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4510 dstr = NEWSV(31, m-s);
4511 sv_setpvn(dstr, s, m-s);
4515 (void)SvUTF8_on(dstr);
4517 /* The rx->minlen is in characters but we want to step
4518 * s ahead by bytes. */
4520 s = (char*)utf8_hop((U8*)m, len);
4522 s = m + len; /* Fake \n at the end */
4527 maxiters += slen * rx->nparens;
4528 while (s < strend && --limit
4529 /* && (!rx->check_substr
4530 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4532 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4533 1 /* minend */, sv, NULL, 0))
4535 TAINT_IF(RX_MATCH_TAINTED(rx));
4536 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4541 strend = s + (strend - m);
4543 m = rx->startp[0] + orig;
4544 dstr = NEWSV(32, m-s);
4545 sv_setpvn(dstr, s, m-s);
4549 (void)SvUTF8_on(dstr);
4552 for (i = 1; i <= (I32)rx->nparens; i++) {
4553 s = rx->startp[i] + orig;
4554 m = rx->endp[i] + orig;
4556 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4557 parens that didn't match -- they should be set to
4558 undef, not the empty string */
4559 if (m >= orig && s >= orig) {
4560 dstr = NEWSV(33, m-s);
4561 sv_setpvn(dstr, s, m-s);
4564 dstr = &PL_sv_undef; /* undef, not "" */
4568 (void)SvUTF8_on(dstr);
4572 s = rx->endp[0] + orig;
4576 LEAVE_SCOPE(oldsave);
4577 iters = (SP - PL_stack_base) - base;
4578 if (iters > maxiters)
4579 DIE(aTHX_ "Split loop");
4581 /* keep field after final delim? */
4582 if (s < strend || (iters && origlimit)) {
4583 STRLEN l = strend - s;
4584 dstr = NEWSV(34, l);
4585 sv_setpvn(dstr, s, l);
4589 (void)SvUTF8_on(dstr);
4593 else if (!origlimit) {
4594 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4595 if (TOPs && !make_mortal)
4604 SWITCHSTACK(ary, oldstack);
4605 if (SvSMAGICAL(ary)) {
4610 if (gimme == G_ARRAY) {
4612 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4620 call_method("PUSH",G_SCALAR|G_DISCARD);
4623 if (gimme == G_ARRAY) {
4624 /* EXTEND should not be needed - we just popped them */
4626 for (i=0; i < iters; i++) {
4627 SV **svp = av_fetch(ary, i, FALSE);
4628 PUSHs((svp) ? *svp : &PL_sv_undef);
4635 if (gimme == G_ARRAY)
4638 if (iters || !pm->op_pmreplroot) {
4646 #ifdef USE_5005THREADS
4648 Perl_unlock_condpair(pTHX_ void *svv)
4650 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4653 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4654 MUTEX_LOCK(MgMUTEXP(mg));
4655 if (MgOWNER(mg) != thr)
4656 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4658 COND_SIGNAL(MgOWNERCONDP(mg));
4659 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4660 PTR2UV(thr), PTR2UV(svv)));
4661 MUTEX_UNLOCK(MgMUTEXP(mg));
4663 #endif /* USE_5005THREADS */
4671 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4672 || SvTYPE(retsv) == SVt_PVCV) {
4673 retsv = refto(retsv);
4681 #ifdef USE_5005THREADS
4684 if (PL_op->op_private & OPpLVAL_INTRO)
4685 PUSHs(*save_threadsv(PL_op->op_targ));
4687 PUSHs(THREADSV(PL_op->op_targ));
4690 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4691 #endif /* USE_5005THREADS */