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 * const 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 while (i < MAXO) { /* The slow way. */
407 if (strEQ(s + 6, PL_op_name[i])
408 || strEQ(s + 6, PL_op_desc[i]))
414 goto nonesuch; /* Should not happen... */
416 defgv = PL_opargs[i] & OA_DEFGV;
417 oa = PL_opargs[i] >> OASHIFT;
419 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
423 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
424 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
425 /* But globs are already references (kinda) */
426 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
430 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
433 if (defgv && str[n - 1] == '$')
436 ret = sv_2mortal(newSVpvn(str, n - 1));
438 else if (code) /* Non-Overridable */
440 else { /* None such */
442 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
446 cv = sv_2cv(TOPs, &stash, &gv, 0);
448 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
457 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
459 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
475 if (GIMME != G_ARRAY) {
479 *MARK = &PL_sv_undef;
480 *MARK = refto(*MARK);
484 EXTEND_MORTAL(SP - MARK);
486 *MARK = refto(*MARK);
491 S_refto(pTHX_ SV *sv)
496 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
499 if (!(sv = LvTARG(sv)))
502 SvREFCNT_inc_void_NN(sv);
504 else if (SvTYPE(sv) == SVt_PVAV) {
505 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
508 SvREFCNT_inc_void_NN(sv);
510 else if (SvPADTMP(sv) && !IS_PADGV(sv))
514 SvREFCNT_inc_void_NN(sv);
517 sv_upgrade(rv, SVt_RV);
527 SV * const sv = POPs;
532 if (!sv || !SvROK(sv))
535 pv = sv_reftype(SvRV(sv),TRUE);
536 PUSHp(pv, strlen(pv));
546 stash = CopSTASH(PL_curcop);
548 SV * const ssv = POPs;
552 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
553 Perl_croak(aTHX_ "Attempt to bless into a reference");
554 ptr = SvPV_const(ssv,len);
555 if (len == 0 && ckWARN(WARN_MISC))
556 Perl_warner(aTHX_ packWARN(WARN_MISC),
557 "Explicit blessing to '' (assuming package main)");
558 stash = gv_stashpvn(ptr, len, TRUE);
561 (void)sv_bless(TOPs, stash);
570 const char * const elem = SvPV_nolen_const(sv);
571 GV * const gv = (GV*)POPs;
576 /* elem will always be NUL terminated. */
577 const char * const second_letter = elem + 1;
580 if (strEQ(second_letter, "RRAY"))
581 tmpRef = (SV*)GvAV(gv);
584 if (strEQ(second_letter, "ODE"))
585 tmpRef = (SV*)GvCVu(gv);
588 if (strEQ(second_letter, "ILEHANDLE")) {
589 /* finally deprecated in 5.8.0 */
590 deprecate("*glob{FILEHANDLE}");
591 tmpRef = (SV*)GvIOp(gv);
594 if (strEQ(second_letter, "ORMAT"))
595 tmpRef = (SV*)GvFORM(gv);
598 if (strEQ(second_letter, "LOB"))
602 if (strEQ(second_letter, "ASH"))
603 tmpRef = (SV*)GvHV(gv);
606 if (*second_letter == 'O' && !elem[2])
607 tmpRef = (SV*)GvIOp(gv);
610 if (strEQ(second_letter, "AME"))
611 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
614 if (strEQ(second_letter, "ACKAGE")) {
615 const HV * const stash = GvSTASH(gv);
616 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
617 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
621 if (strEQ(second_letter, "CALAR"))
636 /* Pattern matching */
641 register unsigned char *s;
644 register I32 *sfirst;
648 if (sv == PL_lastscream) {
652 s = (unsigned char*)(SvPV(sv, len));
654 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
655 /* No point in studying a zero length string, and not safe to study
656 anything that doesn't appear to be a simple scalar (and hence might
657 change between now and when the regexp engine runs without our set
658 magic ever running) such as a reference to an object with overloaded
664 SvSCREAM_off(PL_lastscream);
665 SvREFCNT_dec(PL_lastscream);
667 PL_lastscream = SvREFCNT_inc_simple(sv);
669 s = (unsigned char*)(SvPV(sv, len));
673 if (pos > PL_maxscream) {
674 if (PL_maxscream < 0) {
675 PL_maxscream = pos + 80;
676 Newx(PL_screamfirst, 256, I32);
677 Newx(PL_screamnext, PL_maxscream, I32);
680 PL_maxscream = pos + pos / 4;
681 Renew(PL_screamnext, PL_maxscream, I32);
685 sfirst = PL_screamfirst;
686 snext = PL_screamnext;
688 if (!sfirst || !snext)
689 DIE(aTHX_ "do_study: out of memory");
691 for (ch = 256; ch; --ch)
696 register const I32 ch = s[pos];
698 snext[pos] = sfirst[ch] - pos;
705 /* piggyback on m//g magic */
706 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
715 if (PL_op->op_flags & OPf_STACKED)
717 else if (PL_op->op_private & OPpTARGET_MY)
723 TARG = sv_newmortal();
728 /* Lvalue operators. */
740 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
742 do_chop(TARG, *++MARK);
751 SETi(do_chomp(TOPs));
757 dVAR; dSP; dMARK; dTARGET;
758 register I32 count = 0;
761 count += do_chomp(POPs);
771 if (!PL_op->op_private) {
780 SV_CHECK_THINKFIRST_COW_DROP(sv);
782 switch (SvTYPE(sv)) {
792 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
793 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
794 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
798 /* let user-undef'd sub keep its identity */
799 GV* const gv = CvGV((CV*)sv);
806 SvSetMagicSV(sv, &PL_sv_undef);
811 GvGP(sv) = gp_ref(gp);
813 GvLINE(sv) = CopLINE(PL_curcop);
819 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
834 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
835 DIE(aTHX_ PL_no_modify);
836 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
837 && SvIVX(TOPs) != IV_MIN)
839 SvIV_set(TOPs, SvIVX(TOPs) - 1);
840 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
851 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
852 DIE(aTHX_ PL_no_modify);
853 sv_setsv(TARG, TOPs);
854 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
855 && SvIVX(TOPs) != IV_MAX)
857 SvIV_set(TOPs, SvIVX(TOPs) + 1);
858 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
863 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
873 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 sv_setsv(TARG, TOPs);
876 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
877 && SvIVX(TOPs) != IV_MIN)
879 SvIV_set(TOPs, SvIVX(TOPs) - 1);
880 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
889 /* Ordinary operators. */
894 #ifdef PERL_PRESERVE_IVUV
897 tryAMAGICbin(pow,opASSIGN);
898 #ifdef PERL_PRESERVE_IVUV
899 /* For integer to integer power, we do the calculation by hand wherever
900 we're sure it is safe; otherwise we call pow() and try to convert to
901 integer afterwards. */
914 const IV iv = SvIVX(TOPs);
918 goto float_it; /* Can't do negative powers this way. */
922 baseuok = SvUOK(TOPm1s);
924 baseuv = SvUVX(TOPm1s);
926 const IV iv = SvIVX(TOPm1s);
929 baseuok = TRUE; /* effectively it's a UV now */
931 baseuv = -iv; /* abs, baseuok == false records sign */
934 /* now we have integer ** positive integer. */
937 /* foo & (foo - 1) is zero only for a power of 2. */
938 if (!(baseuv & (baseuv - 1))) {
939 /* We are raising power-of-2 to a positive integer.
940 The logic here will work for any base (even non-integer
941 bases) but it can be less accurate than
942 pow (base,power) or exp (power * log (base)) when the
943 intermediate values start to spill out of the mantissa.
944 With powers of 2 we know this can't happen.
945 And powers of 2 are the favourite thing for perl
946 programmers to notice ** not doing what they mean. */
948 NV base = baseuok ? baseuv : -(NV)baseuv;
953 while (power >>= 1) {
964 register unsigned int highbit = 8 * sizeof(UV);
965 register unsigned int diff = 8 * sizeof(UV);
968 if (baseuv >> highbit) {
972 /* we now have baseuv < 2 ** highbit */
973 if (power * highbit <= 8 * sizeof(UV)) {
974 /* result will definitely fit in UV, so use UV math
975 on same algorithm as above */
976 register UV result = 1;
977 register UV base = baseuv;
978 const bool odd_power = (bool)(power & 1);
982 while (power >>= 1) {
989 if (baseuok || !odd_power)
990 /* answer is positive */
992 else if (result <= (UV)IV_MAX)
993 /* answer negative, fits in IV */
995 else if (result == (UV)IV_MIN)
996 /* 2's complement assumption: special case IV_MIN */
999 /* answer negative, doesn't fit */
1000 SETn( -(NV)result );
1012 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1014 We are building perl with long double support and are on an AIX OS
1015 afflicted with a powl() function that wrongly returns NaNQ for any
1016 negative base. This was reported to IBM as PMR #23047-379 on
1017 03/06/2006. The problem exists in at least the following versions
1018 of AIX and the libm fileset, and no doubt others as well:
1020 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1021 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1022 AIX 5.2.0 bos.adt.libm 5.2.0.85
1024 So, until IBM fixes powl(), we provide the following workaround to
1025 handle the problem ourselves. Our logic is as follows: for
1026 negative bases (left), we use fmod(right, 2) to check if the
1027 exponent is an odd or even integer:
1029 - if odd, powl(left, right) == -powl(-left, right)
1030 - if even, powl(left, right) == powl(-left, right)
1032 If the exponent is not an integer, the result is rightly NaNQ, so
1033 we just return that (as NV_NAN).
1037 NV mod2 = Perl_fmod( right, 2.0 );
1038 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1039 SETn( -Perl_pow( -left, right) );
1040 } else if (mod2 == 0.0) { /* even integer */
1041 SETn( Perl_pow( -left, right) );
1042 } else { /* fractional power */
1046 SETn( Perl_pow( left, right) );
1049 SETn( Perl_pow( left, right) );
1050 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1052 #ifdef PERL_PRESERVE_IVUV
1062 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1063 #ifdef PERL_PRESERVE_IVUV
1066 /* Unless the left argument is integer in range we are going to have to
1067 use NV maths. Hence only attempt to coerce the right argument if
1068 we know the left is integer. */
1069 /* Left operand is defined, so is it IV? */
1070 SvIV_please(TOPm1s);
1071 if (SvIOK(TOPm1s)) {
1072 bool auvok = SvUOK(TOPm1s);
1073 bool buvok = SvUOK(TOPs);
1074 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1075 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1082 alow = SvUVX(TOPm1s);
1084 const IV aiv = SvIVX(TOPm1s);
1087 auvok = TRUE; /* effectively it's a UV now */
1089 alow = -aiv; /* abs, auvok == false records sign */
1095 const IV biv = SvIVX(TOPs);
1098 buvok = TRUE; /* effectively it's a UV now */
1100 blow = -biv; /* abs, buvok == false records sign */
1104 /* If this does sign extension on unsigned it's time for plan B */
1105 ahigh = alow >> (4 * sizeof (UV));
1107 bhigh = blow >> (4 * sizeof (UV));
1109 if (ahigh && bhigh) {
1111 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1112 which is overflow. Drop to NVs below. */
1113 } else if (!ahigh && !bhigh) {
1114 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1115 so the unsigned multiply cannot overflow. */
1116 const UV product = alow * blow;
1117 if (auvok == buvok) {
1118 /* -ve * -ve or +ve * +ve gives a +ve result. */
1122 } else if (product <= (UV)IV_MIN) {
1123 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1124 /* -ve result, which could overflow an IV */
1126 SETi( -(IV)product );
1128 } /* else drop to NVs below. */
1130 /* One operand is large, 1 small */
1133 /* swap the operands */
1135 bhigh = blow; /* bhigh now the temp var for the swap */
1139 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1140 multiplies can't overflow. shift can, add can, -ve can. */
1141 product_middle = ahigh * blow;
1142 if (!(product_middle & topmask)) {
1143 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1145 product_middle <<= (4 * sizeof (UV));
1146 product_low = alow * blow;
1148 /* as for pp_add, UV + something mustn't get smaller.
1149 IIRC ANSI mandates this wrapping *behaviour* for
1150 unsigned whatever the actual representation*/
1151 product_low += product_middle;
1152 if (product_low >= product_middle) {
1153 /* didn't overflow */
1154 if (auvok == buvok) {
1155 /* -ve * -ve or +ve * +ve gives a +ve result. */
1157 SETu( product_low );
1159 } else if (product_low <= (UV)IV_MIN) {
1160 /* 2s complement assumption again */
1161 /* -ve result, which could overflow an IV */
1163 SETi( -(IV)product_low );
1165 } /* else drop to NVs below. */
1167 } /* product_middle too large */
1168 } /* ahigh && bhigh */
1169 } /* SvIOK(TOPm1s) */
1174 SETn( left * right );
1181 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1182 /* Only try to do UV divide first
1183 if ((SLOPPYDIVIDE is true) or
1184 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1186 The assumption is that it is better to use floating point divide
1187 whenever possible, only doing integer divide first if we can't be sure.
1188 If NV_PRESERVES_UV is true then we know at compile time that no UV
1189 can be too large to preserve, so don't need to compile the code to
1190 test the size of UVs. */
1193 # define PERL_TRY_UV_DIVIDE
1194 /* ensure that 20./5. == 4. */
1196 # ifdef PERL_PRESERVE_IVUV
1197 # ifndef NV_PRESERVES_UV
1198 # define PERL_TRY_UV_DIVIDE
1203 #ifdef PERL_TRY_UV_DIVIDE
1206 SvIV_please(TOPm1s);
1207 if (SvIOK(TOPm1s)) {
1208 bool left_non_neg = SvUOK(TOPm1s);
1209 bool right_non_neg = SvUOK(TOPs);
1213 if (right_non_neg) {
1214 right = SvUVX(TOPs);
1217 const IV biv = SvIVX(TOPs);
1220 right_non_neg = TRUE; /* effectively it's a UV now */
1226 /* historically undef()/0 gives a "Use of uninitialized value"
1227 warning before dieing, hence this test goes here.
1228 If it were immediately before the second SvIV_please, then
1229 DIE() would be invoked before left was even inspected, so
1230 no inpsection would give no warning. */
1232 DIE(aTHX_ "Illegal division by zero");
1235 left = SvUVX(TOPm1s);
1238 const IV aiv = SvIVX(TOPm1s);
1241 left_non_neg = TRUE; /* effectively it's a UV now */
1250 /* For sloppy divide we always attempt integer division. */
1252 /* Otherwise we only attempt it if either or both operands
1253 would not be preserved by an NV. If both fit in NVs
1254 we fall through to the NV divide code below. However,
1255 as left >= right to ensure integer result here, we know that
1256 we can skip the test on the right operand - right big
1257 enough not to be preserved can't get here unless left is
1260 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1263 /* Integer division can't overflow, but it can be imprecise. */
1264 const UV result = left / right;
1265 if (result * right == left) {
1266 SP--; /* result is valid */
1267 if (left_non_neg == right_non_neg) {
1268 /* signs identical, result is positive. */
1272 /* 2s complement assumption */
1273 if (result <= (UV)IV_MIN)
1274 SETi( -(IV)result );
1276 /* It's exact but too negative for IV. */
1277 SETn( -(NV)result );
1280 } /* tried integer divide but it was not an integer result */
1281 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1282 } /* left wasn't SvIOK */
1283 } /* right wasn't SvIOK */
1284 #endif /* PERL_TRY_UV_DIVIDE */
1288 DIE(aTHX_ "Illegal division by zero");
1289 PUSHn( left / right );
1296 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1300 bool left_neg = FALSE;
1301 bool right_neg = FALSE;
1302 bool use_double = FALSE;
1303 bool dright_valid = FALSE;
1309 right_neg = !SvUOK(TOPs);
1311 right = SvUVX(POPs);
1313 const IV biv = SvIVX(POPs);
1316 right_neg = FALSE; /* effectively it's a UV now */
1324 right_neg = dright < 0;
1327 if (dright < UV_MAX_P1) {
1328 right = U_V(dright);
1329 dright_valid = TRUE; /* In case we need to use double below. */
1335 /* At this point use_double is only true if right is out of range for
1336 a UV. In range NV has been rounded down to nearest UV and
1337 use_double false. */
1339 if (!use_double && SvIOK(TOPs)) {
1341 left_neg = !SvUOK(TOPs);
1345 const IV aiv = SvIVX(POPs);
1348 left_neg = FALSE; /* effectively it's a UV now */
1357 left_neg = dleft < 0;
1361 /* This should be exactly the 5.6 behaviour - if left and right are
1362 both in range for UV then use U_V() rather than floor. */
1364 if (dleft < UV_MAX_P1) {
1365 /* right was in range, so is dleft, so use UVs not double.
1369 /* left is out of range for UV, right was in range, so promote
1370 right (back) to double. */
1372 /* The +0.5 is used in 5.6 even though it is not strictly
1373 consistent with the implicit +0 floor in the U_V()
1374 inside the #if 1. */
1375 dleft = Perl_floor(dleft + 0.5);
1378 dright = Perl_floor(dright + 0.5);
1388 DIE(aTHX_ "Illegal modulus zero");
1390 dans = Perl_fmod(dleft, dright);
1391 if ((left_neg != right_neg) && dans)
1392 dans = dright - dans;
1395 sv_setnv(TARG, dans);
1401 DIE(aTHX_ "Illegal modulus zero");
1404 if ((left_neg != right_neg) && ans)
1407 /* XXX may warn: unary minus operator applied to unsigned type */
1408 /* could change -foo to be (~foo)+1 instead */
1409 if (ans <= ~((UV)IV_MAX)+1)
1410 sv_setiv(TARG, ~ans+1);
1412 sv_setnv(TARG, -(NV)ans);
1415 sv_setuv(TARG, ans);
1424 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1431 const UV uv = SvUV(sv);
1433 count = IV_MAX; /* The best we can do? */
1437 const IV iv = SvIV(sv);
1444 else if (SvNOKp(sv)) {
1445 const NV nv = SvNV(sv);
1453 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1455 static const char oom_list_extend[] = "Out of memory during list extend";
1456 const I32 items = SP - MARK;
1457 const I32 max = items * count;
1459 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1460 /* Did the max computation overflow? */
1461 if (items > 0 && max > 0 && (max < items || max < count))
1462 Perl_croak(aTHX_ oom_list_extend);
1467 /* This code was intended to fix 20010809.028:
1470 for (($x =~ /./g) x 2) {
1471 print chop; # "abcdabcd" expected as output.
1474 * but that change (#11635) broke this code:
1476 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1478 * I can't think of a better fix that doesn't introduce
1479 * an efficiency hit by copying the SVs. The stack isn't
1480 * refcounted, and mortalisation obviously doesn't
1481 * Do The Right Thing when the stack has more than
1482 * one pointer to the same mortal value.
1486 *SP = sv_2mortal(newSVsv(*SP));
1496 repeatcpy((char*)(MARK + items), (char*)MARK,
1497 items * sizeof(SV*), count - 1);
1500 else if (count <= 0)
1503 else { /* Note: mark already snarfed by pp_list */
1504 SV * const tmpstr = POPs;
1507 static const char oom_string_extend[] =
1508 "Out of memory during string extend";
1510 SvSetSV(TARG, tmpstr);
1511 SvPV_force(TARG, len);
1512 isutf = DO_UTF8(TARG);
1517 const STRLEN max = (UV)count * len;
1518 if (len > ((MEM_SIZE)~0)/count)
1519 Perl_croak(aTHX_ oom_string_extend);
1520 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1521 SvGROW(TARG, max + 1);
1522 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1523 SvCUR_set(TARG, SvCUR(TARG) * count);
1525 *SvEND(TARG) = '\0';
1528 (void)SvPOK_only_UTF8(TARG);
1530 (void)SvPOK_only(TARG);
1532 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1533 /* The parser saw this as a list repeat, and there
1534 are probably several items on the stack. But we're
1535 in scalar context, and there's no pp_list to save us
1536 now. So drop the rest of the items -- robin@kitsite.com
1549 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1550 useleft = USE_LEFT(TOPm1s);
1551 #ifdef PERL_PRESERVE_IVUV
1552 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1553 "bad things" happen if you rely on signed integers wrapping. */
1556 /* Unless the left argument is integer in range we are going to have to
1557 use NV maths. Hence only attempt to coerce the right argument if
1558 we know the left is integer. */
1559 register UV auv = 0;
1565 a_valid = auvok = 1;
1566 /* left operand is undef, treat as zero. */
1568 /* Left operand is defined, so is it IV? */
1569 SvIV_please(TOPm1s);
1570 if (SvIOK(TOPm1s)) {
1571 if ((auvok = SvUOK(TOPm1s)))
1572 auv = SvUVX(TOPm1s);
1574 register const IV aiv = SvIVX(TOPm1s);
1577 auvok = 1; /* Now acting as a sign flag. */
1578 } else { /* 2s complement assumption for IV_MIN */
1586 bool result_good = 0;
1589 bool buvok = SvUOK(TOPs);
1594 register const IV biv = SvIVX(TOPs);
1601 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1602 else "IV" now, independent of how it came in.
1603 if a, b represents positive, A, B negative, a maps to -A etc
1608 all UV maths. negate result if A negative.
1609 subtract if signs same, add if signs differ. */
1611 if (auvok ^ buvok) {
1620 /* Must get smaller */
1625 if (result <= buv) {
1626 /* result really should be -(auv-buv). as its negation
1627 of true value, need to swap our result flag */
1639 if (result <= (UV)IV_MIN)
1640 SETi( -(IV)result );
1642 /* result valid, but out of range for IV. */
1643 SETn( -(NV)result );
1647 } /* Overflow, drop through to NVs. */
1651 useleft = USE_LEFT(TOPm1s);
1655 /* left operand is undef, treat as zero - value */
1659 SETn( TOPn - value );
1666 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1668 const IV shift = POPi;
1669 if (PL_op->op_private & HINT_INTEGER) {
1683 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1685 const IV shift = POPi;
1686 if (PL_op->op_private & HINT_INTEGER) {
1700 dVAR; dSP; tryAMAGICbinSET(lt,0);
1701 #ifdef PERL_PRESERVE_IVUV
1704 SvIV_please(TOPm1s);
1705 if (SvIOK(TOPm1s)) {
1706 bool auvok = SvUOK(TOPm1s);
1707 bool buvok = SvUOK(TOPs);
1709 if (!auvok && !buvok) { /* ## IV < IV ## */
1710 const IV aiv = SvIVX(TOPm1s);
1711 const IV biv = SvIVX(TOPs);
1714 SETs(boolSV(aiv < biv));
1717 if (auvok && buvok) { /* ## UV < UV ## */
1718 const UV auv = SvUVX(TOPm1s);
1719 const UV buv = SvUVX(TOPs);
1722 SETs(boolSV(auv < buv));
1725 if (auvok) { /* ## UV < IV ## */
1727 const IV biv = SvIVX(TOPs);
1730 /* As (a) is a UV, it's >=0, so it cannot be < */
1735 SETs(boolSV(auv < (UV)biv));
1738 { /* ## IV < UV ## */
1739 const IV aiv = SvIVX(TOPm1s);
1743 /* As (b) is a UV, it's >=0, so it must be < */
1750 SETs(boolSV((UV)aiv < buv));
1756 #ifndef NV_PRESERVES_UV
1757 #ifdef PERL_PRESERVE_IVUV
1760 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1762 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1767 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1769 if (Perl_isnan(left) || Perl_isnan(right))
1771 SETs(boolSV(left < right));
1774 SETs(boolSV(TOPn < value));
1782 dVAR; dSP; tryAMAGICbinSET(gt,0);
1783 #ifdef PERL_PRESERVE_IVUV
1786 SvIV_please(TOPm1s);
1787 if (SvIOK(TOPm1s)) {
1788 bool auvok = SvUOK(TOPm1s);
1789 bool buvok = SvUOK(TOPs);
1791 if (!auvok && !buvok) { /* ## IV > IV ## */
1792 const IV aiv = SvIVX(TOPm1s);
1793 const IV biv = SvIVX(TOPs);
1796 SETs(boolSV(aiv > biv));
1799 if (auvok && buvok) { /* ## UV > UV ## */
1800 const UV auv = SvUVX(TOPm1s);
1801 const UV buv = SvUVX(TOPs);
1804 SETs(boolSV(auv > buv));
1807 if (auvok) { /* ## UV > IV ## */
1809 const IV biv = SvIVX(TOPs);
1813 /* As (a) is a UV, it's >=0, so it must be > */
1818 SETs(boolSV(auv > (UV)biv));
1821 { /* ## IV > UV ## */
1822 const IV aiv = SvIVX(TOPm1s);
1826 /* As (b) is a UV, it's >=0, so it cannot be > */
1833 SETs(boolSV((UV)aiv > buv));
1839 #ifndef NV_PRESERVES_UV
1840 #ifdef PERL_PRESERVE_IVUV
1843 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1845 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1850 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1852 if (Perl_isnan(left) || Perl_isnan(right))
1854 SETs(boolSV(left > right));
1857 SETs(boolSV(TOPn > value));
1865 dVAR; dSP; tryAMAGICbinSET(le,0);
1866 #ifdef PERL_PRESERVE_IVUV
1869 SvIV_please(TOPm1s);
1870 if (SvIOK(TOPm1s)) {
1871 bool auvok = SvUOK(TOPm1s);
1872 bool buvok = SvUOK(TOPs);
1874 if (!auvok && !buvok) { /* ## IV <= IV ## */
1875 const IV aiv = SvIVX(TOPm1s);
1876 const IV biv = SvIVX(TOPs);
1879 SETs(boolSV(aiv <= biv));
1882 if (auvok && buvok) { /* ## UV <= UV ## */
1883 UV auv = SvUVX(TOPm1s);
1884 UV buv = SvUVX(TOPs);
1887 SETs(boolSV(auv <= buv));
1890 if (auvok) { /* ## UV <= IV ## */
1892 const IV biv = SvIVX(TOPs);
1896 /* As (a) is a UV, it's >=0, so a cannot be <= */
1901 SETs(boolSV(auv <= (UV)biv));
1904 { /* ## IV <= UV ## */
1905 const IV aiv = SvIVX(TOPm1s);
1909 /* As (b) is a UV, it's >=0, so a must be <= */
1916 SETs(boolSV((UV)aiv <= buv));
1922 #ifndef NV_PRESERVES_UV
1923 #ifdef PERL_PRESERVE_IVUV
1926 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1928 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1933 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1935 if (Perl_isnan(left) || Perl_isnan(right))
1937 SETs(boolSV(left <= right));
1940 SETs(boolSV(TOPn <= value));
1948 dVAR; dSP; tryAMAGICbinSET(ge,0);
1949 #ifdef PERL_PRESERVE_IVUV
1952 SvIV_please(TOPm1s);
1953 if (SvIOK(TOPm1s)) {
1954 bool auvok = SvUOK(TOPm1s);
1955 bool buvok = SvUOK(TOPs);
1957 if (!auvok && !buvok) { /* ## IV >= IV ## */
1958 const IV aiv = SvIVX(TOPm1s);
1959 const IV biv = SvIVX(TOPs);
1962 SETs(boolSV(aiv >= biv));
1965 if (auvok && buvok) { /* ## UV >= UV ## */
1966 const UV auv = SvUVX(TOPm1s);
1967 const UV buv = SvUVX(TOPs);
1970 SETs(boolSV(auv >= buv));
1973 if (auvok) { /* ## UV >= IV ## */
1975 const IV biv = SvIVX(TOPs);
1979 /* As (a) is a UV, it's >=0, so it must be >= */
1984 SETs(boolSV(auv >= (UV)biv));
1987 { /* ## IV >= UV ## */
1988 const IV aiv = SvIVX(TOPm1s);
1992 /* As (b) is a UV, it's >=0, so a cannot be >= */
1999 SETs(boolSV((UV)aiv >= buv));
2005 #ifndef NV_PRESERVES_UV
2006 #ifdef PERL_PRESERVE_IVUV
2009 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2011 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2016 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2018 if (Perl_isnan(left) || Perl_isnan(right))
2020 SETs(boolSV(left >= right));
2023 SETs(boolSV(TOPn >= value));
2031 dVAR; dSP; tryAMAGICbinSET(ne,0);
2032 #ifndef NV_PRESERVES_UV
2033 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2035 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2039 #ifdef PERL_PRESERVE_IVUV
2042 SvIV_please(TOPm1s);
2043 if (SvIOK(TOPm1s)) {
2044 const bool auvok = SvUOK(TOPm1s);
2045 const bool buvok = SvUOK(TOPs);
2047 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2048 /* Casting IV to UV before comparison isn't going to matter
2049 on 2s complement. On 1s complement or sign&magnitude
2050 (if we have any of them) it could make negative zero
2051 differ from normal zero. As I understand it. (Need to
2052 check - is negative zero implementation defined behaviour
2054 const UV buv = SvUVX(POPs);
2055 const UV auv = SvUVX(TOPs);
2057 SETs(boolSV(auv != buv));
2060 { /* ## Mixed IV,UV ## */
2064 /* != is commutative so swap if needed (save code) */
2066 /* swap. top of stack (b) is the iv */
2070 /* As (a) is a UV, it's >0, so it cannot be == */
2079 /* As (b) is a UV, it's >0, so it cannot be == */
2083 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2085 SETs(boolSV((UV)iv != uv));
2092 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2094 if (Perl_isnan(left) || Perl_isnan(right))
2096 SETs(boolSV(left != right));
2099 SETs(boolSV(TOPn != value));
2107 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2108 #ifndef NV_PRESERVES_UV
2109 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2110 const UV right = PTR2UV(SvRV(POPs));
2111 const UV left = PTR2UV(SvRV(TOPs));
2112 SETi((left > right) - (left < right));
2116 #ifdef PERL_PRESERVE_IVUV
2117 /* Fortunately it seems NaN isn't IOK */
2120 SvIV_please(TOPm1s);
2121 if (SvIOK(TOPm1s)) {
2122 const bool leftuvok = SvUOK(TOPm1s);
2123 const bool rightuvok = SvUOK(TOPs);
2125 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2126 const IV leftiv = SvIVX(TOPm1s);
2127 const IV rightiv = SvIVX(TOPs);
2129 if (leftiv > rightiv)
2131 else if (leftiv < rightiv)
2135 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2136 const UV leftuv = SvUVX(TOPm1s);
2137 const UV rightuv = SvUVX(TOPs);
2139 if (leftuv > rightuv)
2141 else if (leftuv < rightuv)
2145 } else if (leftuvok) { /* ## UV <=> IV ## */
2146 const IV rightiv = SvIVX(TOPs);
2148 /* As (a) is a UV, it's >=0, so it cannot be < */
2151 const UV leftuv = SvUVX(TOPm1s);
2152 if (leftuv > (UV)rightiv) {
2154 } else if (leftuv < (UV)rightiv) {
2160 } else { /* ## IV <=> UV ## */
2161 const IV leftiv = SvIVX(TOPm1s);
2163 /* As (b) is a UV, it's >=0, so it must be < */
2166 const UV rightuv = SvUVX(TOPs);
2167 if ((UV)leftiv > rightuv) {
2169 } else if ((UV)leftiv < rightuv) {
2187 if (Perl_isnan(left) || Perl_isnan(right)) {
2191 value = (left > right) - (left < right);
2195 else if (left < right)
2197 else if (left > right)
2213 int amg_type = sle_amg;
2217 switch (PL_op->op_type) {
2236 tryAMAGICbinSET_var(amg_type,0);
2239 const int cmp = (IN_LOCALE_RUNTIME
2240 ? sv_cmp_locale(left, right)
2241 : sv_cmp(left, right));
2242 SETs(boolSV(cmp * multiplier < rhs));
2249 dVAR; dSP; tryAMAGICbinSET(seq,0);
2252 SETs(boolSV(sv_eq(left, right)));
2259 dVAR; dSP; tryAMAGICbinSET(sne,0);
2262 SETs(boolSV(!sv_eq(left, right)));
2269 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2272 const int cmp = (IN_LOCALE_RUNTIME
2273 ? sv_cmp_locale(left, right)
2274 : sv_cmp(left, right));
2282 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2287 if (SvNIOKp(left) || SvNIOKp(right)) {
2288 if (PL_op->op_private & HINT_INTEGER) {
2289 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2293 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2298 do_vop(PL_op->op_type, TARG, left, right);
2307 dVAR; dSP; dATARGET;
2308 const int op_type = PL_op->op_type;
2310 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2315 if (SvNIOKp(left) || SvNIOKp(right)) {
2316 if (PL_op->op_private & HINT_INTEGER) {
2317 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2318 const IV r = SvIV_nomg(right);
2319 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2323 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2324 const UV r = SvUV_nomg(right);
2325 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2330 do_vop(op_type, TARG, left, right);
2339 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2342 const int flags = SvFLAGS(sv);
2344 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2345 /* It's publicly an integer, or privately an integer-not-float */
2348 if (SvIVX(sv) == IV_MIN) {
2349 /* 2s complement assumption. */
2350 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2353 else if (SvUVX(sv) <= IV_MAX) {
2358 else if (SvIVX(sv) != IV_MIN) {
2362 #ifdef PERL_PRESERVE_IVUV
2371 else if (SvPOKp(sv)) {
2373 const char * const s = SvPV_const(sv, len);
2374 if (isIDFIRST(*s)) {
2375 sv_setpvn(TARG, "-", 1);
2378 else if (*s == '+' || *s == '-') {
2380 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2382 else if (DO_UTF8(sv)) {
2385 goto oops_its_an_int;
2387 sv_setnv(TARG, -SvNV(sv));
2389 sv_setpvn(TARG, "-", 1);
2396 goto oops_its_an_int;
2397 sv_setnv(TARG, -SvNV(sv));
2409 dVAR; dSP; tryAMAGICunSET(not);
2410 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2416 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2421 if (PL_op->op_private & HINT_INTEGER) {
2422 const IV i = ~SvIV_nomg(sv);
2426 const UV u = ~SvUV_nomg(sv);
2435 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2436 sv_setsv_nomg(TARG, sv);
2437 tmps = (U8*)SvPV_force(TARG, len);
2440 /* Calculate exact length, let's not estimate. */
2445 U8 * const send = tmps + len;
2446 U8 * const origtmps = tmps;
2447 const UV utf8flags = UTF8_ALLOW_ANYUV;
2449 while (tmps < send) {
2450 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2452 targlen += UNISKIP(~c);
2458 /* Now rewind strings and write them. */
2465 Newx(result, targlen + 1, U8);
2467 while (tmps < send) {
2468 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2470 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2473 sv_usepvn_flags(TARG, (char*)result, targlen,
2474 SV_HAS_TRAILING_NUL);
2481 Newx(result, nchar + 1, U8);
2483 while (tmps < send) {
2484 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2489 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2497 register long *tmpl;
2498 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2501 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2506 for ( ; anum > 0; anum--, tmps++)
2515 /* integer versions of some of the above */
2519 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2522 SETi( left * right );
2530 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2534 DIE(aTHX_ "Illegal division by zero");
2537 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2541 value = num / value;
2550 /* This is the vanilla old i_modulo. */
2551 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2555 DIE(aTHX_ "Illegal modulus zero");
2556 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2560 SETi( left % right );
2565 #if defined(__GLIBC__) && IVSIZE == 8
2569 /* This is the i_modulo with the workaround for the _moddi3 bug
2570 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2571 * See below for pp_i_modulo. */
2572 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2576 DIE(aTHX_ "Illegal modulus zero");
2577 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2581 SETi( left % PERL_ABS(right) );
2589 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2593 DIE(aTHX_ "Illegal modulus zero");
2594 /* The assumption is to use hereafter the old vanilla version... */
2596 PL_ppaddr[OP_I_MODULO] =
2598 /* .. but if we have glibc, we might have a buggy _moddi3
2599 * (at least glicb 2.2.5 is known to have this bug), in other
2600 * words our integer modulus with negative quad as the second
2601 * argument might be broken. Test for this and re-patch the
2602 * opcode dispatch table if that is the case, remembering to
2603 * also apply the workaround so that this first round works
2604 * right, too. See [perl #9402] for more information. */
2605 #if defined(__GLIBC__) && IVSIZE == 8
2609 /* Cannot do this check with inlined IV constants since
2610 * that seems to work correctly even with the buggy glibc. */
2612 /* Yikes, we have the bug.
2613 * Patch in the workaround version. */
2615 PL_ppaddr[OP_I_MODULO] =
2616 &Perl_pp_i_modulo_1;
2617 /* Make certain we work right this time, too. */
2618 right = PERL_ABS(right);
2622 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2626 SETi( left % right );
2633 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2636 SETi( left + right );
2643 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2646 SETi( left - right );
2653 dVAR; dSP; tryAMAGICbinSET(lt,0);
2656 SETs(boolSV(left < right));
2663 dVAR; dSP; tryAMAGICbinSET(gt,0);
2666 SETs(boolSV(left > right));
2673 dVAR; dSP; tryAMAGICbinSET(le,0);
2676 SETs(boolSV(left <= right));
2683 dVAR; dSP; tryAMAGICbinSET(ge,0);
2686 SETs(boolSV(left >= right));
2693 dVAR; dSP; tryAMAGICbinSET(eq,0);
2696 SETs(boolSV(left == right));
2703 dVAR; dSP; tryAMAGICbinSET(ne,0);
2706 SETs(boolSV(left != right));
2713 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2720 else if (left < right)
2731 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2736 /* High falutin' math. */
2740 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2743 SETn(Perl_atan2(left, right));
2751 int amg_type = sin_amg;
2752 const char *neg_report = NULL;
2753 NV (*func)(NV) = Perl_sin;
2754 const int op_type = PL_op->op_type;
2771 amg_type = sqrt_amg;
2773 neg_report = "sqrt";
2777 tryAMAGICun_var(amg_type);
2779 const NV value = POPn;
2781 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2782 SET_NUMERIC_STANDARD();
2783 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2786 XPUSHn(func(value));
2791 /* Support Configure command-line overrides for rand() functions.
2792 After 5.005, perhaps we should replace this by Configure support
2793 for drand48(), random(), or rand(). For 5.005, though, maintain
2794 compatibility by calling rand() but allow the user to override it.
2795 See INSTALL for details. --Andy Dougherty 15 July 1998
2797 /* Now it's after 5.005, and Configure supports drand48() and random(),
2798 in addition to rand(). So the overrides should not be needed any more.
2799 --Jarkko Hietaniemi 27 September 1998
2802 #ifndef HAS_DRAND48_PROTO
2803 extern double drand48 (void);
2816 if (!PL_srand_called) {
2817 (void)seedDrand01((Rand_seed_t)seed());
2818 PL_srand_called = TRUE;
2828 const UV anum = (MAXARG < 1) ? seed() : POPu;
2829 (void)seedDrand01((Rand_seed_t)anum);
2830 PL_srand_called = TRUE;
2837 dVAR; dSP; dTARGET; tryAMAGICun(int);
2839 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2840 /* XXX it's arguable that compiler casting to IV might be subtly
2841 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2842 else preferring IV has introduced a subtle behaviour change bug. OTOH
2843 relying on floating point to be accurate is a bug. */
2847 else if (SvIOK(TOPs)) {
2854 const NV value = TOPn;
2856 if (value < (NV)UV_MAX + 0.5) {
2859 SETn(Perl_floor(value));
2863 if (value > (NV)IV_MIN - 0.5) {
2866 SETn(Perl_ceil(value));
2876 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2878 /* This will cache the NV value if string isn't actually integer */
2883 else if (SvIOK(TOPs)) {
2884 /* IVX is precise */
2886 SETu(TOPu); /* force it to be numeric only */
2894 /* 2s complement assumption. Also, not really needed as
2895 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2901 const NV value = TOPn;
2915 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2919 SV* const sv = POPs;
2921 tmps = (SvPV_const(sv, len));
2923 /* If Unicode, try to downgrade
2924 * If not possible, croak. */
2925 SV* const tsv = sv_2mortal(newSVsv(sv));
2928 sv_utf8_downgrade(tsv, FALSE);
2929 tmps = SvPV_const(tsv, len);
2931 if (PL_op->op_type == OP_HEX)
2934 while (*tmps && len && isSPACE(*tmps))
2940 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2942 else if (*tmps == 'b')
2943 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2945 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2947 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2961 SV * const sv = TOPs;
2964 /* For an overloaded scalar, we can't know in advance if it's going to
2965 be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2966 cache the length. Maybe that should be a documented feature of it.
2969 const char *const p = SvPV_const(sv, len);
2972 SETi(utf8_length((U8*)p, (U8*)p + len));
2978 else if (DO_UTF8(sv))
2979 SETi(sv_len_utf8(sv));
2995 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2997 const I32 arybase = CopARYBASE_get(PL_curcop);
2999 const char *repl = NULL;
3001 const int num_args = PL_op->op_private & 7;
3002 bool repl_need_utf8_upgrade = FALSE;
3003 bool repl_is_utf8 = FALSE;
3005 SvTAINTED_off(TARG); /* decontaminate */
3006 SvUTF8_off(TARG); /* decontaminate */
3010 repl = SvPV_const(repl_sv, repl_len);
3011 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3021 sv_utf8_upgrade(sv);
3023 else if (DO_UTF8(sv))
3024 repl_need_utf8_upgrade = TRUE;
3026 tmps = SvPV_const(sv, curlen);
3028 utf8_curlen = sv_len_utf8(sv);
3029 if (utf8_curlen == curlen)
3032 curlen = utf8_curlen;
3037 if (pos >= arybase) {
3055 else if (len >= 0) {
3057 if (rem > (I32)curlen)
3072 Perl_croak(aTHX_ "substr outside of string");
3073 if (ckWARN(WARN_SUBSTR))
3074 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3078 const I32 upos = pos;
3079 const I32 urem = rem;
3081 sv_pos_u2b(sv, &pos, &rem);
3083 /* we either return a PV or an LV. If the TARG hasn't been used
3084 * before, or is of that type, reuse it; otherwise use a mortal
3085 * instead. Note that LVs can have an extended lifetime, so also
3086 * dont reuse if refcount > 1 (bug #20933) */
3087 if (SvTYPE(TARG) > SVt_NULL) {
3088 if ( (SvTYPE(TARG) == SVt_PVLV)
3089 ? (!lvalue || SvREFCNT(TARG) > 1)
3092 TARG = sv_newmortal();
3096 sv_setpvn(TARG, tmps, rem);
3097 #ifdef USE_LOCALE_COLLATE
3098 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3103 SV* repl_sv_copy = NULL;
3105 if (repl_need_utf8_upgrade) {
3106 repl_sv_copy = newSVsv(repl_sv);
3107 sv_utf8_upgrade(repl_sv_copy);
3108 repl = SvPV_const(repl_sv_copy, repl_len);
3109 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3111 sv_insert(sv, pos, rem, repl, repl_len);
3115 SvREFCNT_dec(repl_sv_copy);
3117 else if (lvalue) { /* it's an lvalue! */
3118 if (!SvGMAGICAL(sv)) {
3120 SvPV_force_nolen(sv);
3121 if (ckWARN(WARN_SUBSTR))
3122 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3123 "Attempt to use reference as lvalue in substr");
3125 if (isGV_with_GP(sv))
3126 SvPV_force_nolen(sv);
3127 else if (SvOK(sv)) /* is it defined ? */
3128 (void)SvPOK_only_UTF8(sv);
3130 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3133 if (SvTYPE(TARG) < SVt_PVLV) {
3134 sv_upgrade(TARG, SVt_PVLV);
3135 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3139 if (LvTARG(TARG) != sv) {
3141 SvREFCNT_dec(LvTARG(TARG));
3142 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3144 LvTARGOFF(TARG) = upos;
3145 LvTARGLEN(TARG) = urem;
3149 PUSHs(TARG); /* avoid SvSETMAGIC here */
3156 register const IV size = POPi;
3157 register const IV offset = POPi;
3158 register SV * const src = POPs;
3159 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3161 SvTAINTED_off(TARG); /* decontaminate */
3162 if (lvalue) { /* it's an lvalue! */
3163 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3164 TARG = sv_newmortal();
3165 if (SvTYPE(TARG) < SVt_PVLV) {
3166 sv_upgrade(TARG, SVt_PVLV);
3167 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3170 if (LvTARG(TARG) != src) {
3172 SvREFCNT_dec(LvTARG(TARG));
3173 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3175 LvTARGOFF(TARG) = offset;
3176 LvTARGLEN(TARG) = size;
3179 sv_setuv(TARG, do_vecget(src, offset, size));
3195 const char *little_p;
3196 const I32 arybase = CopARYBASE_get(PL_curcop);
3199 const bool is_index = PL_op->op_type == OP_INDEX;
3202 /* arybase is in characters, like offset, so combine prior to the
3203 UTF-8 to bytes calculation. */
3204 offset = POPi - arybase;
3208 big_p = SvPV_const(big, biglen);
3209 little_p = SvPV_const(little, llen);
3211 big_utf8 = DO_UTF8(big);
3212 little_utf8 = DO_UTF8(little);
3213 if (big_utf8 ^ little_utf8) {
3214 /* One needs to be upgraded. */
3215 if (little_utf8 && !PL_encoding) {
3216 /* Well, maybe instead we might be able to downgrade the small
3218 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3221 /* If the large string is ISO-8859-1, and it's not possible to
3222 convert the small string to ISO-8859-1, then there is no
3223 way that it could be found anywhere by index. */
3228 /* At this point, pv is a malloc()ed string. So donate it to temp
3229 to ensure it will get free()d */
3230 little = temp = newSV(0);
3231 sv_usepvn(temp, pv, llen);
3232 little_p = SvPVX(little);
3235 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3238 sv_recode_to_utf8(temp, PL_encoding);
3240 sv_utf8_upgrade(temp);
3245 big_p = SvPV_const(big, biglen);
3248 little_p = SvPV_const(little, llen);
3252 if (SvGAMAGIC(big)) {
3253 /* Life just becomes a lot easier if I use a temporary here.
3254 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3255 will trigger magic and overloading again, as will fbm_instr()
3257 big = sv_2mortal(newSVpvn(big_p, biglen));
3262 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3263 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3264 warn on undef, and we've already triggered a warning with the
3265 SvPV_const some lines above. We can't remove that, as we need to
3266 call some SvPV to trigger overloading early and find out if the
3268 This is all getting to messy. The API isn't quite clean enough,
3269 because data access has side effects.
3271 little = sv_2mortal(newSVpvn(little_p, llen));
3274 little_p = SvPVX(little);
3278 offset = is_index ? 0 : biglen;
3280 if (big_utf8 && offset > 0)
3281 sv_pos_u2b(big, &offset, 0);
3287 else if (offset > (I32)biglen)
3289 if (!(little_p = is_index
3290 ? fbm_instr((unsigned char*)big_p + offset,
3291 (unsigned char*)big_p + biglen, little, 0)
3292 : rninstr(big_p, big_p + offset,
3293 little_p, little_p + llen)))
3296 retval = little_p - big_p;
3297 if (retval > 0 && big_utf8)
3298 sv_pos_b2u(big, &retval);
3303 PUSHi(retval + arybase);
3309 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3310 do_sprintf(TARG, SP-MARK, MARK+1);
3311 TAINT_IF(SvTAINTED(TARG));
3323 const U8 *s = (U8*)SvPV_const(argsv, len);
3325 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3326 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3327 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3331 XPUSHu(DO_UTF8(argsv) ?
3332 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3344 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3346 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3348 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3350 (void) POPs; /* Ignore the argument value. */
3351 value = UNICODE_REPLACEMENT;
3357 SvUPGRADE(TARG,SVt_PV);
3359 if (value > 255 && !IN_BYTES) {
3360 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3361 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3362 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3364 (void)SvPOK_only(TARG);
3373 *tmps++ = (char)value;
3375 (void)SvPOK_only(TARG);
3377 if (PL_encoding && !IN_BYTES) {
3378 sv_recode_to_utf8(TARG, PL_encoding);
3380 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3381 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3385 *tmps++ = (char)value;
3401 const char *tmps = SvPV_const(left, len);
3403 if (DO_UTF8(left)) {
3404 /* If Unicode, try to downgrade.
3405 * If not possible, croak.
3406 * Yes, we made this up. */
3407 SV* const tsv = sv_2mortal(newSVsv(left));
3410 sv_utf8_downgrade(tsv, FALSE);
3411 tmps = SvPV_const(tsv, len);
3413 # ifdef USE_ITHREADS
3415 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3416 /* This should be threadsafe because in ithreads there is only
3417 * one thread per interpreter. If this would not be true,
3418 * we would need a mutex to protect this malloc. */
3419 PL_reentrant_buffer->_crypt_struct_buffer =
3420 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3421 #if defined(__GLIBC__) || defined(__EMX__)
3422 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3423 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3424 /* work around glibc-2.2.5 bug */
3425 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3429 # endif /* HAS_CRYPT_R */
3430 # endif /* USE_ITHREADS */
3432 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3434 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3440 "The crypt() function is unimplemented due to excessive paranoia.");
3452 bool inplace = TRUE;
3454 const int op_type = PL_op->op_type;
3457 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3463 s = (const U8*)SvPV_nomg_const(source, slen);
3469 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3471 utf8_to_uvchr(s, &ulen);
3472 if (op_type == OP_UCFIRST) {
3473 toTITLE_utf8(s, tmpbuf, &tculen);
3475 toLOWER_utf8(s, tmpbuf, &tculen);
3477 /* If the two differ, we definately cannot do inplace. */
3478 inplace = (ulen == tculen);
3479 need = slen + 1 - ulen + tculen;
3485 if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3486 /* We can convert in place. */
3489 s = d = (U8*)SvPV_force_nomg(source, slen);
3495 SvUPGRADE(dest, SVt_PV);
3496 d = (U8*)SvGROW(dest, need);
3497 (void)SvPOK_only(dest);
3506 /* slen is the byte length of the whole SV.
3507 * ulen is the byte length of the original Unicode character
3508 * stored as UTF-8 at s.
3509 * tculen is the byte length of the freshly titlecased (or
3510 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3511 * We first set the result to be the titlecased (/lowercased)
3512 * character, and then append the rest of the SV data. */
3513 sv_setpvn(dest, (char*)tmpbuf, tculen);
3515 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3519 Copy(tmpbuf, d, tculen, U8);
3520 SvCUR_set(dest, need - 1);
3525 if (IN_LOCALE_RUNTIME) {
3528 *d = (op_type == OP_UCFIRST)
3529 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3532 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3534 /* See bug #39028 */
3542 /* This will copy the trailing NUL */
3543 Copy(s + 1, d + 1, slen, U8);
3544 SvCUR_set(dest, need - 1);
3551 /* There's so much setup/teardown code common between uc and lc, I wonder if
3552 it would be worth merging the two, and just having a switch outside each
3553 of the three tight loops. */
3567 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3568 && !DO_UTF8(source)) {
3569 /* We can convert in place. */
3572 s = d = (U8*)SvPV_force_nomg(source, len);
3579 /* The old implementation would copy source into TARG at this point.
3580 This had the side effect that if source was undef, TARG was now
3581 an undefined SV with PADTMP set, and they don't warn inside
3582 sv_2pv_flags(). However, we're now getting the PV direct from
3583 source, which doesn't have PADTMP set, so it would warn. Hence the
3587 s = (const U8*)SvPV_nomg_const(source, len);
3594 SvUPGRADE(dest, SVt_PV);
3595 d = (U8*)SvGROW(dest, min);
3596 (void)SvPOK_only(dest);
3601 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3602 to check DO_UTF8 again here. */
3604 if (DO_UTF8(source)) {
3605 const U8 *const send = s + len;
3606 U8 tmpbuf[UTF8_MAXBYTES+1];
3609 const STRLEN u = UTF8SKIP(s);
3612 toUPPER_utf8(s, tmpbuf, &ulen);
3613 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3614 /* If the eventually required minimum size outgrows
3615 * the available space, we need to grow. */
3616 const UV o = d - (U8*)SvPVX_const(dest);
3618 /* If someone uppercases one million U+03B0s we SvGROW() one
3619 * million times. Or we could try guessing how much to
3620 allocate without allocating too much. Such is life. */
3622 d = (U8*)SvPVX(dest) + o;
3624 Copy(tmpbuf, d, ulen, U8);
3630 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3633 const U8 *const send = s + len;
3634 if (IN_LOCALE_RUNTIME) {
3637 for (; s < send; d++, s++)
3638 *d = toUPPER_LC(*s);
3641 for (; s < send; d++, s++)
3645 if (source != dest) {
3647 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3667 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3668 && !DO_UTF8(source)) {
3669 /* We can convert in place. */
3672 s = d = (U8*)SvPV_force_nomg(source, len);
3679 /* The old implementation would copy source into TARG at this point.
3680 This had the side effect that if source was undef, TARG was now
3681 an undefined SV with PADTMP set, and they don't warn inside
3682 sv_2pv_flags(). However, we're now getting the PV direct from
3683 source, which doesn't have PADTMP set, so it would warn. Hence the
3687 s = (const U8*)SvPV_nomg_const(source, len);
3694 SvUPGRADE(dest, SVt_PV);
3695 d = (U8*)SvGROW(dest, min);
3696 (void)SvPOK_only(dest);
3701 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3702 to check DO_UTF8 again here. */
3704 if (DO_UTF8(source)) {
3705 const U8 *const send = s + len;
3706 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3709 const STRLEN u = UTF8SKIP(s);
3711 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3713 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3714 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3717 * Now if the sigma is NOT followed by
3718 * /$ignorable_sequence$cased_letter/;
3719 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3720 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3721 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3722 * then it should be mapped to 0x03C2,
3723 * (GREEK SMALL LETTER FINAL SIGMA),
3724 * instead of staying 0x03A3.
3725 * "should be": in other words, this is not implemented yet.
3726 * See lib/unicore/SpecialCasing.txt.
3729 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3730 /* If the eventually required minimum size outgrows
3731 * the available space, we need to grow. */
3732 const UV o = d - (U8*)SvPVX_const(dest);
3734 /* If someone lowercases one million U+0130s we SvGROW() one
3735 * million times. Or we could try guessing how much to
3736 allocate without allocating too much. Such is life. */
3738 d = (U8*)SvPVX(dest) + o;
3740 Copy(tmpbuf, d, ulen, U8);
3746 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3749 const U8 *const send = s + len;
3750 if (IN_LOCALE_RUNTIME) {
3753 for (; s < send; d++, s++)
3754 *d = toLOWER_LC(*s);
3757 for (; s < send; d++, s++)
3761 if (source != dest) {
3763 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3773 SV * const sv = TOPs;
3775 register const char *s = SvPV_const(sv,len);
3777 SvUTF8_off(TARG); /* decontaminate */
3780 SvUPGRADE(TARG, SVt_PV);
3781 SvGROW(TARG, (len * 2) + 1);
3785 if (UTF8_IS_CONTINUED(*s)) {
3786 STRLEN ulen = UTF8SKIP(s);
3810 SvCUR_set(TARG, d - SvPVX_const(TARG));
3811 (void)SvPOK_only_UTF8(TARG);
3814 sv_setpvn(TARG, s, len);
3816 if (SvSMAGICAL(TARG))
3825 dVAR; dSP; dMARK; dORIGMARK;
3826 register AV* const av = (AV*)POPs;
3827 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3829 if (SvTYPE(av) == SVt_PVAV) {
3830 const I32 arybase = CopARYBASE_get(PL_curcop);
3831 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3834 for (svp = MARK + 1; svp <= SP; svp++) {
3835 const I32 elem = SvIVx(*svp);
3839 if (max > AvMAX(av))
3842 while (++MARK <= SP) {
3844 I32 elem = SvIVx(*MARK);
3848 svp = av_fetch(av, elem, lval);
3850 if (!svp || *svp == &PL_sv_undef)
3851 DIE(aTHX_ PL_no_aelem, elem);
3852 if (PL_op->op_private & OPpLVAL_INTRO)
3853 save_aelem(av, elem, svp);
3855 *MARK = svp ? *svp : &PL_sv_undef;
3858 if (GIMME != G_ARRAY) {
3860 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3866 /* Associative arrays. */
3872 HV * hash = (HV*)POPs;
3874 const I32 gimme = GIMME_V;
3877 /* might clobber stack_sp */
3878 entry = hv_iternext(hash);
3883 SV* const sv = hv_iterkeysv(entry);
3884 PUSHs(sv); /* won't clobber stack_sp */
3885 if (gimme == G_ARRAY) {
3888 /* might clobber stack_sp */
3889 val = hv_iterval(hash, entry);
3894 else if (gimme == G_SCALAR)
3904 const I32 gimme = GIMME_V;
3905 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3907 if (PL_op->op_private & OPpSLICE) {
3909 HV * const hv = (HV*)POPs;
3910 const U32 hvtype = SvTYPE(hv);
3911 if (hvtype == SVt_PVHV) { /* hash element */
3912 while (++MARK <= SP) {
3913 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3914 *MARK = sv ? sv : &PL_sv_undef;
3917 else if (hvtype == SVt_PVAV) { /* array element */
3918 if (PL_op->op_flags & OPf_SPECIAL) {
3919 while (++MARK <= SP) {
3920 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3921 *MARK = sv ? sv : &PL_sv_undef;
3926 DIE(aTHX_ "Not a HASH reference");
3929 else if (gimme == G_SCALAR) {
3934 *++MARK = &PL_sv_undef;
3940 HV * const hv = (HV*)POPs;
3942 if (SvTYPE(hv) == SVt_PVHV)
3943 sv = hv_delete_ent(hv, keysv, discard, 0);
3944 else if (SvTYPE(hv) == SVt_PVAV) {
3945 if (PL_op->op_flags & OPf_SPECIAL)
3946 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3948 DIE(aTHX_ "panic: avhv_delete no longer supported");
3951 DIE(aTHX_ "Not a HASH reference");
3967 if (PL_op->op_private & OPpEXISTS_SUB) {
3969 SV * const sv = POPs;
3970 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3973 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3979 if (SvTYPE(hv) == SVt_PVHV) {
3980 if (hv_exists_ent(hv, tmpsv, 0))
3983 else if (SvTYPE(hv) == SVt_PVAV) {
3984 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3985 if (av_exists((AV*)hv, SvIV(tmpsv)))
3990 DIE(aTHX_ "Not a HASH reference");
3997 dVAR; dSP; dMARK; dORIGMARK;
3998 register HV * const hv = (HV*)POPs;
3999 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4000 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4001 bool other_magic = FALSE;
4007 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4008 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4009 /* Try to preserve the existenceness of a tied hash
4010 * element by using EXISTS and DELETE if possible.
4011 * Fallback to FETCH and STORE otherwise */
4012 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4013 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4014 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4017 while (++MARK <= SP) {
4018 SV * const keysv = *MARK;
4021 bool preeminent = FALSE;
4024 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4025 hv_exists_ent(hv, keysv, 0);
4028 he = hv_fetch_ent(hv, keysv, lval, 0);
4029 svp = he ? &HeVAL(he) : 0;
4032 if (!svp || *svp == &PL_sv_undef) {
4033 DIE(aTHX_ PL_no_helem_sv, keysv);
4036 if (HvNAME_get(hv) && isGV(*svp))
4037 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4040 save_helem(hv, keysv, svp);
4043 const char * const key = SvPV_const(keysv, keylen);
4044 SAVEDELETE(hv, savepvn(key,keylen),
4045 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4050 *MARK = svp ? *svp : &PL_sv_undef;
4052 if (GIMME != G_ARRAY) {
4054 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4060 /* List operators. */
4065 if (GIMME != G_ARRAY) {
4067 *MARK = *SP; /* unwanted list, return last item */
4069 *MARK = &PL_sv_undef;
4079 SV ** const lastrelem = PL_stack_sp;
4080 SV ** const lastlelem = PL_stack_base + POPMARK;
4081 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4082 register SV ** const firstrelem = lastlelem + 1;
4083 const I32 arybase = CopARYBASE_get(PL_curcop);
4084 I32 is_something_there = FALSE;
4086 register const I32 max = lastrelem - lastlelem;
4087 register SV **lelem;
4089 if (GIMME != G_ARRAY) {
4090 I32 ix = SvIVx(*lastlelem);
4095 if (ix < 0 || ix >= max)
4096 *firstlelem = &PL_sv_undef;
4098 *firstlelem = firstrelem[ix];
4104 SP = firstlelem - 1;
4108 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4109 I32 ix = SvIVx(*lelem);
4114 if (ix < 0 || ix >= max)
4115 *lelem = &PL_sv_undef;
4117 is_something_there = TRUE;
4118 if (!(*lelem = firstrelem[ix]))
4119 *lelem = &PL_sv_undef;
4122 if (is_something_there)
4125 SP = firstlelem - 1;
4131 dVAR; dSP; dMARK; dORIGMARK;
4132 const I32 items = SP - MARK;
4133 SV * const av = (SV *) av_make(items, MARK+1);
4134 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4135 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4136 ? newRV_noinc(av) : av));
4142 dVAR; dSP; dMARK; dORIGMARK;
4143 HV* const hv = newHV();
4146 SV * const key = *++MARK;
4147 SV * const val = newSV(0);
4149 sv_setsv(val, *++MARK);
4150 else if (ckWARN(WARN_MISC))
4151 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4152 (void)hv_store_ent(hv,key,val,0);
4155 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4156 ? newRV_noinc((SV*) hv) : (SV*)hv));
4162 dVAR; dSP; dMARK; dORIGMARK;
4163 register AV *ary = (AV*)*++MARK;
4167 register I32 offset;
4168 register I32 length;
4172 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4175 *MARK-- = SvTIED_obj((SV*)ary, mg);
4179 call_method("SPLICE",GIMME_V);
4188 offset = i = SvIVx(*MARK);
4190 offset += AvFILLp(ary) + 1;
4192 offset -= CopARYBASE_get(PL_curcop);
4194 DIE(aTHX_ PL_no_aelem, i);
4196 length = SvIVx(*MARK++);
4198 length += AvFILLp(ary) - offset + 1;
4204 length = AvMAX(ary) + 1; /* close enough to infinity */
4208 length = AvMAX(ary) + 1;
4210 if (offset > AvFILLp(ary) + 1) {
4211 if (ckWARN(WARN_MISC))
4212 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4213 offset = AvFILLp(ary) + 1;
4215 after = AvFILLp(ary) + 1 - (offset + length);
4216 if (after < 0) { /* not that much array */
4217 length += after; /* offset+length now in array */
4223 /* At this point, MARK .. SP-1 is our new LIST */
4226 diff = newlen - length;
4227 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4230 /* make new elements SVs now: avoid problems if they're from the array */
4231 for (dst = MARK, i = newlen; i; i--) {
4232 SV * const h = *dst;
4233 *dst++ = newSVsv(h);
4236 if (diff < 0) { /* shrinking the area */
4237 SV **tmparyval = NULL;
4239 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4240 Copy(MARK, tmparyval, newlen, SV*);
4243 MARK = ORIGMARK + 1;
4244 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4245 MEXTEND(MARK, length);
4246 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4248 EXTEND_MORTAL(length);
4249 for (i = length, dst = MARK; i; i--) {
4250 sv_2mortal(*dst); /* free them eventualy */
4257 *MARK = AvARRAY(ary)[offset+length-1];
4260 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4261 SvREFCNT_dec(*dst++); /* free them now */
4264 AvFILLp(ary) += diff;
4266 /* pull up or down? */
4268 if (offset < after) { /* easier to pull up */
4269 if (offset) { /* esp. if nothing to pull */
4270 src = &AvARRAY(ary)[offset-1];
4271 dst = src - diff; /* diff is negative */
4272 for (i = offset; i > 0; i--) /* can't trust Copy */
4276 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4280 if (after) { /* anything to pull down? */
4281 src = AvARRAY(ary) + offset + length;
4282 dst = src + diff; /* diff is negative */
4283 Move(src, dst, after, SV*);
4285 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4286 /* avoid later double free */
4290 dst[--i] = &PL_sv_undef;
4293 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4294 Safefree(tmparyval);
4297 else { /* no, expanding (or same) */
4298 SV** tmparyval = NULL;
4300 Newx(tmparyval, length, SV*); /* so remember deletion */
4301 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4304 if (diff > 0) { /* expanding */
4305 /* push up or down? */
4306 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4310 Move(src, dst, offset, SV*);
4312 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4314 AvFILLp(ary) += diff;
4317 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4318 av_extend(ary, AvFILLp(ary) + diff);
4319 AvFILLp(ary) += diff;
4322 dst = AvARRAY(ary) + AvFILLp(ary);
4324 for (i = after; i; i--) {
4332 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4335 MARK = ORIGMARK + 1;
4336 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4338 Copy(tmparyval, MARK, length, SV*);
4340 EXTEND_MORTAL(length);
4341 for (i = length, dst = MARK; i; i--) {
4342 sv_2mortal(*dst); /* free them eventualy */
4349 else if (length--) {
4350 *MARK = tmparyval[length];
4353 while (length-- > 0)
4354 SvREFCNT_dec(tmparyval[length]);
4358 *MARK = &PL_sv_undef;
4359 Safefree(tmparyval);
4367 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4368 register AV * const ary = (AV*)*++MARK;
4369 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4372 *MARK-- = SvTIED_obj((SV*)ary, mg);
4376 call_method("PUSH",G_SCALAR|G_DISCARD);
4380 PUSHi( AvFILL(ary) + 1 );
4383 for (++MARK; MARK <= SP; MARK++) {
4384 SV * const sv = newSV(0);
4386 sv_setsv(sv, *MARK);
4387 av_store(ary, AvFILLp(ary)+1, sv);
4390 PUSHi( AvFILLp(ary) + 1 );
4399 AV * const av = (AV*)POPs;
4400 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4404 (void)sv_2mortal(sv);
4411 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4412 register AV *ary = (AV*)*++MARK;
4413 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4416 *MARK-- = SvTIED_obj((SV*)ary, mg);
4420 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4426 av_unshift(ary, SP - MARK);
4428 SV * const sv = newSVsv(*++MARK);
4429 (void)av_store(ary, i++, sv);
4433 PUSHi( AvFILL(ary) + 1 );
4440 SV ** const oldsp = SP;
4442 if (GIMME == G_ARRAY) {
4445 register SV * const tmp = *MARK;
4449 /* safe as long as stack cannot get extended in the above */
4454 register char *down;
4458 PADOFFSET padoff_du;
4460 SvUTF8_off(TARG); /* decontaminate */
4462 do_join(TARG, &PL_sv_no, MARK, SP);
4464 sv_setsv(TARG, (SP > MARK)
4466 : (padoff_du = find_rundefsvoffset(),
4467 (padoff_du == NOT_IN_PAD
4468 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4469 ? DEFSV : PAD_SVl(padoff_du)));
4470 up = SvPV_force(TARG, len);
4472 if (DO_UTF8(TARG)) { /* first reverse each character */
4473 U8* s = (U8*)SvPVX(TARG);
4474 const U8* send = (U8*)(s + len);
4476 if (UTF8_IS_INVARIANT(*s)) {
4481 if (!utf8_to_uvchr(s, 0))
4485 down = (char*)(s - 1);
4486 /* reverse this character */
4490 *down-- = (char)tmp;
4496 down = SvPVX(TARG) + len - 1;
4500 *down-- = (char)tmp;
4502 (void)SvPOK_only_UTF8(TARG);
4514 register IV limit = POPi; /* note, negative is forever */
4515 SV * const sv = POPs;
4517 register const char *s = SvPV_const(sv, len);
4518 const bool do_utf8 = DO_UTF8(sv);
4519 const char *strend = s + len;
4521 register REGEXP *rx;
4523 register const char *m;
4525 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4526 I32 maxiters = slen + 10;
4528 const I32 origlimit = limit;
4531 const I32 gimme = GIMME_V;
4532 const I32 oldsave = PL_savestack_ix;
4533 I32 make_mortal = 1;
4538 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4543 DIE(aTHX_ "panic: pp_split");
4546 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4547 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4549 RX_MATCH_UTF8_set(rx, do_utf8);
4551 if (pm->op_pmreplroot) {
4553 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4555 ary = GvAVn((GV*)pm->op_pmreplroot);
4558 else if (gimme != G_ARRAY)
4559 ary = GvAVn(PL_defgv);
4562 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4568 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4570 XPUSHs(SvTIED_obj((SV*)ary, mg));
4577 for (i = AvFILLp(ary); i >= 0; i--)
4578 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4580 /* temporarily switch stacks */
4581 SAVESWITCHSTACK(PL_curstack, ary);
4585 base = SP - PL_stack_base;
4587 if (pm->op_pmflags & PMf_SKIPWHITE) {
4588 if (pm->op_pmflags & PMf_LOCALE) {
4589 while (isSPACE_LC(*s))
4597 if (pm->op_pmflags & PMf_MULTILINE) {
4602 limit = maxiters + 2;
4603 if (pm->op_pmflags & PMf_WHITE) {
4606 while (m < strend &&
4607 !((pm->op_pmflags & PMf_LOCALE)
4608 ? isSPACE_LC(*m) : isSPACE(*m)))
4613 dstr = newSVpvn(s, m-s);
4617 (void)SvUTF8_on(dstr);
4621 while (s < strend &&
4622 ((pm->op_pmflags & PMf_LOCALE)
4623 ? isSPACE_LC(*s) : isSPACE(*s)))
4627 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4629 for (m = s; m < strend && *m != '\n'; m++)
4634 dstr = newSVpvn(s, m-s);
4638 (void)SvUTF8_on(dstr);
4643 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4644 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4645 && (rx->reganch & ROPT_CHECK_ALL)
4646 && !(rx->reganch & ROPT_ANCH)) {
4647 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4648 SV * const csv = CALLREG_INTUIT_STRING(rx);
4651 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4652 const char c = *SvPV_nolen_const(csv);
4654 for (m = s; m < strend && *m != c; m++)
4658 dstr = newSVpvn(s, m-s);
4662 (void)SvUTF8_on(dstr);
4664 /* The rx->minlen is in characters but we want to step
4665 * s ahead by bytes. */
4667 s = (char*)utf8_hop((U8*)m, len);
4669 s = m + len; /* Fake \n at the end */
4673 while (s < strend && --limit &&
4674 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4675 csv, multiline ? FBMrf_MULTILINE : 0)) )
4677 dstr = newSVpvn(s, m-s);
4681 (void)SvUTF8_on(dstr);
4683 /* The rx->minlen is in characters but we want to step
4684 * s ahead by bytes. */
4686 s = (char*)utf8_hop((U8*)m, len);
4688 s = m + len; /* Fake \n at the end */
4693 maxiters += slen * rx->nparens;
4694 while (s < strend && --limit)
4698 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4701 if (rex_return == 0)
4703 TAINT_IF(RX_MATCH_TAINTED(rx));
4704 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4709 strend = s + (strend - m);
4711 m = rx->startp[0] + orig;
4712 dstr = newSVpvn(s, m-s);
4716 (void)SvUTF8_on(dstr);
4720 for (i = 1; i <= (I32)rx->nparens; i++) {
4721 s = rx->startp[i] + orig;
4722 m = rx->endp[i] + orig;
4724 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4725 parens that didn't match -- they should be set to
4726 undef, not the empty string */
4727 if (m >= orig && s >= orig) {
4728 dstr = newSVpvn(s, m-s);
4731 dstr = &PL_sv_undef; /* undef, not "" */
4735 (void)SvUTF8_on(dstr);
4739 s = rx->endp[0] + orig;
4743 iters = (SP - PL_stack_base) - base;
4744 if (iters > maxiters)
4745 DIE(aTHX_ "Split loop");
4747 /* keep field after final delim? */
4748 if (s < strend || (iters && origlimit)) {
4749 const STRLEN l = strend - s;
4750 dstr = newSVpvn(s, l);
4754 (void)SvUTF8_on(dstr);
4758 else if (!origlimit) {
4759 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4760 if (TOPs && !make_mortal)
4763 *SP-- = &PL_sv_undef;
4768 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4772 if (SvSMAGICAL(ary)) {
4777 if (gimme == G_ARRAY) {
4779 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4787 call_method("PUSH",G_SCALAR|G_DISCARD);
4790 if (gimme == G_ARRAY) {
4792 /* EXTEND should not be needed - we just popped them */
4794 for (i=0; i < iters; i++) {
4795 SV **svp = av_fetch(ary, i, FALSE);
4796 PUSHs((svp) ? *svp : &PL_sv_undef);
4803 if (gimme == G_ARRAY)
4819 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4820 || SvTYPE(retsv) == SVt_PVCV) {
4821 retsv = refto(retsv);
4828 PP(unimplemented_op)
4831 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4837 * c-indentation-style: bsd
4839 * indent-tabs-mode: t
4842 * ex: set ts=8 sts=4 sw=4 noet: