3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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));
225 /* Helper function for pp_rv2sv and pp_rv2av */
227 Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type,
233 if (PL_op->op_private & HINT_STRICT_REFS) {
235 Perl_die(aTHX_ PL_no_symref_sv, sv, what);
237 Perl_die(aTHX_ PL_no_usym, what);
240 if (PL_op->op_flags & OPf_REF)
241 Perl_die(aTHX_ PL_no_usym, what);
242 if (ckWARN(WARN_UNINITIALIZED))
244 if (type != SVt_PV && GIMME_V == G_ARRAY) {
248 **spp = &PL_sv_undef;
251 if ((PL_op->op_flags & OPf_SPECIAL) &&
252 !(PL_op->op_flags & OPf_MOD))
254 gv = gv_fetchsv(sv, 0, type);
256 && (!is_gv_magical_sv(sv,0)
257 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
259 **spp = &PL_sv_undef;
264 gv = gv_fetchsv(sv, GV_ADD, type);
276 tryAMAGICunDEREF(to_sv);
279 switch (SvTYPE(sv)) {
285 DIE(aTHX_ "Not a SCALAR reference");
292 if (SvTYPE(gv) != SVt_PVGV) {
293 if (SvGMAGICAL(sv)) {
298 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
304 if (PL_op->op_flags & OPf_MOD) {
305 if (PL_op->op_private & OPpLVAL_INTRO) {
306 if (cUNOP->op_first->op_type == OP_NULL)
307 sv = save_scalar((GV*)TOPs);
309 sv = save_scalar(gv);
311 Perl_croak(aTHX_ PL_no_localize_ref);
313 else if (PL_op->op_private & OPpDEREF)
314 vivify_ref(sv, PL_op->op_private & OPpDEREF);
323 AV * const av = (AV*)TOPs;
324 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
327 sv_upgrade(*sv, SVt_PVMG);
328 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
336 dVAR; dSP; dTARGET; dPOPss;
338 if (PL_op->op_flags & OPf_MOD || LVRET) {
339 if (SvTYPE(TARG) < SVt_PVLV) {
340 sv_upgrade(TARG, SVt_PVLV);
341 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
345 if (LvTARG(TARG) != sv) {
347 SvREFCNT_dec(LvTARG(TARG));
348 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
350 PUSHs(TARG); /* no SvSETMAGIC */
354 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
355 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
356 if (mg && mg->mg_len >= 0) {
360 PUSHi(i + CopARYBASE_get(PL_curcop));
373 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
375 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
378 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
379 /* (But not in defined().) */
381 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
384 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
385 if ((PL_op->op_private & OPpLVAL_INTRO)) {
386 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
389 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
392 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
396 cv = (CV*)&PL_sv_undef;
407 SV *ret = &PL_sv_undef;
409 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
410 const char * s = SvPVX_const(TOPs);
411 if (strnEQ(s, "CORE::", 6)) {
412 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
413 if (code < 0) { /* Overridable. */
414 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
415 int i = 0, n = 0, seen_question = 0, defgv = 0;
417 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
419 if (code == -KEY_chop || code == -KEY_chomp
420 || code == -KEY_exec || code == -KEY_system || code == -KEY_err)
422 if (code == -KEY_mkdir) {
423 ret = sv_2mortal(newSVpvs("_;$"));
426 if (code == -KEY_readpipe) {
427 s = "CORE::backtick";
429 while (i < MAXO) { /* The slow way. */
430 if (strEQ(s + 6, PL_op_name[i])
431 || strEQ(s + 6, PL_op_desc[i]))
437 goto nonesuch; /* Should not happen... */
439 defgv = PL_opargs[i] & OA_DEFGV;
440 oa = PL_opargs[i] >> OASHIFT;
442 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
446 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
447 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
448 /* But globs are already references (kinda) */
449 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
453 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
456 if (defgv && str[n - 1] == '$')
459 ret = sv_2mortal(newSVpvn(str, n - 1));
461 else if (code) /* Non-Overridable */
463 else { /* None such */
465 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
469 cv = sv_2cv(TOPs, &stash, &gv, 0);
471 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
480 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
482 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
498 if (GIMME != G_ARRAY) {
502 *MARK = &PL_sv_undef;
503 *MARK = refto(*MARK);
507 EXTEND_MORTAL(SP - MARK);
509 *MARK = refto(*MARK);
514 S_refto(pTHX_ SV *sv)
519 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
522 if (!(sv = LvTARG(sv)))
525 SvREFCNT_inc_void_NN(sv);
527 else if (SvTYPE(sv) == SVt_PVAV) {
528 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
531 SvREFCNT_inc_void_NN(sv);
533 else if (SvPADTMP(sv) && !IS_PADGV(sv))
537 SvREFCNT_inc_void_NN(sv);
540 sv_upgrade(rv, SVt_RV);
550 SV * const sv = POPs;
555 if (!sv || !SvROK(sv))
558 pv = sv_reftype(SvRV(sv),TRUE);
559 PUSHp(pv, strlen(pv));
569 stash = CopSTASH(PL_curcop);
571 SV * const ssv = POPs;
575 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
576 Perl_croak(aTHX_ "Attempt to bless into a reference");
577 ptr = SvPV_const(ssv,len);
578 if (len == 0 && ckWARN(WARN_MISC))
579 Perl_warner(aTHX_ packWARN(WARN_MISC),
580 "Explicit blessing to '' (assuming package main)");
581 stash = gv_stashpvn(ptr, len, GV_ADD);
584 (void)sv_bless(TOPs, stash);
593 const char * const elem = SvPV_nolen_const(sv);
594 GV * const gv = (GV*)POPs;
599 /* elem will always be NUL terminated. */
600 const char * const second_letter = elem + 1;
603 if (strEQ(second_letter, "RRAY"))
604 tmpRef = (SV*)GvAV(gv);
607 if (strEQ(second_letter, "ODE"))
608 tmpRef = (SV*)GvCVu(gv);
611 if (strEQ(second_letter, "ILEHANDLE")) {
612 /* finally deprecated in 5.8.0 */
613 deprecate("*glob{FILEHANDLE}");
614 tmpRef = (SV*)GvIOp(gv);
617 if (strEQ(second_letter, "ORMAT"))
618 tmpRef = (SV*)GvFORM(gv);
621 if (strEQ(second_letter, "LOB"))
625 if (strEQ(second_letter, "ASH"))
626 tmpRef = (SV*)GvHV(gv);
629 if (*second_letter == 'O' && !elem[2])
630 tmpRef = (SV*)GvIOp(gv);
633 if (strEQ(second_letter, "AME"))
634 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
637 if (strEQ(second_letter, "ACKAGE")) {
638 const HV * const stash = GvSTASH(gv);
639 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
640 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
644 if (strEQ(second_letter, "CALAR"))
659 /* Pattern matching */
664 register unsigned char *s;
667 register I32 *sfirst;
671 if (sv == PL_lastscream) {
675 s = (unsigned char*)(SvPV(sv, len));
677 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
678 /* No point in studying a zero length string, and not safe to study
679 anything that doesn't appear to be a simple scalar (and hence might
680 change between now and when the regexp engine runs without our set
681 magic ever running) such as a reference to an object with overloaded
687 SvSCREAM_off(PL_lastscream);
688 SvREFCNT_dec(PL_lastscream);
690 PL_lastscream = SvREFCNT_inc_simple(sv);
692 s = (unsigned char*)(SvPV(sv, len));
696 if (pos > PL_maxscream) {
697 if (PL_maxscream < 0) {
698 PL_maxscream = pos + 80;
699 Newx(PL_screamfirst, 256, I32);
700 Newx(PL_screamnext, PL_maxscream, I32);
703 PL_maxscream = pos + pos / 4;
704 Renew(PL_screamnext, PL_maxscream, I32);
708 sfirst = PL_screamfirst;
709 snext = PL_screamnext;
711 if (!sfirst || !snext)
712 DIE(aTHX_ "do_study: out of memory");
714 for (ch = 256; ch; --ch)
719 register const I32 ch = s[pos];
721 snext[pos] = sfirst[ch] - pos;
728 /* piggyback on m//g magic */
729 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
738 if (PL_op->op_flags & OPf_STACKED)
740 else if (PL_op->op_private & OPpTARGET_MY)
746 TARG = sv_newmortal();
751 /* Lvalue operators. */
763 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
765 do_chop(TARG, *++MARK);
774 SETi(do_chomp(TOPs));
780 dVAR; dSP; dMARK; dTARGET;
781 register I32 count = 0;
784 count += do_chomp(POPs);
794 if (!PL_op->op_private) {
803 SV_CHECK_THINKFIRST_COW_DROP(sv);
805 switch (SvTYPE(sv)) {
815 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
816 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
817 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
821 /* let user-undef'd sub keep its identity */
822 GV* const gv = CvGV((CV*)sv);
829 SvSetMagicSV(sv, &PL_sv_undef);
834 GvGP(sv) = gp_ref(gp);
836 GvLINE(sv) = CopLINE(PL_curcop);
842 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
857 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
858 DIE(aTHX_ PL_no_modify);
859 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
860 && SvIVX(TOPs) != IV_MIN)
862 SvIV_set(TOPs, SvIVX(TOPs) - 1);
863 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
874 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
875 DIE(aTHX_ PL_no_modify);
876 sv_setsv(TARG, TOPs);
877 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
878 && SvIVX(TOPs) != IV_MAX)
880 SvIV_set(TOPs, SvIVX(TOPs) + 1);
881 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
886 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
896 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
897 DIE(aTHX_ PL_no_modify);
898 sv_setsv(TARG, TOPs);
899 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
900 && SvIVX(TOPs) != IV_MIN)
902 SvIV_set(TOPs, SvIVX(TOPs) - 1);
903 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
912 /* Ordinary operators. */
917 #ifdef PERL_PRESERVE_IVUV
920 tryAMAGICbin(pow,opASSIGN);
921 #ifdef PERL_PRESERVE_IVUV
922 /* For integer to integer power, we do the calculation by hand wherever
923 we're sure it is safe; otherwise we call pow() and try to convert to
924 integer afterwards. */
937 const IV iv = SvIVX(TOPs);
941 goto float_it; /* Can't do negative powers this way. */
945 baseuok = SvUOK(TOPm1s);
947 baseuv = SvUVX(TOPm1s);
949 const IV iv = SvIVX(TOPm1s);
952 baseuok = TRUE; /* effectively it's a UV now */
954 baseuv = -iv; /* abs, baseuok == false records sign */
957 /* now we have integer ** positive integer. */
960 /* foo & (foo - 1) is zero only for a power of 2. */
961 if (!(baseuv & (baseuv - 1))) {
962 /* We are raising power-of-2 to a positive integer.
963 The logic here will work for any base (even non-integer
964 bases) but it can be less accurate than
965 pow (base,power) or exp (power * log (base)) when the
966 intermediate values start to spill out of the mantissa.
967 With powers of 2 we know this can't happen.
968 And powers of 2 are the favourite thing for perl
969 programmers to notice ** not doing what they mean. */
971 NV base = baseuok ? baseuv : -(NV)baseuv;
976 while (power >>= 1) {
987 register unsigned int highbit = 8 * sizeof(UV);
988 register unsigned int diff = 8 * sizeof(UV);
991 if (baseuv >> highbit) {
995 /* we now have baseuv < 2 ** highbit */
996 if (power * highbit <= 8 * sizeof(UV)) {
997 /* result will definitely fit in UV, so use UV math
998 on same algorithm as above */
999 register UV result = 1;
1000 register UV base = baseuv;
1001 const bool odd_power = (bool)(power & 1);
1005 while (power >>= 1) {
1012 if (baseuok || !odd_power)
1013 /* answer is positive */
1015 else if (result <= (UV)IV_MAX)
1016 /* answer negative, fits in IV */
1017 SETi( -(IV)result );
1018 else if (result == (UV)IV_MIN)
1019 /* 2's complement assumption: special case IV_MIN */
1022 /* answer negative, doesn't fit */
1023 SETn( -(NV)result );
1035 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1037 We are building perl with long double support and are on an AIX OS
1038 afflicted with a powl() function that wrongly returns NaNQ for any
1039 negative base. This was reported to IBM as PMR #23047-379 on
1040 03/06/2006. The problem exists in at least the following versions
1041 of AIX and the libm fileset, and no doubt others as well:
1043 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1044 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1045 AIX 5.2.0 bos.adt.libm 5.2.0.85
1047 So, until IBM fixes powl(), we provide the following workaround to
1048 handle the problem ourselves. Our logic is as follows: for
1049 negative bases (left), we use fmod(right, 2) to check if the
1050 exponent is an odd or even integer:
1052 - if odd, powl(left, right) == -powl(-left, right)
1053 - if even, powl(left, right) == powl(-left, right)
1055 If the exponent is not an integer, the result is rightly NaNQ, so
1056 we just return that (as NV_NAN).
1060 NV mod2 = Perl_fmod( right, 2.0 );
1061 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1062 SETn( -Perl_pow( -left, right) );
1063 } else if (mod2 == 0.0) { /* even integer */
1064 SETn( Perl_pow( -left, right) );
1065 } else { /* fractional power */
1069 SETn( Perl_pow( left, right) );
1072 SETn( Perl_pow( left, right) );
1073 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1075 #ifdef PERL_PRESERVE_IVUV
1085 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1086 #ifdef PERL_PRESERVE_IVUV
1089 /* Unless the left argument is integer in range we are going to have to
1090 use NV maths. Hence only attempt to coerce the right argument if
1091 we know the left is integer. */
1092 /* Left operand is defined, so is it IV? */
1093 SvIV_please(TOPm1s);
1094 if (SvIOK(TOPm1s)) {
1095 bool auvok = SvUOK(TOPm1s);
1096 bool buvok = SvUOK(TOPs);
1097 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1098 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1105 alow = SvUVX(TOPm1s);
1107 const IV aiv = SvIVX(TOPm1s);
1110 auvok = TRUE; /* effectively it's a UV now */
1112 alow = -aiv; /* abs, auvok == false records sign */
1118 const IV biv = SvIVX(TOPs);
1121 buvok = TRUE; /* effectively it's a UV now */
1123 blow = -biv; /* abs, buvok == false records sign */
1127 /* If this does sign extension on unsigned it's time for plan B */
1128 ahigh = alow >> (4 * sizeof (UV));
1130 bhigh = blow >> (4 * sizeof (UV));
1132 if (ahigh && bhigh) {
1134 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1135 which is overflow. Drop to NVs below. */
1136 } else if (!ahigh && !bhigh) {
1137 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1138 so the unsigned multiply cannot overflow. */
1139 const UV product = alow * blow;
1140 if (auvok == buvok) {
1141 /* -ve * -ve or +ve * +ve gives a +ve result. */
1145 } else if (product <= (UV)IV_MIN) {
1146 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1147 /* -ve result, which could overflow an IV */
1149 SETi( -(IV)product );
1151 } /* else drop to NVs below. */
1153 /* One operand is large, 1 small */
1156 /* swap the operands */
1158 bhigh = blow; /* bhigh now the temp var for the swap */
1162 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1163 multiplies can't overflow. shift can, add can, -ve can. */
1164 product_middle = ahigh * blow;
1165 if (!(product_middle & topmask)) {
1166 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1168 product_middle <<= (4 * sizeof (UV));
1169 product_low = alow * blow;
1171 /* as for pp_add, UV + something mustn't get smaller.
1172 IIRC ANSI mandates this wrapping *behaviour* for
1173 unsigned whatever the actual representation*/
1174 product_low += product_middle;
1175 if (product_low >= product_middle) {
1176 /* didn't overflow */
1177 if (auvok == buvok) {
1178 /* -ve * -ve or +ve * +ve gives a +ve result. */
1180 SETu( product_low );
1182 } else if (product_low <= (UV)IV_MIN) {
1183 /* 2s complement assumption again */
1184 /* -ve result, which could overflow an IV */
1186 SETi( -(IV)product_low );
1188 } /* else drop to NVs below. */
1190 } /* product_middle too large */
1191 } /* ahigh && bhigh */
1192 } /* SvIOK(TOPm1s) */
1197 SETn( left * right );
1204 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1205 /* Only try to do UV divide first
1206 if ((SLOPPYDIVIDE is true) or
1207 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1209 The assumption is that it is better to use floating point divide
1210 whenever possible, only doing integer divide first if we can't be sure.
1211 If NV_PRESERVES_UV is true then we know at compile time that no UV
1212 can be too large to preserve, so don't need to compile the code to
1213 test the size of UVs. */
1216 # define PERL_TRY_UV_DIVIDE
1217 /* ensure that 20./5. == 4. */
1219 # ifdef PERL_PRESERVE_IVUV
1220 # ifndef NV_PRESERVES_UV
1221 # define PERL_TRY_UV_DIVIDE
1226 #ifdef PERL_TRY_UV_DIVIDE
1229 SvIV_please(TOPm1s);
1230 if (SvIOK(TOPm1s)) {
1231 bool left_non_neg = SvUOK(TOPm1s);
1232 bool right_non_neg = SvUOK(TOPs);
1236 if (right_non_neg) {
1237 right = SvUVX(TOPs);
1240 const IV biv = SvIVX(TOPs);
1243 right_non_neg = TRUE; /* effectively it's a UV now */
1249 /* historically undef()/0 gives a "Use of uninitialized value"
1250 warning before dieing, hence this test goes here.
1251 If it were immediately before the second SvIV_please, then
1252 DIE() would be invoked before left was even inspected, so
1253 no inpsection would give no warning. */
1255 DIE(aTHX_ "Illegal division by zero");
1258 left = SvUVX(TOPm1s);
1261 const IV aiv = SvIVX(TOPm1s);
1264 left_non_neg = TRUE; /* effectively it's a UV now */
1273 /* For sloppy divide we always attempt integer division. */
1275 /* Otherwise we only attempt it if either or both operands
1276 would not be preserved by an NV. If both fit in NVs
1277 we fall through to the NV divide code below. However,
1278 as left >= right to ensure integer result here, we know that
1279 we can skip the test on the right operand - right big
1280 enough not to be preserved can't get here unless left is
1283 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1286 /* Integer division can't overflow, but it can be imprecise. */
1287 const UV result = left / right;
1288 if (result * right == left) {
1289 SP--; /* result is valid */
1290 if (left_non_neg == right_non_neg) {
1291 /* signs identical, result is positive. */
1295 /* 2s complement assumption */
1296 if (result <= (UV)IV_MIN)
1297 SETi( -(IV)result );
1299 /* It's exact but too negative for IV. */
1300 SETn( -(NV)result );
1303 } /* tried integer divide but it was not an integer result */
1304 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1305 } /* left wasn't SvIOK */
1306 } /* right wasn't SvIOK */
1307 #endif /* PERL_TRY_UV_DIVIDE */
1311 DIE(aTHX_ "Illegal division by zero");
1312 PUSHn( left / right );
1319 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1323 bool left_neg = FALSE;
1324 bool right_neg = FALSE;
1325 bool use_double = FALSE;
1326 bool dright_valid = FALSE;
1332 right_neg = !SvUOK(TOPs);
1334 right = SvUVX(POPs);
1336 const IV biv = SvIVX(POPs);
1339 right_neg = FALSE; /* effectively it's a UV now */
1347 right_neg = dright < 0;
1350 if (dright < UV_MAX_P1) {
1351 right = U_V(dright);
1352 dright_valid = TRUE; /* In case we need to use double below. */
1358 /* At this point use_double is only true if right is out of range for
1359 a UV. In range NV has been rounded down to nearest UV and
1360 use_double false. */
1362 if (!use_double && SvIOK(TOPs)) {
1364 left_neg = !SvUOK(TOPs);
1368 const IV aiv = SvIVX(POPs);
1371 left_neg = FALSE; /* effectively it's a UV now */
1380 left_neg = dleft < 0;
1384 /* This should be exactly the 5.6 behaviour - if left and right are
1385 both in range for UV then use U_V() rather than floor. */
1387 if (dleft < UV_MAX_P1) {
1388 /* right was in range, so is dleft, so use UVs not double.
1392 /* left is out of range for UV, right was in range, so promote
1393 right (back) to double. */
1395 /* The +0.5 is used in 5.6 even though it is not strictly
1396 consistent with the implicit +0 floor in the U_V()
1397 inside the #if 1. */
1398 dleft = Perl_floor(dleft + 0.5);
1401 dright = Perl_floor(dright + 0.5);
1411 DIE(aTHX_ "Illegal modulus zero");
1413 dans = Perl_fmod(dleft, dright);
1414 if ((left_neg != right_neg) && dans)
1415 dans = dright - dans;
1418 sv_setnv(TARG, dans);
1424 DIE(aTHX_ "Illegal modulus zero");
1427 if ((left_neg != right_neg) && ans)
1430 /* XXX may warn: unary minus operator applied to unsigned type */
1431 /* could change -foo to be (~foo)+1 instead */
1432 if (ans <= ~((UV)IV_MAX)+1)
1433 sv_setiv(TARG, ~ans+1);
1435 sv_setnv(TARG, -(NV)ans);
1438 sv_setuv(TARG, ans);
1447 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1454 const UV uv = SvUV(sv);
1456 count = IV_MAX; /* The best we can do? */
1460 const IV iv = SvIV(sv);
1467 else if (SvNOKp(sv)) {
1468 const NV nv = SvNV(sv);
1476 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1478 static const char oom_list_extend[] = "Out of memory during list extend";
1479 const I32 items = SP - MARK;
1480 const I32 max = items * count;
1482 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1483 /* Did the max computation overflow? */
1484 if (items > 0 && max > 0 && (max < items || max < count))
1485 Perl_croak(aTHX_ oom_list_extend);
1490 /* This code was intended to fix 20010809.028:
1493 for (($x =~ /./g) x 2) {
1494 print chop; # "abcdabcd" expected as output.
1497 * but that change (#11635) broke this code:
1499 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1501 * I can't think of a better fix that doesn't introduce
1502 * an efficiency hit by copying the SVs. The stack isn't
1503 * refcounted, and mortalisation obviously doesn't
1504 * Do The Right Thing when the stack has more than
1505 * one pointer to the same mortal value.
1509 *SP = sv_2mortal(newSVsv(*SP));
1519 repeatcpy((char*)(MARK + items), (char*)MARK,
1520 items * sizeof(SV*), count - 1);
1523 else if (count <= 0)
1526 else { /* Note: mark already snarfed by pp_list */
1527 SV * const tmpstr = POPs;
1530 static const char oom_string_extend[] =
1531 "Out of memory during string extend";
1533 SvSetSV(TARG, tmpstr);
1534 SvPV_force(TARG, len);
1535 isutf = DO_UTF8(TARG);
1540 const STRLEN max = (UV)count * len;
1541 if (len > ((MEM_SIZE)~0)/count)
1542 Perl_croak(aTHX_ oom_string_extend);
1543 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1544 SvGROW(TARG, max + 1);
1545 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1546 SvCUR_set(TARG, SvCUR(TARG) * count);
1548 *SvEND(TARG) = '\0';
1551 (void)SvPOK_only_UTF8(TARG);
1553 (void)SvPOK_only(TARG);
1555 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1556 /* The parser saw this as a list repeat, and there
1557 are probably several items on the stack. But we're
1558 in scalar context, and there's no pp_list to save us
1559 now. So drop the rest of the items -- robin@kitsite.com
1572 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1573 useleft = USE_LEFT(TOPm1s);
1574 #ifdef PERL_PRESERVE_IVUV
1575 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1576 "bad things" happen if you rely on signed integers wrapping. */
1579 /* Unless the left argument is integer in range we are going to have to
1580 use NV maths. Hence only attempt to coerce the right argument if
1581 we know the left is integer. */
1582 register UV auv = 0;
1588 a_valid = auvok = 1;
1589 /* left operand is undef, treat as zero. */
1591 /* Left operand is defined, so is it IV? */
1592 SvIV_please(TOPm1s);
1593 if (SvIOK(TOPm1s)) {
1594 if ((auvok = SvUOK(TOPm1s)))
1595 auv = SvUVX(TOPm1s);
1597 register const IV aiv = SvIVX(TOPm1s);
1600 auvok = 1; /* Now acting as a sign flag. */
1601 } else { /* 2s complement assumption for IV_MIN */
1609 bool result_good = 0;
1612 bool buvok = SvUOK(TOPs);
1617 register const IV biv = SvIVX(TOPs);
1624 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1625 else "IV" now, independent of how it came in.
1626 if a, b represents positive, A, B negative, a maps to -A etc
1631 all UV maths. negate result if A negative.
1632 subtract if signs same, add if signs differ. */
1634 if (auvok ^ buvok) {
1643 /* Must get smaller */
1648 if (result <= buv) {
1649 /* result really should be -(auv-buv). as its negation
1650 of true value, need to swap our result flag */
1662 if (result <= (UV)IV_MIN)
1663 SETi( -(IV)result );
1665 /* result valid, but out of range for IV. */
1666 SETn( -(NV)result );
1670 } /* Overflow, drop through to NVs. */
1674 useleft = USE_LEFT(TOPm1s);
1678 /* left operand is undef, treat as zero - value */
1682 SETn( TOPn - value );
1689 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1691 const IV shift = POPi;
1692 if (PL_op->op_private & HINT_INTEGER) {
1706 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1708 const IV shift = POPi;
1709 if (PL_op->op_private & HINT_INTEGER) {
1723 dVAR; dSP; tryAMAGICbinSET(lt,0);
1724 #ifdef PERL_PRESERVE_IVUV
1727 SvIV_please(TOPm1s);
1728 if (SvIOK(TOPm1s)) {
1729 bool auvok = SvUOK(TOPm1s);
1730 bool buvok = SvUOK(TOPs);
1732 if (!auvok && !buvok) { /* ## IV < IV ## */
1733 const IV aiv = SvIVX(TOPm1s);
1734 const IV biv = SvIVX(TOPs);
1737 SETs(boolSV(aiv < biv));
1740 if (auvok && buvok) { /* ## UV < UV ## */
1741 const UV auv = SvUVX(TOPm1s);
1742 const UV buv = SvUVX(TOPs);
1745 SETs(boolSV(auv < buv));
1748 if (auvok) { /* ## UV < IV ## */
1750 const IV biv = SvIVX(TOPs);
1753 /* As (a) is a UV, it's >=0, so it cannot be < */
1758 SETs(boolSV(auv < (UV)biv));
1761 { /* ## IV < UV ## */
1762 const IV aiv = SvIVX(TOPm1s);
1766 /* As (b) is a UV, it's >=0, so it must be < */
1773 SETs(boolSV((UV)aiv < buv));
1779 #ifndef NV_PRESERVES_UV
1780 #ifdef PERL_PRESERVE_IVUV
1783 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1785 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1790 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1792 if (Perl_isnan(left) || Perl_isnan(right))
1794 SETs(boolSV(left < right));
1797 SETs(boolSV(TOPn < value));
1805 dVAR; dSP; tryAMAGICbinSET(gt,0);
1806 #ifdef PERL_PRESERVE_IVUV
1809 SvIV_please(TOPm1s);
1810 if (SvIOK(TOPm1s)) {
1811 bool auvok = SvUOK(TOPm1s);
1812 bool buvok = SvUOK(TOPs);
1814 if (!auvok && !buvok) { /* ## IV > IV ## */
1815 const IV aiv = SvIVX(TOPm1s);
1816 const IV biv = SvIVX(TOPs);
1819 SETs(boolSV(aiv > biv));
1822 if (auvok && buvok) { /* ## UV > UV ## */
1823 const UV auv = SvUVX(TOPm1s);
1824 const UV buv = SvUVX(TOPs);
1827 SETs(boolSV(auv > buv));
1830 if (auvok) { /* ## UV > IV ## */
1832 const IV biv = SvIVX(TOPs);
1836 /* As (a) is a UV, it's >=0, so it must be > */
1841 SETs(boolSV(auv > (UV)biv));
1844 { /* ## IV > UV ## */
1845 const IV aiv = SvIVX(TOPm1s);
1849 /* As (b) is a UV, it's >=0, so it cannot be > */
1856 SETs(boolSV((UV)aiv > buv));
1862 #ifndef NV_PRESERVES_UV
1863 #ifdef PERL_PRESERVE_IVUV
1866 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1868 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1873 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1875 if (Perl_isnan(left) || Perl_isnan(right))
1877 SETs(boolSV(left > right));
1880 SETs(boolSV(TOPn > value));
1888 dVAR; dSP; tryAMAGICbinSET(le,0);
1889 #ifdef PERL_PRESERVE_IVUV
1892 SvIV_please(TOPm1s);
1893 if (SvIOK(TOPm1s)) {
1894 bool auvok = SvUOK(TOPm1s);
1895 bool buvok = SvUOK(TOPs);
1897 if (!auvok && !buvok) { /* ## IV <= IV ## */
1898 const IV aiv = SvIVX(TOPm1s);
1899 const IV biv = SvIVX(TOPs);
1902 SETs(boolSV(aiv <= biv));
1905 if (auvok && buvok) { /* ## UV <= UV ## */
1906 UV auv = SvUVX(TOPm1s);
1907 UV buv = SvUVX(TOPs);
1910 SETs(boolSV(auv <= buv));
1913 if (auvok) { /* ## UV <= IV ## */
1915 const IV biv = SvIVX(TOPs);
1919 /* As (a) is a UV, it's >=0, so a cannot be <= */
1924 SETs(boolSV(auv <= (UV)biv));
1927 { /* ## IV <= UV ## */
1928 const IV aiv = SvIVX(TOPm1s);
1932 /* As (b) is a UV, it's >=0, so a must be <= */
1939 SETs(boolSV((UV)aiv <= buv));
1945 #ifndef NV_PRESERVES_UV
1946 #ifdef PERL_PRESERVE_IVUV
1949 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1951 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1956 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1958 if (Perl_isnan(left) || Perl_isnan(right))
1960 SETs(boolSV(left <= right));
1963 SETs(boolSV(TOPn <= value));
1971 dVAR; dSP; tryAMAGICbinSET(ge,0);
1972 #ifdef PERL_PRESERVE_IVUV
1975 SvIV_please(TOPm1s);
1976 if (SvIOK(TOPm1s)) {
1977 bool auvok = SvUOK(TOPm1s);
1978 bool buvok = SvUOK(TOPs);
1980 if (!auvok && !buvok) { /* ## IV >= IV ## */
1981 const IV aiv = SvIVX(TOPm1s);
1982 const IV biv = SvIVX(TOPs);
1985 SETs(boolSV(aiv >= biv));
1988 if (auvok && buvok) { /* ## UV >= UV ## */
1989 const UV auv = SvUVX(TOPm1s);
1990 const UV buv = SvUVX(TOPs);
1993 SETs(boolSV(auv >= buv));
1996 if (auvok) { /* ## UV >= IV ## */
1998 const IV biv = SvIVX(TOPs);
2002 /* As (a) is a UV, it's >=0, so it must be >= */
2007 SETs(boolSV(auv >= (UV)biv));
2010 { /* ## IV >= UV ## */
2011 const IV aiv = SvIVX(TOPm1s);
2015 /* As (b) is a UV, it's >=0, so a cannot be >= */
2022 SETs(boolSV((UV)aiv >= buv));
2028 #ifndef NV_PRESERVES_UV
2029 #ifdef PERL_PRESERVE_IVUV
2032 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2034 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2039 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2041 if (Perl_isnan(left) || Perl_isnan(right))
2043 SETs(boolSV(left >= right));
2046 SETs(boolSV(TOPn >= value));
2054 dVAR; dSP; tryAMAGICbinSET(ne,0);
2055 #ifndef NV_PRESERVES_UV
2056 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2058 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2062 #ifdef PERL_PRESERVE_IVUV
2065 SvIV_please(TOPm1s);
2066 if (SvIOK(TOPm1s)) {
2067 const bool auvok = SvUOK(TOPm1s);
2068 const bool buvok = SvUOK(TOPs);
2070 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2071 /* Casting IV to UV before comparison isn't going to matter
2072 on 2s complement. On 1s complement or sign&magnitude
2073 (if we have any of them) it could make negative zero
2074 differ from normal zero. As I understand it. (Need to
2075 check - is negative zero implementation defined behaviour
2077 const UV buv = SvUVX(POPs);
2078 const UV auv = SvUVX(TOPs);
2080 SETs(boolSV(auv != buv));
2083 { /* ## Mixed IV,UV ## */
2087 /* != is commutative so swap if needed (save code) */
2089 /* swap. top of stack (b) is the iv */
2093 /* As (a) is a UV, it's >0, so it cannot be == */
2102 /* As (b) is a UV, it's >0, so it cannot be == */
2106 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2108 SETs(boolSV((UV)iv != uv));
2115 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2117 if (Perl_isnan(left) || Perl_isnan(right))
2119 SETs(boolSV(left != right));
2122 SETs(boolSV(TOPn != value));
2130 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2131 #ifndef NV_PRESERVES_UV
2132 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2133 const UV right = PTR2UV(SvRV(POPs));
2134 const UV left = PTR2UV(SvRV(TOPs));
2135 SETi((left > right) - (left < right));
2139 #ifdef PERL_PRESERVE_IVUV
2140 /* Fortunately it seems NaN isn't IOK */
2143 SvIV_please(TOPm1s);
2144 if (SvIOK(TOPm1s)) {
2145 const bool leftuvok = SvUOK(TOPm1s);
2146 const bool rightuvok = SvUOK(TOPs);
2148 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2149 const IV leftiv = SvIVX(TOPm1s);
2150 const IV rightiv = SvIVX(TOPs);
2152 if (leftiv > rightiv)
2154 else if (leftiv < rightiv)
2158 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2159 const UV leftuv = SvUVX(TOPm1s);
2160 const UV rightuv = SvUVX(TOPs);
2162 if (leftuv > rightuv)
2164 else if (leftuv < rightuv)
2168 } else if (leftuvok) { /* ## UV <=> IV ## */
2169 const IV rightiv = SvIVX(TOPs);
2171 /* As (a) is a UV, it's >=0, so it cannot be < */
2174 const UV leftuv = SvUVX(TOPm1s);
2175 if (leftuv > (UV)rightiv) {
2177 } else if (leftuv < (UV)rightiv) {
2183 } else { /* ## IV <=> UV ## */
2184 const IV leftiv = SvIVX(TOPm1s);
2186 /* As (b) is a UV, it's >=0, so it must be < */
2189 const UV rightuv = SvUVX(TOPs);
2190 if ((UV)leftiv > rightuv) {
2192 } else if ((UV)leftiv < rightuv) {
2210 if (Perl_isnan(left) || Perl_isnan(right)) {
2214 value = (left > right) - (left < right);
2218 else if (left < right)
2220 else if (left > right)
2236 int amg_type = sle_amg;
2240 switch (PL_op->op_type) {
2259 tryAMAGICbinSET_var(amg_type,0);
2262 const int cmp = (IN_LOCALE_RUNTIME
2263 ? sv_cmp_locale(left, right)
2264 : sv_cmp(left, right));
2265 SETs(boolSV(cmp * multiplier < rhs));
2272 dVAR; dSP; tryAMAGICbinSET(seq,0);
2275 SETs(boolSV(sv_eq(left, right)));
2282 dVAR; dSP; tryAMAGICbinSET(sne,0);
2285 SETs(boolSV(!sv_eq(left, right)));
2292 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2295 const int cmp = (IN_LOCALE_RUNTIME
2296 ? sv_cmp_locale(left, right)
2297 : sv_cmp(left, right));
2305 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2310 if (SvNIOKp(left) || SvNIOKp(right)) {
2311 if (PL_op->op_private & HINT_INTEGER) {
2312 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2316 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2321 do_vop(PL_op->op_type, TARG, left, right);
2330 dVAR; dSP; dATARGET;
2331 const int op_type = PL_op->op_type;
2333 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2338 if (SvNIOKp(left) || SvNIOKp(right)) {
2339 if (PL_op->op_private & HINT_INTEGER) {
2340 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2341 const IV r = SvIV_nomg(right);
2342 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2346 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2347 const UV r = SvUV_nomg(right);
2348 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2353 do_vop(op_type, TARG, left, right);
2362 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2365 const int flags = SvFLAGS(sv);
2367 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2368 /* It's publicly an integer, or privately an integer-not-float */
2371 if (SvIVX(sv) == IV_MIN) {
2372 /* 2s complement assumption. */
2373 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2376 else if (SvUVX(sv) <= IV_MAX) {
2381 else if (SvIVX(sv) != IV_MIN) {
2385 #ifdef PERL_PRESERVE_IVUV
2394 else if (SvPOKp(sv)) {
2396 const char * const s = SvPV_const(sv, len);
2397 if (isIDFIRST(*s)) {
2398 sv_setpvn(TARG, "-", 1);
2401 else if (*s == '+' || *s == '-') {
2403 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2405 else if (DO_UTF8(sv)) {
2408 goto oops_its_an_int;
2410 sv_setnv(TARG, -SvNV(sv));
2412 sv_setpvn(TARG, "-", 1);
2419 goto oops_its_an_int;
2420 sv_setnv(TARG, -SvNV(sv));
2432 dVAR; dSP; tryAMAGICunSET(not);
2433 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2439 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2444 if (PL_op->op_private & HINT_INTEGER) {
2445 const IV i = ~SvIV_nomg(sv);
2449 const UV u = ~SvUV_nomg(sv);
2458 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2459 sv_setsv_nomg(TARG, sv);
2460 tmps = (U8*)SvPV_force(TARG, len);
2463 /* Calculate exact length, let's not estimate. */
2468 U8 * const send = tmps + len;
2469 U8 * const origtmps = tmps;
2470 const UV utf8flags = UTF8_ALLOW_ANYUV;
2472 while (tmps < send) {
2473 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2475 targlen += UNISKIP(~c);
2481 /* Now rewind strings and write them. */
2488 Newx(result, targlen + 1, U8);
2490 while (tmps < send) {
2491 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2493 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2496 sv_usepvn_flags(TARG, (char*)result, targlen,
2497 SV_HAS_TRAILING_NUL);
2504 Newx(result, nchar + 1, U8);
2506 while (tmps < send) {
2507 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2512 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2520 register long *tmpl;
2521 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2524 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2529 for ( ; anum > 0; anum--, tmps++)
2538 /* integer versions of some of the above */
2542 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2545 SETi( left * right );
2553 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2557 DIE(aTHX_ "Illegal division by zero");
2560 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2564 value = num / value;
2573 /* This is the vanilla old i_modulo. */
2574 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2578 DIE(aTHX_ "Illegal modulus zero");
2579 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2583 SETi( left % right );
2588 #if defined(__GLIBC__) && IVSIZE == 8
2592 /* This is the i_modulo with the workaround for the _moddi3 bug
2593 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2594 * See below for pp_i_modulo. */
2595 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2599 DIE(aTHX_ "Illegal modulus zero");
2600 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2604 SETi( left % PERL_ABS(right) );
2612 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2616 DIE(aTHX_ "Illegal modulus zero");
2617 /* The assumption is to use hereafter the old vanilla version... */
2619 PL_ppaddr[OP_I_MODULO] =
2621 /* .. but if we have glibc, we might have a buggy _moddi3
2622 * (at least glicb 2.2.5 is known to have this bug), in other
2623 * words our integer modulus with negative quad as the second
2624 * argument might be broken. Test for this and re-patch the
2625 * opcode dispatch table if that is the case, remembering to
2626 * also apply the workaround so that this first round works
2627 * right, too. See [perl #9402] for more information. */
2628 #if defined(__GLIBC__) && IVSIZE == 8
2632 /* Cannot do this check with inlined IV constants since
2633 * that seems to work correctly even with the buggy glibc. */
2635 /* Yikes, we have the bug.
2636 * Patch in the workaround version. */
2638 PL_ppaddr[OP_I_MODULO] =
2639 &Perl_pp_i_modulo_1;
2640 /* Make certain we work right this time, too. */
2641 right = PERL_ABS(right);
2645 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2649 SETi( left % right );
2656 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2659 SETi( left + right );
2666 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2669 SETi( left - right );
2676 dVAR; dSP; tryAMAGICbinSET(lt,0);
2679 SETs(boolSV(left < right));
2686 dVAR; dSP; tryAMAGICbinSET(gt,0);
2689 SETs(boolSV(left > right));
2696 dVAR; dSP; tryAMAGICbinSET(le,0);
2699 SETs(boolSV(left <= right));
2706 dVAR; dSP; tryAMAGICbinSET(ge,0);
2709 SETs(boolSV(left >= right));
2716 dVAR; dSP; tryAMAGICbinSET(eq,0);
2719 SETs(boolSV(left == right));
2726 dVAR; dSP; tryAMAGICbinSET(ne,0);
2729 SETs(boolSV(left != right));
2736 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2743 else if (left < right)
2754 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2759 /* High falutin' math. */
2763 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2766 SETn(Perl_atan2(left, right));
2774 int amg_type = sin_amg;
2775 const char *neg_report = NULL;
2776 NV (*func)(NV) = Perl_sin;
2777 const int op_type = PL_op->op_type;
2794 amg_type = sqrt_amg;
2796 neg_report = "sqrt";
2800 tryAMAGICun_var(amg_type);
2802 const NV value = POPn;
2804 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2805 SET_NUMERIC_STANDARD();
2806 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2809 XPUSHn(func(value));
2814 /* Support Configure command-line overrides for rand() functions.
2815 After 5.005, perhaps we should replace this by Configure support
2816 for drand48(), random(), or rand(). For 5.005, though, maintain
2817 compatibility by calling rand() but allow the user to override it.
2818 See INSTALL for details. --Andy Dougherty 15 July 1998
2820 /* Now it's after 5.005, and Configure supports drand48() and random(),
2821 in addition to rand(). So the overrides should not be needed any more.
2822 --Jarkko Hietaniemi 27 September 1998
2825 #ifndef HAS_DRAND48_PROTO
2826 extern double drand48 (void);
2839 if (!PL_srand_called) {
2840 (void)seedDrand01((Rand_seed_t)seed());
2841 PL_srand_called = TRUE;
2851 const UV anum = (MAXARG < 1) ? seed() : POPu;
2852 (void)seedDrand01((Rand_seed_t)anum);
2853 PL_srand_called = TRUE;
2860 dVAR; dSP; dTARGET; tryAMAGICun(int);
2862 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2863 /* XXX it's arguable that compiler casting to IV might be subtly
2864 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2865 else preferring IV has introduced a subtle behaviour change bug. OTOH
2866 relying on floating point to be accurate is a bug. */
2870 else if (SvIOK(TOPs)) {
2877 const NV value = TOPn;
2879 if (value < (NV)UV_MAX + 0.5) {
2882 SETn(Perl_floor(value));
2886 if (value > (NV)IV_MIN - 0.5) {
2889 SETn(Perl_ceil(value));
2899 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2901 /* This will cache the NV value if string isn't actually integer */
2906 else if (SvIOK(TOPs)) {
2907 /* IVX is precise */
2909 SETu(TOPu); /* force it to be numeric only */
2917 /* 2s complement assumption. Also, not really needed as
2918 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2924 const NV value = TOPn;
2938 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2942 SV* const sv = POPs;
2944 tmps = (SvPV_const(sv, len));
2946 /* If Unicode, try to downgrade
2947 * If not possible, croak. */
2948 SV* const tsv = sv_2mortal(newSVsv(sv));
2951 sv_utf8_downgrade(tsv, FALSE);
2952 tmps = SvPV_const(tsv, len);
2954 if (PL_op->op_type == OP_HEX)
2957 while (*tmps && len && isSPACE(*tmps))
2963 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2965 else if (*tmps == 'b')
2966 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2968 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2970 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2984 SV * const sv = TOPs;
2987 /* For an overloaded scalar, we can't know in advance if it's going to
2988 be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2989 cache the length. Maybe that should be a documented feature of it.
2992 const char *const p = SvPV_const(sv, len);
2995 SETi(utf8_length((U8*)p, (U8*)p + len));
3001 else if (DO_UTF8(sv))
3002 SETi(sv_len_utf8(sv));
3018 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3020 const I32 arybase = CopARYBASE_get(PL_curcop);
3022 const char *repl = NULL;
3024 const int num_args = PL_op->op_private & 7;
3025 bool repl_need_utf8_upgrade = FALSE;
3026 bool repl_is_utf8 = FALSE;
3028 SvTAINTED_off(TARG); /* decontaminate */
3029 SvUTF8_off(TARG); /* decontaminate */
3033 repl = SvPV_const(repl_sv, repl_len);
3034 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3044 sv_utf8_upgrade(sv);
3046 else if (DO_UTF8(sv))
3047 repl_need_utf8_upgrade = TRUE;
3049 tmps = SvPV_const(sv, curlen);
3051 utf8_curlen = sv_len_utf8(sv);
3052 if (utf8_curlen == curlen)
3055 curlen = utf8_curlen;
3060 if (pos >= arybase) {
3078 else if (len >= 0) {
3080 if (rem > (I32)curlen)
3095 Perl_croak(aTHX_ "substr outside of string");
3096 if (ckWARN(WARN_SUBSTR))
3097 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3101 const I32 upos = pos;
3102 const I32 urem = rem;
3104 sv_pos_u2b(sv, &pos, &rem);
3106 /* we either return a PV or an LV. If the TARG hasn't been used
3107 * before, or is of that type, reuse it; otherwise use a mortal
3108 * instead. Note that LVs can have an extended lifetime, so also
3109 * dont reuse if refcount > 1 (bug #20933) */
3110 if (SvTYPE(TARG) > SVt_NULL) {
3111 if ( (SvTYPE(TARG) == SVt_PVLV)
3112 ? (!lvalue || SvREFCNT(TARG) > 1)
3115 TARG = sv_newmortal();
3119 sv_setpvn(TARG, tmps, rem);
3120 #ifdef USE_LOCALE_COLLATE
3121 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3126 SV* repl_sv_copy = NULL;
3128 if (repl_need_utf8_upgrade) {
3129 repl_sv_copy = newSVsv(repl_sv);
3130 sv_utf8_upgrade(repl_sv_copy);
3131 repl = SvPV_const(repl_sv_copy, repl_len);
3132 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3134 sv_insert(sv, pos, rem, repl, repl_len);
3138 SvREFCNT_dec(repl_sv_copy);
3140 else if (lvalue) { /* it's an lvalue! */
3141 if (!SvGMAGICAL(sv)) {
3143 SvPV_force_nolen(sv);
3144 if (ckWARN(WARN_SUBSTR))
3145 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3146 "Attempt to use reference as lvalue in substr");
3148 if (isGV_with_GP(sv))
3149 SvPV_force_nolen(sv);
3150 else if (SvOK(sv)) /* is it defined ? */
3151 (void)SvPOK_only_UTF8(sv);
3153 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3156 if (SvTYPE(TARG) < SVt_PVLV) {
3157 sv_upgrade(TARG, SVt_PVLV);
3158 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3162 if (LvTARG(TARG) != sv) {
3164 SvREFCNT_dec(LvTARG(TARG));
3165 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3167 LvTARGOFF(TARG) = upos;
3168 LvTARGLEN(TARG) = urem;
3172 PUSHs(TARG); /* avoid SvSETMAGIC here */
3179 register const IV size = POPi;
3180 register const IV offset = POPi;
3181 register SV * const src = POPs;
3182 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3184 SvTAINTED_off(TARG); /* decontaminate */
3185 if (lvalue) { /* it's an lvalue! */
3186 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3187 TARG = sv_newmortal();
3188 if (SvTYPE(TARG) < SVt_PVLV) {
3189 sv_upgrade(TARG, SVt_PVLV);
3190 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3193 if (LvTARG(TARG) != src) {
3195 SvREFCNT_dec(LvTARG(TARG));
3196 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3198 LvTARGOFF(TARG) = offset;
3199 LvTARGLEN(TARG) = size;
3202 sv_setuv(TARG, do_vecget(src, offset, size));
3218 const char *little_p;
3219 const I32 arybase = CopARYBASE_get(PL_curcop);
3222 const bool is_index = PL_op->op_type == OP_INDEX;
3225 /* arybase is in characters, like offset, so combine prior to the
3226 UTF-8 to bytes calculation. */
3227 offset = POPi - arybase;
3231 big_p = SvPV_const(big, biglen);
3232 little_p = SvPV_const(little, llen);
3234 big_utf8 = DO_UTF8(big);
3235 little_utf8 = DO_UTF8(little);
3236 if (big_utf8 ^ little_utf8) {
3237 /* One needs to be upgraded. */
3238 if (little_utf8 && !PL_encoding) {
3239 /* Well, maybe instead we might be able to downgrade the small
3241 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3244 /* If the large string is ISO-8859-1, and it's not possible to
3245 convert the small string to ISO-8859-1, then there is no
3246 way that it could be found anywhere by index. */
3251 /* At this point, pv is a malloc()ed string. So donate it to temp
3252 to ensure it will get free()d */
3253 little = temp = newSV(0);
3254 sv_usepvn(temp, pv, llen);
3255 little_p = SvPVX(little);
3258 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3261 sv_recode_to_utf8(temp, PL_encoding);
3263 sv_utf8_upgrade(temp);
3268 big_p = SvPV_const(big, biglen);
3271 little_p = SvPV_const(little, llen);
3275 if (SvGAMAGIC(big)) {
3276 /* Life just becomes a lot easier if I use a temporary here.
3277 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3278 will trigger magic and overloading again, as will fbm_instr()
3280 big = sv_2mortal(newSVpvn(big_p, biglen));
3285 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3286 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3287 warn on undef, and we've already triggered a warning with the
3288 SvPV_const some lines above. We can't remove that, as we need to
3289 call some SvPV to trigger overloading early and find out if the
3291 This is all getting to messy. The API isn't quite clean enough,
3292 because data access has side effects.
3294 little = sv_2mortal(newSVpvn(little_p, llen));
3297 little_p = SvPVX(little);
3301 offset = is_index ? 0 : biglen;
3303 if (big_utf8 && offset > 0)
3304 sv_pos_u2b(big, &offset, 0);
3310 else if (offset > (I32)biglen)
3312 if (!(little_p = is_index
3313 ? fbm_instr((unsigned char*)big_p + offset,
3314 (unsigned char*)big_p + biglen, little, 0)
3315 : rninstr(big_p, big_p + offset,
3316 little_p, little_p + llen)))
3319 retval = little_p - big_p;
3320 if (retval > 0 && big_utf8)
3321 sv_pos_b2u(big, &retval);
3326 PUSHi(retval + arybase);
3332 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3333 if (SvTAINTED(MARK[1]))
3334 TAINT_PROPER("sprintf");
3335 do_sprintf(TARG, SP-MARK, MARK+1);
3336 TAINT_IF(SvTAINTED(TARG));
3348 const U8 *s = (U8*)SvPV_const(argsv, len);
3350 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3351 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3352 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3356 XPUSHu(DO_UTF8(argsv) ?
3357 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3369 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3371 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3373 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3375 (void) POPs; /* Ignore the argument value. */
3376 value = UNICODE_REPLACEMENT;
3382 SvUPGRADE(TARG,SVt_PV);
3384 if (value > 255 && !IN_BYTES) {
3385 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3386 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3387 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3389 (void)SvPOK_only(TARG);
3398 *tmps++ = (char)value;
3400 (void)SvPOK_only(TARG);
3402 if (PL_encoding && !IN_BYTES) {
3403 sv_recode_to_utf8(TARG, PL_encoding);
3405 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3406 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3410 *tmps++ = (char)value;
3426 const char *tmps = SvPV_const(left, len);
3428 if (DO_UTF8(left)) {
3429 /* If Unicode, try to downgrade.
3430 * If not possible, croak.
3431 * Yes, we made this up. */
3432 SV* const tsv = sv_2mortal(newSVsv(left));
3435 sv_utf8_downgrade(tsv, FALSE);
3436 tmps = SvPV_const(tsv, len);
3438 # ifdef USE_ITHREADS
3440 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3441 /* This should be threadsafe because in ithreads there is only
3442 * one thread per interpreter. If this would not be true,
3443 * we would need a mutex to protect this malloc. */
3444 PL_reentrant_buffer->_crypt_struct_buffer =
3445 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3446 #if defined(__GLIBC__) || defined(__EMX__)
3447 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3448 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3449 /* work around glibc-2.2.5 bug */
3450 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3454 # endif /* HAS_CRYPT_R */
3455 # endif /* USE_ITHREADS */
3457 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3459 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3465 "The crypt() function is unimplemented due to excessive paranoia.");
3477 bool inplace = TRUE;
3479 const int op_type = PL_op->op_type;
3482 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3488 s = (const U8*)SvPV_nomg_const(source, slen);
3494 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3496 utf8_to_uvchr(s, &ulen);
3497 if (op_type == OP_UCFIRST) {
3498 toTITLE_utf8(s, tmpbuf, &tculen);
3500 toLOWER_utf8(s, tmpbuf, &tculen);
3502 /* If the two differ, we definately cannot do inplace. */
3503 inplace = (ulen == tculen);
3504 need = slen + 1 - ulen + tculen;
3510 if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3511 /* We can convert in place. */
3514 s = d = (U8*)SvPV_force_nomg(source, slen);
3520 SvUPGRADE(dest, SVt_PV);
3521 d = (U8*)SvGROW(dest, need);
3522 (void)SvPOK_only(dest);
3531 /* slen is the byte length of the whole SV.
3532 * ulen is the byte length of the original Unicode character
3533 * stored as UTF-8 at s.
3534 * tculen is the byte length of the freshly titlecased (or
3535 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3536 * We first set the result to be the titlecased (/lowercased)
3537 * character, and then append the rest of the SV data. */
3538 sv_setpvn(dest, (char*)tmpbuf, tculen);
3540 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3544 Copy(tmpbuf, d, tculen, U8);
3545 SvCUR_set(dest, need - 1);
3550 if (IN_LOCALE_RUNTIME) {
3553 *d = (op_type == OP_UCFIRST)
3554 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3557 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3559 /* See bug #39028 */
3567 /* This will copy the trailing NUL */
3568 Copy(s + 1, d + 1, slen, U8);
3569 SvCUR_set(dest, need - 1);
3576 /* There's so much setup/teardown code common between uc and lc, I wonder if
3577 it would be worth merging the two, and just having a switch outside each
3578 of the three tight loops. */
3592 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3593 && !DO_UTF8(source)) {
3594 /* We can convert in place. */
3597 s = d = (U8*)SvPV_force_nomg(source, len);
3604 /* The old implementation would copy source into TARG at this point.
3605 This had the side effect that if source was undef, TARG was now
3606 an undefined SV with PADTMP set, and they don't warn inside
3607 sv_2pv_flags(). However, we're now getting the PV direct from
3608 source, which doesn't have PADTMP set, so it would warn. Hence the
3612 s = (const U8*)SvPV_nomg_const(source, len);
3619 SvUPGRADE(dest, SVt_PV);
3620 d = (U8*)SvGROW(dest, min);
3621 (void)SvPOK_only(dest);
3626 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3627 to check DO_UTF8 again here. */
3629 if (DO_UTF8(source)) {
3630 const U8 *const send = s + len;
3631 U8 tmpbuf[UTF8_MAXBYTES+1];
3634 const STRLEN u = UTF8SKIP(s);
3637 toUPPER_utf8(s, tmpbuf, &ulen);
3638 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3639 /* If the eventually required minimum size outgrows
3640 * the available space, we need to grow. */
3641 const UV o = d - (U8*)SvPVX_const(dest);
3643 /* If someone uppercases one million U+03B0s we SvGROW() one
3644 * million times. Or we could try guessing how much to
3645 allocate without allocating too much. Such is life. */
3647 d = (U8*)SvPVX(dest) + o;
3649 Copy(tmpbuf, d, ulen, U8);
3655 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3658 const U8 *const send = s + len;
3659 if (IN_LOCALE_RUNTIME) {
3662 for (; s < send; d++, s++)
3663 *d = toUPPER_LC(*s);
3666 for (; s < send; d++, s++)
3670 if (source != dest) {
3672 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3692 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3693 && !DO_UTF8(source)) {
3694 /* We can convert in place. */
3697 s = d = (U8*)SvPV_force_nomg(source, len);
3704 /* The old implementation would copy source into TARG at this point.
3705 This had the side effect that if source was undef, TARG was now
3706 an undefined SV with PADTMP set, and they don't warn inside
3707 sv_2pv_flags(). However, we're now getting the PV direct from
3708 source, which doesn't have PADTMP set, so it would warn. Hence the
3712 s = (const U8*)SvPV_nomg_const(source, len);
3719 SvUPGRADE(dest, SVt_PV);
3720 d = (U8*)SvGROW(dest, min);
3721 (void)SvPOK_only(dest);
3726 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3727 to check DO_UTF8 again here. */
3729 if (DO_UTF8(source)) {
3730 const U8 *const send = s + len;
3731 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3734 const STRLEN u = UTF8SKIP(s);
3736 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3738 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3739 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3742 * Now if the sigma is NOT followed by
3743 * /$ignorable_sequence$cased_letter/;
3744 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3745 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3746 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3747 * then it should be mapped to 0x03C2,
3748 * (GREEK SMALL LETTER FINAL SIGMA),
3749 * instead of staying 0x03A3.
3750 * "should be": in other words, this is not implemented yet.
3751 * See lib/unicore/SpecialCasing.txt.
3754 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3755 /* If the eventually required minimum size outgrows
3756 * the available space, we need to grow. */
3757 const UV o = d - (U8*)SvPVX_const(dest);
3759 /* If someone lowercases one million U+0130s we SvGROW() one
3760 * million times. Or we could try guessing how much to
3761 allocate without allocating too much. Such is life. */
3763 d = (U8*)SvPVX(dest) + o;
3765 Copy(tmpbuf, d, ulen, U8);
3771 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3774 const U8 *const send = s + len;
3775 if (IN_LOCALE_RUNTIME) {
3778 for (; s < send; d++, s++)
3779 *d = toLOWER_LC(*s);
3782 for (; s < send; d++, s++)
3786 if (source != dest) {
3788 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3798 SV * const sv = TOPs;
3800 register const char *s = SvPV_const(sv,len);
3802 SvUTF8_off(TARG); /* decontaminate */
3805 SvUPGRADE(TARG, SVt_PV);
3806 SvGROW(TARG, (len * 2) + 1);
3810 if (UTF8_IS_CONTINUED(*s)) {
3811 STRLEN ulen = UTF8SKIP(s);
3835 SvCUR_set(TARG, d - SvPVX_const(TARG));
3836 (void)SvPOK_only_UTF8(TARG);
3839 sv_setpvn(TARG, s, len);
3841 if (SvSMAGICAL(TARG))
3850 dVAR; dSP; dMARK; dORIGMARK;
3851 register AV* const av = (AV*)POPs;
3852 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3854 if (SvTYPE(av) == SVt_PVAV) {
3855 const I32 arybase = CopARYBASE_get(PL_curcop);
3856 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3859 for (svp = MARK + 1; svp <= SP; svp++) {
3860 const I32 elem = SvIVx(*svp);
3864 if (max > AvMAX(av))
3867 while (++MARK <= SP) {
3869 I32 elem = SvIVx(*MARK);
3873 svp = av_fetch(av, elem, lval);
3875 if (!svp || *svp == &PL_sv_undef)
3876 DIE(aTHX_ PL_no_aelem, elem);
3877 if (PL_op->op_private & OPpLVAL_INTRO)
3878 save_aelem(av, elem, svp);
3880 *MARK = svp ? *svp : &PL_sv_undef;
3883 if (GIMME != G_ARRAY) {
3885 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3891 /* Associative arrays. */
3897 HV * hash = (HV*)POPs;
3899 const I32 gimme = GIMME_V;
3902 /* might clobber stack_sp */
3903 entry = hv_iternext(hash);
3908 SV* const sv = hv_iterkeysv(entry);
3909 PUSHs(sv); /* won't clobber stack_sp */
3910 if (gimme == G_ARRAY) {
3913 /* might clobber stack_sp */
3914 val = hv_iterval(hash, entry);
3919 else if (gimme == G_SCALAR)
3929 const I32 gimme = GIMME_V;
3930 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3932 if (PL_op->op_private & OPpSLICE) {
3934 HV * const hv = (HV*)POPs;
3935 const U32 hvtype = SvTYPE(hv);
3936 if (hvtype == SVt_PVHV) { /* hash element */
3937 while (++MARK <= SP) {
3938 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3939 *MARK = sv ? sv : &PL_sv_undef;
3942 else if (hvtype == SVt_PVAV) { /* array element */
3943 if (PL_op->op_flags & OPf_SPECIAL) {
3944 while (++MARK <= SP) {
3945 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3946 *MARK = sv ? sv : &PL_sv_undef;
3951 DIE(aTHX_ "Not a HASH reference");
3954 else if (gimme == G_SCALAR) {
3959 *++MARK = &PL_sv_undef;
3965 HV * const hv = (HV*)POPs;
3967 if (SvTYPE(hv) == SVt_PVHV)
3968 sv = hv_delete_ent(hv, keysv, discard, 0);
3969 else if (SvTYPE(hv) == SVt_PVAV) {
3970 if (PL_op->op_flags & OPf_SPECIAL)
3971 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3973 DIE(aTHX_ "panic: avhv_delete no longer supported");
3976 DIE(aTHX_ "Not a HASH reference");
3992 if (PL_op->op_private & OPpEXISTS_SUB) {
3994 SV * const sv = POPs;
3995 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3998 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4004 if (SvTYPE(hv) == SVt_PVHV) {
4005 if (hv_exists_ent(hv, tmpsv, 0))
4008 else if (SvTYPE(hv) == SVt_PVAV) {
4009 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4010 if (av_exists((AV*)hv, SvIV(tmpsv)))
4015 DIE(aTHX_ "Not a HASH reference");
4022 dVAR; dSP; dMARK; dORIGMARK;
4023 register HV * const hv = (HV*)POPs;
4024 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4025 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4026 bool other_magic = FALSE;
4032 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4033 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4034 /* Try to preserve the existenceness of a tied hash
4035 * element by using EXISTS and DELETE if possible.
4036 * Fallback to FETCH and STORE otherwise */
4037 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4038 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4039 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4042 while (++MARK <= SP) {
4043 SV * const keysv = *MARK;
4046 bool preeminent = FALSE;
4049 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4050 hv_exists_ent(hv, keysv, 0);
4053 he = hv_fetch_ent(hv, keysv, lval, 0);
4054 svp = he ? &HeVAL(he) : 0;
4057 if (!svp || *svp == &PL_sv_undef) {
4058 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4061 if (HvNAME_get(hv) && isGV(*svp))
4062 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4065 save_helem(hv, keysv, svp);
4068 const char * const key = SvPV_const(keysv, keylen);
4069 SAVEDELETE(hv, savepvn(key,keylen),
4070 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4075 *MARK = svp ? *svp : &PL_sv_undef;
4077 if (GIMME != G_ARRAY) {
4079 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4085 /* List operators. */
4090 if (GIMME != G_ARRAY) {
4092 *MARK = *SP; /* unwanted list, return last item */
4094 *MARK = &PL_sv_undef;
4104 SV ** const lastrelem = PL_stack_sp;
4105 SV ** const lastlelem = PL_stack_base + POPMARK;
4106 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4107 register SV ** const firstrelem = lastlelem + 1;
4108 const I32 arybase = CopARYBASE_get(PL_curcop);
4109 I32 is_something_there = FALSE;
4111 register const I32 max = lastrelem - lastlelem;
4112 register SV **lelem;
4114 if (GIMME != G_ARRAY) {
4115 I32 ix = SvIVx(*lastlelem);
4120 if (ix < 0 || ix >= max)
4121 *firstlelem = &PL_sv_undef;
4123 *firstlelem = firstrelem[ix];
4129 SP = firstlelem - 1;
4133 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4134 I32 ix = SvIVx(*lelem);
4139 if (ix < 0 || ix >= max)
4140 *lelem = &PL_sv_undef;
4142 is_something_there = TRUE;
4143 if (!(*lelem = firstrelem[ix]))
4144 *lelem = &PL_sv_undef;
4147 if (is_something_there)
4150 SP = firstlelem - 1;
4156 dVAR; dSP; dMARK; dORIGMARK;
4157 const I32 items = SP - MARK;
4158 SV * const av = (SV *) av_make(items, MARK+1);
4159 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4160 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4161 ? newRV_noinc(av) : av));
4167 dVAR; dSP; dMARK; dORIGMARK;
4168 HV* const hv = newHV();
4171 SV * const key = *++MARK;
4172 SV * const val = newSV(0);
4174 sv_setsv(val, *++MARK);
4175 else if (ckWARN(WARN_MISC))
4176 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4177 (void)hv_store_ent(hv,key,val,0);
4180 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4181 ? newRV_noinc((SV*) hv) : (SV*)hv));
4187 dVAR; dSP; dMARK; dORIGMARK;
4188 register AV *ary = (AV*)*++MARK;
4192 register I32 offset;
4193 register I32 length;
4197 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4200 *MARK-- = SvTIED_obj((SV*)ary, mg);
4204 call_method("SPLICE",GIMME_V);
4213 offset = i = SvIVx(*MARK);
4215 offset += AvFILLp(ary) + 1;
4217 offset -= CopARYBASE_get(PL_curcop);
4219 DIE(aTHX_ PL_no_aelem, i);
4221 length = SvIVx(*MARK++);
4223 length += AvFILLp(ary) - offset + 1;
4229 length = AvMAX(ary) + 1; /* close enough to infinity */
4233 length = AvMAX(ary) + 1;
4235 if (offset > AvFILLp(ary) + 1) {
4236 if (ckWARN(WARN_MISC))
4237 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4238 offset = AvFILLp(ary) + 1;
4240 after = AvFILLp(ary) + 1 - (offset + length);
4241 if (after < 0) { /* not that much array */
4242 length += after; /* offset+length now in array */
4248 /* At this point, MARK .. SP-1 is our new LIST */
4251 diff = newlen - length;
4252 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4255 /* make new elements SVs now: avoid problems if they're from the array */
4256 for (dst = MARK, i = newlen; i; i--) {
4257 SV * const h = *dst;
4258 *dst++ = newSVsv(h);
4261 if (diff < 0) { /* shrinking the area */
4262 SV **tmparyval = NULL;
4264 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4265 Copy(MARK, tmparyval, newlen, SV*);
4268 MARK = ORIGMARK + 1;
4269 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4270 MEXTEND(MARK, length);
4271 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4273 EXTEND_MORTAL(length);
4274 for (i = length, dst = MARK; i; i--) {
4275 sv_2mortal(*dst); /* free them eventualy */
4282 *MARK = AvARRAY(ary)[offset+length-1];
4285 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4286 SvREFCNT_dec(*dst++); /* free them now */
4289 AvFILLp(ary) += diff;
4291 /* pull up or down? */
4293 if (offset < after) { /* easier to pull up */
4294 if (offset) { /* esp. if nothing to pull */
4295 src = &AvARRAY(ary)[offset-1];
4296 dst = src - diff; /* diff is negative */
4297 for (i = offset; i > 0; i--) /* can't trust Copy */
4301 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4305 if (after) { /* anything to pull down? */
4306 src = AvARRAY(ary) + offset + length;
4307 dst = src + diff; /* diff is negative */
4308 Move(src, dst, after, SV*);
4310 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4311 /* avoid later double free */
4315 dst[--i] = &PL_sv_undef;
4318 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4319 Safefree(tmparyval);
4322 else { /* no, expanding (or same) */
4323 SV** tmparyval = NULL;
4325 Newx(tmparyval, length, SV*); /* so remember deletion */
4326 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4329 if (diff > 0) { /* expanding */
4330 /* push up or down? */
4331 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4335 Move(src, dst, offset, SV*);
4337 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4339 AvFILLp(ary) += diff;
4342 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4343 av_extend(ary, AvFILLp(ary) + diff);
4344 AvFILLp(ary) += diff;
4347 dst = AvARRAY(ary) + AvFILLp(ary);
4349 for (i = after; i; i--) {
4357 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4360 MARK = ORIGMARK + 1;
4361 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4363 Copy(tmparyval, MARK, length, SV*);
4365 EXTEND_MORTAL(length);
4366 for (i = length, dst = MARK; i; i--) {
4367 sv_2mortal(*dst); /* free them eventualy */
4374 else if (length--) {
4375 *MARK = tmparyval[length];
4378 while (length-- > 0)
4379 SvREFCNT_dec(tmparyval[length]);
4383 *MARK = &PL_sv_undef;
4384 Safefree(tmparyval);
4392 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4393 register AV * const ary = (AV*)*++MARK;
4394 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4397 *MARK-- = SvTIED_obj((SV*)ary, mg);
4401 call_method("PUSH",G_SCALAR|G_DISCARD);
4405 PUSHi( AvFILL(ary) + 1 );
4408 for (++MARK; MARK <= SP; MARK++) {
4409 SV * const sv = newSV(0);
4411 sv_setsv(sv, *MARK);
4412 av_store(ary, AvFILLp(ary)+1, sv);
4415 PUSHi( AvFILLp(ary) + 1 );
4424 AV * const av = (AV*)POPs;
4425 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4429 (void)sv_2mortal(sv);
4436 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4437 register AV *ary = (AV*)*++MARK;
4438 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4441 *MARK-- = SvTIED_obj((SV*)ary, mg);
4445 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4451 av_unshift(ary, SP - MARK);
4453 SV * const sv = newSVsv(*++MARK);
4454 (void)av_store(ary, i++, sv);
4458 PUSHi( AvFILL(ary) + 1 );
4465 SV ** const oldsp = SP;
4467 if (GIMME == G_ARRAY) {
4470 register SV * const tmp = *MARK;
4474 /* safe as long as stack cannot get extended in the above */
4479 register char *down;
4483 PADOFFSET padoff_du;
4485 SvUTF8_off(TARG); /* decontaminate */
4487 do_join(TARG, &PL_sv_no, MARK, SP);
4489 sv_setsv(TARG, (SP > MARK)
4491 : (padoff_du = find_rundefsvoffset(),
4492 (padoff_du == NOT_IN_PAD
4493 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4494 ? DEFSV : PAD_SVl(padoff_du)));
4495 up = SvPV_force(TARG, len);
4497 if (DO_UTF8(TARG)) { /* first reverse each character */
4498 U8* s = (U8*)SvPVX(TARG);
4499 const U8* send = (U8*)(s + len);
4501 if (UTF8_IS_INVARIANT(*s)) {
4506 if (!utf8_to_uvchr(s, 0))
4510 down = (char*)(s - 1);
4511 /* reverse this character */
4515 *down-- = (char)tmp;
4521 down = SvPVX(TARG) + len - 1;
4525 *down-- = (char)tmp;
4527 (void)SvPOK_only_UTF8(TARG);
4539 register IV limit = POPi; /* note, negative is forever */
4540 SV * const sv = POPs;
4542 register const char *s = SvPV_const(sv, len);
4543 const bool do_utf8 = DO_UTF8(sv);
4544 const char *strend = s + len;
4546 register REGEXP *rx;
4548 register const char *m;
4550 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4551 I32 maxiters = slen + 10;
4553 const I32 origlimit = limit;
4556 const I32 gimme = GIMME_V;
4557 const I32 oldsave = PL_savestack_ix;
4558 I32 make_mortal = 1;
4563 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4568 DIE(aTHX_ "panic: pp_split");
4571 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4572 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4574 RX_MATCH_UTF8_set(rx, do_utf8);
4576 if (pm->op_pmreplroot) {
4578 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4580 ary = GvAVn((GV*)pm->op_pmreplroot);
4583 else if (gimme != G_ARRAY)
4584 ary = GvAVn(PL_defgv);
4587 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4593 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4595 XPUSHs(SvTIED_obj((SV*)ary, mg));
4602 for (i = AvFILLp(ary); i >= 0; i--)
4603 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4605 /* temporarily switch stacks */
4606 SAVESWITCHSTACK(PL_curstack, ary);
4610 base = SP - PL_stack_base;
4612 if (pm->op_pmflags & PMf_SKIPWHITE) {
4614 while (*s == ' ' || is_utf8_space((U8*)s))
4617 else if (pm->op_pmflags & PMf_LOCALE) {
4618 while (isSPACE_LC(*s))
4626 if (pm->op_pmflags & PMf_MULTILINE) {
4631 limit = maxiters + 2;
4632 if (pm->op_pmflags & PMf_WHITE) {
4635 /* this one uses 'm' and is a negative test */
4637 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4638 const int t = UTF8SKIP(m);
4639 /* is_utf8_space returns FALSE for malform utf8 */
4645 } else if (pm->op_pmflags & PMf_LOCALE) {
4646 while (m < strend && !isSPACE_LC(*m))
4649 while (m < strend && !isSPACE(*m))
4655 dstr = newSVpvn(s, m-s);
4659 (void)SvUTF8_on(dstr);
4662 /* skip the whitespace found last */
4664 s = m + UTF8SKIP(m);
4668 /* this one uses 's' and is a positive test */
4670 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4672 } else if (pm->op_pmflags & PMf_LOCALE) {
4673 while (s < strend && isSPACE_LC(*s))
4676 while (s < strend && isSPACE(*s))
4681 else if (rx->extflags & RXf_START_ONLY) {
4683 for (m = s; m < strend && *m != '\n'; m++)
4688 dstr = newSVpvn(s, m-s);
4692 (void)SvUTF8_on(dstr);
4697 else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
4698 (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
4699 && (rx->extflags & RXf_CHECK_ALL)
4700 && !(rx->extflags & RXf_ANCH)) {
4701 const int tail = (rx->extflags & RXf_INTUIT_TAIL);
4702 SV * const csv = CALLREG_INTUIT_STRING(rx);
4704 len = rx->minlenret;
4705 if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
4706 const char c = *SvPV_nolen_const(csv);
4708 for (m = s; m < strend && *m != c; m++)
4712 dstr = newSVpvn(s, m-s);
4716 (void)SvUTF8_on(dstr);
4718 /* The rx->minlen is in characters but we want to step
4719 * s ahead by bytes. */
4721 s = (char*)utf8_hop((U8*)m, len);
4723 s = m + len; /* Fake \n at the end */
4727 while (s < strend && --limit &&
4728 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4729 csv, multiline ? FBMrf_MULTILINE : 0)) )
4731 dstr = newSVpvn(s, m-s);
4735 (void)SvUTF8_on(dstr);
4737 /* The rx->minlen is in characters but we want to step
4738 * s ahead by bytes. */
4740 s = (char*)utf8_hop((U8*)m, len);
4742 s = m + len; /* Fake \n at the end */
4747 maxiters += slen * rx->nparens;
4748 while (s < strend && --limit)
4752 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4755 if (rex_return == 0)
4757 TAINT_IF(RX_MATCH_TAINTED(rx));
4758 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4763 strend = s + (strend - m);
4765 m = rx->startp[0] + orig;
4766 dstr = newSVpvn(s, m-s);
4770 (void)SvUTF8_on(dstr);
4774 for (i = 1; i <= (I32)rx->nparens; i++) {
4775 s = rx->startp[i] + orig;
4776 m = rx->endp[i] + orig;
4778 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4779 parens that didn't match -- they should be set to
4780 undef, not the empty string */
4781 if (m >= orig && s >= orig) {
4782 dstr = newSVpvn(s, m-s);
4785 dstr = &PL_sv_undef; /* undef, not "" */
4789 (void)SvUTF8_on(dstr);
4793 s = rx->endp[0] + orig;
4797 iters = (SP - PL_stack_base) - base;
4798 if (iters > maxiters)
4799 DIE(aTHX_ "Split loop");
4801 /* keep field after final delim? */
4802 if (s < strend || (iters && origlimit)) {
4803 const STRLEN l = strend - s;
4804 dstr = newSVpvn(s, l);
4808 (void)SvUTF8_on(dstr);
4812 else if (!origlimit) {
4813 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4814 if (TOPs && !make_mortal)
4817 *SP-- = &PL_sv_undef;
4822 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4826 if (SvSMAGICAL(ary)) {
4831 if (gimme == G_ARRAY) {
4833 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4841 call_method("PUSH",G_SCALAR|G_DISCARD);
4844 if (gimme == G_ARRAY) {
4846 /* EXTEND should not be needed - we just popped them */
4848 for (i=0; i < iters; i++) {
4849 SV **svp = av_fetch(ary, i, FALSE);
4850 PUSHs((svp) ? *svp : &PL_sv_undef);
4857 if (gimme == G_ARRAY)
4873 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4874 || SvTYPE(retsv) == SVt_PVCV) {
4875 retsv = refto(retsv);
4882 PP(unimplemented_op)
4885 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4891 * c-indentation-style: bsd
4893 * indent-tabs-mode: t
4896 * ex: set ts=8 sts=4 sw=4 noet: