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");
248 if (SvTYPE(gv) != SVt_PVGV) {
249 if (SvGMAGICAL(sv)) {
254 if (PL_op->op_private & HINT_STRICT_REFS) {
256 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
258 DIE(aTHX_ PL_no_usym, "a SCALAR");
261 if (PL_op->op_flags & OPf_REF)
262 DIE(aTHX_ PL_no_usym, "a SCALAR");
263 if (ckWARN(WARN_UNINITIALIZED))
267 if ((PL_op->op_flags & OPf_SPECIAL) &&
268 !(PL_op->op_flags & OPf_MOD))
270 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
272 && (!is_gv_magical_sv(sv, 0)
273 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
279 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
284 if (PL_op->op_flags & OPf_MOD) {
285 if (PL_op->op_private & OPpLVAL_INTRO) {
286 if (cUNOP->op_first->op_type == OP_NULL)
287 sv = save_scalar((GV*)TOPs);
289 sv = save_scalar(gv);
291 Perl_croak(aTHX_ PL_no_localize_ref);
293 else if (PL_op->op_private & OPpDEREF)
294 vivify_ref(sv, PL_op->op_private & OPpDEREF);
303 AV * const av = (AV*)TOPs;
304 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
307 sv_upgrade(*sv, SVt_PVMG);
308 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
316 dVAR; dSP; dTARGET; dPOPss;
318 if (PL_op->op_flags & OPf_MOD || LVRET) {
319 if (SvTYPE(TARG) < SVt_PVLV) {
320 sv_upgrade(TARG, SVt_PVLV);
321 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
325 if (LvTARG(TARG) != sv) {
327 SvREFCNT_dec(LvTARG(TARG));
328 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
330 PUSHs(TARG); /* no SvSETMAGIC */
334 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
335 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
336 if (mg && mg->mg_len >= 0) {
340 PUSHi(i + CopARYBASE_get(PL_curcop));
353 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
355 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
358 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
359 /* (But not in defined().) */
361 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
364 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
365 if ((PL_op->op_private & OPpLVAL_INTRO)) {
366 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
369 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
372 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
376 cv = (CV*)&PL_sv_undef;
387 SV *ret = &PL_sv_undef;
389 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
390 const char * s = SvPVX_const(TOPs);
391 if (strnEQ(s, "CORE::", 6)) {
392 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
393 if (code < 0) { /* Overridable. */
394 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
395 int i = 0, n = 0, seen_question = 0, defgv = 0;
397 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
399 if (code == -KEY_chop || code == -KEY_chomp
400 || code == -KEY_exec || code == -KEY_system || code == -KEY_err)
402 if (code == -KEY_mkdir) {
403 ret = sv_2mortal(newSVpvs("_;$"));
406 if (code == -KEY_readpipe) {
407 s = "CORE::backtick";
409 while (i < MAXO) { /* The slow way. */
410 if (strEQ(s + 6, PL_op_name[i])
411 || strEQ(s + 6, PL_op_desc[i]))
417 goto nonesuch; /* Should not happen... */
419 defgv = PL_opargs[i] & OA_DEFGV;
420 oa = PL_opargs[i] >> OASHIFT;
422 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
426 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
427 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
428 /* But globs are already references (kinda) */
429 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
433 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
436 if (defgv && str[n - 1] == '$')
439 ret = sv_2mortal(newSVpvn(str, n - 1));
441 else if (code) /* Non-Overridable */
443 else { /* None such */
445 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
449 cv = sv_2cv(TOPs, &stash, &gv, 0);
451 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
460 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
462 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
478 if (GIMME != G_ARRAY) {
482 *MARK = &PL_sv_undef;
483 *MARK = refto(*MARK);
487 EXTEND_MORTAL(SP - MARK);
489 *MARK = refto(*MARK);
494 S_refto(pTHX_ SV *sv)
499 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
502 if (!(sv = LvTARG(sv)))
505 SvREFCNT_inc_void_NN(sv);
507 else if (SvTYPE(sv) == SVt_PVAV) {
508 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
511 SvREFCNT_inc_void_NN(sv);
513 else if (SvPADTMP(sv) && !IS_PADGV(sv))
517 SvREFCNT_inc_void_NN(sv);
520 sv_upgrade(rv, SVt_RV);
530 SV * const sv = POPs;
535 if (!sv || !SvROK(sv))
538 pv = sv_reftype(SvRV(sv),TRUE);
539 PUSHp(pv, strlen(pv));
549 stash = CopSTASH(PL_curcop);
551 SV * const ssv = POPs;
555 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
556 Perl_croak(aTHX_ "Attempt to bless into a reference");
557 ptr = SvPV_const(ssv,len);
558 if (len == 0 && ckWARN(WARN_MISC))
559 Perl_warner(aTHX_ packWARN(WARN_MISC),
560 "Explicit blessing to '' (assuming package main)");
561 stash = gv_stashpvn(ptr, len, TRUE);
564 (void)sv_bless(TOPs, stash);
573 const char * const elem = SvPV_nolen_const(sv);
574 GV * const gv = (GV*)POPs;
579 /* elem will always be NUL terminated. */
580 const char * const second_letter = elem + 1;
583 if (strEQ(second_letter, "RRAY"))
584 tmpRef = (SV*)GvAV(gv);
587 if (strEQ(second_letter, "ODE"))
588 tmpRef = (SV*)GvCVu(gv);
591 if (strEQ(second_letter, "ILEHANDLE")) {
592 /* finally deprecated in 5.8.0 */
593 deprecate("*glob{FILEHANDLE}");
594 tmpRef = (SV*)GvIOp(gv);
597 if (strEQ(second_letter, "ORMAT"))
598 tmpRef = (SV*)GvFORM(gv);
601 if (strEQ(second_letter, "LOB"))
605 if (strEQ(second_letter, "ASH"))
606 tmpRef = (SV*)GvHV(gv);
609 if (*second_letter == 'O' && !elem[2])
610 tmpRef = (SV*)GvIOp(gv);
613 if (strEQ(second_letter, "AME"))
614 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
617 if (strEQ(second_letter, "ACKAGE")) {
618 const HV * const stash = GvSTASH(gv);
619 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
620 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
624 if (strEQ(second_letter, "CALAR"))
639 /* Pattern matching */
644 register unsigned char *s;
647 register I32 *sfirst;
651 if (sv == PL_lastscream) {
655 s = (unsigned char*)(SvPV(sv, len));
657 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
658 /* No point in studying a zero length string, and not safe to study
659 anything that doesn't appear to be a simple scalar (and hence might
660 change between now and when the regexp engine runs without our set
661 magic ever running) such as a reference to an object with overloaded
667 SvSCREAM_off(PL_lastscream);
668 SvREFCNT_dec(PL_lastscream);
670 PL_lastscream = SvREFCNT_inc_simple(sv);
672 s = (unsigned char*)(SvPV(sv, len));
676 if (pos > PL_maxscream) {
677 if (PL_maxscream < 0) {
678 PL_maxscream = pos + 80;
679 Newx(PL_screamfirst, 256, I32);
680 Newx(PL_screamnext, PL_maxscream, I32);
683 PL_maxscream = pos + pos / 4;
684 Renew(PL_screamnext, PL_maxscream, I32);
688 sfirst = PL_screamfirst;
689 snext = PL_screamnext;
691 if (!sfirst || !snext)
692 DIE(aTHX_ "do_study: out of memory");
694 for (ch = 256; ch; --ch)
699 register const I32 ch = s[pos];
701 snext[pos] = sfirst[ch] - pos;
708 /* piggyback on m//g magic */
709 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
718 if (PL_op->op_flags & OPf_STACKED)
720 else if (PL_op->op_private & OPpTARGET_MY)
726 TARG = sv_newmortal();
731 /* Lvalue operators. */
743 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
745 do_chop(TARG, *++MARK);
754 SETi(do_chomp(TOPs));
760 dVAR; dSP; dMARK; dTARGET;
761 register I32 count = 0;
764 count += do_chomp(POPs);
774 if (!PL_op->op_private) {
783 SV_CHECK_THINKFIRST_COW_DROP(sv);
785 switch (SvTYPE(sv)) {
795 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
796 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
797 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
801 /* let user-undef'd sub keep its identity */
802 GV* const gv = CvGV((CV*)sv);
809 SvSetMagicSV(sv, &PL_sv_undef);
814 GvGP(sv) = gp_ref(gp);
816 GvLINE(sv) = CopLINE(PL_curcop);
822 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
837 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
838 DIE(aTHX_ PL_no_modify);
839 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
840 && SvIVX(TOPs) != IV_MIN)
842 SvIV_set(TOPs, SvIVX(TOPs) - 1);
843 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
854 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
855 DIE(aTHX_ PL_no_modify);
856 sv_setsv(TARG, TOPs);
857 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
858 && SvIVX(TOPs) != IV_MAX)
860 SvIV_set(TOPs, SvIVX(TOPs) + 1);
861 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
866 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
876 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
877 DIE(aTHX_ PL_no_modify);
878 sv_setsv(TARG, TOPs);
879 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
880 && SvIVX(TOPs) != IV_MIN)
882 SvIV_set(TOPs, SvIVX(TOPs) - 1);
883 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
892 /* Ordinary operators. */
897 #ifdef PERL_PRESERVE_IVUV
900 tryAMAGICbin(pow,opASSIGN);
901 #ifdef PERL_PRESERVE_IVUV
902 /* For integer to integer power, we do the calculation by hand wherever
903 we're sure it is safe; otherwise we call pow() and try to convert to
904 integer afterwards. */
917 const IV iv = SvIVX(TOPs);
921 goto float_it; /* Can't do negative powers this way. */
925 baseuok = SvUOK(TOPm1s);
927 baseuv = SvUVX(TOPm1s);
929 const IV iv = SvIVX(TOPm1s);
932 baseuok = TRUE; /* effectively it's a UV now */
934 baseuv = -iv; /* abs, baseuok == false records sign */
937 /* now we have integer ** positive integer. */
940 /* foo & (foo - 1) is zero only for a power of 2. */
941 if (!(baseuv & (baseuv - 1))) {
942 /* We are raising power-of-2 to a positive integer.
943 The logic here will work for any base (even non-integer
944 bases) but it can be less accurate than
945 pow (base,power) or exp (power * log (base)) when the
946 intermediate values start to spill out of the mantissa.
947 With powers of 2 we know this can't happen.
948 And powers of 2 are the favourite thing for perl
949 programmers to notice ** not doing what they mean. */
951 NV base = baseuok ? baseuv : -(NV)baseuv;
956 while (power >>= 1) {
967 register unsigned int highbit = 8 * sizeof(UV);
968 register unsigned int diff = 8 * sizeof(UV);
971 if (baseuv >> highbit) {
975 /* we now have baseuv < 2 ** highbit */
976 if (power * highbit <= 8 * sizeof(UV)) {
977 /* result will definitely fit in UV, so use UV math
978 on same algorithm as above */
979 register UV result = 1;
980 register UV base = baseuv;
981 const bool odd_power = (bool)(power & 1);
985 while (power >>= 1) {
992 if (baseuok || !odd_power)
993 /* answer is positive */
995 else if (result <= (UV)IV_MAX)
996 /* answer negative, fits in IV */
998 else if (result == (UV)IV_MIN)
999 /* 2's complement assumption: special case IV_MIN */
1002 /* answer negative, doesn't fit */
1003 SETn( -(NV)result );
1015 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1017 We are building perl with long double support and are on an AIX OS
1018 afflicted with a powl() function that wrongly returns NaNQ for any
1019 negative base. This was reported to IBM as PMR #23047-379 on
1020 03/06/2006. The problem exists in at least the following versions
1021 of AIX and the libm fileset, and no doubt others as well:
1023 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1024 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1025 AIX 5.2.0 bos.adt.libm 5.2.0.85
1027 So, until IBM fixes powl(), we provide the following workaround to
1028 handle the problem ourselves. Our logic is as follows: for
1029 negative bases (left), we use fmod(right, 2) to check if the
1030 exponent is an odd or even integer:
1032 - if odd, powl(left, right) == -powl(-left, right)
1033 - if even, powl(left, right) == powl(-left, right)
1035 If the exponent is not an integer, the result is rightly NaNQ, so
1036 we just return that (as NV_NAN).
1040 NV mod2 = Perl_fmod( right, 2.0 );
1041 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1042 SETn( -Perl_pow( -left, right) );
1043 } else if (mod2 == 0.0) { /* even integer */
1044 SETn( Perl_pow( -left, right) );
1045 } else { /* fractional power */
1049 SETn( Perl_pow( left, right) );
1052 SETn( Perl_pow( left, right) );
1053 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1055 #ifdef PERL_PRESERVE_IVUV
1065 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1066 #ifdef PERL_PRESERVE_IVUV
1069 /* Unless the left argument is integer in range we are going to have to
1070 use NV maths. Hence only attempt to coerce the right argument if
1071 we know the left is integer. */
1072 /* Left operand is defined, so is it IV? */
1073 SvIV_please(TOPm1s);
1074 if (SvIOK(TOPm1s)) {
1075 bool auvok = SvUOK(TOPm1s);
1076 bool buvok = SvUOK(TOPs);
1077 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1078 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1085 alow = SvUVX(TOPm1s);
1087 const IV aiv = SvIVX(TOPm1s);
1090 auvok = TRUE; /* effectively it's a UV now */
1092 alow = -aiv; /* abs, auvok == false records sign */
1098 const IV biv = SvIVX(TOPs);
1101 buvok = TRUE; /* effectively it's a UV now */
1103 blow = -biv; /* abs, buvok == false records sign */
1107 /* If this does sign extension on unsigned it's time for plan B */
1108 ahigh = alow >> (4 * sizeof (UV));
1110 bhigh = blow >> (4 * sizeof (UV));
1112 if (ahigh && bhigh) {
1114 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1115 which is overflow. Drop to NVs below. */
1116 } else if (!ahigh && !bhigh) {
1117 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1118 so the unsigned multiply cannot overflow. */
1119 const UV product = alow * blow;
1120 if (auvok == buvok) {
1121 /* -ve * -ve or +ve * +ve gives a +ve result. */
1125 } else if (product <= (UV)IV_MIN) {
1126 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1127 /* -ve result, which could overflow an IV */
1129 SETi( -(IV)product );
1131 } /* else drop to NVs below. */
1133 /* One operand is large, 1 small */
1136 /* swap the operands */
1138 bhigh = blow; /* bhigh now the temp var for the swap */
1142 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1143 multiplies can't overflow. shift can, add can, -ve can. */
1144 product_middle = ahigh * blow;
1145 if (!(product_middle & topmask)) {
1146 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1148 product_middle <<= (4 * sizeof (UV));
1149 product_low = alow * blow;
1151 /* as for pp_add, UV + something mustn't get smaller.
1152 IIRC ANSI mandates this wrapping *behaviour* for
1153 unsigned whatever the actual representation*/
1154 product_low += product_middle;
1155 if (product_low >= product_middle) {
1156 /* didn't overflow */
1157 if (auvok == buvok) {
1158 /* -ve * -ve or +ve * +ve gives a +ve result. */
1160 SETu( product_low );
1162 } else if (product_low <= (UV)IV_MIN) {
1163 /* 2s complement assumption again */
1164 /* -ve result, which could overflow an IV */
1166 SETi( -(IV)product_low );
1168 } /* else drop to NVs below. */
1170 } /* product_middle too large */
1171 } /* ahigh && bhigh */
1172 } /* SvIOK(TOPm1s) */
1177 SETn( left * right );
1184 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1185 /* Only try to do UV divide first
1186 if ((SLOPPYDIVIDE is true) or
1187 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1189 The assumption is that it is better to use floating point divide
1190 whenever possible, only doing integer divide first if we can't be sure.
1191 If NV_PRESERVES_UV is true then we know at compile time that no UV
1192 can be too large to preserve, so don't need to compile the code to
1193 test the size of UVs. */
1196 # define PERL_TRY_UV_DIVIDE
1197 /* ensure that 20./5. == 4. */
1199 # ifdef PERL_PRESERVE_IVUV
1200 # ifndef NV_PRESERVES_UV
1201 # define PERL_TRY_UV_DIVIDE
1206 #ifdef PERL_TRY_UV_DIVIDE
1209 SvIV_please(TOPm1s);
1210 if (SvIOK(TOPm1s)) {
1211 bool left_non_neg = SvUOK(TOPm1s);
1212 bool right_non_neg = SvUOK(TOPs);
1216 if (right_non_neg) {
1217 right = SvUVX(TOPs);
1220 const IV biv = SvIVX(TOPs);
1223 right_non_neg = TRUE; /* effectively it's a UV now */
1229 /* historically undef()/0 gives a "Use of uninitialized value"
1230 warning before dieing, hence this test goes here.
1231 If it were immediately before the second SvIV_please, then
1232 DIE() would be invoked before left was even inspected, so
1233 no inpsection would give no warning. */
1235 DIE(aTHX_ "Illegal division by zero");
1238 left = SvUVX(TOPm1s);
1241 const IV aiv = SvIVX(TOPm1s);
1244 left_non_neg = TRUE; /* effectively it's a UV now */
1253 /* For sloppy divide we always attempt integer division. */
1255 /* Otherwise we only attempt it if either or both operands
1256 would not be preserved by an NV. If both fit in NVs
1257 we fall through to the NV divide code below. However,
1258 as left >= right to ensure integer result here, we know that
1259 we can skip the test on the right operand - right big
1260 enough not to be preserved can't get here unless left is
1263 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1266 /* Integer division can't overflow, but it can be imprecise. */
1267 const UV result = left / right;
1268 if (result * right == left) {
1269 SP--; /* result is valid */
1270 if (left_non_neg == right_non_neg) {
1271 /* signs identical, result is positive. */
1275 /* 2s complement assumption */
1276 if (result <= (UV)IV_MIN)
1277 SETi( -(IV)result );
1279 /* It's exact but too negative for IV. */
1280 SETn( -(NV)result );
1283 } /* tried integer divide but it was not an integer result */
1284 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1285 } /* left wasn't SvIOK */
1286 } /* right wasn't SvIOK */
1287 #endif /* PERL_TRY_UV_DIVIDE */
1291 DIE(aTHX_ "Illegal division by zero");
1292 PUSHn( left / right );
1299 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1303 bool left_neg = FALSE;
1304 bool right_neg = FALSE;
1305 bool use_double = FALSE;
1306 bool dright_valid = FALSE;
1312 right_neg = !SvUOK(TOPs);
1314 right = SvUVX(POPs);
1316 const IV biv = SvIVX(POPs);
1319 right_neg = FALSE; /* effectively it's a UV now */
1327 right_neg = dright < 0;
1330 if (dright < UV_MAX_P1) {
1331 right = U_V(dright);
1332 dright_valid = TRUE; /* In case we need to use double below. */
1338 /* At this point use_double is only true if right is out of range for
1339 a UV. In range NV has been rounded down to nearest UV and
1340 use_double false. */
1342 if (!use_double && SvIOK(TOPs)) {
1344 left_neg = !SvUOK(TOPs);
1348 const IV aiv = SvIVX(POPs);
1351 left_neg = FALSE; /* effectively it's a UV now */
1360 left_neg = dleft < 0;
1364 /* This should be exactly the 5.6 behaviour - if left and right are
1365 both in range for UV then use U_V() rather than floor. */
1367 if (dleft < UV_MAX_P1) {
1368 /* right was in range, so is dleft, so use UVs not double.
1372 /* left is out of range for UV, right was in range, so promote
1373 right (back) to double. */
1375 /* The +0.5 is used in 5.6 even though it is not strictly
1376 consistent with the implicit +0 floor in the U_V()
1377 inside the #if 1. */
1378 dleft = Perl_floor(dleft + 0.5);
1381 dright = Perl_floor(dright + 0.5);
1391 DIE(aTHX_ "Illegal modulus zero");
1393 dans = Perl_fmod(dleft, dright);
1394 if ((left_neg != right_neg) && dans)
1395 dans = dright - dans;
1398 sv_setnv(TARG, dans);
1404 DIE(aTHX_ "Illegal modulus zero");
1407 if ((left_neg != right_neg) && ans)
1410 /* XXX may warn: unary minus operator applied to unsigned type */
1411 /* could change -foo to be (~foo)+1 instead */
1412 if (ans <= ~((UV)IV_MAX)+1)
1413 sv_setiv(TARG, ~ans+1);
1415 sv_setnv(TARG, -(NV)ans);
1418 sv_setuv(TARG, ans);
1427 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1434 const UV uv = SvUV(sv);
1436 count = IV_MAX; /* The best we can do? */
1440 const IV iv = SvIV(sv);
1447 else if (SvNOKp(sv)) {
1448 const NV nv = SvNV(sv);
1456 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1458 static const char oom_list_extend[] = "Out of memory during list extend";
1459 const I32 items = SP - MARK;
1460 const I32 max = items * count;
1462 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1463 /* Did the max computation overflow? */
1464 if (items > 0 && max > 0 && (max < items || max < count))
1465 Perl_croak(aTHX_ oom_list_extend);
1470 /* This code was intended to fix 20010809.028:
1473 for (($x =~ /./g) x 2) {
1474 print chop; # "abcdabcd" expected as output.
1477 * but that change (#11635) broke this code:
1479 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1481 * I can't think of a better fix that doesn't introduce
1482 * an efficiency hit by copying the SVs. The stack isn't
1483 * refcounted, and mortalisation obviously doesn't
1484 * Do The Right Thing when the stack has more than
1485 * one pointer to the same mortal value.
1489 *SP = sv_2mortal(newSVsv(*SP));
1499 repeatcpy((char*)(MARK + items), (char*)MARK,
1500 items * sizeof(SV*), count - 1);
1503 else if (count <= 0)
1506 else { /* Note: mark already snarfed by pp_list */
1507 SV * const tmpstr = POPs;
1510 static const char oom_string_extend[] =
1511 "Out of memory during string extend";
1513 SvSetSV(TARG, tmpstr);
1514 SvPV_force(TARG, len);
1515 isutf = DO_UTF8(TARG);
1520 const STRLEN max = (UV)count * len;
1521 if (len > ((MEM_SIZE)~0)/count)
1522 Perl_croak(aTHX_ oom_string_extend);
1523 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1524 SvGROW(TARG, max + 1);
1525 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1526 SvCUR_set(TARG, SvCUR(TARG) * count);
1528 *SvEND(TARG) = '\0';
1531 (void)SvPOK_only_UTF8(TARG);
1533 (void)SvPOK_only(TARG);
1535 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1536 /* The parser saw this as a list repeat, and there
1537 are probably several items on the stack. But we're
1538 in scalar context, and there's no pp_list to save us
1539 now. So drop the rest of the items -- robin@kitsite.com
1552 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1553 useleft = USE_LEFT(TOPm1s);
1554 #ifdef PERL_PRESERVE_IVUV
1555 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1556 "bad things" happen if you rely on signed integers wrapping. */
1559 /* Unless the left argument is integer in range we are going to have to
1560 use NV maths. Hence only attempt to coerce the right argument if
1561 we know the left is integer. */
1562 register UV auv = 0;
1568 a_valid = auvok = 1;
1569 /* left operand is undef, treat as zero. */
1571 /* Left operand is defined, so is it IV? */
1572 SvIV_please(TOPm1s);
1573 if (SvIOK(TOPm1s)) {
1574 if ((auvok = SvUOK(TOPm1s)))
1575 auv = SvUVX(TOPm1s);
1577 register const IV aiv = SvIVX(TOPm1s);
1580 auvok = 1; /* Now acting as a sign flag. */
1581 } else { /* 2s complement assumption for IV_MIN */
1589 bool result_good = 0;
1592 bool buvok = SvUOK(TOPs);
1597 register const IV biv = SvIVX(TOPs);
1604 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1605 else "IV" now, independent of how it came in.
1606 if a, b represents positive, A, B negative, a maps to -A etc
1611 all UV maths. negate result if A negative.
1612 subtract if signs same, add if signs differ. */
1614 if (auvok ^ buvok) {
1623 /* Must get smaller */
1628 if (result <= buv) {
1629 /* result really should be -(auv-buv). as its negation
1630 of true value, need to swap our result flag */
1642 if (result <= (UV)IV_MIN)
1643 SETi( -(IV)result );
1645 /* result valid, but out of range for IV. */
1646 SETn( -(NV)result );
1650 } /* Overflow, drop through to NVs. */
1654 useleft = USE_LEFT(TOPm1s);
1658 /* left operand is undef, treat as zero - value */
1662 SETn( TOPn - value );
1669 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1671 const IV shift = POPi;
1672 if (PL_op->op_private & HINT_INTEGER) {
1686 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1688 const IV shift = POPi;
1689 if (PL_op->op_private & HINT_INTEGER) {
1703 dVAR; dSP; tryAMAGICbinSET(lt,0);
1704 #ifdef PERL_PRESERVE_IVUV
1707 SvIV_please(TOPm1s);
1708 if (SvIOK(TOPm1s)) {
1709 bool auvok = SvUOK(TOPm1s);
1710 bool buvok = SvUOK(TOPs);
1712 if (!auvok && !buvok) { /* ## IV < IV ## */
1713 const IV aiv = SvIVX(TOPm1s);
1714 const IV biv = SvIVX(TOPs);
1717 SETs(boolSV(aiv < biv));
1720 if (auvok && buvok) { /* ## UV < UV ## */
1721 const UV auv = SvUVX(TOPm1s);
1722 const UV buv = SvUVX(TOPs);
1725 SETs(boolSV(auv < buv));
1728 if (auvok) { /* ## UV < IV ## */
1730 const IV biv = SvIVX(TOPs);
1733 /* As (a) is a UV, it's >=0, so it cannot be < */
1738 SETs(boolSV(auv < (UV)biv));
1741 { /* ## IV < UV ## */
1742 const IV aiv = SvIVX(TOPm1s);
1746 /* As (b) is a UV, it's >=0, so it must be < */
1753 SETs(boolSV((UV)aiv < buv));
1759 #ifndef NV_PRESERVES_UV
1760 #ifdef PERL_PRESERVE_IVUV
1763 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1765 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1770 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1772 if (Perl_isnan(left) || Perl_isnan(right))
1774 SETs(boolSV(left < right));
1777 SETs(boolSV(TOPn < value));
1785 dVAR; dSP; tryAMAGICbinSET(gt,0);
1786 #ifdef PERL_PRESERVE_IVUV
1789 SvIV_please(TOPm1s);
1790 if (SvIOK(TOPm1s)) {
1791 bool auvok = SvUOK(TOPm1s);
1792 bool buvok = SvUOK(TOPs);
1794 if (!auvok && !buvok) { /* ## IV > IV ## */
1795 const IV aiv = SvIVX(TOPm1s);
1796 const IV biv = SvIVX(TOPs);
1799 SETs(boolSV(aiv > biv));
1802 if (auvok && buvok) { /* ## UV > UV ## */
1803 const UV auv = SvUVX(TOPm1s);
1804 const UV buv = SvUVX(TOPs);
1807 SETs(boolSV(auv > buv));
1810 if (auvok) { /* ## UV > IV ## */
1812 const IV biv = SvIVX(TOPs);
1816 /* As (a) is a UV, it's >=0, so it must be > */
1821 SETs(boolSV(auv > (UV)biv));
1824 { /* ## IV > UV ## */
1825 const IV aiv = SvIVX(TOPm1s);
1829 /* As (b) is a UV, it's >=0, so it cannot be > */
1836 SETs(boolSV((UV)aiv > buv));
1842 #ifndef NV_PRESERVES_UV
1843 #ifdef PERL_PRESERVE_IVUV
1846 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1848 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1853 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1855 if (Perl_isnan(left) || Perl_isnan(right))
1857 SETs(boolSV(left > right));
1860 SETs(boolSV(TOPn > value));
1868 dVAR; dSP; tryAMAGICbinSET(le,0);
1869 #ifdef PERL_PRESERVE_IVUV
1872 SvIV_please(TOPm1s);
1873 if (SvIOK(TOPm1s)) {
1874 bool auvok = SvUOK(TOPm1s);
1875 bool buvok = SvUOK(TOPs);
1877 if (!auvok && !buvok) { /* ## IV <= IV ## */
1878 const IV aiv = SvIVX(TOPm1s);
1879 const IV biv = SvIVX(TOPs);
1882 SETs(boolSV(aiv <= biv));
1885 if (auvok && buvok) { /* ## UV <= UV ## */
1886 UV auv = SvUVX(TOPm1s);
1887 UV buv = SvUVX(TOPs);
1890 SETs(boolSV(auv <= buv));
1893 if (auvok) { /* ## UV <= IV ## */
1895 const IV biv = SvIVX(TOPs);
1899 /* As (a) is a UV, it's >=0, so a cannot be <= */
1904 SETs(boolSV(auv <= (UV)biv));
1907 { /* ## IV <= UV ## */
1908 const IV aiv = SvIVX(TOPm1s);
1912 /* As (b) is a UV, it's >=0, so a must be <= */
1919 SETs(boolSV((UV)aiv <= buv));
1925 #ifndef NV_PRESERVES_UV
1926 #ifdef PERL_PRESERVE_IVUV
1929 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1931 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1936 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1938 if (Perl_isnan(left) || Perl_isnan(right))
1940 SETs(boolSV(left <= right));
1943 SETs(boolSV(TOPn <= value));
1951 dVAR; dSP; tryAMAGICbinSET(ge,0);
1952 #ifdef PERL_PRESERVE_IVUV
1955 SvIV_please(TOPm1s);
1956 if (SvIOK(TOPm1s)) {
1957 bool auvok = SvUOK(TOPm1s);
1958 bool buvok = SvUOK(TOPs);
1960 if (!auvok && !buvok) { /* ## IV >= IV ## */
1961 const IV aiv = SvIVX(TOPm1s);
1962 const IV biv = SvIVX(TOPs);
1965 SETs(boolSV(aiv >= biv));
1968 if (auvok && buvok) { /* ## UV >= UV ## */
1969 const UV auv = SvUVX(TOPm1s);
1970 const UV buv = SvUVX(TOPs);
1973 SETs(boolSV(auv >= buv));
1976 if (auvok) { /* ## UV >= IV ## */
1978 const IV biv = SvIVX(TOPs);
1982 /* As (a) is a UV, it's >=0, so it must be >= */
1987 SETs(boolSV(auv >= (UV)biv));
1990 { /* ## IV >= UV ## */
1991 const IV aiv = SvIVX(TOPm1s);
1995 /* As (b) is a UV, it's >=0, so a cannot be >= */
2002 SETs(boolSV((UV)aiv >= buv));
2008 #ifndef NV_PRESERVES_UV
2009 #ifdef PERL_PRESERVE_IVUV
2012 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2014 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2019 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2021 if (Perl_isnan(left) || Perl_isnan(right))
2023 SETs(boolSV(left >= right));
2026 SETs(boolSV(TOPn >= value));
2034 dVAR; dSP; tryAMAGICbinSET(ne,0);
2035 #ifndef NV_PRESERVES_UV
2036 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2038 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2042 #ifdef PERL_PRESERVE_IVUV
2045 SvIV_please(TOPm1s);
2046 if (SvIOK(TOPm1s)) {
2047 const bool auvok = SvUOK(TOPm1s);
2048 const bool buvok = SvUOK(TOPs);
2050 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2051 /* Casting IV to UV before comparison isn't going to matter
2052 on 2s complement. On 1s complement or sign&magnitude
2053 (if we have any of them) it could make negative zero
2054 differ from normal zero. As I understand it. (Need to
2055 check - is negative zero implementation defined behaviour
2057 const UV buv = SvUVX(POPs);
2058 const UV auv = SvUVX(TOPs);
2060 SETs(boolSV(auv != buv));
2063 { /* ## Mixed IV,UV ## */
2067 /* != is commutative so swap if needed (save code) */
2069 /* swap. top of stack (b) is the iv */
2073 /* As (a) is a UV, it's >0, so it cannot be == */
2082 /* As (b) is a UV, it's >0, so it cannot be == */
2086 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2088 SETs(boolSV((UV)iv != uv));
2095 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2097 if (Perl_isnan(left) || Perl_isnan(right))
2099 SETs(boolSV(left != right));
2102 SETs(boolSV(TOPn != value));
2110 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2111 #ifndef NV_PRESERVES_UV
2112 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2113 const UV right = PTR2UV(SvRV(POPs));
2114 const UV left = PTR2UV(SvRV(TOPs));
2115 SETi((left > right) - (left < right));
2119 #ifdef PERL_PRESERVE_IVUV
2120 /* Fortunately it seems NaN isn't IOK */
2123 SvIV_please(TOPm1s);
2124 if (SvIOK(TOPm1s)) {
2125 const bool leftuvok = SvUOK(TOPm1s);
2126 const bool rightuvok = SvUOK(TOPs);
2128 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2129 const IV leftiv = SvIVX(TOPm1s);
2130 const IV rightiv = SvIVX(TOPs);
2132 if (leftiv > rightiv)
2134 else if (leftiv < rightiv)
2138 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2139 const UV leftuv = SvUVX(TOPm1s);
2140 const UV rightuv = SvUVX(TOPs);
2142 if (leftuv > rightuv)
2144 else if (leftuv < rightuv)
2148 } else if (leftuvok) { /* ## UV <=> IV ## */
2149 const IV rightiv = SvIVX(TOPs);
2151 /* As (a) is a UV, it's >=0, so it cannot be < */
2154 const UV leftuv = SvUVX(TOPm1s);
2155 if (leftuv > (UV)rightiv) {
2157 } else if (leftuv < (UV)rightiv) {
2163 } else { /* ## IV <=> UV ## */
2164 const IV leftiv = SvIVX(TOPm1s);
2166 /* As (b) is a UV, it's >=0, so it must be < */
2169 const UV rightuv = SvUVX(TOPs);
2170 if ((UV)leftiv > rightuv) {
2172 } else if ((UV)leftiv < rightuv) {
2190 if (Perl_isnan(left) || Perl_isnan(right)) {
2194 value = (left > right) - (left < right);
2198 else if (left < right)
2200 else if (left > right)
2216 int amg_type = sle_amg;
2220 switch (PL_op->op_type) {
2239 tryAMAGICbinSET_var(amg_type,0);
2242 const int cmp = (IN_LOCALE_RUNTIME
2243 ? sv_cmp_locale(left, right)
2244 : sv_cmp(left, right));
2245 SETs(boolSV(cmp * multiplier < rhs));
2252 dVAR; dSP; tryAMAGICbinSET(seq,0);
2255 SETs(boolSV(sv_eq(left, right)));
2262 dVAR; dSP; tryAMAGICbinSET(sne,0);
2265 SETs(boolSV(!sv_eq(left, right)));
2272 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2275 const int cmp = (IN_LOCALE_RUNTIME
2276 ? sv_cmp_locale(left, right)
2277 : sv_cmp(left, right));
2285 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2290 if (SvNIOKp(left) || SvNIOKp(right)) {
2291 if (PL_op->op_private & HINT_INTEGER) {
2292 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2296 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2301 do_vop(PL_op->op_type, TARG, left, right);
2310 dVAR; dSP; dATARGET;
2311 const int op_type = PL_op->op_type;
2313 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2318 if (SvNIOKp(left) || SvNIOKp(right)) {
2319 if (PL_op->op_private & HINT_INTEGER) {
2320 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2321 const IV r = SvIV_nomg(right);
2322 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2326 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2327 const UV r = SvUV_nomg(right);
2328 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2333 do_vop(op_type, TARG, left, right);
2342 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2345 const int flags = SvFLAGS(sv);
2347 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2348 /* It's publicly an integer, or privately an integer-not-float */
2351 if (SvIVX(sv) == IV_MIN) {
2352 /* 2s complement assumption. */
2353 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2356 else if (SvUVX(sv) <= IV_MAX) {
2361 else if (SvIVX(sv) != IV_MIN) {
2365 #ifdef PERL_PRESERVE_IVUV
2374 else if (SvPOKp(sv)) {
2376 const char * const s = SvPV_const(sv, len);
2377 if (isIDFIRST(*s)) {
2378 sv_setpvn(TARG, "-", 1);
2381 else if (*s == '+' || *s == '-') {
2383 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2385 else if (DO_UTF8(sv)) {
2388 goto oops_its_an_int;
2390 sv_setnv(TARG, -SvNV(sv));
2392 sv_setpvn(TARG, "-", 1);
2399 goto oops_its_an_int;
2400 sv_setnv(TARG, -SvNV(sv));
2412 dVAR; dSP; tryAMAGICunSET(not);
2413 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2419 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2424 if (PL_op->op_private & HINT_INTEGER) {
2425 const IV i = ~SvIV_nomg(sv);
2429 const UV u = ~SvUV_nomg(sv);
2438 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2439 sv_setsv_nomg(TARG, sv);
2440 tmps = (U8*)SvPV_force(TARG, len);
2443 /* Calculate exact length, let's not estimate. */
2448 U8 * const send = tmps + len;
2449 U8 * const origtmps = tmps;
2450 const UV utf8flags = UTF8_ALLOW_ANYUV;
2452 while (tmps < send) {
2453 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2455 targlen += UNISKIP(~c);
2461 /* Now rewind strings and write them. */
2468 Newx(result, targlen + 1, U8);
2470 while (tmps < send) {
2471 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2473 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2476 sv_usepvn_flags(TARG, (char*)result, targlen,
2477 SV_HAS_TRAILING_NUL);
2484 Newx(result, nchar + 1, U8);
2486 while (tmps < send) {
2487 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2492 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2500 register long *tmpl;
2501 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2504 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2509 for ( ; anum > 0; anum--, tmps++)
2518 /* integer versions of some of the above */
2522 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2525 SETi( left * right );
2533 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2537 DIE(aTHX_ "Illegal division by zero");
2540 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2544 value = num / value;
2553 /* This is the vanilla old i_modulo. */
2554 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2558 DIE(aTHX_ "Illegal modulus zero");
2559 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2563 SETi( left % right );
2568 #if defined(__GLIBC__) && IVSIZE == 8
2572 /* This is the i_modulo with the workaround for the _moddi3 bug
2573 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2574 * See below for pp_i_modulo. */
2575 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2579 DIE(aTHX_ "Illegal modulus zero");
2580 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2584 SETi( left % PERL_ABS(right) );
2592 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2596 DIE(aTHX_ "Illegal modulus zero");
2597 /* The assumption is to use hereafter the old vanilla version... */
2599 PL_ppaddr[OP_I_MODULO] =
2601 /* .. but if we have glibc, we might have a buggy _moddi3
2602 * (at least glicb 2.2.5 is known to have this bug), in other
2603 * words our integer modulus with negative quad as the second
2604 * argument might be broken. Test for this and re-patch the
2605 * opcode dispatch table if that is the case, remembering to
2606 * also apply the workaround so that this first round works
2607 * right, too. See [perl #9402] for more information. */
2608 #if defined(__GLIBC__) && IVSIZE == 8
2612 /* Cannot do this check with inlined IV constants since
2613 * that seems to work correctly even with the buggy glibc. */
2615 /* Yikes, we have the bug.
2616 * Patch in the workaround version. */
2618 PL_ppaddr[OP_I_MODULO] =
2619 &Perl_pp_i_modulo_1;
2620 /* Make certain we work right this time, too. */
2621 right = PERL_ABS(right);
2625 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2629 SETi( left % right );
2636 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2639 SETi( left + right );
2646 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2649 SETi( left - right );
2656 dVAR; dSP; tryAMAGICbinSET(lt,0);
2659 SETs(boolSV(left < right));
2666 dVAR; dSP; tryAMAGICbinSET(gt,0);
2669 SETs(boolSV(left > right));
2676 dVAR; dSP; tryAMAGICbinSET(le,0);
2679 SETs(boolSV(left <= right));
2686 dVAR; dSP; tryAMAGICbinSET(ge,0);
2689 SETs(boolSV(left >= right));
2696 dVAR; dSP; tryAMAGICbinSET(eq,0);
2699 SETs(boolSV(left == right));
2706 dVAR; dSP; tryAMAGICbinSET(ne,0);
2709 SETs(boolSV(left != right));
2716 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2723 else if (left < right)
2734 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2739 /* High falutin' math. */
2743 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2746 SETn(Perl_atan2(left, right));
2754 int amg_type = sin_amg;
2755 const char *neg_report = NULL;
2756 NV (*func)(NV) = Perl_sin;
2757 const int op_type = PL_op->op_type;
2774 amg_type = sqrt_amg;
2776 neg_report = "sqrt";
2780 tryAMAGICun_var(amg_type);
2782 const NV value = POPn;
2784 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2785 SET_NUMERIC_STANDARD();
2786 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2789 XPUSHn(func(value));
2794 /* Support Configure command-line overrides for rand() functions.
2795 After 5.005, perhaps we should replace this by Configure support
2796 for drand48(), random(), or rand(). For 5.005, though, maintain
2797 compatibility by calling rand() but allow the user to override it.
2798 See INSTALL for details. --Andy Dougherty 15 July 1998
2800 /* Now it's after 5.005, and Configure supports drand48() and random(),
2801 in addition to rand(). So the overrides should not be needed any more.
2802 --Jarkko Hietaniemi 27 September 1998
2805 #ifndef HAS_DRAND48_PROTO
2806 extern double drand48 (void);
2819 if (!PL_srand_called) {
2820 (void)seedDrand01((Rand_seed_t)seed());
2821 PL_srand_called = TRUE;
2831 const UV anum = (MAXARG < 1) ? seed() : POPu;
2832 (void)seedDrand01((Rand_seed_t)anum);
2833 PL_srand_called = TRUE;
2840 dVAR; dSP; dTARGET; tryAMAGICun(int);
2842 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2843 /* XXX it's arguable that compiler casting to IV might be subtly
2844 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2845 else preferring IV has introduced a subtle behaviour change bug. OTOH
2846 relying on floating point to be accurate is a bug. */
2850 else if (SvIOK(TOPs)) {
2857 const NV value = TOPn;
2859 if (value < (NV)UV_MAX + 0.5) {
2862 SETn(Perl_floor(value));
2866 if (value > (NV)IV_MIN - 0.5) {
2869 SETn(Perl_ceil(value));
2879 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2881 /* This will cache the NV value if string isn't actually integer */
2886 else if (SvIOK(TOPs)) {
2887 /* IVX is precise */
2889 SETu(TOPu); /* force it to be numeric only */
2897 /* 2s complement assumption. Also, not really needed as
2898 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2904 const NV value = TOPn;
2918 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2922 SV* const sv = POPs;
2924 tmps = (SvPV_const(sv, len));
2926 /* If Unicode, try to downgrade
2927 * If not possible, croak. */
2928 SV* const tsv = sv_2mortal(newSVsv(sv));
2931 sv_utf8_downgrade(tsv, FALSE);
2932 tmps = SvPV_const(tsv, len);
2934 if (PL_op->op_type == OP_HEX)
2937 while (*tmps && len && isSPACE(*tmps))
2943 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2945 else if (*tmps == 'b')
2946 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2948 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2950 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2964 SV * const sv = TOPs;
2967 /* For an overloaded scalar, we can't know in advance if it's going to
2968 be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2969 cache the length. Maybe that should be a documented feature of it.
2972 const char *const p = SvPV_const(sv, len);
2975 SETi(utf8_length((U8*)p, (U8*)p + len));
2981 else if (DO_UTF8(sv))
2982 SETi(sv_len_utf8(sv));
2998 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3000 const I32 arybase = CopARYBASE_get(PL_curcop);
3002 const char *repl = NULL;
3004 const int num_args = PL_op->op_private & 7;
3005 bool repl_need_utf8_upgrade = FALSE;
3006 bool repl_is_utf8 = FALSE;
3008 SvTAINTED_off(TARG); /* decontaminate */
3009 SvUTF8_off(TARG); /* decontaminate */
3013 repl = SvPV_const(repl_sv, repl_len);
3014 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3024 sv_utf8_upgrade(sv);
3026 else if (DO_UTF8(sv))
3027 repl_need_utf8_upgrade = TRUE;
3029 tmps = SvPV_const(sv, curlen);
3031 utf8_curlen = sv_len_utf8(sv);
3032 if (utf8_curlen == curlen)
3035 curlen = utf8_curlen;
3040 if (pos >= arybase) {
3058 else if (len >= 0) {
3060 if (rem > (I32)curlen)
3075 Perl_croak(aTHX_ "substr outside of string");
3076 if (ckWARN(WARN_SUBSTR))
3077 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3081 const I32 upos = pos;
3082 const I32 urem = rem;
3084 sv_pos_u2b(sv, &pos, &rem);
3086 /* we either return a PV or an LV. If the TARG hasn't been used
3087 * before, or is of that type, reuse it; otherwise use a mortal
3088 * instead. Note that LVs can have an extended lifetime, so also
3089 * dont reuse if refcount > 1 (bug #20933) */
3090 if (SvTYPE(TARG) > SVt_NULL) {
3091 if ( (SvTYPE(TARG) == SVt_PVLV)
3092 ? (!lvalue || SvREFCNT(TARG) > 1)
3095 TARG = sv_newmortal();
3099 sv_setpvn(TARG, tmps, rem);
3100 #ifdef USE_LOCALE_COLLATE
3101 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3106 SV* repl_sv_copy = NULL;
3108 if (repl_need_utf8_upgrade) {
3109 repl_sv_copy = newSVsv(repl_sv);
3110 sv_utf8_upgrade(repl_sv_copy);
3111 repl = SvPV_const(repl_sv_copy, repl_len);
3112 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3114 sv_insert(sv, pos, rem, repl, repl_len);
3118 SvREFCNT_dec(repl_sv_copy);
3120 else if (lvalue) { /* it's an lvalue! */
3121 if (!SvGMAGICAL(sv)) {
3123 SvPV_force_nolen(sv);
3124 if (ckWARN(WARN_SUBSTR))
3125 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3126 "Attempt to use reference as lvalue in substr");
3128 if (isGV_with_GP(sv))
3129 SvPV_force_nolen(sv);
3130 else if (SvOK(sv)) /* is it defined ? */
3131 (void)SvPOK_only_UTF8(sv);
3133 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3136 if (SvTYPE(TARG) < SVt_PVLV) {
3137 sv_upgrade(TARG, SVt_PVLV);
3138 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3142 if (LvTARG(TARG) != sv) {
3144 SvREFCNT_dec(LvTARG(TARG));
3145 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3147 LvTARGOFF(TARG) = upos;
3148 LvTARGLEN(TARG) = urem;
3152 PUSHs(TARG); /* avoid SvSETMAGIC here */
3159 register const IV size = POPi;
3160 register const IV offset = POPi;
3161 register SV * const src = POPs;
3162 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3164 SvTAINTED_off(TARG); /* decontaminate */
3165 if (lvalue) { /* it's an lvalue! */
3166 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3167 TARG = sv_newmortal();
3168 if (SvTYPE(TARG) < SVt_PVLV) {
3169 sv_upgrade(TARG, SVt_PVLV);
3170 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3173 if (LvTARG(TARG) != src) {
3175 SvREFCNT_dec(LvTARG(TARG));
3176 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3178 LvTARGOFF(TARG) = offset;
3179 LvTARGLEN(TARG) = size;
3182 sv_setuv(TARG, do_vecget(src, offset, size));
3198 const char *little_p;
3199 const I32 arybase = CopARYBASE_get(PL_curcop);
3202 const bool is_index = PL_op->op_type == OP_INDEX;
3205 /* arybase is in characters, like offset, so combine prior to the
3206 UTF-8 to bytes calculation. */
3207 offset = POPi - arybase;
3211 big_p = SvPV_const(big, biglen);
3212 little_p = SvPV_const(little, llen);
3214 big_utf8 = DO_UTF8(big);
3215 little_utf8 = DO_UTF8(little);
3216 if (big_utf8 ^ little_utf8) {
3217 /* One needs to be upgraded. */
3218 if (little_utf8 && !PL_encoding) {
3219 /* Well, maybe instead we might be able to downgrade the small
3221 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3224 /* If the large string is ISO-8859-1, and it's not possible to
3225 convert the small string to ISO-8859-1, then there is no
3226 way that it could be found anywhere by index. */
3231 /* At this point, pv is a malloc()ed string. So donate it to temp
3232 to ensure it will get free()d */
3233 little = temp = newSV(0);
3234 sv_usepvn(temp, pv, llen);
3235 little_p = SvPVX(little);
3238 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3241 sv_recode_to_utf8(temp, PL_encoding);
3243 sv_utf8_upgrade(temp);
3248 big_p = SvPV_const(big, biglen);
3251 little_p = SvPV_const(little, llen);
3255 if (SvGAMAGIC(big)) {
3256 /* Life just becomes a lot easier if I use a temporary here.
3257 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3258 will trigger magic and overloading again, as will fbm_instr()
3260 big = sv_2mortal(newSVpvn(big_p, biglen));
3265 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3266 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3267 warn on undef, and we've already triggered a warning with the
3268 SvPV_const some lines above. We can't remove that, as we need to
3269 call some SvPV to trigger overloading early and find out if the
3271 This is all getting to messy. The API isn't quite clean enough,
3272 because data access has side effects.
3274 little = sv_2mortal(newSVpvn(little_p, llen));
3277 little_p = SvPVX(little);
3281 offset = is_index ? 0 : biglen;
3283 if (big_utf8 && offset > 0)
3284 sv_pos_u2b(big, &offset, 0);
3290 else if (offset > (I32)biglen)
3292 if (!(little_p = is_index
3293 ? fbm_instr((unsigned char*)big_p + offset,
3294 (unsigned char*)big_p + biglen, little, 0)
3295 : rninstr(big_p, big_p + offset,
3296 little_p, little_p + llen)))
3299 retval = little_p - big_p;
3300 if (retval > 0 && big_utf8)
3301 sv_pos_b2u(big, &retval);
3306 PUSHi(retval + arybase);
3312 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3313 do_sprintf(TARG, SP-MARK, MARK+1);
3314 TAINT_IF(SvTAINTED(TARG));
3326 const U8 *s = (U8*)SvPV_const(argsv, len);
3328 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3329 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3330 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3334 XPUSHu(DO_UTF8(argsv) ?
3335 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3347 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3349 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3351 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3353 (void) POPs; /* Ignore the argument value. */
3354 value = UNICODE_REPLACEMENT;
3360 SvUPGRADE(TARG,SVt_PV);
3362 if (value > 255 && !IN_BYTES) {
3363 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3364 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3365 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3367 (void)SvPOK_only(TARG);
3376 *tmps++ = (char)value;
3378 (void)SvPOK_only(TARG);
3380 if (PL_encoding && !IN_BYTES) {
3381 sv_recode_to_utf8(TARG, PL_encoding);
3383 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3384 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3388 *tmps++ = (char)value;
3404 const char *tmps = SvPV_const(left, len);
3406 if (DO_UTF8(left)) {
3407 /* If Unicode, try to downgrade.
3408 * If not possible, croak.
3409 * Yes, we made this up. */
3410 SV* const tsv = sv_2mortal(newSVsv(left));
3413 sv_utf8_downgrade(tsv, FALSE);
3414 tmps = SvPV_const(tsv, len);
3416 # ifdef USE_ITHREADS
3418 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3419 /* This should be threadsafe because in ithreads there is only
3420 * one thread per interpreter. If this would not be true,
3421 * we would need a mutex to protect this malloc. */
3422 PL_reentrant_buffer->_crypt_struct_buffer =
3423 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3424 #if defined(__GLIBC__) || defined(__EMX__)
3425 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3426 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3427 /* work around glibc-2.2.5 bug */
3428 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3432 # endif /* HAS_CRYPT_R */
3433 # endif /* USE_ITHREADS */
3435 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3437 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3443 "The crypt() function is unimplemented due to excessive paranoia.");
3455 bool inplace = TRUE;
3457 const int op_type = PL_op->op_type;
3460 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3466 s = (const U8*)SvPV_nomg_const(source, slen);
3472 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3474 utf8_to_uvchr(s, &ulen);
3475 if (op_type == OP_UCFIRST) {
3476 toTITLE_utf8(s, tmpbuf, &tculen);
3478 toLOWER_utf8(s, tmpbuf, &tculen);
3480 /* If the two differ, we definately cannot do inplace. */
3481 inplace = (ulen == tculen);
3482 need = slen + 1 - ulen + tculen;
3488 if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3489 /* We can convert in place. */
3492 s = d = (U8*)SvPV_force_nomg(source, slen);
3498 SvUPGRADE(dest, SVt_PV);
3499 d = (U8*)SvGROW(dest, need);
3500 (void)SvPOK_only(dest);
3509 /* slen is the byte length of the whole SV.
3510 * ulen is the byte length of the original Unicode character
3511 * stored as UTF-8 at s.
3512 * tculen is the byte length of the freshly titlecased (or
3513 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3514 * We first set the result to be the titlecased (/lowercased)
3515 * character, and then append the rest of the SV data. */
3516 sv_setpvn(dest, (char*)tmpbuf, tculen);
3518 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3522 Copy(tmpbuf, d, tculen, U8);
3523 SvCUR_set(dest, need - 1);
3528 if (IN_LOCALE_RUNTIME) {
3531 *d = (op_type == OP_UCFIRST)
3532 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3535 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3537 /* See bug #39028 */
3545 /* This will copy the trailing NUL */
3546 Copy(s + 1, d + 1, slen, U8);
3547 SvCUR_set(dest, need - 1);
3554 /* There's so much setup/teardown code common between uc and lc, I wonder if
3555 it would be worth merging the two, and just having a switch outside each
3556 of the three tight loops. */
3570 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3571 && !DO_UTF8(source)) {
3572 /* We can convert in place. */
3575 s = d = (U8*)SvPV_force_nomg(source, len);
3582 /* The old implementation would copy source into TARG at this point.
3583 This had the side effect that if source was undef, TARG was now
3584 an undefined SV with PADTMP set, and they don't warn inside
3585 sv_2pv_flags(). However, we're now getting the PV direct from
3586 source, which doesn't have PADTMP set, so it would warn. Hence the
3590 s = (const U8*)SvPV_nomg_const(source, len);
3597 SvUPGRADE(dest, SVt_PV);
3598 d = (U8*)SvGROW(dest, min);
3599 (void)SvPOK_only(dest);
3604 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3605 to check DO_UTF8 again here. */
3607 if (DO_UTF8(source)) {
3608 const U8 *const send = s + len;
3609 U8 tmpbuf[UTF8_MAXBYTES+1];
3612 const STRLEN u = UTF8SKIP(s);
3615 toUPPER_utf8(s, tmpbuf, &ulen);
3616 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3617 /* If the eventually required minimum size outgrows
3618 * the available space, we need to grow. */
3619 const UV o = d - (U8*)SvPVX_const(dest);
3621 /* If someone uppercases one million U+03B0s we SvGROW() one
3622 * million times. Or we could try guessing how much to
3623 allocate without allocating too much. Such is life. */
3625 d = (U8*)SvPVX(dest) + o;
3627 Copy(tmpbuf, d, ulen, U8);
3633 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3636 const U8 *const send = s + len;
3637 if (IN_LOCALE_RUNTIME) {
3640 for (; s < send; d++, s++)
3641 *d = toUPPER_LC(*s);
3644 for (; s < send; d++, s++)
3648 if (source != dest) {
3650 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3670 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3671 && !DO_UTF8(source)) {
3672 /* We can convert in place. */
3675 s = d = (U8*)SvPV_force_nomg(source, len);
3682 /* The old implementation would copy source into TARG at this point.
3683 This had the side effect that if source was undef, TARG was now
3684 an undefined SV with PADTMP set, and they don't warn inside
3685 sv_2pv_flags(). However, we're now getting the PV direct from
3686 source, which doesn't have PADTMP set, so it would warn. Hence the
3690 s = (const U8*)SvPV_nomg_const(source, len);
3697 SvUPGRADE(dest, SVt_PV);
3698 d = (U8*)SvGROW(dest, min);
3699 (void)SvPOK_only(dest);
3704 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3705 to check DO_UTF8 again here. */
3707 if (DO_UTF8(source)) {
3708 const U8 *const send = s + len;
3709 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3712 const STRLEN u = UTF8SKIP(s);
3714 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3716 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3717 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3720 * Now if the sigma is NOT followed by
3721 * /$ignorable_sequence$cased_letter/;
3722 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3723 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3724 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3725 * then it should be mapped to 0x03C2,
3726 * (GREEK SMALL LETTER FINAL SIGMA),
3727 * instead of staying 0x03A3.
3728 * "should be": in other words, this is not implemented yet.
3729 * See lib/unicore/SpecialCasing.txt.
3732 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3733 /* If the eventually required minimum size outgrows
3734 * the available space, we need to grow. */
3735 const UV o = d - (U8*)SvPVX_const(dest);
3737 /* If someone lowercases one million U+0130s we SvGROW() one
3738 * million times. Or we could try guessing how much to
3739 allocate without allocating too much. Such is life. */
3741 d = (U8*)SvPVX(dest) + o;
3743 Copy(tmpbuf, d, ulen, U8);
3749 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3752 const U8 *const send = s + len;
3753 if (IN_LOCALE_RUNTIME) {
3756 for (; s < send; d++, s++)
3757 *d = toLOWER_LC(*s);
3760 for (; s < send; d++, s++)
3764 if (source != dest) {
3766 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3776 SV * const sv = TOPs;
3778 register const char *s = SvPV_const(sv,len);
3780 SvUTF8_off(TARG); /* decontaminate */
3783 SvUPGRADE(TARG, SVt_PV);
3784 SvGROW(TARG, (len * 2) + 1);
3788 if (UTF8_IS_CONTINUED(*s)) {
3789 STRLEN ulen = UTF8SKIP(s);
3813 SvCUR_set(TARG, d - SvPVX_const(TARG));
3814 (void)SvPOK_only_UTF8(TARG);
3817 sv_setpvn(TARG, s, len);
3819 if (SvSMAGICAL(TARG))
3828 dVAR; dSP; dMARK; dORIGMARK;
3829 register AV* const av = (AV*)POPs;
3830 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3832 if (SvTYPE(av) == SVt_PVAV) {
3833 const I32 arybase = CopARYBASE_get(PL_curcop);
3834 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3837 for (svp = MARK + 1; svp <= SP; svp++) {
3838 const I32 elem = SvIVx(*svp);
3842 if (max > AvMAX(av))
3845 while (++MARK <= SP) {
3847 I32 elem = SvIVx(*MARK);
3851 svp = av_fetch(av, elem, lval);
3853 if (!svp || *svp == &PL_sv_undef)
3854 DIE(aTHX_ PL_no_aelem, elem);
3855 if (PL_op->op_private & OPpLVAL_INTRO)
3856 save_aelem(av, elem, svp);
3858 *MARK = svp ? *svp : &PL_sv_undef;
3861 if (GIMME != G_ARRAY) {
3863 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3869 /* Associative arrays. */
3875 HV * hash = (HV*)POPs;
3877 const I32 gimme = GIMME_V;
3880 /* might clobber stack_sp */
3881 entry = hv_iternext(hash);
3886 SV* const sv = hv_iterkeysv(entry);
3887 PUSHs(sv); /* won't clobber stack_sp */
3888 if (gimme == G_ARRAY) {
3891 /* might clobber stack_sp */
3892 val = hv_iterval(hash, entry);
3897 else if (gimme == G_SCALAR)
3907 const I32 gimme = GIMME_V;
3908 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3910 if (PL_op->op_private & OPpSLICE) {
3912 HV * const hv = (HV*)POPs;
3913 const U32 hvtype = SvTYPE(hv);
3914 if (hvtype == SVt_PVHV) { /* hash element */
3915 while (++MARK <= SP) {
3916 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3917 *MARK = sv ? sv : &PL_sv_undef;
3920 else if (hvtype == SVt_PVAV) { /* array element */
3921 if (PL_op->op_flags & OPf_SPECIAL) {
3922 while (++MARK <= SP) {
3923 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3924 *MARK = sv ? sv : &PL_sv_undef;
3929 DIE(aTHX_ "Not a HASH reference");
3932 else if (gimme == G_SCALAR) {
3937 *++MARK = &PL_sv_undef;
3943 HV * const hv = (HV*)POPs;
3945 if (SvTYPE(hv) == SVt_PVHV)
3946 sv = hv_delete_ent(hv, keysv, discard, 0);
3947 else if (SvTYPE(hv) == SVt_PVAV) {
3948 if (PL_op->op_flags & OPf_SPECIAL)
3949 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3951 DIE(aTHX_ "panic: avhv_delete no longer supported");
3954 DIE(aTHX_ "Not a HASH reference");
3970 if (PL_op->op_private & OPpEXISTS_SUB) {
3972 SV * const sv = POPs;
3973 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3976 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3982 if (SvTYPE(hv) == SVt_PVHV) {
3983 if (hv_exists_ent(hv, tmpsv, 0))
3986 else if (SvTYPE(hv) == SVt_PVAV) {
3987 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3988 if (av_exists((AV*)hv, SvIV(tmpsv)))
3993 DIE(aTHX_ "Not a HASH reference");
4000 dVAR; dSP; dMARK; dORIGMARK;
4001 register HV * const hv = (HV*)POPs;
4002 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4003 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4004 bool other_magic = FALSE;
4010 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4011 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4012 /* Try to preserve the existenceness of a tied hash
4013 * element by using EXISTS and DELETE if possible.
4014 * Fallback to FETCH and STORE otherwise */
4015 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4016 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4017 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4020 while (++MARK <= SP) {
4021 SV * const keysv = *MARK;
4024 bool preeminent = FALSE;
4027 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4028 hv_exists_ent(hv, keysv, 0);
4031 he = hv_fetch_ent(hv, keysv, lval, 0);
4032 svp = he ? &HeVAL(he) : 0;
4035 if (!svp || *svp == &PL_sv_undef) {
4036 DIE(aTHX_ PL_no_helem_sv, keysv);
4039 if (HvNAME_get(hv) && isGV(*svp))
4040 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4043 save_helem(hv, keysv, svp);
4046 const char * const key = SvPV_const(keysv, keylen);
4047 SAVEDELETE(hv, savepvn(key,keylen),
4048 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4053 *MARK = svp ? *svp : &PL_sv_undef;
4055 if (GIMME != G_ARRAY) {
4057 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4063 /* List operators. */
4068 if (GIMME != G_ARRAY) {
4070 *MARK = *SP; /* unwanted list, return last item */
4072 *MARK = &PL_sv_undef;
4082 SV ** const lastrelem = PL_stack_sp;
4083 SV ** const lastlelem = PL_stack_base + POPMARK;
4084 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4085 register SV ** const firstrelem = lastlelem + 1;
4086 const I32 arybase = CopARYBASE_get(PL_curcop);
4087 I32 is_something_there = FALSE;
4089 register const I32 max = lastrelem - lastlelem;
4090 register SV **lelem;
4092 if (GIMME != G_ARRAY) {
4093 I32 ix = SvIVx(*lastlelem);
4098 if (ix < 0 || ix >= max)
4099 *firstlelem = &PL_sv_undef;
4101 *firstlelem = firstrelem[ix];
4107 SP = firstlelem - 1;
4111 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4112 I32 ix = SvIVx(*lelem);
4117 if (ix < 0 || ix >= max)
4118 *lelem = &PL_sv_undef;
4120 is_something_there = TRUE;
4121 if (!(*lelem = firstrelem[ix]))
4122 *lelem = &PL_sv_undef;
4125 if (is_something_there)
4128 SP = firstlelem - 1;
4134 dVAR; dSP; dMARK; dORIGMARK;
4135 const I32 items = SP - MARK;
4136 SV * const av = (SV *) av_make(items, MARK+1);
4137 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4138 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4139 ? newRV_noinc(av) : av));
4145 dVAR; dSP; dMARK; dORIGMARK;
4146 HV* const hv = newHV();
4149 SV * const key = *++MARK;
4150 SV * const val = newSV(0);
4152 sv_setsv(val, *++MARK);
4153 else if (ckWARN(WARN_MISC))
4154 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4155 (void)hv_store_ent(hv,key,val,0);
4158 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4159 ? newRV_noinc((SV*) hv) : (SV*)hv));
4165 dVAR; dSP; dMARK; dORIGMARK;
4166 register AV *ary = (AV*)*++MARK;
4170 register I32 offset;
4171 register I32 length;
4175 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4178 *MARK-- = SvTIED_obj((SV*)ary, mg);
4182 call_method("SPLICE",GIMME_V);
4191 offset = i = SvIVx(*MARK);
4193 offset += AvFILLp(ary) + 1;
4195 offset -= CopARYBASE_get(PL_curcop);
4197 DIE(aTHX_ PL_no_aelem, i);
4199 length = SvIVx(*MARK++);
4201 length += AvFILLp(ary) - offset + 1;
4207 length = AvMAX(ary) + 1; /* close enough to infinity */
4211 length = AvMAX(ary) + 1;
4213 if (offset > AvFILLp(ary) + 1) {
4214 if (ckWARN(WARN_MISC))
4215 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4216 offset = AvFILLp(ary) + 1;
4218 after = AvFILLp(ary) + 1 - (offset + length);
4219 if (after < 0) { /* not that much array */
4220 length += after; /* offset+length now in array */
4226 /* At this point, MARK .. SP-1 is our new LIST */
4229 diff = newlen - length;
4230 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4233 /* make new elements SVs now: avoid problems if they're from the array */
4234 for (dst = MARK, i = newlen; i; i--) {
4235 SV * const h = *dst;
4236 *dst++ = newSVsv(h);
4239 if (diff < 0) { /* shrinking the area */
4240 SV **tmparyval = NULL;
4242 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4243 Copy(MARK, tmparyval, newlen, SV*);
4246 MARK = ORIGMARK + 1;
4247 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4248 MEXTEND(MARK, length);
4249 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4251 EXTEND_MORTAL(length);
4252 for (i = length, dst = MARK; i; i--) {
4253 sv_2mortal(*dst); /* free them eventualy */
4260 *MARK = AvARRAY(ary)[offset+length-1];
4263 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4264 SvREFCNT_dec(*dst++); /* free them now */
4267 AvFILLp(ary) += diff;
4269 /* pull up or down? */
4271 if (offset < after) { /* easier to pull up */
4272 if (offset) { /* esp. if nothing to pull */
4273 src = &AvARRAY(ary)[offset-1];
4274 dst = src - diff; /* diff is negative */
4275 for (i = offset; i > 0; i--) /* can't trust Copy */
4279 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4283 if (after) { /* anything to pull down? */
4284 src = AvARRAY(ary) + offset + length;
4285 dst = src + diff; /* diff is negative */
4286 Move(src, dst, after, SV*);
4288 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4289 /* avoid later double free */
4293 dst[--i] = &PL_sv_undef;
4296 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4297 Safefree(tmparyval);
4300 else { /* no, expanding (or same) */
4301 SV** tmparyval = NULL;
4303 Newx(tmparyval, length, SV*); /* so remember deletion */
4304 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4307 if (diff > 0) { /* expanding */
4308 /* push up or down? */
4309 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4313 Move(src, dst, offset, SV*);
4315 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4317 AvFILLp(ary) += diff;
4320 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4321 av_extend(ary, AvFILLp(ary) + diff);
4322 AvFILLp(ary) += diff;
4325 dst = AvARRAY(ary) + AvFILLp(ary);
4327 for (i = after; i; i--) {
4335 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4338 MARK = ORIGMARK + 1;
4339 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4341 Copy(tmparyval, MARK, length, SV*);
4343 EXTEND_MORTAL(length);
4344 for (i = length, dst = MARK; i; i--) {
4345 sv_2mortal(*dst); /* free them eventualy */
4352 else if (length--) {
4353 *MARK = tmparyval[length];
4356 while (length-- > 0)
4357 SvREFCNT_dec(tmparyval[length]);
4361 *MARK = &PL_sv_undef;
4362 Safefree(tmparyval);
4370 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4371 register AV * const ary = (AV*)*++MARK;
4372 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4375 *MARK-- = SvTIED_obj((SV*)ary, mg);
4379 call_method("PUSH",G_SCALAR|G_DISCARD);
4383 PUSHi( AvFILL(ary) + 1 );
4386 for (++MARK; MARK <= SP; MARK++) {
4387 SV * const sv = newSV(0);
4389 sv_setsv(sv, *MARK);
4390 av_store(ary, AvFILLp(ary)+1, sv);
4393 PUSHi( AvFILLp(ary) + 1 );
4402 AV * const av = (AV*)POPs;
4403 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4407 (void)sv_2mortal(sv);
4414 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4415 register AV *ary = (AV*)*++MARK;
4416 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4419 *MARK-- = SvTIED_obj((SV*)ary, mg);
4423 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4429 av_unshift(ary, SP - MARK);
4431 SV * const sv = newSVsv(*++MARK);
4432 (void)av_store(ary, i++, sv);
4436 PUSHi( AvFILL(ary) + 1 );
4443 SV ** const oldsp = SP;
4445 if (GIMME == G_ARRAY) {
4448 register SV * const tmp = *MARK;
4452 /* safe as long as stack cannot get extended in the above */
4457 register char *down;
4461 PADOFFSET padoff_du;
4463 SvUTF8_off(TARG); /* decontaminate */
4465 do_join(TARG, &PL_sv_no, MARK, SP);
4467 sv_setsv(TARG, (SP > MARK)
4469 : (padoff_du = find_rundefsvoffset(),
4470 (padoff_du == NOT_IN_PAD
4471 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4472 ? DEFSV : PAD_SVl(padoff_du)));
4473 up = SvPV_force(TARG, len);
4475 if (DO_UTF8(TARG)) { /* first reverse each character */
4476 U8* s = (U8*)SvPVX(TARG);
4477 const U8* send = (U8*)(s + len);
4479 if (UTF8_IS_INVARIANT(*s)) {
4484 if (!utf8_to_uvchr(s, 0))
4488 down = (char*)(s - 1);
4489 /* reverse this character */
4493 *down-- = (char)tmp;
4499 down = SvPVX(TARG) + len - 1;
4503 *down-- = (char)tmp;
4505 (void)SvPOK_only_UTF8(TARG);
4517 register IV limit = POPi; /* note, negative is forever */
4518 SV * const sv = POPs;
4520 register const char *s = SvPV_const(sv, len);
4521 const bool do_utf8 = DO_UTF8(sv);
4522 const char *strend = s + len;
4524 register REGEXP *rx;
4526 register const char *m;
4528 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4529 I32 maxiters = slen + 10;
4531 const I32 origlimit = limit;
4534 const I32 gimme = GIMME_V;
4535 const I32 oldsave = PL_savestack_ix;
4536 I32 make_mortal = 1;
4541 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4546 DIE(aTHX_ "panic: pp_split");
4549 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4550 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4552 RX_MATCH_UTF8_set(rx, do_utf8);
4554 if (pm->op_pmreplroot) {
4556 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4558 ary = GvAVn((GV*)pm->op_pmreplroot);
4561 else if (gimme != G_ARRAY)
4562 ary = GvAVn(PL_defgv);
4565 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4571 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4573 XPUSHs(SvTIED_obj((SV*)ary, mg));
4580 for (i = AvFILLp(ary); i >= 0; i--)
4581 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4583 /* temporarily switch stacks */
4584 SAVESWITCHSTACK(PL_curstack, ary);
4588 base = SP - PL_stack_base;
4590 if (pm->op_pmflags & PMf_SKIPWHITE) {
4591 if (pm->op_pmflags & PMf_LOCALE) {
4592 while (isSPACE_LC(*s))
4600 if (pm->op_pmflags & PMf_MULTILINE) {
4605 limit = maxiters + 2;
4606 if (pm->op_pmflags & PMf_WHITE) {
4609 while (m < strend &&
4610 !((pm->op_pmflags & PMf_LOCALE)
4611 ? isSPACE_LC(*m) : isSPACE(*m)))
4616 dstr = newSVpvn(s, m-s);
4620 (void)SvUTF8_on(dstr);
4624 while (s < strend &&
4625 ((pm->op_pmflags & PMf_LOCALE)
4626 ? isSPACE_LC(*s) : isSPACE(*s)))
4630 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4632 for (m = s; m < strend && *m != '\n'; m++)
4637 dstr = newSVpvn(s, m-s);
4641 (void)SvUTF8_on(dstr);
4646 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4647 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4648 && (rx->reganch & ROPT_CHECK_ALL)
4649 && !(rx->reganch & ROPT_ANCH)) {
4650 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4651 SV * const csv = CALLREG_INTUIT_STRING(rx);
4654 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4655 const char c = *SvPV_nolen_const(csv);
4657 for (m = s; m < strend && *m != c; m++)
4661 dstr = newSVpvn(s, m-s);
4665 (void)SvUTF8_on(dstr);
4667 /* The rx->minlen is in characters but we want to step
4668 * s ahead by bytes. */
4670 s = (char*)utf8_hop((U8*)m, len);
4672 s = m + len; /* Fake \n at the end */
4676 while (s < strend && --limit &&
4677 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4678 csv, multiline ? FBMrf_MULTILINE : 0)) )
4680 dstr = newSVpvn(s, m-s);
4684 (void)SvUTF8_on(dstr);
4686 /* The rx->minlen is in characters but we want to step
4687 * s ahead by bytes. */
4689 s = (char*)utf8_hop((U8*)m, len);
4691 s = m + len; /* Fake \n at the end */
4696 maxiters += slen * rx->nparens;
4697 while (s < strend && --limit)
4701 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4704 if (rex_return == 0)
4706 TAINT_IF(RX_MATCH_TAINTED(rx));
4707 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4712 strend = s + (strend - m);
4714 m = rx->startp[0] + orig;
4715 dstr = newSVpvn(s, m-s);
4719 (void)SvUTF8_on(dstr);
4723 for (i = 1; i <= (I32)rx->nparens; i++) {
4724 s = rx->startp[i] + orig;
4725 m = rx->endp[i] + orig;
4727 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4728 parens that didn't match -- they should be set to
4729 undef, not the empty string */
4730 if (m >= orig && s >= orig) {
4731 dstr = newSVpvn(s, m-s);
4734 dstr = &PL_sv_undef; /* undef, not "" */
4738 (void)SvUTF8_on(dstr);
4742 s = rx->endp[0] + orig;
4746 iters = (SP - PL_stack_base) - base;
4747 if (iters > maxiters)
4748 DIE(aTHX_ "Split loop");
4750 /* keep field after final delim? */
4751 if (s < strend || (iters && origlimit)) {
4752 const STRLEN l = strend - s;
4753 dstr = newSVpvn(s, l);
4757 (void)SvUTF8_on(dstr);
4761 else if (!origlimit) {
4762 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4763 if (TOPs && !make_mortal)
4766 *SP-- = &PL_sv_undef;
4771 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4775 if (SvSMAGICAL(ary)) {
4780 if (gimme == G_ARRAY) {
4782 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4790 call_method("PUSH",G_SCALAR|G_DISCARD);
4793 if (gimme == G_ARRAY) {
4795 /* EXTEND should not be needed - we just popped them */
4797 for (i=0; i < iters; i++) {
4798 SV **svp = av_fetch(ary, i, FALSE);
4799 PUSHs((svp) ? *svp : &PL_sv_undef);
4806 if (gimme == G_ARRAY)
4822 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4823 || SvTYPE(retsv) == SVt_PVCV) {
4824 retsv = refto(retsv);
4831 PP(unimplemented_op)
4834 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4840 * c-indentation-style: bsd
4842 * indent-tabs-mode: t
4845 * ex: set ts=8 sts=4 sw=4 noet: