3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
52 if (GIMME_V == G_SCALAR)
63 if (PL_op->op_private & OPpLVAL_INTRO)
64 if (!(PL_op->op_private & OPpPAD_STATE))
65 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
67 if (PL_op->op_flags & OPf_REF) {
71 if (GIMME == G_SCALAR)
72 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
77 if (gimme == G_ARRAY) {
78 const I32 maxarg = AvFILL((AV*)TARG) + 1;
80 if (SvMAGICAL(TARG)) {
82 for (i=0; i < (U32)maxarg; i++) {
83 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
84 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
88 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
92 else if (gimme == G_SCALAR) {
93 SV* const sv = sv_newmortal();
94 const I32 maxarg = AvFILL((AV*)TARG) + 1;
107 if (PL_op->op_private & OPpLVAL_INTRO)
108 if (!(PL_op->op_private & OPpPAD_STATE))
109 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
110 if (PL_op->op_flags & OPf_REF)
113 if (GIMME == G_SCALAR)
114 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
118 if (gimme == G_ARRAY) {
121 else if (gimme == G_SCALAR) {
122 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
136 tryAMAGICunDEREF(to_gv);
139 if (SvTYPE(sv) == SVt_PVIO) {
140 GV * const gv = (GV*) sv_newmortal();
141 gv_init(gv, 0, "", 0, 0);
142 GvIOp(gv) = (IO *)sv;
143 SvREFCNT_inc_void_NN(sv);
146 else if (SvTYPE(sv) != SVt_PVGV)
147 DIE(aTHX_ "Not a GLOB reference");
150 if (SvTYPE(sv) != SVt_PVGV) {
151 if (SvGMAGICAL(sv)) {
156 if (!SvOK(sv) && sv != &PL_sv_undef) {
157 /* If this is a 'my' scalar and flag is set then vivify
161 Perl_croak(aTHX_ PL_no_modify);
162 if (PL_op->op_private & OPpDEREF) {
164 if (cUNOP->op_targ) {
166 SV * const namesv = PAD_SV(cUNOP->op_targ);
167 const char * const name = SvPV(namesv, len);
169 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
172 const char * const name = CopSTASHPV(PL_curcop);
175 if (SvTYPE(sv) < SVt_RV)
176 sv_upgrade(sv, SVt_RV);
177 else if (SvPVX_const(sv)) {
182 SvRV_set(sv, (SV*)gv);
187 if (PL_op->op_flags & OPf_REF ||
188 PL_op->op_private & HINT_STRICT_REFS)
189 DIE(aTHX_ PL_no_usym, "a symbol");
190 if (ckWARN(WARN_UNINITIALIZED))
194 if ((PL_op->op_flags & OPf_SPECIAL) &&
195 !(PL_op->op_flags & OPf_MOD))
197 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
199 && (!is_gv_magical_sv(sv,0)
200 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
206 if (PL_op->op_private & HINT_STRICT_REFS)
207 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
208 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
209 == OPpDONT_INIT_GV) {
210 /* We are the target of a coderef assignment. Return
211 the scalar unchanged, and let pp_sasssign deal with
215 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
219 if (PL_op->op_private & OPpLVAL_INTRO)
220 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
232 tryAMAGICunDEREF(to_sv);
235 switch (SvTYPE(sv)) {
241 DIE(aTHX_ "Not a SCALAR reference");
247 if (SvTYPE(gv) != SVt_PVGV) {
248 if (SvGMAGICAL(sv)) {
253 if (PL_op->op_private & HINT_STRICT_REFS) {
255 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
257 DIE(aTHX_ PL_no_usym, "a SCALAR");
260 if (PL_op->op_flags & OPf_REF)
261 DIE(aTHX_ PL_no_usym, "a SCALAR");
262 if (ckWARN(WARN_UNINITIALIZED))
266 if ((PL_op->op_flags & OPf_SPECIAL) &&
267 !(PL_op->op_flags & OPf_MOD))
269 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
271 && (!is_gv_magical_sv(sv, 0)
272 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
278 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
283 if (PL_op->op_flags & OPf_MOD) {
284 if (PL_op->op_private & OPpLVAL_INTRO) {
285 if (cUNOP->op_first->op_type == OP_NULL)
286 sv = save_scalar((GV*)TOPs);
288 sv = save_scalar(gv);
290 Perl_croak(aTHX_ PL_no_localize_ref);
292 else if (PL_op->op_private & OPpDEREF)
293 vivify_ref(sv, PL_op->op_private & OPpDEREF);
302 AV * const av = (AV*)TOPs;
303 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
306 sv_upgrade(*sv, SVt_PVMG);
307 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
315 dVAR; dSP; dTARGET; dPOPss;
317 if (PL_op->op_flags & OPf_MOD || LVRET) {
318 if (SvTYPE(TARG) < SVt_PVLV) {
319 sv_upgrade(TARG, SVt_PVLV);
320 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
324 if (LvTARG(TARG) != sv) {
326 SvREFCNT_dec(LvTARG(TARG));
327 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
329 PUSHs(TARG); /* no SvSETMAGIC */
333 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
334 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
335 if (mg && mg->mg_len >= 0) {
339 PUSHi(i + CopARYBASE_get(PL_curcop));
352 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
354 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
357 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
358 /* (But not in defined().) */
360 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
363 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
364 if ((PL_op->op_private & OPpLVAL_INTRO)) {
365 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
368 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
371 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
375 cv = (CV*)&PL_sv_undef;
386 SV *ret = &PL_sv_undef;
388 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
389 const char * const s = SvPVX_const(TOPs);
390 if (strnEQ(s, "CORE::", 6)) {
391 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
392 if (code < 0) { /* Overridable. */
393 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
394 int i = 0, n = 0, seen_question = 0;
396 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
398 if (code == -KEY_chop || code == -KEY_chomp
399 || code == -KEY_exec || code == -KEY_system)
401 while (i < MAXO) { /* The slow way. */
402 if (strEQ(s + 6, PL_op_name[i])
403 || strEQ(s + 6, PL_op_desc[i]))
409 goto nonesuch; /* Should not happen... */
411 oa = PL_opargs[i] >> OASHIFT;
413 if (oa & OA_OPTIONAL && !seen_question) {
417 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
418 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
419 /* But globs are already references (kinda) */
420 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
424 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
428 ret = sv_2mortal(newSVpvn(str, n - 1));
430 else if (code) /* Non-Overridable */
432 else { /* None such */
434 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
438 cv = sv_2cv(TOPs, &stash, &gv, 0);
440 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
449 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
451 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
467 if (GIMME != G_ARRAY) {
471 *MARK = &PL_sv_undef;
472 *MARK = refto(*MARK);
476 EXTEND_MORTAL(SP - MARK);
478 *MARK = refto(*MARK);
483 S_refto(pTHX_ SV *sv)
488 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
491 if (!(sv = LvTARG(sv)))
494 SvREFCNT_inc_void_NN(sv);
496 else if (SvTYPE(sv) == SVt_PVAV) {
497 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
500 SvREFCNT_inc_void_NN(sv);
502 else if (SvPADTMP(sv) && !IS_PADGV(sv))
506 SvREFCNT_inc_void_NN(sv);
509 sv_upgrade(rv, SVt_RV);
519 SV * const sv = POPs;
524 if (!sv || !SvROK(sv))
527 pv = sv_reftype(SvRV(sv),TRUE);
528 PUSHp(pv, strlen(pv));
538 stash = CopSTASH(PL_curcop);
540 SV * const ssv = POPs;
544 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
545 Perl_croak(aTHX_ "Attempt to bless into a reference");
546 ptr = SvPV_const(ssv,len);
547 if (len == 0 && ckWARN(WARN_MISC))
548 Perl_warner(aTHX_ packWARN(WARN_MISC),
549 "Explicit blessing to '' (assuming package main)");
550 stash = gv_stashpvn(ptr, len, TRUE);
553 (void)sv_bless(TOPs, stash);
562 const char * const elem = SvPV_nolen_const(sv);
563 GV * const gv = (GV*)POPs;
568 /* elem will always be NUL terminated. */
569 const char * const second_letter = elem + 1;
572 if (strEQ(second_letter, "RRAY"))
573 tmpRef = (SV*)GvAV(gv);
576 if (strEQ(second_letter, "ODE"))
577 tmpRef = (SV*)GvCVu(gv);
580 if (strEQ(second_letter, "ILEHANDLE")) {
581 /* finally deprecated in 5.8.0 */
582 deprecate("*glob{FILEHANDLE}");
583 tmpRef = (SV*)GvIOp(gv);
586 if (strEQ(second_letter, "ORMAT"))
587 tmpRef = (SV*)GvFORM(gv);
590 if (strEQ(second_letter, "LOB"))
594 if (strEQ(second_letter, "ASH"))
595 tmpRef = (SV*)GvHV(gv);
598 if (*second_letter == 'O' && !elem[2])
599 tmpRef = (SV*)GvIOp(gv);
602 if (strEQ(second_letter, "AME"))
603 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
606 if (strEQ(second_letter, "ACKAGE")) {
607 const HV * const stash = GvSTASH(gv);
608 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
609 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
613 if (strEQ(second_letter, "CALAR"))
628 /* Pattern matching */
633 register unsigned char *s;
636 register I32 *sfirst;
640 if (sv == PL_lastscream) {
644 s = (unsigned char*)(SvPV(sv, len));
646 if (pos <= 0 || !SvPOK(sv)) {
647 /* No point in studying a zero length string, and not safe to study
648 anything that doesn't appear to be a simple scalar (and hence might
649 change between now and when the regexp engine runs without our set
650 magic ever running) such as a reference to an object with overloaded
656 SvSCREAM_off(PL_lastscream);
657 SvREFCNT_dec(PL_lastscream);
659 PL_lastscream = SvREFCNT_inc_simple(sv);
661 s = (unsigned char*)(SvPV(sv, len));
665 if (pos > PL_maxscream) {
666 if (PL_maxscream < 0) {
667 PL_maxscream = pos + 80;
668 Newx(PL_screamfirst, 256, I32);
669 Newx(PL_screamnext, PL_maxscream, I32);
672 PL_maxscream = pos + pos / 4;
673 Renew(PL_screamnext, PL_maxscream, I32);
677 sfirst = PL_screamfirst;
678 snext = PL_screamnext;
680 if (!sfirst || !snext)
681 DIE(aTHX_ "do_study: out of memory");
683 for (ch = 256; ch; --ch)
688 register const I32 ch = s[pos];
690 snext[pos] = sfirst[ch] - pos;
697 /* piggyback on m//g magic */
698 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
707 if (PL_op->op_flags & OPf_STACKED)
709 else if (PL_op->op_private & OPpTARGET_MY)
715 TARG = sv_newmortal();
720 /* Lvalue operators. */
732 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
734 do_chop(TARG, *++MARK);
743 SETi(do_chomp(TOPs));
749 dVAR; dSP; dMARK; dTARGET;
750 register I32 count = 0;
753 count += do_chomp(POPs);
763 if (!PL_op->op_private) {
772 SV_CHECK_THINKFIRST_COW_DROP(sv);
774 switch (SvTYPE(sv)) {
784 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
785 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
786 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
790 /* let user-undef'd sub keep its identity */
791 GV* const gv = CvGV((CV*)sv);
798 SvSetMagicSV(sv, &PL_sv_undef);
803 GvGP(sv) = gp_ref(gp);
805 GvLINE(sv) = CopLINE(PL_curcop);
811 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
826 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
827 DIE(aTHX_ PL_no_modify);
828 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
829 && SvIVX(TOPs) != IV_MIN)
831 SvIV_set(TOPs, SvIVX(TOPs) - 1);
832 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
843 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
844 DIE(aTHX_ PL_no_modify);
845 sv_setsv(TARG, TOPs);
846 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
847 && SvIVX(TOPs) != IV_MAX)
849 SvIV_set(TOPs, SvIVX(TOPs) + 1);
850 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
855 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
865 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
866 DIE(aTHX_ PL_no_modify);
867 sv_setsv(TARG, TOPs);
868 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
869 && SvIVX(TOPs) != IV_MIN)
871 SvIV_set(TOPs, SvIVX(TOPs) - 1);
872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
881 /* Ordinary operators. */
886 #ifdef PERL_PRESERVE_IVUV
889 tryAMAGICbin(pow,opASSIGN);
890 #ifdef PERL_PRESERVE_IVUV
891 /* For integer to integer power, we do the calculation by hand wherever
892 we're sure it is safe; otherwise we call pow() and try to convert to
893 integer afterwards. */
906 const IV iv = SvIVX(TOPs);
910 goto float_it; /* Can't do negative powers this way. */
914 baseuok = SvUOK(TOPm1s);
916 baseuv = SvUVX(TOPm1s);
918 const IV iv = SvIVX(TOPm1s);
921 baseuok = TRUE; /* effectively it's a UV now */
923 baseuv = -iv; /* abs, baseuok == false records sign */
926 /* now we have integer ** positive integer. */
929 /* foo & (foo - 1) is zero only for a power of 2. */
930 if (!(baseuv & (baseuv - 1))) {
931 /* We are raising power-of-2 to a positive integer.
932 The logic here will work for any base (even non-integer
933 bases) but it can be less accurate than
934 pow (base,power) or exp (power * log (base)) when the
935 intermediate values start to spill out of the mantissa.
936 With powers of 2 we know this can't happen.
937 And powers of 2 are the favourite thing for perl
938 programmers to notice ** not doing what they mean. */
940 NV base = baseuok ? baseuv : -(NV)baseuv;
945 while (power >>= 1) {
956 register unsigned int highbit = 8 * sizeof(UV);
957 register unsigned int diff = 8 * sizeof(UV);
960 if (baseuv >> highbit) {
964 /* we now have baseuv < 2 ** highbit */
965 if (power * highbit <= 8 * sizeof(UV)) {
966 /* result will definitely fit in UV, so use UV math
967 on same algorithm as above */
968 register UV result = 1;
969 register UV base = baseuv;
970 const bool odd_power = (bool)(power & 1);
974 while (power >>= 1) {
981 if (baseuok || !odd_power)
982 /* answer is positive */
984 else if (result <= (UV)IV_MAX)
985 /* answer negative, fits in IV */
987 else if (result == (UV)IV_MIN)
988 /* 2's complement assumption: special case IV_MIN */
991 /* answer negative, doesn't fit */
1004 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1006 We are building perl with long double support and are on an AIX OS
1007 afflicted with a powl() function that wrongly returns NaNQ for any
1008 negative base. This was reported to IBM as PMR #23047-379 on
1009 03/06/2006. The problem exists in at least the following versions
1010 of AIX and the libm fileset, and no doubt others as well:
1012 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1013 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1014 AIX 5.2.0 bos.adt.libm 5.2.0.85
1016 So, until IBM fixes powl(), we provide the following workaround to
1017 handle the problem ourselves. Our logic is as follows: for
1018 negative bases (left), we use fmod(right, 2) to check if the
1019 exponent is an odd or even integer:
1021 - if odd, powl(left, right) == -powl(-left, right)
1022 - if even, powl(left, right) == powl(-left, right)
1024 If the exponent is not an integer, the result is rightly NaNQ, so
1025 we just return that (as NV_NAN).
1029 NV mod2 = Perl_fmod( right, 2.0 );
1030 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1031 SETn( -Perl_pow( -left, right) );
1032 } else if (mod2 == 0.0) { /* even integer */
1033 SETn( Perl_pow( -left, right) );
1034 } else { /* fractional power */
1038 SETn( Perl_pow( left, right) );
1041 SETn( Perl_pow( left, right) );
1042 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1044 #ifdef PERL_PRESERVE_IVUV
1054 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1055 #ifdef PERL_PRESERVE_IVUV
1058 /* Unless the left argument is integer in range we are going to have to
1059 use NV maths. Hence only attempt to coerce the right argument if
1060 we know the left is integer. */
1061 /* Left operand is defined, so is it IV? */
1062 SvIV_please(TOPm1s);
1063 if (SvIOK(TOPm1s)) {
1064 bool auvok = SvUOK(TOPm1s);
1065 bool buvok = SvUOK(TOPs);
1066 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1067 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1074 alow = SvUVX(TOPm1s);
1076 const IV aiv = SvIVX(TOPm1s);
1079 auvok = TRUE; /* effectively it's a UV now */
1081 alow = -aiv; /* abs, auvok == false records sign */
1087 const IV biv = SvIVX(TOPs);
1090 buvok = TRUE; /* effectively it's a UV now */
1092 blow = -biv; /* abs, buvok == false records sign */
1096 /* If this does sign extension on unsigned it's time for plan B */
1097 ahigh = alow >> (4 * sizeof (UV));
1099 bhigh = blow >> (4 * sizeof (UV));
1101 if (ahigh && bhigh) {
1103 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1104 which is overflow. Drop to NVs below. */
1105 } else if (!ahigh && !bhigh) {
1106 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1107 so the unsigned multiply cannot overflow. */
1108 const UV product = alow * blow;
1109 if (auvok == buvok) {
1110 /* -ve * -ve or +ve * +ve gives a +ve result. */
1114 } else if (product <= (UV)IV_MIN) {
1115 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1116 /* -ve result, which could overflow an IV */
1118 SETi( -(IV)product );
1120 } /* else drop to NVs below. */
1122 /* One operand is large, 1 small */
1125 /* swap the operands */
1127 bhigh = blow; /* bhigh now the temp var for the swap */
1131 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1132 multiplies can't overflow. shift can, add can, -ve can. */
1133 product_middle = ahigh * blow;
1134 if (!(product_middle & topmask)) {
1135 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1137 product_middle <<= (4 * sizeof (UV));
1138 product_low = alow * blow;
1140 /* as for pp_add, UV + something mustn't get smaller.
1141 IIRC ANSI mandates this wrapping *behaviour* for
1142 unsigned whatever the actual representation*/
1143 product_low += product_middle;
1144 if (product_low >= product_middle) {
1145 /* didn't overflow */
1146 if (auvok == buvok) {
1147 /* -ve * -ve or +ve * +ve gives a +ve result. */
1149 SETu( product_low );
1151 } else if (product_low <= (UV)IV_MIN) {
1152 /* 2s complement assumption again */
1153 /* -ve result, which could overflow an IV */
1155 SETi( -(IV)product_low );
1157 } /* else drop to NVs below. */
1159 } /* product_middle too large */
1160 } /* ahigh && bhigh */
1161 } /* SvIOK(TOPm1s) */
1166 SETn( left * right );
1173 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1174 /* Only try to do UV divide first
1175 if ((SLOPPYDIVIDE is true) or
1176 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1178 The assumption is that it is better to use floating point divide
1179 whenever possible, only doing integer divide first if we can't be sure.
1180 If NV_PRESERVES_UV is true then we know at compile time that no UV
1181 can be too large to preserve, so don't need to compile the code to
1182 test the size of UVs. */
1185 # define PERL_TRY_UV_DIVIDE
1186 /* ensure that 20./5. == 4. */
1188 # ifdef PERL_PRESERVE_IVUV
1189 # ifndef NV_PRESERVES_UV
1190 # define PERL_TRY_UV_DIVIDE
1195 #ifdef PERL_TRY_UV_DIVIDE
1198 SvIV_please(TOPm1s);
1199 if (SvIOK(TOPm1s)) {
1200 bool left_non_neg = SvUOK(TOPm1s);
1201 bool right_non_neg = SvUOK(TOPs);
1205 if (right_non_neg) {
1206 right = SvUVX(TOPs);
1209 const IV biv = SvIVX(TOPs);
1212 right_non_neg = TRUE; /* effectively it's a UV now */
1218 /* historically undef()/0 gives a "Use of uninitialized value"
1219 warning before dieing, hence this test goes here.
1220 If it were immediately before the second SvIV_please, then
1221 DIE() would be invoked before left was even inspected, so
1222 no inpsection would give no warning. */
1224 DIE(aTHX_ "Illegal division by zero");
1227 left = SvUVX(TOPm1s);
1230 const IV aiv = SvIVX(TOPm1s);
1233 left_non_neg = TRUE; /* effectively it's a UV now */
1242 /* For sloppy divide we always attempt integer division. */
1244 /* Otherwise we only attempt it if either or both operands
1245 would not be preserved by an NV. If both fit in NVs
1246 we fall through to the NV divide code below. However,
1247 as left >= right to ensure integer result here, we know that
1248 we can skip the test on the right operand - right big
1249 enough not to be preserved can't get here unless left is
1252 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1255 /* Integer division can't overflow, but it can be imprecise. */
1256 const UV result = left / right;
1257 if (result * right == left) {
1258 SP--; /* result is valid */
1259 if (left_non_neg == right_non_neg) {
1260 /* signs identical, result is positive. */
1264 /* 2s complement assumption */
1265 if (result <= (UV)IV_MIN)
1266 SETi( -(IV)result );
1268 /* It's exact but too negative for IV. */
1269 SETn( -(NV)result );
1272 } /* tried integer divide but it was not an integer result */
1273 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1274 } /* left wasn't SvIOK */
1275 } /* right wasn't SvIOK */
1276 #endif /* PERL_TRY_UV_DIVIDE */
1280 DIE(aTHX_ "Illegal division by zero");
1281 PUSHn( left / right );
1288 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1292 bool left_neg = FALSE;
1293 bool right_neg = FALSE;
1294 bool use_double = FALSE;
1295 bool dright_valid = FALSE;
1301 right_neg = !SvUOK(TOPs);
1303 right = SvUVX(POPs);
1305 const IV biv = SvIVX(POPs);
1308 right_neg = FALSE; /* effectively it's a UV now */
1316 right_neg = dright < 0;
1319 if (dright < UV_MAX_P1) {
1320 right = U_V(dright);
1321 dright_valid = TRUE; /* In case we need to use double below. */
1327 /* At this point use_double is only true if right is out of range for
1328 a UV. In range NV has been rounded down to nearest UV and
1329 use_double false. */
1331 if (!use_double && SvIOK(TOPs)) {
1333 left_neg = !SvUOK(TOPs);
1337 const IV aiv = SvIVX(POPs);
1340 left_neg = FALSE; /* effectively it's a UV now */
1349 left_neg = dleft < 0;
1353 /* This should be exactly the 5.6 behaviour - if left and right are
1354 both in range for UV then use U_V() rather than floor. */
1356 if (dleft < UV_MAX_P1) {
1357 /* right was in range, so is dleft, so use UVs not double.
1361 /* left is out of range for UV, right was in range, so promote
1362 right (back) to double. */
1364 /* The +0.5 is used in 5.6 even though it is not strictly
1365 consistent with the implicit +0 floor in the U_V()
1366 inside the #if 1. */
1367 dleft = Perl_floor(dleft + 0.5);
1370 dright = Perl_floor(dright + 0.5);
1380 DIE(aTHX_ "Illegal modulus zero");
1382 dans = Perl_fmod(dleft, dright);
1383 if ((left_neg != right_neg) && dans)
1384 dans = dright - dans;
1387 sv_setnv(TARG, dans);
1393 DIE(aTHX_ "Illegal modulus zero");
1396 if ((left_neg != right_neg) && ans)
1399 /* XXX may warn: unary minus operator applied to unsigned type */
1400 /* could change -foo to be (~foo)+1 instead */
1401 if (ans <= ~((UV)IV_MAX)+1)
1402 sv_setiv(TARG, ~ans+1);
1404 sv_setnv(TARG, -(NV)ans);
1407 sv_setuv(TARG, ans);
1416 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1423 const UV uv = SvUV(sv);
1425 count = IV_MAX; /* The best we can do? */
1429 const IV iv = SvIV(sv);
1436 else if (SvNOKp(sv)) {
1437 const NV nv = SvNV(sv);
1445 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1447 static const char oom_list_extend[] = "Out of memory during list extend";
1448 const I32 items = SP - MARK;
1449 const I32 max = items * count;
1451 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1452 /* Did the max computation overflow? */
1453 if (items > 0 && max > 0 && (max < items || max < count))
1454 Perl_croak(aTHX_ oom_list_extend);
1459 /* This code was intended to fix 20010809.028:
1462 for (($x =~ /./g) x 2) {
1463 print chop; # "abcdabcd" expected as output.
1466 * but that change (#11635) broke this code:
1468 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1470 * I can't think of a better fix that doesn't introduce
1471 * an efficiency hit by copying the SVs. The stack isn't
1472 * refcounted, and mortalisation obviously doesn't
1473 * Do The Right Thing when the stack has more than
1474 * one pointer to the same mortal value.
1478 *SP = sv_2mortal(newSVsv(*SP));
1488 repeatcpy((char*)(MARK + items), (char*)MARK,
1489 items * sizeof(SV*), count - 1);
1492 else if (count <= 0)
1495 else { /* Note: mark already snarfed by pp_list */
1496 SV * const tmpstr = POPs;
1499 static const char oom_string_extend[] =
1500 "Out of memory during string extend";
1502 SvSetSV(TARG, tmpstr);
1503 SvPV_force(TARG, len);
1504 isutf = DO_UTF8(TARG);
1509 const STRLEN max = (UV)count * len;
1510 if (len > ((MEM_SIZE)~0)/count)
1511 Perl_croak(aTHX_ oom_string_extend);
1512 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1513 SvGROW(TARG, max + 1);
1514 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1515 SvCUR_set(TARG, SvCUR(TARG) * count);
1517 *SvEND(TARG) = '\0';
1520 (void)SvPOK_only_UTF8(TARG);
1522 (void)SvPOK_only(TARG);
1524 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1525 /* The parser saw this as a list repeat, and there
1526 are probably several items on the stack. But we're
1527 in scalar context, and there's no pp_list to save us
1528 now. So drop the rest of the items -- robin@kitsite.com
1541 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1542 useleft = USE_LEFT(TOPm1s);
1543 #ifdef PERL_PRESERVE_IVUV
1544 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1545 "bad things" happen if you rely on signed integers wrapping. */
1548 /* Unless the left argument is integer in range we are going to have to
1549 use NV maths. Hence only attempt to coerce the right argument if
1550 we know the left is integer. */
1551 register UV auv = 0;
1557 a_valid = auvok = 1;
1558 /* left operand is undef, treat as zero. */
1560 /* Left operand is defined, so is it IV? */
1561 SvIV_please(TOPm1s);
1562 if (SvIOK(TOPm1s)) {
1563 if ((auvok = SvUOK(TOPm1s)))
1564 auv = SvUVX(TOPm1s);
1566 register const IV aiv = SvIVX(TOPm1s);
1569 auvok = 1; /* Now acting as a sign flag. */
1570 } else { /* 2s complement assumption for IV_MIN */
1578 bool result_good = 0;
1581 bool buvok = SvUOK(TOPs);
1586 register const IV biv = SvIVX(TOPs);
1593 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1594 else "IV" now, independent of how it came in.
1595 if a, b represents positive, A, B negative, a maps to -A etc
1600 all UV maths. negate result if A negative.
1601 subtract if signs same, add if signs differ. */
1603 if (auvok ^ buvok) {
1612 /* Must get smaller */
1617 if (result <= buv) {
1618 /* result really should be -(auv-buv). as its negation
1619 of true value, need to swap our result flag */
1631 if (result <= (UV)IV_MIN)
1632 SETi( -(IV)result );
1634 /* result valid, but out of range for IV. */
1635 SETn( -(NV)result );
1639 } /* Overflow, drop through to NVs. */
1643 useleft = USE_LEFT(TOPm1s);
1647 /* left operand is undef, treat as zero - value */
1651 SETn( TOPn - value );
1658 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1660 const IV shift = POPi;
1661 if (PL_op->op_private & HINT_INTEGER) {
1675 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1677 const IV shift = POPi;
1678 if (PL_op->op_private & HINT_INTEGER) {
1692 dVAR; dSP; tryAMAGICbinSET(lt,0);
1693 #ifdef PERL_PRESERVE_IVUV
1696 SvIV_please(TOPm1s);
1697 if (SvIOK(TOPm1s)) {
1698 bool auvok = SvUOK(TOPm1s);
1699 bool buvok = SvUOK(TOPs);
1701 if (!auvok && !buvok) { /* ## IV < IV ## */
1702 const IV aiv = SvIVX(TOPm1s);
1703 const IV biv = SvIVX(TOPs);
1706 SETs(boolSV(aiv < biv));
1709 if (auvok && buvok) { /* ## UV < UV ## */
1710 const UV auv = SvUVX(TOPm1s);
1711 const UV buv = SvUVX(TOPs);
1714 SETs(boolSV(auv < buv));
1717 if (auvok) { /* ## UV < IV ## */
1719 const IV biv = SvIVX(TOPs);
1722 /* As (a) is a UV, it's >=0, so it cannot be < */
1727 SETs(boolSV(auv < (UV)biv));
1730 { /* ## IV < UV ## */
1731 const IV aiv = SvIVX(TOPm1s);
1735 /* As (b) is a UV, it's >=0, so it must be < */
1742 SETs(boolSV((UV)aiv < buv));
1748 #ifndef NV_PRESERVES_UV
1749 #ifdef PERL_PRESERVE_IVUV
1752 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1754 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1759 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1761 if (Perl_isnan(left) || Perl_isnan(right))
1763 SETs(boolSV(left < right));
1766 SETs(boolSV(TOPn < value));
1774 dVAR; dSP; tryAMAGICbinSET(gt,0);
1775 #ifdef PERL_PRESERVE_IVUV
1778 SvIV_please(TOPm1s);
1779 if (SvIOK(TOPm1s)) {
1780 bool auvok = SvUOK(TOPm1s);
1781 bool buvok = SvUOK(TOPs);
1783 if (!auvok && !buvok) { /* ## IV > IV ## */
1784 const IV aiv = SvIVX(TOPm1s);
1785 const IV biv = SvIVX(TOPs);
1788 SETs(boolSV(aiv > biv));
1791 if (auvok && buvok) { /* ## UV > UV ## */
1792 const UV auv = SvUVX(TOPm1s);
1793 const UV buv = SvUVX(TOPs);
1796 SETs(boolSV(auv > buv));
1799 if (auvok) { /* ## UV > IV ## */
1801 const IV biv = SvIVX(TOPs);
1805 /* As (a) is a UV, it's >=0, so it must be > */
1810 SETs(boolSV(auv > (UV)biv));
1813 { /* ## IV > UV ## */
1814 const IV aiv = SvIVX(TOPm1s);
1818 /* As (b) is a UV, it's >=0, so it cannot be > */
1825 SETs(boolSV((UV)aiv > buv));
1831 #ifndef NV_PRESERVES_UV
1832 #ifdef PERL_PRESERVE_IVUV
1835 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1837 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1842 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1844 if (Perl_isnan(left) || Perl_isnan(right))
1846 SETs(boolSV(left > right));
1849 SETs(boolSV(TOPn > value));
1857 dVAR; dSP; tryAMAGICbinSET(le,0);
1858 #ifdef PERL_PRESERVE_IVUV
1861 SvIV_please(TOPm1s);
1862 if (SvIOK(TOPm1s)) {
1863 bool auvok = SvUOK(TOPm1s);
1864 bool buvok = SvUOK(TOPs);
1866 if (!auvok && !buvok) { /* ## IV <= IV ## */
1867 const IV aiv = SvIVX(TOPm1s);
1868 const IV biv = SvIVX(TOPs);
1871 SETs(boolSV(aiv <= biv));
1874 if (auvok && buvok) { /* ## UV <= UV ## */
1875 UV auv = SvUVX(TOPm1s);
1876 UV buv = SvUVX(TOPs);
1879 SETs(boolSV(auv <= buv));
1882 if (auvok) { /* ## UV <= IV ## */
1884 const IV biv = SvIVX(TOPs);
1888 /* As (a) is a UV, it's >=0, so a cannot be <= */
1893 SETs(boolSV(auv <= (UV)biv));
1896 { /* ## IV <= UV ## */
1897 const IV aiv = SvIVX(TOPm1s);
1901 /* As (b) is a UV, it's >=0, so a must be <= */
1908 SETs(boolSV((UV)aiv <= buv));
1914 #ifndef NV_PRESERVES_UV
1915 #ifdef PERL_PRESERVE_IVUV
1918 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1920 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1925 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1927 if (Perl_isnan(left) || Perl_isnan(right))
1929 SETs(boolSV(left <= right));
1932 SETs(boolSV(TOPn <= value));
1940 dVAR; dSP; tryAMAGICbinSET(ge,0);
1941 #ifdef PERL_PRESERVE_IVUV
1944 SvIV_please(TOPm1s);
1945 if (SvIOK(TOPm1s)) {
1946 bool auvok = SvUOK(TOPm1s);
1947 bool buvok = SvUOK(TOPs);
1949 if (!auvok && !buvok) { /* ## IV >= IV ## */
1950 const IV aiv = SvIVX(TOPm1s);
1951 const IV biv = SvIVX(TOPs);
1954 SETs(boolSV(aiv >= biv));
1957 if (auvok && buvok) { /* ## UV >= UV ## */
1958 const UV auv = SvUVX(TOPm1s);
1959 const UV buv = SvUVX(TOPs);
1962 SETs(boolSV(auv >= buv));
1965 if (auvok) { /* ## UV >= IV ## */
1967 const IV biv = SvIVX(TOPs);
1971 /* As (a) is a UV, it's >=0, so it must be >= */
1976 SETs(boolSV(auv >= (UV)biv));
1979 { /* ## IV >= UV ## */
1980 const IV aiv = SvIVX(TOPm1s);
1984 /* As (b) is a UV, it's >=0, so a cannot be >= */
1991 SETs(boolSV((UV)aiv >= buv));
1997 #ifndef NV_PRESERVES_UV
1998 #ifdef PERL_PRESERVE_IVUV
2001 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2003 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2008 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2010 if (Perl_isnan(left) || Perl_isnan(right))
2012 SETs(boolSV(left >= right));
2015 SETs(boolSV(TOPn >= value));
2023 dVAR; dSP; tryAMAGICbinSET(ne,0);
2024 #ifndef NV_PRESERVES_UV
2025 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2027 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2031 #ifdef PERL_PRESERVE_IVUV
2034 SvIV_please(TOPm1s);
2035 if (SvIOK(TOPm1s)) {
2036 const bool auvok = SvUOK(TOPm1s);
2037 const bool buvok = SvUOK(TOPs);
2039 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2040 /* Casting IV to UV before comparison isn't going to matter
2041 on 2s complement. On 1s complement or sign&magnitude
2042 (if we have any of them) it could make negative zero
2043 differ from normal zero. As I understand it. (Need to
2044 check - is negative zero implementation defined behaviour
2046 const UV buv = SvUVX(POPs);
2047 const UV auv = SvUVX(TOPs);
2049 SETs(boolSV(auv != buv));
2052 { /* ## Mixed IV,UV ## */
2056 /* != is commutative so swap if needed (save code) */
2058 /* swap. top of stack (b) is the iv */
2062 /* As (a) is a UV, it's >0, so it cannot be == */
2071 /* As (b) is a UV, it's >0, so it cannot be == */
2075 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2077 SETs(boolSV((UV)iv != uv));
2084 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2086 if (Perl_isnan(left) || Perl_isnan(right))
2088 SETs(boolSV(left != right));
2091 SETs(boolSV(TOPn != value));
2099 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2100 #ifndef NV_PRESERVES_UV
2101 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2102 const UV right = PTR2UV(SvRV(POPs));
2103 const UV left = PTR2UV(SvRV(TOPs));
2104 SETi((left > right) - (left < right));
2108 #ifdef PERL_PRESERVE_IVUV
2109 /* Fortunately it seems NaN isn't IOK */
2112 SvIV_please(TOPm1s);
2113 if (SvIOK(TOPm1s)) {
2114 const bool leftuvok = SvUOK(TOPm1s);
2115 const bool rightuvok = SvUOK(TOPs);
2117 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2118 const IV leftiv = SvIVX(TOPm1s);
2119 const IV rightiv = SvIVX(TOPs);
2121 if (leftiv > rightiv)
2123 else if (leftiv < rightiv)
2127 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2128 const UV leftuv = SvUVX(TOPm1s);
2129 const UV rightuv = SvUVX(TOPs);
2131 if (leftuv > rightuv)
2133 else if (leftuv < rightuv)
2137 } else if (leftuvok) { /* ## UV <=> IV ## */
2138 const IV rightiv = SvIVX(TOPs);
2140 /* As (a) is a UV, it's >=0, so it cannot be < */
2143 const UV leftuv = SvUVX(TOPm1s);
2144 if (leftuv > (UV)rightiv) {
2146 } else if (leftuv < (UV)rightiv) {
2152 } else { /* ## IV <=> UV ## */
2153 const IV leftiv = SvIVX(TOPm1s);
2155 /* As (b) is a UV, it's >=0, so it must be < */
2158 const UV rightuv = SvUVX(TOPs);
2159 if ((UV)leftiv > rightuv) {
2161 } else if ((UV)leftiv < rightuv) {
2179 if (Perl_isnan(left) || Perl_isnan(right)) {
2183 value = (left > right) - (left < right);
2187 else if (left < right)
2189 else if (left > right)
2205 int amg_type = sle_amg;
2209 switch (PL_op->op_type) {
2228 tryAMAGICbinSET_var(amg_type,0);
2231 const int cmp = (IN_LOCALE_RUNTIME
2232 ? sv_cmp_locale(left, right)
2233 : sv_cmp(left, right));
2234 SETs(boolSV(cmp * multiplier < rhs));
2241 dVAR; dSP; tryAMAGICbinSET(seq,0);
2244 SETs(boolSV(sv_eq(left, right)));
2251 dVAR; dSP; tryAMAGICbinSET(sne,0);
2254 SETs(boolSV(!sv_eq(left, right)));
2261 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2264 const int cmp = (IN_LOCALE_RUNTIME
2265 ? sv_cmp_locale(left, right)
2266 : sv_cmp(left, right));
2274 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2279 if (SvNIOKp(left) || SvNIOKp(right)) {
2280 if (PL_op->op_private & HINT_INTEGER) {
2281 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2285 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2290 do_vop(PL_op->op_type, TARG, left, right);
2299 dVAR; dSP; dATARGET;
2300 const int op_type = PL_op->op_type;
2302 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2307 if (SvNIOKp(left) || SvNIOKp(right)) {
2308 if (PL_op->op_private & HINT_INTEGER) {
2309 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2310 const IV r = SvIV_nomg(right);
2311 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2315 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2316 const UV r = SvUV_nomg(right);
2317 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2322 do_vop(op_type, TARG, left, right);
2331 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2334 const int flags = SvFLAGS(sv);
2336 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2337 /* It's publicly an integer, or privately an integer-not-float */
2340 if (SvIVX(sv) == IV_MIN) {
2341 /* 2s complement assumption. */
2342 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2345 else if (SvUVX(sv) <= IV_MAX) {
2350 else if (SvIVX(sv) != IV_MIN) {
2354 #ifdef PERL_PRESERVE_IVUV
2363 else if (SvPOKp(sv)) {
2365 const char * const s = SvPV_const(sv, len);
2366 if (isIDFIRST(*s)) {
2367 sv_setpvn(TARG, "-", 1);
2370 else if (*s == '+' || *s == '-') {
2372 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2374 else if (DO_UTF8(sv)) {
2377 goto oops_its_an_int;
2379 sv_setnv(TARG, -SvNV(sv));
2381 sv_setpvn(TARG, "-", 1);
2388 goto oops_its_an_int;
2389 sv_setnv(TARG, -SvNV(sv));
2401 dVAR; dSP; tryAMAGICunSET(not);
2402 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2408 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2413 if (PL_op->op_private & HINT_INTEGER) {
2414 const IV i = ~SvIV_nomg(sv);
2418 const UV u = ~SvUV_nomg(sv);
2427 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2428 sv_setsv_nomg(TARG, sv);
2429 tmps = (U8*)SvPV_force(TARG, len);
2432 /* Calculate exact length, let's not estimate. */
2437 U8 * const send = tmps + len;
2438 U8 * const origtmps = tmps;
2439 const UV utf8flags = UTF8_ALLOW_ANYUV;
2441 while (tmps < send) {
2442 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2444 targlen += UNISKIP(~c);
2450 /* Now rewind strings and write them. */
2457 Newx(result, targlen + 1, U8);
2459 while (tmps < send) {
2460 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2462 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2465 sv_usepvn_flags(TARG, (char*)result, targlen,
2466 SV_HAS_TRAILING_NUL);
2473 Newx(result, nchar + 1, U8);
2475 while (tmps < send) {
2476 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2481 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2489 register long *tmpl;
2490 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2493 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2498 for ( ; anum > 0; anum--, tmps++)
2507 /* integer versions of some of the above */
2511 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2514 SETi( left * right );
2522 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2526 DIE(aTHX_ "Illegal division by zero");
2529 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2533 value = num / value;
2542 /* This is the vanilla old i_modulo. */
2543 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2547 DIE(aTHX_ "Illegal modulus zero");
2548 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2552 SETi( left % right );
2557 #if defined(__GLIBC__) && IVSIZE == 8
2561 /* This is the i_modulo with the workaround for the _moddi3 bug
2562 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2563 * See below for pp_i_modulo. */
2564 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2568 DIE(aTHX_ "Illegal modulus zero");
2569 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2573 SETi( left % PERL_ABS(right) );
2581 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2585 DIE(aTHX_ "Illegal modulus zero");
2586 /* The assumption is to use hereafter the old vanilla version... */
2588 PL_ppaddr[OP_I_MODULO] =
2590 /* .. but if we have glibc, we might have a buggy _moddi3
2591 * (at least glicb 2.2.5 is known to have this bug), in other
2592 * words our integer modulus with negative quad as the second
2593 * argument might be broken. Test for this and re-patch the
2594 * opcode dispatch table if that is the case, remembering to
2595 * also apply the workaround so that this first round works
2596 * right, too. See [perl #9402] for more information. */
2597 #if defined(__GLIBC__) && IVSIZE == 8
2601 /* Cannot do this check with inlined IV constants since
2602 * that seems to work correctly even with the buggy glibc. */
2604 /* Yikes, we have the bug.
2605 * Patch in the workaround version. */
2607 PL_ppaddr[OP_I_MODULO] =
2608 &Perl_pp_i_modulo_1;
2609 /* Make certain we work right this time, too. */
2610 right = PERL_ABS(right);
2614 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2618 SETi( left % right );
2625 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2628 SETi( left + right );
2635 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2638 SETi( left - right );
2645 dVAR; dSP; tryAMAGICbinSET(lt,0);
2648 SETs(boolSV(left < right));
2655 dVAR; dSP; tryAMAGICbinSET(gt,0);
2658 SETs(boolSV(left > right));
2665 dVAR; dSP; tryAMAGICbinSET(le,0);
2668 SETs(boolSV(left <= right));
2675 dVAR; dSP; tryAMAGICbinSET(ge,0);
2678 SETs(boolSV(left >= right));
2685 dVAR; dSP; tryAMAGICbinSET(eq,0);
2688 SETs(boolSV(left == right));
2695 dVAR; dSP; tryAMAGICbinSET(ne,0);
2698 SETs(boolSV(left != right));
2705 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2712 else if (left < right)
2723 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2728 /* High falutin' math. */
2732 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2735 SETn(Perl_atan2(left, right));
2743 int amg_type = sin_amg;
2744 const char *neg_report = NULL;
2745 NV (*func)(NV) = Perl_sin;
2746 const int op_type = PL_op->op_type;
2763 amg_type = sqrt_amg;
2765 neg_report = "sqrt";
2769 tryAMAGICun_var(amg_type);
2771 const NV value = POPn;
2773 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2774 SET_NUMERIC_STANDARD();
2775 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2778 XPUSHn(func(value));
2783 /* Support Configure command-line overrides for rand() functions.
2784 After 5.005, perhaps we should replace this by Configure support
2785 for drand48(), random(), or rand(). For 5.005, though, maintain
2786 compatibility by calling rand() but allow the user to override it.
2787 See INSTALL for details. --Andy Dougherty 15 July 1998
2789 /* Now it's after 5.005, and Configure supports drand48() and random(),
2790 in addition to rand(). So the overrides should not be needed any more.
2791 --Jarkko Hietaniemi 27 September 1998
2794 #ifndef HAS_DRAND48_PROTO
2795 extern double drand48 (void);
2808 if (!PL_srand_called) {
2809 (void)seedDrand01((Rand_seed_t)seed());
2810 PL_srand_called = TRUE;
2820 const UV anum = (MAXARG < 1) ? seed() : POPu;
2821 (void)seedDrand01((Rand_seed_t)anum);
2822 PL_srand_called = TRUE;
2829 dVAR; dSP; dTARGET; tryAMAGICun(int);
2831 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2832 /* XXX it's arguable that compiler casting to IV might be subtly
2833 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2834 else preferring IV has introduced a subtle behaviour change bug. OTOH
2835 relying on floating point to be accurate is a bug. */
2839 else if (SvIOK(TOPs)) {
2846 const NV value = TOPn;
2848 if (value < (NV)UV_MAX + 0.5) {
2851 SETn(Perl_floor(value));
2855 if (value > (NV)IV_MIN - 0.5) {
2858 SETn(Perl_ceil(value));
2868 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2870 /* This will cache the NV value if string isn't actually integer */
2875 else if (SvIOK(TOPs)) {
2876 /* IVX is precise */
2878 SETu(TOPu); /* force it to be numeric only */
2886 /* 2s complement assumption. Also, not really needed as
2887 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2893 const NV value = TOPn;
2907 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2911 SV* const sv = POPs;
2913 tmps = (SvPV_const(sv, len));
2915 /* If Unicode, try to downgrade
2916 * If not possible, croak. */
2917 SV* const tsv = sv_2mortal(newSVsv(sv));
2920 sv_utf8_downgrade(tsv, FALSE);
2921 tmps = SvPV_const(tsv, len);
2923 if (PL_op->op_type == OP_HEX)
2926 while (*tmps && len && isSPACE(*tmps))
2932 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) {
2953 SV * const sv = TOPs;
2956 /* For an overloaded scalar, we can't know in advance if it's going to
2957 be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2958 cache the length. Maybe that should be a documented feature of it.
2961 const char *const p = SvPV_const(sv, len);
2964 SETi(utf8_length((U8*)p, (U8*)p + len));
2970 else if (DO_UTF8(sv))
2971 SETi(sv_len_utf8(sv));
2987 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2989 const I32 arybase = CopARYBASE_get(PL_curcop);
2991 const char *repl = NULL;
2993 const int num_args = PL_op->op_private & 7;
2994 bool repl_need_utf8_upgrade = FALSE;
2995 bool repl_is_utf8 = FALSE;
2997 SvTAINTED_off(TARG); /* decontaminate */
2998 SvUTF8_off(TARG); /* decontaminate */
3002 repl = SvPV_const(repl_sv, repl_len);
3003 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3013 sv_utf8_upgrade(sv);
3015 else if (DO_UTF8(sv))
3016 repl_need_utf8_upgrade = TRUE;
3018 tmps = SvPV_const(sv, curlen);
3020 utf8_curlen = sv_len_utf8(sv);
3021 if (utf8_curlen == curlen)
3024 curlen = utf8_curlen;
3029 if (pos >= arybase) {
3047 else if (len >= 0) {
3049 if (rem > (I32)curlen)
3064 Perl_croak(aTHX_ "substr outside of string");
3065 if (ckWARN(WARN_SUBSTR))
3066 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3070 const I32 upos = pos;
3071 const I32 urem = rem;
3073 sv_pos_u2b(sv, &pos, &rem);
3075 /* we either return a PV or an LV. If the TARG hasn't been used
3076 * before, or is of that type, reuse it; otherwise use a mortal
3077 * instead. Note that LVs can have an extended lifetime, so also
3078 * dont reuse if refcount > 1 (bug #20933) */
3079 if (SvTYPE(TARG) > SVt_NULL) {
3080 if ( (SvTYPE(TARG) == SVt_PVLV)
3081 ? (!lvalue || SvREFCNT(TARG) > 1)
3084 TARG = sv_newmortal();
3088 sv_setpvn(TARG, tmps, rem);
3089 #ifdef USE_LOCALE_COLLATE
3090 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3095 SV* repl_sv_copy = NULL;
3097 if (repl_need_utf8_upgrade) {
3098 repl_sv_copy = newSVsv(repl_sv);
3099 sv_utf8_upgrade(repl_sv_copy);
3100 repl = SvPV_const(repl_sv_copy, repl_len);
3101 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3103 sv_insert(sv, pos, rem, repl, repl_len);
3107 SvREFCNT_dec(repl_sv_copy);
3109 else if (lvalue) { /* it's an lvalue! */
3110 if (!SvGMAGICAL(sv)) {
3112 SvPV_force_nolen(sv);
3113 if (ckWARN(WARN_SUBSTR))
3114 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3115 "Attempt to use reference as lvalue in substr");
3117 if (isGV_with_GP(sv))
3118 SvPV_force_nolen(sv);
3119 else if (SvOK(sv)) /* is it defined ? */
3120 (void)SvPOK_only_UTF8(sv);
3122 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3125 if (SvTYPE(TARG) < SVt_PVLV) {
3126 sv_upgrade(TARG, SVt_PVLV);
3127 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3133 if (LvTARG(TARG) != sv) {
3135 SvREFCNT_dec(LvTARG(TARG));
3136 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3138 LvTARGOFF(TARG) = upos;
3139 LvTARGLEN(TARG) = urem;
3143 PUSHs(TARG); /* avoid SvSETMAGIC here */
3150 register const IV size = POPi;
3151 register const IV offset = POPi;
3152 register SV * const src = POPs;
3153 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3155 SvTAINTED_off(TARG); /* decontaminate */
3156 if (lvalue) { /* it's an lvalue! */
3157 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3158 TARG = sv_newmortal();
3159 if (SvTYPE(TARG) < SVt_PVLV) {
3160 sv_upgrade(TARG, SVt_PVLV);
3161 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3164 if (LvTARG(TARG) != src) {
3166 SvREFCNT_dec(LvTARG(TARG));
3167 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3169 LvTARGOFF(TARG) = offset;
3170 LvTARGLEN(TARG) = size;
3173 sv_setuv(TARG, do_vecget(src, offset, size));
3189 const char *little_p;
3190 const I32 arybase = CopARYBASE_get(PL_curcop);
3193 const bool is_index = PL_op->op_type == OP_INDEX;
3196 /* arybase is in characters, like offset, so combine prior to the
3197 UTF-8 to bytes calculation. */
3198 offset = POPi - arybase;
3202 big_p = SvPV_const(big, biglen);
3203 little_p = SvPV_const(little, llen);
3205 big_utf8 = DO_UTF8(big);
3206 little_utf8 = DO_UTF8(little);
3207 if (big_utf8 ^ little_utf8) {
3208 /* One needs to be upgraded. */
3209 if (little_utf8 && !PL_encoding) {
3210 /* Well, maybe instead we might be able to downgrade the small
3212 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3215 /* If the large string is ISO-8859-1, and it's not possible to
3216 convert the small string to ISO-8859-1, then there is no
3217 way that it could be found anywhere by index. */
3222 /* At this point, pv is a malloc()ed string. So donate it to temp
3223 to ensure it will get free()d */
3224 little = temp = newSV(0);
3225 sv_usepvn(temp, pv, llen);
3226 little_p = SvPVX(little);
3229 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3232 sv_recode_to_utf8(temp, PL_encoding);
3234 sv_utf8_upgrade(temp);
3239 big_p = SvPV_const(big, biglen);
3242 little_p = SvPV_const(little, llen);
3246 if (SvGAMAGIC(big)) {
3247 /* Life just becomes a lot easier if I use a temporary here.
3248 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3249 will trigger magic and overloading again, as will fbm_instr()
3251 big = sv_2mortal(newSVpvn(big_p, biglen));
3256 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3257 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3258 warn on undef, and we've already triggered a warning with the
3259 SvPV_const some lines above. We can't remove that, as we need to
3260 call some SvPV to trigger overloading early and find out if the
3262 This is all getting to messy. The API isn't quite clean enough,
3263 because data access has side effects.
3265 little = sv_2mortal(newSVpvn(little_p, llen));
3268 little_p = SvPVX(little);
3272 offset = is_index ? 0 : biglen;
3274 if (big_utf8 && offset > 0)
3275 sv_pos_u2b(big, &offset, 0);
3281 else if (offset > (I32)biglen)
3283 if (!(little_p = is_index
3284 ? fbm_instr((unsigned char*)big_p + offset,
3285 (unsigned char*)big_p + biglen, little, 0)
3286 : rninstr(big_p, big_p + offset,
3287 little_p, little_p + llen)))
3290 retval = little_p - big_p;
3291 if (retval > 0 && big_utf8)
3292 sv_pos_b2u(big, &retval);
3297 PUSHi(retval + arybase);
3303 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3304 do_sprintf(TARG, SP-MARK, MARK+1);
3305 TAINT_IF(SvTAINTED(TARG));
3317 const U8 *s = (U8*)SvPV_const(argsv, len);
3319 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3320 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3321 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3325 XPUSHu(DO_UTF8(argsv) ?
3326 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3338 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3340 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3342 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3344 (void) POPs; /* Ignore the argument value. */
3345 value = UNICODE_REPLACEMENT;
3351 SvUPGRADE(TARG,SVt_PV);
3353 if (value > 255 && !IN_BYTES) {
3354 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3355 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3356 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3358 (void)SvPOK_only(TARG);
3367 *tmps++ = (char)value;
3369 (void)SvPOK_only(TARG);
3371 if (PL_encoding && !IN_BYTES) {
3372 sv_recode_to_utf8(TARG, PL_encoding);
3374 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3375 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3379 *tmps++ = (char)value;
3395 const char *tmps = SvPV_const(left, len);
3397 if (DO_UTF8(left)) {
3398 /* If Unicode, try to downgrade.
3399 * If not possible, croak.
3400 * Yes, we made this up. */
3401 SV* const tsv = sv_2mortal(newSVsv(left));
3404 sv_utf8_downgrade(tsv, FALSE);
3405 tmps = SvPV_const(tsv, len);
3407 # ifdef USE_ITHREADS
3409 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3410 /* This should be threadsafe because in ithreads there is only
3411 * one thread per interpreter. If this would not be true,
3412 * we would need a mutex to protect this malloc. */
3413 PL_reentrant_buffer->_crypt_struct_buffer =
3414 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3415 #if defined(__GLIBC__) || defined(__EMX__)
3416 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3417 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3418 /* work around glibc-2.2.5 bug */
3419 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3423 # endif /* HAS_CRYPT_R */
3424 # endif /* USE_ITHREADS */
3426 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3428 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3434 "The crypt() function is unimplemented due to excessive paranoia.");
3446 bool inplace = TRUE;
3448 const int op_type = PL_op->op_type;
3451 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3457 s = (const U8*)SvPV_nomg_const(source, slen);
3463 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3465 utf8_to_uvchr(s, &ulen);
3466 if (op_type == OP_UCFIRST) {
3467 toTITLE_utf8(s, tmpbuf, &tculen);
3469 toLOWER_utf8(s, tmpbuf, &tculen);
3471 /* If the two differ, we definately cannot do inplace. */
3472 inplace = (ulen == tculen);
3473 need = slen + 1 - ulen + tculen;
3479 if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3480 /* We can convert in place. */
3483 s = d = (U8*)SvPV_force_nomg(source, slen);
3489 SvUPGRADE(dest, SVt_PV);
3490 d = (U8*)SvGROW(dest, need);
3491 (void)SvPOK_only(dest);
3500 /* slen is the byte length of the whole SV.
3501 * ulen is the byte length of the original Unicode character
3502 * stored as UTF-8 at s.
3503 * tculen is the byte length of the freshly titlecased (or
3504 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3505 * We first set the result to be the titlecased (/lowercased)
3506 * character, and then append the rest of the SV data. */
3507 sv_setpvn(dest, (char*)tmpbuf, tculen);
3509 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3513 Copy(tmpbuf, d, tculen, U8);
3514 SvCUR_set(dest, need - 1);
3519 if (IN_LOCALE_RUNTIME) {
3522 *d = (op_type == OP_UCFIRST)
3523 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3526 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3528 /* See bug #39028 */
3536 /* This will copy the trailing NUL */
3537 Copy(s + 1, d + 1, slen, U8);
3538 SvCUR_set(dest, need - 1);
3545 /* There's so much setup/teardown code common between uc and lc, I wonder if
3546 it would be worth merging the two, and just having a switch outside each
3547 of the three tight loops. */
3561 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3562 && !DO_UTF8(source)) {
3563 /* We can convert in place. */
3566 s = d = (U8*)SvPV_force_nomg(source, len);
3573 /* The old implementation would copy source into TARG at this point.
3574 This had the side effect that if source was undef, TARG was now
3575 an undefined SV with PADTMP set, and they don't warn inside
3576 sv_2pv_flags(). However, we're now getting the PV direct from
3577 source, which doesn't have PADTMP set, so it would warn. Hence the
3581 s = (const U8*)SvPV_nomg_const(source, len);
3588 SvUPGRADE(dest, SVt_PV);
3589 d = (U8*)SvGROW(dest, min);
3590 (void)SvPOK_only(dest);
3595 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3596 to check DO_UTF8 again here. */
3598 if (DO_UTF8(source)) {
3599 const U8 *const send = s + len;
3600 U8 tmpbuf[UTF8_MAXBYTES+1];
3603 const STRLEN u = UTF8SKIP(s);
3606 toUPPER_utf8(s, tmpbuf, &ulen);
3607 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3608 /* If the eventually required minimum size outgrows
3609 * the available space, we need to grow. */
3610 const UV o = d - (U8*)SvPVX_const(dest);
3612 /* If someone uppercases one million U+03B0s we SvGROW() one
3613 * million times. Or we could try guessing how much to
3614 allocate without allocating too much. Such is life. */
3616 d = (U8*)SvPVX(dest) + o;
3618 Copy(tmpbuf, d, ulen, U8);
3624 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3627 const U8 *const send = s + len;
3628 if (IN_LOCALE_RUNTIME) {
3631 for (; s < send; d++, s++)
3632 *d = toUPPER_LC(*s);
3635 for (; s < send; d++, s++)
3639 if (source != dest) {
3641 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3661 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3662 && !DO_UTF8(source)) {
3663 /* We can convert in place. */
3666 s = d = (U8*)SvPV_force_nomg(source, len);
3673 /* The old implementation would copy source into TARG at this point.
3674 This had the side effect that if source was undef, TARG was now
3675 an undefined SV with PADTMP set, and they don't warn inside
3676 sv_2pv_flags(). However, we're now getting the PV direct from
3677 source, which doesn't have PADTMP set, so it would warn. Hence the
3681 s = (const U8*)SvPV_nomg_const(source, len);
3688 SvUPGRADE(dest, SVt_PV);
3689 d = (U8*)SvGROW(dest, min);
3690 (void)SvPOK_only(dest);
3695 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3696 to check DO_UTF8 again here. */
3698 if (DO_UTF8(source)) {
3699 const U8 *const send = s + len;
3700 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3703 const STRLEN u = UTF8SKIP(s);
3705 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3707 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3708 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3711 * Now if the sigma is NOT followed by
3712 * /$ignorable_sequence$cased_letter/;
3713 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3714 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3715 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3716 * then it should be mapped to 0x03C2,
3717 * (GREEK SMALL LETTER FINAL SIGMA),
3718 * instead of staying 0x03A3.
3719 * "should be": in other words, this is not implemented yet.
3720 * See lib/unicore/SpecialCasing.txt.
3723 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3724 /* If the eventually required minimum size outgrows
3725 * the available space, we need to grow. */
3726 const UV o = d - (U8*)SvPVX_const(dest);
3728 /* If someone lowercases one million U+0130s we SvGROW() one
3729 * million times. Or we could try guessing how much to
3730 allocate without allocating too much. Such is life. */
3732 d = (U8*)SvPVX(dest) + o;
3734 Copy(tmpbuf, d, ulen, U8);
3740 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3743 const U8 *const send = s + len;
3744 if (IN_LOCALE_RUNTIME) {
3747 for (; s < send; d++, s++)
3748 *d = toLOWER_LC(*s);
3751 for (; s < send; d++, s++)
3755 if (source != dest) {
3757 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3767 SV * const sv = TOPs;
3769 register const char *s = SvPV_const(sv,len);
3771 SvUTF8_off(TARG); /* decontaminate */
3774 SvUPGRADE(TARG, SVt_PV);
3775 SvGROW(TARG, (len * 2) + 1);
3779 if (UTF8_IS_CONTINUED(*s)) {
3780 STRLEN ulen = UTF8SKIP(s);
3804 SvCUR_set(TARG, d - SvPVX_const(TARG));
3805 (void)SvPOK_only_UTF8(TARG);
3808 sv_setpvn(TARG, s, len);
3810 if (SvSMAGICAL(TARG))
3819 dVAR; dSP; dMARK; dORIGMARK;
3820 register AV* const av = (AV*)POPs;
3821 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3823 if (SvTYPE(av) == SVt_PVAV) {
3824 const I32 arybase = CopARYBASE_get(PL_curcop);
3825 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3828 for (svp = MARK + 1; svp <= SP; svp++) {
3829 const I32 elem = SvIVx(*svp);
3833 if (max > AvMAX(av))
3836 while (++MARK <= SP) {
3838 I32 elem = SvIVx(*MARK);
3842 svp = av_fetch(av, elem, lval);
3844 if (!svp || *svp == &PL_sv_undef)
3845 DIE(aTHX_ PL_no_aelem, elem);
3846 if (PL_op->op_private & OPpLVAL_INTRO)
3847 save_aelem(av, elem, svp);
3849 *MARK = svp ? *svp : &PL_sv_undef;
3852 if (GIMME != G_ARRAY) {
3854 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3860 /* Associative arrays. */
3866 HV * const hash = (HV*)POPs;
3868 const I32 gimme = GIMME_V;
3871 /* might clobber stack_sp */
3872 entry = hv_iternext(hash);
3877 SV* const sv = hv_iterkeysv(entry);
3878 PUSHs(sv); /* won't clobber stack_sp */
3879 if (gimme == G_ARRAY) {
3882 /* might clobber stack_sp */
3883 val = hv_iterval(hash, entry);
3888 else if (gimme == G_SCALAR)
3898 const I32 gimme = GIMME_V;
3899 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3901 if (PL_op->op_private & OPpSLICE) {
3903 HV * const hv = (HV*)POPs;
3904 const U32 hvtype = SvTYPE(hv);
3905 if (hvtype == SVt_PVHV) { /* hash element */
3906 while (++MARK <= SP) {
3907 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3908 *MARK = sv ? sv : &PL_sv_undef;
3911 else if (hvtype == SVt_PVAV) { /* array element */
3912 if (PL_op->op_flags & OPf_SPECIAL) {
3913 while (++MARK <= SP) {
3914 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3915 *MARK = sv ? sv : &PL_sv_undef;
3920 DIE(aTHX_ "Not a HASH reference");
3923 else if (gimme == G_SCALAR) {
3928 *++MARK = &PL_sv_undef;
3934 HV * const hv = (HV*)POPs;
3936 if (SvTYPE(hv) == SVt_PVHV)
3937 sv = hv_delete_ent(hv, keysv, discard, 0);
3938 else if (SvTYPE(hv) == SVt_PVAV) {
3939 if (PL_op->op_flags & OPf_SPECIAL)
3940 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3942 DIE(aTHX_ "panic: avhv_delete no longer supported");
3945 DIE(aTHX_ "Not a HASH reference");
3961 if (PL_op->op_private & OPpEXISTS_SUB) {
3963 SV * const sv = POPs;
3964 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3967 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3973 if (SvTYPE(hv) == SVt_PVHV) {
3974 if (hv_exists_ent(hv, tmpsv, 0))
3977 else if (SvTYPE(hv) == SVt_PVAV) {
3978 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3979 if (av_exists((AV*)hv, SvIV(tmpsv)))
3984 DIE(aTHX_ "Not a HASH reference");
3991 dVAR; dSP; dMARK; dORIGMARK;
3992 register HV * const hv = (HV*)POPs;
3993 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3994 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3995 bool other_magic = FALSE;
4001 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4002 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4003 /* Try to preserve the existenceness of a tied hash
4004 * element by using EXISTS and DELETE if possible.
4005 * Fallback to FETCH and STORE otherwise */
4006 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4007 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4008 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4011 while (++MARK <= SP) {
4012 SV * const keysv = *MARK;
4015 bool preeminent = FALSE;
4018 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4019 hv_exists_ent(hv, keysv, 0);
4022 he = hv_fetch_ent(hv, keysv, lval, 0);
4023 svp = he ? &HeVAL(he) : 0;
4026 if (!svp || *svp == &PL_sv_undef) {
4027 DIE(aTHX_ PL_no_helem_sv, keysv);
4030 if (HvNAME_get(hv) && isGV(*svp))
4031 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4034 save_helem(hv, keysv, svp);
4037 const char * const key = SvPV_const(keysv, keylen);
4038 SAVEDELETE(hv, savepvn(key,keylen),
4039 SvUTF8(keysv) ? -keylen : keylen);
4044 *MARK = svp ? *svp : &PL_sv_undef;
4046 if (GIMME != G_ARRAY) {
4048 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4054 /* List operators. */
4059 if (GIMME != G_ARRAY) {
4061 *MARK = *SP; /* unwanted list, return last item */
4063 *MARK = &PL_sv_undef;
4073 SV ** const lastrelem = PL_stack_sp;
4074 SV ** const lastlelem = PL_stack_base + POPMARK;
4075 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4076 register SV ** const firstrelem = lastlelem + 1;
4077 const I32 arybase = CopARYBASE_get(PL_curcop);
4078 I32 is_something_there = PL_op->op_flags & OPf_MOD;
4080 register const I32 max = lastrelem - lastlelem;
4081 register SV **lelem;
4083 if (GIMME != G_ARRAY) {
4084 I32 ix = SvIVx(*lastlelem);
4089 if (ix < 0 || ix >= max)
4090 *firstlelem = &PL_sv_undef;
4092 *firstlelem = firstrelem[ix];
4098 SP = firstlelem - 1;
4102 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4103 I32 ix = SvIVx(*lelem);
4108 if (ix < 0 || ix >= max)
4109 *lelem = &PL_sv_undef;
4111 is_something_there = TRUE;
4112 if (!(*lelem = firstrelem[ix]))
4113 *lelem = &PL_sv_undef;
4116 if (is_something_there)
4119 SP = firstlelem - 1;
4125 dVAR; dSP; dMARK; dORIGMARK;
4126 const I32 items = SP - MARK;
4127 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4128 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4135 dVAR; dSP; dMARK; dORIGMARK;
4136 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4139 SV * const key = *++MARK;
4140 SV * const val = newSV(0);
4142 sv_setsv(val, *++MARK);
4143 else if (ckWARN(WARN_MISC))
4144 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4145 (void)hv_store_ent(hv,key,val,0);
4154 dVAR; dSP; dMARK; dORIGMARK;
4155 register AV *ary = (AV*)*++MARK;
4159 register I32 offset;
4160 register I32 length;
4164 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4167 *MARK-- = SvTIED_obj((SV*)ary, mg);
4171 call_method("SPLICE",GIMME_V);
4180 offset = i = SvIVx(*MARK);
4182 offset += AvFILLp(ary) + 1;
4184 offset -= CopARYBASE_get(PL_curcop);
4186 DIE(aTHX_ PL_no_aelem, i);
4188 length = SvIVx(*MARK++);
4190 length += AvFILLp(ary) - offset + 1;
4196 length = AvMAX(ary) + 1; /* close enough to infinity */
4200 length = AvMAX(ary) + 1;
4202 if (offset > AvFILLp(ary) + 1) {
4203 if (ckWARN(WARN_MISC))
4204 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4205 offset = AvFILLp(ary) + 1;
4207 after = AvFILLp(ary) + 1 - (offset + length);
4208 if (after < 0) { /* not that much array */
4209 length += after; /* offset+length now in array */
4215 /* At this point, MARK .. SP-1 is our new LIST */
4218 diff = newlen - length;
4219 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4222 /* make new elements SVs now: avoid problems if they're from the array */
4223 for (dst = MARK, i = newlen; i; i--) {
4224 SV * const h = *dst;
4225 *dst++ = newSVsv(h);
4228 if (diff < 0) { /* shrinking the area */
4229 SV **tmparyval = NULL;
4231 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4232 Copy(MARK, tmparyval, newlen, SV*);
4235 MARK = ORIGMARK + 1;
4236 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4237 MEXTEND(MARK, length);
4238 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4240 EXTEND_MORTAL(length);
4241 for (i = length, dst = MARK; i; i--) {
4242 sv_2mortal(*dst); /* free them eventualy */
4249 *MARK = AvARRAY(ary)[offset+length-1];
4252 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4253 SvREFCNT_dec(*dst++); /* free them now */
4256 AvFILLp(ary) += diff;
4258 /* pull up or down? */
4260 if (offset < after) { /* easier to pull up */
4261 if (offset) { /* esp. if nothing to pull */
4262 src = &AvARRAY(ary)[offset-1];
4263 dst = src - diff; /* diff is negative */
4264 for (i = offset; i > 0; i--) /* can't trust Copy */
4268 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4272 if (after) { /* anything to pull down? */
4273 src = AvARRAY(ary) + offset + length;
4274 dst = src + diff; /* diff is negative */
4275 Move(src, dst, after, SV*);
4277 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4278 /* avoid later double free */
4282 dst[--i] = &PL_sv_undef;
4285 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4286 Safefree(tmparyval);
4289 else { /* no, expanding (or same) */
4290 SV** tmparyval = NULL;
4292 Newx(tmparyval, length, SV*); /* so remember deletion */
4293 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4296 if (diff > 0) { /* expanding */
4297 /* push up or down? */
4298 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4302 Move(src, dst, offset, SV*);
4304 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4306 AvFILLp(ary) += diff;
4309 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4310 av_extend(ary, AvFILLp(ary) + diff);
4311 AvFILLp(ary) += diff;
4314 dst = AvARRAY(ary) + AvFILLp(ary);
4316 for (i = after; i; i--) {
4324 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4327 MARK = ORIGMARK + 1;
4328 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4330 Copy(tmparyval, MARK, length, SV*);
4332 EXTEND_MORTAL(length);
4333 for (i = length, dst = MARK; i; i--) {
4334 sv_2mortal(*dst); /* free them eventualy */
4341 else if (length--) {
4342 *MARK = tmparyval[length];
4345 while (length-- > 0)
4346 SvREFCNT_dec(tmparyval[length]);
4350 *MARK = &PL_sv_undef;
4351 Safefree(tmparyval);
4359 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4360 register AV * const ary = (AV*)*++MARK;
4361 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4364 *MARK-- = SvTIED_obj((SV*)ary, mg);
4368 call_method("PUSH",G_SCALAR|G_DISCARD);
4372 PUSHi( AvFILL(ary) + 1 );
4375 for (++MARK; MARK <= SP; MARK++) {
4376 SV * const sv = newSV(0);
4378 sv_setsv(sv, *MARK);
4379 av_store(ary, AvFILLp(ary)+1, sv);
4382 PUSHi( AvFILLp(ary) + 1 );
4391 AV * const av = (AV*)POPs;
4392 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4396 (void)sv_2mortal(sv);
4403 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4404 register AV *ary = (AV*)*++MARK;
4405 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4408 *MARK-- = SvTIED_obj((SV*)ary, mg);
4412 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4418 av_unshift(ary, SP - MARK);
4420 SV * const sv = newSVsv(*++MARK);
4421 (void)av_store(ary, i++, sv);
4425 PUSHi( AvFILL(ary) + 1 );
4432 SV ** const oldsp = SP;
4434 if (GIMME == G_ARRAY) {
4437 register SV * const tmp = *MARK;
4441 /* safe as long as stack cannot get extended in the above */
4446 register char *down;
4450 PADOFFSET padoff_du;
4452 SvUTF8_off(TARG); /* decontaminate */
4454 do_join(TARG, &PL_sv_no, MARK, SP);
4456 sv_setsv(TARG, (SP > MARK)
4458 : (padoff_du = find_rundefsvoffset(),
4459 (padoff_du == NOT_IN_PAD
4460 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4461 ? DEFSV : PAD_SVl(padoff_du)));
4462 up = SvPV_force(TARG, len);
4464 if (DO_UTF8(TARG)) { /* first reverse each character */
4465 U8* s = (U8*)SvPVX(TARG);
4466 const U8* send = (U8*)(s + len);
4468 if (UTF8_IS_INVARIANT(*s)) {
4473 if (!utf8_to_uvchr(s, 0))
4477 down = (char*)(s - 1);
4478 /* reverse this character */
4482 *down-- = (char)tmp;
4488 down = SvPVX(TARG) + len - 1;
4492 *down-- = (char)tmp;
4494 (void)SvPOK_only_UTF8(TARG);
4506 register IV limit = POPi; /* note, negative is forever */
4507 SV * const sv = POPs;
4509 register const char *s = SvPV_const(sv, len);
4510 const bool do_utf8 = DO_UTF8(sv);
4511 const char *strend = s + len;
4513 register REGEXP *rx;
4515 register const char *m;
4517 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4518 I32 maxiters = slen + 10;
4520 const I32 origlimit = limit;
4523 const I32 gimme = GIMME_V;
4524 const I32 oldsave = PL_savestack_ix;
4525 I32 make_mortal = 1;
4530 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4535 DIE(aTHX_ "panic: pp_split");
4538 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4539 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4541 RX_MATCH_UTF8_set(rx, do_utf8);
4543 if (pm->op_pmreplroot) {
4545 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4547 ary = GvAVn((GV*)pm->op_pmreplroot);
4550 else if (gimme != G_ARRAY)
4551 ary = GvAVn(PL_defgv);
4554 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4560 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4562 XPUSHs(SvTIED_obj((SV*)ary, mg));
4569 for (i = AvFILLp(ary); i >= 0; i--)
4570 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4572 /* temporarily switch stacks */
4573 SAVESWITCHSTACK(PL_curstack, ary);
4577 base = SP - PL_stack_base;
4579 if (pm->op_pmflags & PMf_SKIPWHITE) {
4580 if (pm->op_pmflags & PMf_LOCALE) {
4581 while (isSPACE_LC(*s))
4589 if (pm->op_pmflags & PMf_MULTILINE) {
4594 limit = maxiters + 2;
4595 if (pm->op_pmflags & PMf_WHITE) {
4598 while (m < strend &&
4599 !((pm->op_pmflags & PMf_LOCALE)
4600 ? isSPACE_LC(*m) : isSPACE(*m)))
4605 dstr = newSVpvn(s, m-s);
4609 (void)SvUTF8_on(dstr);
4613 while (s < strend &&
4614 ((pm->op_pmflags & PMf_LOCALE)
4615 ? isSPACE_LC(*s) : isSPACE(*s)))
4619 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4621 for (m = s; m < strend && *m != '\n'; m++)
4626 dstr = newSVpvn(s, m-s);
4630 (void)SvUTF8_on(dstr);
4635 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4636 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4637 && (rx->reganch & ROPT_CHECK_ALL)
4638 && !(rx->reganch & ROPT_ANCH)) {
4639 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4640 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4643 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4644 const char c = *SvPV_nolen_const(csv);
4646 for (m = s; m < strend && *m != c; m++)
4650 dstr = newSVpvn(s, m-s);
4654 (void)SvUTF8_on(dstr);
4656 /* The rx->minlen is in characters but we want to step
4657 * s ahead by bytes. */
4659 s = (char*)utf8_hop((U8*)m, len);
4661 s = m + len; /* Fake \n at the end */
4665 while (s < strend && --limit &&
4666 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4667 csv, multiline ? FBMrf_MULTILINE : 0)) )
4669 dstr = newSVpvn(s, m-s);
4673 (void)SvUTF8_on(dstr);
4675 /* The rx->minlen is in characters but we want to step
4676 * s ahead by bytes. */
4678 s = (char*)utf8_hop((U8*)m, len);
4680 s = m + len; /* Fake \n at the end */
4685 maxiters += slen * rx->nparens;
4686 while (s < strend && --limit)
4690 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4693 if (rex_return == 0)
4695 TAINT_IF(RX_MATCH_TAINTED(rx));
4696 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4701 strend = s + (strend - m);
4703 m = rx->startp[0] + orig;
4704 dstr = newSVpvn(s, m-s);
4708 (void)SvUTF8_on(dstr);
4712 for (i = 1; i <= (I32)rx->nparens; i++) {
4713 s = rx->startp[i] + orig;
4714 m = rx->endp[i] + orig;
4716 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4717 parens that didn't match -- they should be set to
4718 undef, not the empty string */
4719 if (m >= orig && s >= orig) {
4720 dstr = newSVpvn(s, m-s);
4723 dstr = &PL_sv_undef; /* undef, not "" */
4727 (void)SvUTF8_on(dstr);
4731 s = rx->endp[0] + orig;
4735 iters = (SP - PL_stack_base) - base;
4736 if (iters > maxiters)
4737 DIE(aTHX_ "Split loop");
4739 /* keep field after final delim? */
4740 if (s < strend || (iters && origlimit)) {
4741 const STRLEN l = strend - s;
4742 dstr = newSVpvn(s, l);
4746 (void)SvUTF8_on(dstr);
4750 else if (!origlimit) {
4751 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4752 if (TOPs && !make_mortal)
4755 *SP-- = &PL_sv_undef;
4760 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4764 if (SvSMAGICAL(ary)) {
4769 if (gimme == G_ARRAY) {
4771 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4779 call_method("PUSH",G_SCALAR|G_DISCARD);
4782 if (gimme == G_ARRAY) {
4784 /* EXTEND should not be needed - we just popped them */
4786 for (i=0; i < iters; i++) {
4787 SV **svp = av_fetch(ary, i, FALSE);
4788 PUSHs((svp) ? *svp : &PL_sv_undef);
4795 if (gimme == G_ARRAY)
4811 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4812 || SvTYPE(retsv) == SVt_PVCV) {
4813 retsv = refto(retsv);
4820 PP(unimplemented_op)
4823 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4829 * c-indentation-style: bsd
4831 * indent-tabs-mode: t
4834 * ex: set ts=8 sts=4 sw=4 noet: