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 prepare_SV_for_RV(sv);
176 SvRV_set(sv, (SV*)gv);
181 if (PL_op->op_flags & OPf_REF ||
182 PL_op->op_private & HINT_STRICT_REFS)
183 DIE(aTHX_ PL_no_usym, "a symbol");
184 if (ckWARN(WARN_UNINITIALIZED))
188 if ((PL_op->op_flags & OPf_SPECIAL) &&
189 !(PL_op->op_flags & OPf_MOD))
191 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
193 && (!is_gv_magical_sv(sv,0)
194 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
200 if (PL_op->op_private & HINT_STRICT_REFS)
201 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
202 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
203 == OPpDONT_INIT_GV) {
204 /* We are the target of a coderef assignment. Return
205 the scalar unchanged, and let pp_sasssign deal with
209 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
213 if (PL_op->op_private & OPpLVAL_INTRO)
214 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
219 /* Helper function for pp_rv2sv and pp_rv2av */
221 Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type,
227 if (PL_op->op_private & HINT_STRICT_REFS) {
229 Perl_die(aTHX_ PL_no_symref_sv, sv, what);
231 Perl_die(aTHX_ PL_no_usym, what);
234 if (PL_op->op_flags & OPf_REF)
235 Perl_die(aTHX_ PL_no_usym, what);
236 if (ckWARN(WARN_UNINITIALIZED))
238 if (type != SVt_PV && GIMME_V == G_ARRAY) {
242 **spp = &PL_sv_undef;
245 if ((PL_op->op_flags & OPf_SPECIAL) &&
246 !(PL_op->op_flags & OPf_MOD))
248 gv = gv_fetchsv(sv, 0, type);
250 && (!is_gv_magical_sv(sv,0)
251 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
253 **spp = &PL_sv_undef;
258 gv = gv_fetchsv(sv, GV_ADD, type);
270 tryAMAGICunDEREF(to_sv);
273 switch (SvTYPE(sv)) {
279 DIE(aTHX_ "Not a SCALAR reference");
286 if (SvTYPE(gv) != SVt_PVGV) {
287 if (SvGMAGICAL(sv)) {
292 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
298 if (PL_op->op_flags & OPf_MOD) {
299 if (PL_op->op_private & OPpLVAL_INTRO) {
300 if (cUNOP->op_first->op_type == OP_NULL)
301 sv = save_scalar((GV*)TOPs);
303 sv = save_scalar(gv);
305 Perl_croak(aTHX_ PL_no_localize_ref);
307 else if (PL_op->op_private & OPpDEREF)
308 vivify_ref(sv, PL_op->op_private & OPpDEREF);
317 AV * const av = (AV*)TOPs;
318 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
320 *sv = newSV_type(SVt_PVMG);
321 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
329 dVAR; dSP; dTARGET; dPOPss;
331 if (PL_op->op_flags & OPf_MOD || LVRET) {
332 if (SvTYPE(TARG) < SVt_PVLV) {
333 sv_upgrade(TARG, SVt_PVLV);
334 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
338 if (LvTARG(TARG) != sv) {
340 SvREFCNT_dec(LvTARG(TARG));
341 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
343 PUSHs(TARG); /* no SvSETMAGIC */
347 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
348 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
349 if (mg && mg->mg_len >= 0) {
353 PUSHi(i + CopARYBASE_get(PL_curcop));
366 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
368 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
371 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
372 /* (But not in defined().) */
374 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
377 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
378 if ((PL_op->op_private & OPpLVAL_INTRO)) {
379 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
382 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
385 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
389 cv = (CV*)&PL_sv_undef;
400 SV *ret = &PL_sv_undef;
402 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
403 const char * s = SvPVX_const(TOPs);
404 if (strnEQ(s, "CORE::", 6)) {
405 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
406 if (code < 0) { /* Overridable. */
407 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
408 int i = 0, n = 0, seen_question = 0, defgv = 0;
410 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
412 if (code == -KEY_chop || code == -KEY_chomp
413 || code == -KEY_exec || code == -KEY_system)
415 if (code == -KEY_mkdir) {
416 ret = sv_2mortal(newSVpvs("_;$"));
419 if (code == -KEY_readpipe) {
420 s = "CORE::backtick";
422 while (i < MAXO) { /* The slow way. */
423 if (strEQ(s + 6, PL_op_name[i])
424 || strEQ(s + 6, PL_op_desc[i]))
430 goto nonesuch; /* Should not happen... */
432 defgv = PL_opargs[i] & OA_DEFGV;
433 oa = PL_opargs[i] >> OASHIFT;
435 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
439 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
440 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
441 /* But globs are already references (kinda) */
442 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
446 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
449 if (defgv && str[n - 1] == '$')
452 ret = sv_2mortal(newSVpvn(str, n - 1));
454 else if (code) /* Non-Overridable */
456 else { /* None such */
458 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
462 cv = sv_2cv(TOPs, &stash, &gv, 0);
464 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
473 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
475 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
491 if (GIMME != G_ARRAY) {
495 *MARK = &PL_sv_undef;
496 *MARK = refto(*MARK);
500 EXTEND_MORTAL(SP - MARK);
502 *MARK = refto(*MARK);
507 S_refto(pTHX_ SV *sv)
512 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
515 if (!(sv = LvTARG(sv)))
518 SvREFCNT_inc_void_NN(sv);
520 else if (SvTYPE(sv) == SVt_PVAV) {
521 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
524 SvREFCNT_inc_void_NN(sv);
526 else if (SvPADTMP(sv) && !IS_PADGV(sv))
530 SvREFCNT_inc_void_NN(sv);
533 sv_upgrade(rv, SVt_IV);
543 SV * const sv = POPs;
548 if (!sv || !SvROK(sv))
551 pv = sv_reftype(SvRV(sv),TRUE);
552 PUSHp(pv, strlen(pv));
562 stash = CopSTASH(PL_curcop);
564 SV * const ssv = POPs;
568 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
569 Perl_croak(aTHX_ "Attempt to bless into a reference");
570 ptr = SvPV_const(ssv,len);
571 if (len == 0 && ckWARN(WARN_MISC))
572 Perl_warner(aTHX_ packWARN(WARN_MISC),
573 "Explicit blessing to '' (assuming package main)");
574 stash = gv_stashpvn(ptr, len, GV_ADD);
577 (void)sv_bless(TOPs, stash);
586 const char * const elem = SvPV_nolen_const(sv);
587 GV * const gv = (GV*)POPs;
592 /* elem will always be NUL terminated. */
593 const char * const second_letter = elem + 1;
596 if (strEQ(second_letter, "RRAY"))
597 tmpRef = (SV*)GvAV(gv);
600 if (strEQ(second_letter, "ODE"))
601 tmpRef = (SV*)GvCVu(gv);
604 if (strEQ(second_letter, "ILEHANDLE")) {
605 /* finally deprecated in 5.8.0 */
606 deprecate("*glob{FILEHANDLE}");
607 tmpRef = (SV*)GvIOp(gv);
610 if (strEQ(second_letter, "ORMAT"))
611 tmpRef = (SV*)GvFORM(gv);
614 if (strEQ(second_letter, "LOB"))
618 if (strEQ(second_letter, "ASH"))
619 tmpRef = (SV*)GvHV(gv);
622 if (*second_letter == 'O' && !elem[2])
623 tmpRef = (SV*)GvIOp(gv);
626 if (strEQ(second_letter, "AME"))
627 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
630 if (strEQ(second_letter, "ACKAGE")) {
631 const HV * const stash = GvSTASH(gv);
632 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
633 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
637 if (strEQ(second_letter, "CALAR"))
652 /* Pattern matching */
657 register unsigned char *s;
660 register I32 *sfirst;
664 if (sv == PL_lastscream) {
668 s = (unsigned char*)(SvPV(sv, len));
670 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
671 /* No point in studying a zero length string, and not safe to study
672 anything that doesn't appear to be a simple scalar (and hence might
673 change between now and when the regexp engine runs without our set
674 magic ever running) such as a reference to an object with overloaded
680 SvSCREAM_off(PL_lastscream);
681 SvREFCNT_dec(PL_lastscream);
683 PL_lastscream = SvREFCNT_inc_simple(sv);
685 s = (unsigned char*)(SvPV(sv, len));
689 if (pos > PL_maxscream) {
690 if (PL_maxscream < 0) {
691 PL_maxscream = pos + 80;
692 Newx(PL_screamfirst, 256, I32);
693 Newx(PL_screamnext, PL_maxscream, I32);
696 PL_maxscream = pos + pos / 4;
697 Renew(PL_screamnext, PL_maxscream, I32);
701 sfirst = PL_screamfirst;
702 snext = PL_screamnext;
704 if (!sfirst || !snext)
705 DIE(aTHX_ "do_study: out of memory");
707 for (ch = 256; ch; --ch)
712 register const I32 ch = s[pos];
714 snext[pos] = sfirst[ch] - pos;
721 /* piggyback on m//g magic */
722 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
731 if (PL_op->op_flags & OPf_STACKED)
733 else if (PL_op->op_private & OPpTARGET_MY)
739 TARG = sv_newmortal();
744 /* Lvalue operators. */
756 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
758 do_chop(TARG, *++MARK);
767 SETi(do_chomp(TOPs));
773 dVAR; dSP; dMARK; dTARGET;
774 register I32 count = 0;
777 count += do_chomp(POPs);
787 if (!PL_op->op_private) {
796 SV_CHECK_THINKFIRST_COW_DROP(sv);
798 switch (SvTYPE(sv)) {
808 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
809 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
810 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
814 /* let user-undef'd sub keep its identity */
815 GV* const gv = CvGV((CV*)sv);
822 SvSetMagicSV(sv, &PL_sv_undef);
828 if((stash = GvHV((GV*)sv)) && HvNAME_get(stash))
829 mro_isa_changed_in(stash);
830 /* undef *Pkg::meth_name ... */
831 else if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
832 mro_method_changed_in(stash);
836 GvGP(sv) = gp_ref(gp);
838 GvLINE(sv) = CopLINE(PL_curcop);
844 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
859 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
860 DIE(aTHX_ PL_no_modify);
861 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
862 && SvIVX(TOPs) != IV_MIN)
864 SvIV_set(TOPs, SvIVX(TOPs) - 1);
865 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
876 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
877 DIE(aTHX_ PL_no_modify);
878 sv_setsv(TARG, TOPs);
879 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
880 && SvIVX(TOPs) != IV_MAX)
882 SvIV_set(TOPs, SvIVX(TOPs) + 1);
883 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
888 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
898 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
899 DIE(aTHX_ PL_no_modify);
900 sv_setsv(TARG, TOPs);
901 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
902 && SvIVX(TOPs) != IV_MIN)
904 SvIV_set(TOPs, SvIVX(TOPs) - 1);
905 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
914 /* Ordinary operators. */
918 dVAR; dSP; dATARGET; SV *svl, *svr;
919 #ifdef PERL_PRESERVE_IVUV
922 tryAMAGICbin(pow,opASSIGN);
923 svl = sv_2num(TOPm1s);
925 #ifdef PERL_PRESERVE_IVUV
926 /* For integer to integer power, we do the calculation by hand wherever
927 we're sure it is safe; otherwise we call pow() and try to convert to
928 integer afterwards. */
941 const IV iv = SvIVX(svr);
945 goto float_it; /* Can't do negative powers this way. */
949 baseuok = SvUOK(svl);
953 const IV iv = SvIVX(svl);
956 baseuok = TRUE; /* effectively it's a UV now */
958 baseuv = -iv; /* abs, baseuok == false records sign */
961 /* now we have integer ** positive integer. */
964 /* foo & (foo - 1) is zero only for a power of 2. */
965 if (!(baseuv & (baseuv - 1))) {
966 /* We are raising power-of-2 to a positive integer.
967 The logic here will work for any base (even non-integer
968 bases) but it can be less accurate than
969 pow (base,power) or exp (power * log (base)) when the
970 intermediate values start to spill out of the mantissa.
971 With powers of 2 we know this can't happen.
972 And powers of 2 are the favourite thing for perl
973 programmers to notice ** not doing what they mean. */
975 NV base = baseuok ? baseuv : -(NV)baseuv;
980 while (power >>= 1) {
991 register unsigned int highbit = 8 * sizeof(UV);
992 register unsigned int diff = 8 * sizeof(UV);
995 if (baseuv >> highbit) {
999 /* we now have baseuv < 2 ** highbit */
1000 if (power * highbit <= 8 * sizeof(UV)) {
1001 /* result will definitely fit in UV, so use UV math
1002 on same algorithm as above */
1003 register UV result = 1;
1004 register UV base = baseuv;
1005 const bool odd_power = (bool)(power & 1);
1009 while (power >>= 1) {
1016 if (baseuok || !odd_power)
1017 /* answer is positive */
1019 else if (result <= (UV)IV_MAX)
1020 /* answer negative, fits in IV */
1021 SETi( -(IV)result );
1022 else if (result == (UV)IV_MIN)
1023 /* 2's complement assumption: special case IV_MIN */
1026 /* answer negative, doesn't fit */
1027 SETn( -(NV)result );
1037 NV right = SvNV(svr);
1038 NV left = SvNV(svl);
1041 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1043 We are building perl with long double support and are on an AIX OS
1044 afflicted with a powl() function that wrongly returns NaNQ for any
1045 negative base. This was reported to IBM as PMR #23047-379 on
1046 03/06/2006. The problem exists in at least the following versions
1047 of AIX and the libm fileset, and no doubt others as well:
1049 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1050 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1051 AIX 5.2.0 bos.adt.libm 5.2.0.85
1053 So, until IBM fixes powl(), we provide the following workaround to
1054 handle the problem ourselves. Our logic is as follows: for
1055 negative bases (left), we use fmod(right, 2) to check if the
1056 exponent is an odd or even integer:
1058 - if odd, powl(left, right) == -powl(-left, right)
1059 - if even, powl(left, right) == powl(-left, right)
1061 If the exponent is not an integer, the result is rightly NaNQ, so
1062 we just return that (as NV_NAN).
1066 NV mod2 = Perl_fmod( right, 2.0 );
1067 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1068 SETn( -Perl_pow( -left, right) );
1069 } else if (mod2 == 0.0) { /* even integer */
1070 SETn( Perl_pow( -left, right) );
1071 } else { /* fractional power */
1075 SETn( Perl_pow( left, right) );
1078 SETn( Perl_pow( left, right) );
1079 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1081 #ifdef PERL_PRESERVE_IVUV
1091 dVAR; dSP; dATARGET; SV *svl, *svr;
1092 tryAMAGICbin(mult,opASSIGN);
1093 svl = sv_2num(TOPm1s);
1094 svr = sv_2num(TOPs);
1095 #ifdef PERL_PRESERVE_IVUV
1098 /* Unless the left argument is integer in range we are going to have to
1099 use NV maths. Hence only attempt to coerce the right argument if
1100 we know the left is integer. */
1101 /* Left operand is defined, so is it IV? */
1104 bool auvok = SvUOK(svl);
1105 bool buvok = SvUOK(svr);
1106 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1107 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1116 const IV aiv = SvIVX(svl);
1119 auvok = TRUE; /* effectively it's a UV now */
1121 alow = -aiv; /* abs, auvok == false records sign */
1127 const IV biv = SvIVX(svr);
1130 buvok = TRUE; /* effectively it's a UV now */
1132 blow = -biv; /* abs, buvok == false records sign */
1136 /* If this does sign extension on unsigned it's time for plan B */
1137 ahigh = alow >> (4 * sizeof (UV));
1139 bhigh = blow >> (4 * sizeof (UV));
1141 if (ahigh && bhigh) {
1143 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1144 which is overflow. Drop to NVs below. */
1145 } else if (!ahigh && !bhigh) {
1146 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1147 so the unsigned multiply cannot overflow. */
1148 const UV product = alow * blow;
1149 if (auvok == buvok) {
1150 /* -ve * -ve or +ve * +ve gives a +ve result. */
1154 } else if (product <= (UV)IV_MIN) {
1155 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1156 /* -ve result, which could overflow an IV */
1158 SETi( -(IV)product );
1160 } /* else drop to NVs below. */
1162 /* One operand is large, 1 small */
1165 /* swap the operands */
1167 bhigh = blow; /* bhigh now the temp var for the swap */
1171 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1172 multiplies can't overflow. shift can, add can, -ve can. */
1173 product_middle = ahigh * blow;
1174 if (!(product_middle & topmask)) {
1175 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1177 product_middle <<= (4 * sizeof (UV));
1178 product_low = alow * blow;
1180 /* as for pp_add, UV + something mustn't get smaller.
1181 IIRC ANSI mandates this wrapping *behaviour* for
1182 unsigned whatever the actual representation*/
1183 product_low += product_middle;
1184 if (product_low >= product_middle) {
1185 /* didn't overflow */
1186 if (auvok == buvok) {
1187 /* -ve * -ve or +ve * +ve gives a +ve result. */
1189 SETu( product_low );
1191 } else if (product_low <= (UV)IV_MIN) {
1192 /* 2s complement assumption again */
1193 /* -ve result, which could overflow an IV */
1195 SETi( -(IV)product_low );
1197 } /* else drop to NVs below. */
1199 } /* product_middle too large */
1200 } /* ahigh && bhigh */
1205 NV right = SvNV(svr);
1206 NV left = SvNV(svl);
1208 SETn( left * right );
1215 dVAR; dSP; dATARGET; SV *svl, *svr;
1216 tryAMAGICbin(div,opASSIGN);
1217 svl = sv_2num(TOPm1s);
1218 svr = sv_2num(TOPs);
1219 /* Only try to do UV divide first
1220 if ((SLOPPYDIVIDE is true) or
1221 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1223 The assumption is that it is better to use floating point divide
1224 whenever possible, only doing integer divide first if we can't be sure.
1225 If NV_PRESERVES_UV is true then we know at compile time that no UV
1226 can be too large to preserve, so don't need to compile the code to
1227 test the size of UVs. */
1230 # define PERL_TRY_UV_DIVIDE
1231 /* ensure that 20./5. == 4. */
1233 # ifdef PERL_PRESERVE_IVUV
1234 # ifndef NV_PRESERVES_UV
1235 # define PERL_TRY_UV_DIVIDE
1240 #ifdef PERL_TRY_UV_DIVIDE
1245 bool left_non_neg = SvUOK(svl);
1246 bool right_non_neg = SvUOK(svr);
1250 if (right_non_neg) {
1254 const IV biv = SvIVX(svr);
1257 right_non_neg = TRUE; /* effectively it's a UV now */
1263 /* historically undef()/0 gives a "Use of uninitialized value"
1264 warning before dieing, hence this test goes here.
1265 If it were immediately before the second SvIV_please, then
1266 DIE() would be invoked before left was even inspected, so
1267 no inpsection would give no warning. */
1269 DIE(aTHX_ "Illegal division by zero");
1275 const IV aiv = SvIVX(svl);
1278 left_non_neg = TRUE; /* effectively it's a UV now */
1287 /* For sloppy divide we always attempt integer division. */
1289 /* Otherwise we only attempt it if either or both operands
1290 would not be preserved by an NV. If both fit in NVs
1291 we fall through to the NV divide code below. However,
1292 as left >= right to ensure integer result here, we know that
1293 we can skip the test on the right operand - right big
1294 enough not to be preserved can't get here unless left is
1297 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1300 /* Integer division can't overflow, but it can be imprecise. */
1301 const UV result = left / right;
1302 if (result * right == left) {
1303 SP--; /* result is valid */
1304 if (left_non_neg == right_non_neg) {
1305 /* signs identical, result is positive. */
1309 /* 2s complement assumption */
1310 if (result <= (UV)IV_MIN)
1311 SETi( -(IV)result );
1313 /* It's exact but too negative for IV. */
1314 SETn( -(NV)result );
1317 } /* tried integer divide but it was not an integer result */
1318 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1319 } /* left wasn't SvIOK */
1320 } /* right wasn't SvIOK */
1321 #endif /* PERL_TRY_UV_DIVIDE */
1323 NV right = SvNV(svr);
1324 NV left = SvNV(svl);
1325 (void)POPs;(void)POPs;
1326 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1327 if (! Perl_isnan(right) && right == 0.0)
1331 DIE(aTHX_ "Illegal division by zero");
1332 PUSHn( left / right );
1339 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1343 bool left_neg = FALSE;
1344 bool right_neg = FALSE;
1345 bool use_double = FALSE;
1346 bool dright_valid = FALSE;
1350 SV * const svr = sv_2num(TOPs);
1353 right_neg = !SvUOK(svr);
1357 const IV biv = SvIVX(svr);
1360 right_neg = FALSE; /* effectively it's a UV now */
1368 right_neg = dright < 0;
1371 if (dright < UV_MAX_P1) {
1372 right = U_V(dright);
1373 dright_valid = TRUE; /* In case we need to use double below. */
1380 /* At this point use_double is only true if right is out of range for
1381 a UV. In range NV has been rounded down to nearest UV and
1382 use_double false. */
1383 svl = sv_2num(TOPs);
1385 if (!use_double && SvIOK(svl)) {
1387 left_neg = !SvUOK(svl);
1391 const IV aiv = SvIVX(svl);
1394 left_neg = FALSE; /* effectively it's a UV now */
1403 left_neg = dleft < 0;
1407 /* This should be exactly the 5.6 behaviour - if left and right are
1408 both in range for UV then use U_V() rather than floor. */
1410 if (dleft < UV_MAX_P1) {
1411 /* right was in range, so is dleft, so use UVs not double.
1415 /* left is out of range for UV, right was in range, so promote
1416 right (back) to double. */
1418 /* The +0.5 is used in 5.6 even though it is not strictly
1419 consistent with the implicit +0 floor in the U_V()
1420 inside the #if 1. */
1421 dleft = Perl_floor(dleft + 0.5);
1424 dright = Perl_floor(dright + 0.5);
1435 DIE(aTHX_ "Illegal modulus zero");
1437 dans = Perl_fmod(dleft, dright);
1438 if ((left_neg != right_neg) && dans)
1439 dans = dright - dans;
1442 sv_setnv(TARG, dans);
1448 DIE(aTHX_ "Illegal modulus zero");
1451 if ((left_neg != right_neg) && ans)
1454 /* XXX may warn: unary minus operator applied to unsigned type */
1455 /* could change -foo to be (~foo)+1 instead */
1456 if (ans <= ~((UV)IV_MAX)+1)
1457 sv_setiv(TARG, ~ans+1);
1459 sv_setnv(TARG, -(NV)ans);
1462 sv_setuv(TARG, ans);
1471 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1478 const UV uv = SvUV(sv);
1480 count = IV_MAX; /* The best we can do? */
1484 const IV iv = SvIV(sv);
1491 else if (SvNOKp(sv)) {
1492 const NV nv = SvNV(sv);
1500 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1502 static const char oom_list_extend[] = "Out of memory during list extend";
1503 const I32 items = SP - MARK;
1504 const I32 max = items * count;
1506 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1507 /* Did the max computation overflow? */
1508 if (items > 0 && max > 0 && (max < items || max < count))
1509 Perl_croak(aTHX_ oom_list_extend);
1514 /* This code was intended to fix 20010809.028:
1517 for (($x =~ /./g) x 2) {
1518 print chop; # "abcdabcd" expected as output.
1521 * but that change (#11635) broke this code:
1523 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1525 * I can't think of a better fix that doesn't introduce
1526 * an efficiency hit by copying the SVs. The stack isn't
1527 * refcounted, and mortalisation obviously doesn't
1528 * Do The Right Thing when the stack has more than
1529 * one pointer to the same mortal value.
1533 *SP = sv_2mortal(newSVsv(*SP));
1543 repeatcpy((char*)(MARK + items), (char*)MARK,
1544 items * sizeof(SV*), count - 1);
1547 else if (count <= 0)
1550 else { /* Note: mark already snarfed by pp_list */
1551 SV * const tmpstr = POPs;
1554 static const char oom_string_extend[] =
1555 "Out of memory during string extend";
1557 SvSetSV(TARG, tmpstr);
1558 SvPV_force(TARG, len);
1559 isutf = DO_UTF8(TARG);
1564 const STRLEN max = (UV)count * len;
1565 if (len > MEM_SIZE_MAX / count)
1566 Perl_croak(aTHX_ oom_string_extend);
1567 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1568 SvGROW(TARG, max + 1);
1569 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1570 SvCUR_set(TARG, SvCUR(TARG) * count);
1572 *SvEND(TARG) = '\0';
1575 (void)SvPOK_only_UTF8(TARG);
1577 (void)SvPOK_only(TARG);
1579 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1580 /* The parser saw this as a list repeat, and there
1581 are probably several items on the stack. But we're
1582 in scalar context, and there's no pp_list to save us
1583 now. So drop the rest of the items -- robin@kitsite.com
1596 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1597 tryAMAGICbin(subtr,opASSIGN);
1598 svl = sv_2num(TOPm1s);
1599 svr = sv_2num(TOPs);
1600 useleft = USE_LEFT(svl);
1601 #ifdef PERL_PRESERVE_IVUV
1602 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1603 "bad things" happen if you rely on signed integers wrapping. */
1606 /* Unless the left argument is integer in range we are going to have to
1607 use NV maths. Hence only attempt to coerce the right argument if
1608 we know the left is integer. */
1609 register UV auv = 0;
1615 a_valid = auvok = 1;
1616 /* left operand is undef, treat as zero. */
1618 /* Left operand is defined, so is it IV? */
1621 if ((auvok = SvUOK(svl)))
1624 register const IV aiv = SvIVX(svl);
1627 auvok = 1; /* Now acting as a sign flag. */
1628 } else { /* 2s complement assumption for IV_MIN */
1636 bool result_good = 0;
1639 bool buvok = SvUOK(svr);
1644 register const IV biv = SvIVX(svr);
1651 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1652 else "IV" now, independent of how it came in.
1653 if a, b represents positive, A, B negative, a maps to -A etc
1658 all UV maths. negate result if A negative.
1659 subtract if signs same, add if signs differ. */
1661 if (auvok ^ buvok) {
1670 /* Must get smaller */
1675 if (result <= buv) {
1676 /* result really should be -(auv-buv). as its negation
1677 of true value, need to swap our result flag */
1689 if (result <= (UV)IV_MIN)
1690 SETi( -(IV)result );
1692 /* result valid, but out of range for IV. */
1693 SETn( -(NV)result );
1697 } /* Overflow, drop through to NVs. */
1702 NV value = SvNV(svr);
1706 /* left operand is undef, treat as zero - value */
1710 SETn( SvNV(svl) - value );
1717 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1719 const IV shift = POPi;
1720 if (PL_op->op_private & HINT_INTEGER) {
1734 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1736 const IV shift = POPi;
1737 if (PL_op->op_private & HINT_INTEGER) {
1751 dVAR; dSP; tryAMAGICbinSET(lt,0);
1752 #ifdef PERL_PRESERVE_IVUV
1755 SvIV_please(TOPm1s);
1756 if (SvIOK(TOPm1s)) {
1757 bool auvok = SvUOK(TOPm1s);
1758 bool buvok = SvUOK(TOPs);
1760 if (!auvok && !buvok) { /* ## IV < IV ## */
1761 const IV aiv = SvIVX(TOPm1s);
1762 const IV biv = SvIVX(TOPs);
1765 SETs(boolSV(aiv < biv));
1768 if (auvok && buvok) { /* ## UV < UV ## */
1769 const UV auv = SvUVX(TOPm1s);
1770 const UV buv = SvUVX(TOPs);
1773 SETs(boolSV(auv < buv));
1776 if (auvok) { /* ## UV < IV ## */
1778 const IV biv = SvIVX(TOPs);
1781 /* As (a) is a UV, it's >=0, so it cannot be < */
1786 SETs(boolSV(auv < (UV)biv));
1789 { /* ## IV < UV ## */
1790 const IV aiv = SvIVX(TOPm1s);
1794 /* As (b) is a UV, it's >=0, so it must be < */
1801 SETs(boolSV((UV)aiv < buv));
1807 #ifndef NV_PRESERVES_UV
1808 #ifdef PERL_PRESERVE_IVUV
1811 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1813 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1818 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1820 if (Perl_isnan(left) || Perl_isnan(right))
1822 SETs(boolSV(left < right));
1825 SETs(boolSV(TOPn < value));
1833 dVAR; dSP; tryAMAGICbinSET(gt,0);
1834 #ifdef PERL_PRESERVE_IVUV
1837 SvIV_please(TOPm1s);
1838 if (SvIOK(TOPm1s)) {
1839 bool auvok = SvUOK(TOPm1s);
1840 bool buvok = SvUOK(TOPs);
1842 if (!auvok && !buvok) { /* ## IV > IV ## */
1843 const IV aiv = SvIVX(TOPm1s);
1844 const IV biv = SvIVX(TOPs);
1847 SETs(boolSV(aiv > biv));
1850 if (auvok && buvok) { /* ## UV > UV ## */
1851 const UV auv = SvUVX(TOPm1s);
1852 const UV buv = SvUVX(TOPs);
1855 SETs(boolSV(auv > buv));
1858 if (auvok) { /* ## UV > IV ## */
1860 const IV biv = SvIVX(TOPs);
1864 /* As (a) is a UV, it's >=0, so it must be > */
1869 SETs(boolSV(auv > (UV)biv));
1872 { /* ## IV > UV ## */
1873 const IV aiv = SvIVX(TOPm1s);
1877 /* As (b) is a UV, it's >=0, so it cannot be > */
1884 SETs(boolSV((UV)aiv > buv));
1890 #ifndef NV_PRESERVES_UV
1891 #ifdef PERL_PRESERVE_IVUV
1894 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1896 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1901 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1903 if (Perl_isnan(left) || Perl_isnan(right))
1905 SETs(boolSV(left > right));
1908 SETs(boolSV(TOPn > value));
1916 dVAR; dSP; tryAMAGICbinSET(le,0);
1917 #ifdef PERL_PRESERVE_IVUV
1920 SvIV_please(TOPm1s);
1921 if (SvIOK(TOPm1s)) {
1922 bool auvok = SvUOK(TOPm1s);
1923 bool buvok = SvUOK(TOPs);
1925 if (!auvok && !buvok) { /* ## IV <= IV ## */
1926 const IV aiv = SvIVX(TOPm1s);
1927 const IV biv = SvIVX(TOPs);
1930 SETs(boolSV(aiv <= biv));
1933 if (auvok && buvok) { /* ## UV <= UV ## */
1934 UV auv = SvUVX(TOPm1s);
1935 UV buv = SvUVX(TOPs);
1938 SETs(boolSV(auv <= buv));
1941 if (auvok) { /* ## UV <= IV ## */
1943 const IV biv = SvIVX(TOPs);
1947 /* As (a) is a UV, it's >=0, so a cannot be <= */
1952 SETs(boolSV(auv <= (UV)biv));
1955 { /* ## IV <= UV ## */
1956 const IV aiv = SvIVX(TOPm1s);
1960 /* As (b) is a UV, it's >=0, so a must be <= */
1967 SETs(boolSV((UV)aiv <= buv));
1973 #ifndef NV_PRESERVES_UV
1974 #ifdef PERL_PRESERVE_IVUV
1977 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1979 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1984 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1986 if (Perl_isnan(left) || Perl_isnan(right))
1988 SETs(boolSV(left <= right));
1991 SETs(boolSV(TOPn <= value));
1999 dVAR; dSP; tryAMAGICbinSET(ge,0);
2000 #ifdef PERL_PRESERVE_IVUV
2003 SvIV_please(TOPm1s);
2004 if (SvIOK(TOPm1s)) {
2005 bool auvok = SvUOK(TOPm1s);
2006 bool buvok = SvUOK(TOPs);
2008 if (!auvok && !buvok) { /* ## IV >= IV ## */
2009 const IV aiv = SvIVX(TOPm1s);
2010 const IV biv = SvIVX(TOPs);
2013 SETs(boolSV(aiv >= biv));
2016 if (auvok && buvok) { /* ## UV >= UV ## */
2017 const UV auv = SvUVX(TOPm1s);
2018 const UV buv = SvUVX(TOPs);
2021 SETs(boolSV(auv >= buv));
2024 if (auvok) { /* ## UV >= IV ## */
2026 const IV biv = SvIVX(TOPs);
2030 /* As (a) is a UV, it's >=0, so it must be >= */
2035 SETs(boolSV(auv >= (UV)biv));
2038 { /* ## IV >= UV ## */
2039 const IV aiv = SvIVX(TOPm1s);
2043 /* As (b) is a UV, it's >=0, so a cannot be >= */
2050 SETs(boolSV((UV)aiv >= buv));
2056 #ifndef NV_PRESERVES_UV
2057 #ifdef PERL_PRESERVE_IVUV
2060 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2062 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2067 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2069 if (Perl_isnan(left) || Perl_isnan(right))
2071 SETs(boolSV(left >= right));
2074 SETs(boolSV(TOPn >= value));
2082 dVAR; dSP; tryAMAGICbinSET(ne,0);
2083 #ifndef NV_PRESERVES_UV
2084 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2086 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2090 #ifdef PERL_PRESERVE_IVUV
2093 SvIV_please(TOPm1s);
2094 if (SvIOK(TOPm1s)) {
2095 const bool auvok = SvUOK(TOPm1s);
2096 const bool buvok = SvUOK(TOPs);
2098 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2099 /* Casting IV to UV before comparison isn't going to matter
2100 on 2s complement. On 1s complement or sign&magnitude
2101 (if we have any of them) it could make negative zero
2102 differ from normal zero. As I understand it. (Need to
2103 check - is negative zero implementation defined behaviour
2105 const UV buv = SvUVX(POPs);
2106 const UV auv = SvUVX(TOPs);
2108 SETs(boolSV(auv != buv));
2111 { /* ## Mixed IV,UV ## */
2115 /* != is commutative so swap if needed (save code) */
2117 /* swap. top of stack (b) is the iv */
2121 /* As (a) is a UV, it's >0, so it cannot be == */
2130 /* As (b) is a UV, it's >0, so it cannot be == */
2134 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2136 SETs(boolSV((UV)iv != uv));
2143 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2145 if (Perl_isnan(left) || Perl_isnan(right))
2147 SETs(boolSV(left != right));
2150 SETs(boolSV(TOPn != value));
2158 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2159 #ifndef NV_PRESERVES_UV
2160 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2161 const UV right = PTR2UV(SvRV(POPs));
2162 const UV left = PTR2UV(SvRV(TOPs));
2163 SETi((left > right) - (left < right));
2167 #ifdef PERL_PRESERVE_IVUV
2168 /* Fortunately it seems NaN isn't IOK */
2171 SvIV_please(TOPm1s);
2172 if (SvIOK(TOPm1s)) {
2173 const bool leftuvok = SvUOK(TOPm1s);
2174 const bool rightuvok = SvUOK(TOPs);
2176 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2177 const IV leftiv = SvIVX(TOPm1s);
2178 const IV rightiv = SvIVX(TOPs);
2180 if (leftiv > rightiv)
2182 else if (leftiv < rightiv)
2186 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2187 const UV leftuv = SvUVX(TOPm1s);
2188 const UV rightuv = SvUVX(TOPs);
2190 if (leftuv > rightuv)
2192 else if (leftuv < rightuv)
2196 } else if (leftuvok) { /* ## UV <=> IV ## */
2197 const IV rightiv = SvIVX(TOPs);
2199 /* As (a) is a UV, it's >=0, so it cannot be < */
2202 const UV leftuv = SvUVX(TOPm1s);
2203 if (leftuv > (UV)rightiv) {
2205 } else if (leftuv < (UV)rightiv) {
2211 } else { /* ## IV <=> UV ## */
2212 const IV leftiv = SvIVX(TOPm1s);
2214 /* As (b) is a UV, it's >=0, so it must be < */
2217 const UV rightuv = SvUVX(TOPs);
2218 if ((UV)leftiv > rightuv) {
2220 } else if ((UV)leftiv < rightuv) {
2238 if (Perl_isnan(left) || Perl_isnan(right)) {
2242 value = (left > right) - (left < right);
2246 else if (left < right)
2248 else if (left > right)
2264 int amg_type = sle_amg;
2268 switch (PL_op->op_type) {
2287 tryAMAGICbinSET_var(amg_type,0);
2290 const int cmp = (IN_LOCALE_RUNTIME
2291 ? sv_cmp_locale(left, right)
2292 : sv_cmp(left, right));
2293 SETs(boolSV(cmp * multiplier < rhs));
2300 dVAR; dSP; tryAMAGICbinSET(seq,0);
2303 SETs(boolSV(sv_eq(left, right)));
2310 dVAR; dSP; tryAMAGICbinSET(sne,0);
2313 SETs(boolSV(!sv_eq(left, right)));
2320 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2323 const int cmp = (IN_LOCALE_RUNTIME
2324 ? sv_cmp_locale(left, right)
2325 : sv_cmp(left, right));
2333 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2338 if (SvNIOKp(left) || SvNIOKp(right)) {
2339 if (PL_op->op_private & HINT_INTEGER) {
2340 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2344 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2349 do_vop(PL_op->op_type, TARG, left, right);
2358 dVAR; dSP; dATARGET;
2359 const int op_type = PL_op->op_type;
2361 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2366 if (SvNIOKp(left) || SvNIOKp(right)) {
2367 if (PL_op->op_private & HINT_INTEGER) {
2368 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2369 const IV r = SvIV_nomg(right);
2370 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2374 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2375 const UV r = SvUV_nomg(right);
2376 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2381 do_vop(op_type, TARG, left, right);
2390 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2392 SV * const sv = sv_2num(TOPs);
2393 const int flags = SvFLAGS(sv);
2395 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2396 /* It's publicly an integer, or privately an integer-not-float */
2399 if (SvIVX(sv) == IV_MIN) {
2400 /* 2s complement assumption. */
2401 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2404 else if (SvUVX(sv) <= IV_MAX) {
2409 else if (SvIVX(sv) != IV_MIN) {
2413 #ifdef PERL_PRESERVE_IVUV
2422 else if (SvPOKp(sv)) {
2424 const char * const s = SvPV_const(sv, len);
2425 if (isIDFIRST(*s)) {
2426 sv_setpvn(TARG, "-", 1);
2429 else if (*s == '+' || *s == '-') {
2431 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2433 else if (DO_UTF8(sv)) {
2436 goto oops_its_an_int;
2438 sv_setnv(TARG, -SvNV(sv));
2440 sv_setpvn(TARG, "-", 1);
2447 goto oops_its_an_int;
2448 sv_setnv(TARG, -SvNV(sv));
2460 dVAR; dSP; tryAMAGICunSET(not);
2461 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2467 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2472 if (PL_op->op_private & HINT_INTEGER) {
2473 const IV i = ~SvIV_nomg(sv);
2477 const UV u = ~SvUV_nomg(sv);
2486 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2487 sv_setsv_nomg(TARG, sv);
2488 tmps = (U8*)SvPV_force(TARG, len);
2491 /* Calculate exact length, let's not estimate. */
2496 U8 * const send = tmps + len;
2497 U8 * const origtmps = tmps;
2498 const UV utf8flags = UTF8_ALLOW_ANYUV;
2500 while (tmps < send) {
2501 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2503 targlen += UNISKIP(~c);
2509 /* Now rewind strings and write them. */
2516 Newx(result, targlen + 1, U8);
2518 while (tmps < send) {
2519 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2521 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2524 sv_usepvn_flags(TARG, (char*)result, targlen,
2525 SV_HAS_TRAILING_NUL);
2532 Newx(result, nchar + 1, U8);
2534 while (tmps < send) {
2535 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2540 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2548 register long *tmpl;
2549 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2552 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2557 for ( ; anum > 0; anum--, tmps++)
2566 /* integer versions of some of the above */
2570 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2573 SETi( left * right );
2581 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2585 DIE(aTHX_ "Illegal division by zero");
2588 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2592 value = num / value;
2598 #if defined(__GLIBC__) && IVSIZE == 8
2605 /* This is the vanilla old i_modulo. */
2606 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2610 DIE(aTHX_ "Illegal modulus zero");
2611 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2615 SETi( left % right );
2620 #if defined(__GLIBC__) && IVSIZE == 8
2625 /* This is the i_modulo with the workaround for the _moddi3 bug
2626 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2627 * See below for pp_i_modulo. */
2628 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2632 DIE(aTHX_ "Illegal modulus zero");
2633 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2637 SETi( left % PERL_ABS(right) );
2644 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2648 DIE(aTHX_ "Illegal modulus zero");
2649 /* The assumption is to use hereafter the old vanilla version... */
2651 PL_ppaddr[OP_I_MODULO] =
2653 /* .. but if we have glibc, we might have a buggy _moddi3
2654 * (at least glicb 2.2.5 is known to have this bug), in other
2655 * words our integer modulus with negative quad as the second
2656 * argument might be broken. Test for this and re-patch the
2657 * opcode dispatch table if that is the case, remembering to
2658 * also apply the workaround so that this first round works
2659 * right, too. See [perl #9402] for more information. */
2663 /* Cannot do this check with inlined IV constants since
2664 * that seems to work correctly even with the buggy glibc. */
2666 /* Yikes, we have the bug.
2667 * Patch in the workaround version. */
2669 PL_ppaddr[OP_I_MODULO] =
2670 &Perl_pp_i_modulo_1;
2671 /* Make certain we work right this time, too. */
2672 right = PERL_ABS(right);
2675 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2679 SETi( left % right );
2687 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2690 SETi( left + right );
2697 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2700 SETi( left - right );
2707 dVAR; dSP; tryAMAGICbinSET(lt,0);
2710 SETs(boolSV(left < right));
2717 dVAR; dSP; tryAMAGICbinSET(gt,0);
2720 SETs(boolSV(left > right));
2727 dVAR; dSP; tryAMAGICbinSET(le,0);
2730 SETs(boolSV(left <= right));
2737 dVAR; dSP; tryAMAGICbinSET(ge,0);
2740 SETs(boolSV(left >= right));
2747 dVAR; dSP; tryAMAGICbinSET(eq,0);
2750 SETs(boolSV(left == right));
2757 dVAR; dSP; tryAMAGICbinSET(ne,0);
2760 SETs(boolSV(left != right));
2767 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2774 else if (left < right)
2785 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2790 /* High falutin' math. */
2794 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2797 SETn(Perl_atan2(left, right));
2805 int amg_type = sin_amg;
2806 const char *neg_report = NULL;
2807 NV (*func)(NV) = Perl_sin;
2808 const int op_type = PL_op->op_type;
2825 amg_type = sqrt_amg;
2827 neg_report = "sqrt";
2831 tryAMAGICun_var(amg_type);
2833 const NV value = POPn;
2835 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2836 SET_NUMERIC_STANDARD();
2837 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2840 XPUSHn(func(value));
2845 /* Support Configure command-line overrides for rand() functions.
2846 After 5.005, perhaps we should replace this by Configure support
2847 for drand48(), random(), or rand(). For 5.005, though, maintain
2848 compatibility by calling rand() but allow the user to override it.
2849 See INSTALL for details. --Andy Dougherty 15 July 1998
2851 /* Now it's after 5.005, and Configure supports drand48() and random(),
2852 in addition to rand(). So the overrides should not be needed any more.
2853 --Jarkko Hietaniemi 27 September 1998
2856 #ifndef HAS_DRAND48_PROTO
2857 extern double drand48 (void);
2870 if (!PL_srand_called) {
2871 (void)seedDrand01((Rand_seed_t)seed());
2872 PL_srand_called = TRUE;
2882 const UV anum = (MAXARG < 1) ? seed() : POPu;
2883 (void)seedDrand01((Rand_seed_t)anum);
2884 PL_srand_called = TRUE;
2891 dVAR; dSP; dTARGET; tryAMAGICun(int);
2893 SV * const sv = sv_2num(TOPs);
2894 const IV iv = SvIV(sv);
2895 /* XXX it's arguable that compiler casting to IV might be subtly
2896 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2897 else preferring IV has introduced a subtle behaviour change bug. OTOH
2898 relying on floating point to be accurate is a bug. */
2903 else if (SvIOK(sv)) {
2910 const NV value = SvNV(sv);
2912 if (value < (NV)UV_MAX + 0.5) {
2915 SETn(Perl_floor(value));
2919 if (value > (NV)IV_MIN - 0.5) {
2922 SETn(Perl_ceil(value));
2932 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2934 SV * const sv = sv_2num(TOPs);
2935 /* This will cache the NV value if string isn't actually integer */
2936 const IV iv = SvIV(sv);
2941 else if (SvIOK(sv)) {
2942 /* IVX is precise */
2944 SETu(SvUV(sv)); /* force it to be numeric only */
2952 /* 2s complement assumption. Also, not really needed as
2953 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2959 const NV value = SvNV(sv);
2973 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2977 SV* const sv = POPs;
2979 tmps = (SvPV_const(sv, len));
2981 /* If Unicode, try to downgrade
2982 * If not possible, croak. */
2983 SV* const tsv = sv_2mortal(newSVsv(sv));
2986 sv_utf8_downgrade(tsv, FALSE);
2987 tmps = SvPV_const(tsv, len);
2989 if (PL_op->op_type == OP_HEX)
2992 while (*tmps && len && isSPACE(*tmps))
2998 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3000 else if (*tmps == 'b')
3001 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3003 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3005 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3019 SV * const sv = TOPs;
3022 /* For an overloaded scalar, we can't know in advance if it's going to
3023 be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
3024 cache the length. Maybe that should be a documented feature of it.
3027 const char *const p = SvPV_const(sv, len);
3030 SETi(utf8_length((U8*)p, (U8*)p + len));
3036 else if (DO_UTF8(sv))
3037 SETi(sv_len_utf8(sv));
3053 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3055 const I32 arybase = CopARYBASE_get(PL_curcop);
3057 const char *repl = NULL;
3059 const int num_args = PL_op->op_private & 7;
3060 bool repl_need_utf8_upgrade = FALSE;
3061 bool repl_is_utf8 = FALSE;
3063 SvTAINTED_off(TARG); /* decontaminate */
3064 SvUTF8_off(TARG); /* decontaminate */
3068 repl = SvPV_const(repl_sv, repl_len);
3069 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3079 sv_utf8_upgrade(sv);
3081 else if (DO_UTF8(sv))
3082 repl_need_utf8_upgrade = TRUE;
3084 tmps = SvPV_const(sv, curlen);
3086 utf8_curlen = sv_len_utf8(sv);
3087 if (utf8_curlen == curlen)
3090 curlen = utf8_curlen;
3095 if (pos >= arybase) {
3113 else if (len >= 0) {
3115 if (rem > (I32)curlen)
3130 Perl_croak(aTHX_ "substr outside of string");
3131 if (ckWARN(WARN_SUBSTR))
3132 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3136 const I32 upos = pos;
3137 const I32 urem = rem;
3139 sv_pos_u2b(sv, &pos, &rem);
3141 /* we either return a PV or an LV. If the TARG hasn't been used
3142 * before, or is of that type, reuse it; otherwise use a mortal
3143 * instead. Note that LVs can have an extended lifetime, so also
3144 * dont reuse if refcount > 1 (bug #20933) */
3145 if (SvTYPE(TARG) > SVt_NULL) {
3146 if ( (SvTYPE(TARG) == SVt_PVLV)
3147 ? (!lvalue || SvREFCNT(TARG) > 1)
3150 TARG = sv_newmortal();
3154 sv_setpvn(TARG, tmps, rem);
3155 #ifdef USE_LOCALE_COLLATE
3156 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3161 SV* repl_sv_copy = NULL;
3163 if (repl_need_utf8_upgrade) {
3164 repl_sv_copy = newSVsv(repl_sv);
3165 sv_utf8_upgrade(repl_sv_copy);
3166 repl = SvPV_const(repl_sv_copy, repl_len);
3167 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3169 sv_insert(sv, pos, rem, repl, repl_len);
3173 SvREFCNT_dec(repl_sv_copy);
3175 else if (lvalue) { /* it's an lvalue! */
3176 if (!SvGMAGICAL(sv)) {
3178 SvPV_force_nolen(sv);
3179 if (ckWARN(WARN_SUBSTR))
3180 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3181 "Attempt to use reference as lvalue in substr");
3183 if (isGV_with_GP(sv))
3184 SvPV_force_nolen(sv);
3185 else if (SvOK(sv)) /* is it defined ? */
3186 (void)SvPOK_only_UTF8(sv);
3188 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3191 if (SvTYPE(TARG) < SVt_PVLV) {
3192 sv_upgrade(TARG, SVt_PVLV);
3193 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3197 if (LvTARG(TARG) != sv) {
3199 SvREFCNT_dec(LvTARG(TARG));
3200 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3202 LvTARGOFF(TARG) = upos;
3203 LvTARGLEN(TARG) = urem;
3207 PUSHs(TARG); /* avoid SvSETMAGIC here */
3214 register const IV size = POPi;
3215 register const IV offset = POPi;
3216 register SV * const src = POPs;
3217 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3219 SvTAINTED_off(TARG); /* decontaminate */
3220 if (lvalue) { /* it's an lvalue! */
3221 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3222 TARG = sv_newmortal();
3223 if (SvTYPE(TARG) < SVt_PVLV) {
3224 sv_upgrade(TARG, SVt_PVLV);
3225 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3228 if (LvTARG(TARG) != src) {
3230 SvREFCNT_dec(LvTARG(TARG));
3231 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3233 LvTARGOFF(TARG) = offset;
3234 LvTARGLEN(TARG) = size;
3237 sv_setuv(TARG, do_vecget(src, offset, size));
3253 const char *little_p;
3254 const I32 arybase = CopARYBASE_get(PL_curcop);
3257 const bool is_index = PL_op->op_type == OP_INDEX;
3260 /* arybase is in characters, like offset, so combine prior to the
3261 UTF-8 to bytes calculation. */
3262 offset = POPi - arybase;
3266 big_p = SvPV_const(big, biglen);
3267 little_p = SvPV_const(little, llen);
3269 big_utf8 = DO_UTF8(big);
3270 little_utf8 = DO_UTF8(little);
3271 if (big_utf8 ^ little_utf8) {
3272 /* One needs to be upgraded. */
3273 if (little_utf8 && !PL_encoding) {
3274 /* Well, maybe instead we might be able to downgrade the small
3276 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3279 /* If the large string is ISO-8859-1, and it's not possible to
3280 convert the small string to ISO-8859-1, then there is no
3281 way that it could be found anywhere by index. */
3286 /* At this point, pv is a malloc()ed string. So donate it to temp
3287 to ensure it will get free()d */
3288 little = temp = newSV(0);
3289 sv_usepvn(temp, pv, llen);
3290 little_p = SvPVX(little);
3293 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3296 sv_recode_to_utf8(temp, PL_encoding);
3298 sv_utf8_upgrade(temp);
3303 big_p = SvPV_const(big, biglen);
3306 little_p = SvPV_const(little, llen);
3310 if (SvGAMAGIC(big)) {
3311 /* Life just becomes a lot easier if I use a temporary here.
3312 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3313 will trigger magic and overloading again, as will fbm_instr()
3315 big = sv_2mortal(newSVpvn(big_p, biglen));
3320 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3321 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3322 warn on undef, and we've already triggered a warning with the
3323 SvPV_const some lines above. We can't remove that, as we need to
3324 call some SvPV to trigger overloading early and find out if the
3326 This is all getting to messy. The API isn't quite clean enough,
3327 because data access has side effects.
3329 little = sv_2mortal(newSVpvn(little_p, llen));
3332 little_p = SvPVX(little);
3336 offset = is_index ? 0 : biglen;
3338 if (big_utf8 && offset > 0)
3339 sv_pos_u2b(big, &offset, 0);
3345 else if (offset > (I32)biglen)
3347 if (!(little_p = is_index
3348 ? fbm_instr((unsigned char*)big_p + offset,
3349 (unsigned char*)big_p + biglen, little, 0)
3350 : rninstr(big_p, big_p + offset,
3351 little_p, little_p + llen)))
3354 retval = little_p - big_p;
3355 if (retval > 0 && big_utf8)
3356 sv_pos_b2u(big, &retval);
3361 PUSHi(retval + arybase);
3367 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3368 if (SvTAINTED(MARK[1]))
3369 TAINT_PROPER("sprintf");
3370 do_sprintf(TARG, SP-MARK, MARK+1);
3371 TAINT_IF(SvTAINTED(TARG));
3383 const U8 *s = (U8*)SvPV_const(argsv, len);
3385 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3386 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3387 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3391 XPUSHu(DO_UTF8(argsv) ?
3392 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3404 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3406 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3408 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3410 (void) POPs; /* Ignore the argument value. */
3411 value = UNICODE_REPLACEMENT;
3417 SvUPGRADE(TARG,SVt_PV);
3419 if (value > 255 && !IN_BYTES) {
3420 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3421 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3422 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3424 (void)SvPOK_only(TARG);
3433 *tmps++ = (char)value;
3435 (void)SvPOK_only(TARG);
3437 if (PL_encoding && !IN_BYTES) {
3438 sv_recode_to_utf8(TARG, PL_encoding);
3440 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3441 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3445 *tmps++ = (char)value;
3461 const char *tmps = SvPV_const(left, len);
3463 if (DO_UTF8(left)) {
3464 /* If Unicode, try to downgrade.
3465 * If not possible, croak.
3466 * Yes, we made this up. */
3467 SV* const tsv = sv_2mortal(newSVsv(left));
3470 sv_utf8_downgrade(tsv, FALSE);
3471 tmps = SvPV_const(tsv, len);
3473 # ifdef USE_ITHREADS
3475 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3476 /* This should be threadsafe because in ithreads there is only
3477 * one thread per interpreter. If this would not be true,
3478 * we would need a mutex to protect this malloc. */
3479 PL_reentrant_buffer->_crypt_struct_buffer =
3480 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3481 #if defined(__GLIBC__) || defined(__EMX__)
3482 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3483 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3484 /* work around glibc-2.2.5 bug */
3485 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3489 # endif /* HAS_CRYPT_R */
3490 # endif /* USE_ITHREADS */
3492 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3494 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3500 "The crypt() function is unimplemented due to excessive paranoia.");
3512 bool inplace = TRUE;
3514 const int op_type = PL_op->op_type;
3517 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3523 s = (const U8*)SvPV_nomg_const(source, slen);
3529 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3531 utf8_to_uvchr(s, &ulen);
3532 if (op_type == OP_UCFIRST) {
3533 toTITLE_utf8(s, tmpbuf, &tculen);
3535 toLOWER_utf8(s, tmpbuf, &tculen);
3537 /* If the two differ, we definately cannot do inplace. */
3538 inplace = (ulen == tculen);
3539 need = slen + 1 - ulen + tculen;
3545 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3546 /* We can convert in place. */
3549 s = d = (U8*)SvPV_force_nomg(source, slen);
3555 SvUPGRADE(dest, SVt_PV);
3556 d = (U8*)SvGROW(dest, need);
3557 (void)SvPOK_only(dest);
3566 /* slen is the byte length of the whole SV.
3567 * ulen is the byte length of the original Unicode character
3568 * stored as UTF-8 at s.
3569 * tculen is the byte length of the freshly titlecased (or
3570 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3571 * We first set the result to be the titlecased (/lowercased)
3572 * character, and then append the rest of the SV data. */
3573 sv_setpvn(dest, (char*)tmpbuf, tculen);
3575 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3579 Copy(tmpbuf, d, tculen, U8);
3580 SvCUR_set(dest, need - 1);
3585 if (IN_LOCALE_RUNTIME) {
3588 *d = (op_type == OP_UCFIRST)
3589 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3592 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3594 /* See bug #39028 */
3602 /* This will copy the trailing NUL */
3603 Copy(s + 1, d + 1, slen, U8);
3604 SvCUR_set(dest, need - 1);
3611 /* There's so much setup/teardown code common between uc and lc, I wonder if
3612 it would be worth merging the two, and just having a switch outside each
3613 of the three tight loops. */
3627 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3628 && SvTEMP(source) && !DO_UTF8(source)) {
3629 /* We can convert in place. */
3632 s = d = (U8*)SvPV_force_nomg(source, len);
3639 /* The old implementation would copy source into TARG at this point.
3640 This had the side effect that if source was undef, TARG was now
3641 an undefined SV with PADTMP set, and they don't warn inside
3642 sv_2pv_flags(). However, we're now getting the PV direct from
3643 source, which doesn't have PADTMP set, so it would warn. Hence the
3647 s = (const U8*)SvPV_nomg_const(source, len);
3654 SvUPGRADE(dest, SVt_PV);
3655 d = (U8*)SvGROW(dest, min);
3656 (void)SvPOK_only(dest);
3661 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3662 to check DO_UTF8 again here. */
3664 if (DO_UTF8(source)) {
3665 const U8 *const send = s + len;
3666 U8 tmpbuf[UTF8_MAXBYTES+1];
3669 const STRLEN u = UTF8SKIP(s);
3672 toUPPER_utf8(s, tmpbuf, &ulen);
3673 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3674 /* If the eventually required minimum size outgrows
3675 * the available space, we need to grow. */
3676 const UV o = d - (U8*)SvPVX_const(dest);
3678 /* If someone uppercases one million U+03B0s we SvGROW() one
3679 * million times. Or we could try guessing how much to
3680 allocate without allocating too much. Such is life. */
3682 d = (U8*)SvPVX(dest) + o;
3684 Copy(tmpbuf, d, ulen, U8);
3690 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3693 const U8 *const send = s + len;
3694 if (IN_LOCALE_RUNTIME) {
3697 for (; s < send; d++, s++)
3698 *d = toUPPER_LC(*s);
3701 for (; s < send; d++, s++)
3705 if (source != dest) {
3707 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3727 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3728 && SvTEMP(source) && !DO_UTF8(source)) {
3729 /* We can convert in place. */
3732 s = d = (U8*)SvPV_force_nomg(source, len);
3739 /* The old implementation would copy source into TARG at this point.
3740 This had the side effect that if source was undef, TARG was now
3741 an undefined SV with PADTMP set, and they don't warn inside
3742 sv_2pv_flags(). However, we're now getting the PV direct from
3743 source, which doesn't have PADTMP set, so it would warn. Hence the
3747 s = (const U8*)SvPV_nomg_const(source, len);
3754 SvUPGRADE(dest, SVt_PV);
3755 d = (U8*)SvGROW(dest, min);
3756 (void)SvPOK_only(dest);
3761 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3762 to check DO_UTF8 again here. */
3764 if (DO_UTF8(source)) {
3765 const U8 *const send = s + len;
3766 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3769 const STRLEN u = UTF8SKIP(s);
3771 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3773 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3774 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3777 * Now if the sigma is NOT followed by
3778 * /$ignorable_sequence$cased_letter/;
3779 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3780 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3781 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3782 * then it should be mapped to 0x03C2,
3783 * (GREEK SMALL LETTER FINAL SIGMA),
3784 * instead of staying 0x03A3.
3785 * "should be": in other words, this is not implemented yet.
3786 * See lib/unicore/SpecialCasing.txt.
3789 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3790 /* If the eventually required minimum size outgrows
3791 * the available space, we need to grow. */
3792 const UV o = d - (U8*)SvPVX_const(dest);
3794 /* If someone lowercases one million U+0130s we SvGROW() one
3795 * million times. Or we could try guessing how much to
3796 allocate without allocating too much. Such is life. */
3798 d = (U8*)SvPVX(dest) + o;
3800 Copy(tmpbuf, d, ulen, U8);
3806 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3809 const U8 *const send = s + len;
3810 if (IN_LOCALE_RUNTIME) {
3813 for (; s < send; d++, s++)
3814 *d = toLOWER_LC(*s);
3817 for (; s < send; d++, s++)
3821 if (source != dest) {
3823 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3833 SV * const sv = TOPs;
3835 register const char *s = SvPV_const(sv,len);
3837 SvUTF8_off(TARG); /* decontaminate */
3840 SvUPGRADE(TARG, SVt_PV);
3841 SvGROW(TARG, (len * 2) + 1);
3845 if (UTF8_IS_CONTINUED(*s)) {
3846 STRLEN ulen = UTF8SKIP(s);
3870 SvCUR_set(TARG, d - SvPVX_const(TARG));
3871 (void)SvPOK_only_UTF8(TARG);
3874 sv_setpvn(TARG, s, len);
3876 if (SvSMAGICAL(TARG))
3885 dVAR; dSP; dMARK; dORIGMARK;
3886 register AV* const av = (AV*)POPs;
3887 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3889 if (SvTYPE(av) == SVt_PVAV) {
3890 const I32 arybase = CopARYBASE_get(PL_curcop);
3891 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3894 for (svp = MARK + 1; svp <= SP; svp++) {
3895 const I32 elem = SvIV(*svp);
3899 if (max > AvMAX(av))
3902 while (++MARK <= SP) {
3904 I32 elem = SvIV(*MARK);
3908 svp = av_fetch(av, elem, lval);
3910 if (!svp || *svp == &PL_sv_undef)
3911 DIE(aTHX_ PL_no_aelem, elem);
3912 if (PL_op->op_private & OPpLVAL_INTRO)
3913 save_aelem(av, elem, svp);
3915 *MARK = svp ? *svp : &PL_sv_undef;
3918 if (GIMME != G_ARRAY) {
3920 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3930 AV *array = (AV*)POPs;
3931 const I32 gimme = GIMME_V;
3932 IV *iterp = Perl_av_iter_p(aTHX_ array);
3933 const IV current = (*iterp)++;
3935 if (current > av_len(array)) {
3937 if (gimme == G_SCALAR)
3944 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3945 if (gimme == G_ARRAY) {
3946 SV **const element = av_fetch(array, current, 0);
3947 PUSHs(element ? *element : &PL_sv_undef);
3956 AV *array = (AV*)POPs;
3957 const I32 gimme = GIMME_V;
3959 *Perl_av_iter_p(aTHX_ array) = 0;
3961 if (gimme == G_SCALAR) {
3963 PUSHi(av_len(array) + 1);
3965 else if (gimme == G_ARRAY) {
3966 IV n = Perl_av_len(aTHX_ array);
3967 IV i = CopARYBASE_get(PL_curcop);
3971 if (PL_op->op_type == OP_AKEYS) {
3973 for (; i <= n; i++) {
3978 for (i = 0; i <= n; i++) {
3979 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
3980 PUSHs(elem ? *elem : &PL_sv_undef);
3987 /* Associative arrays. */
3993 HV * hash = (HV*)POPs;
3995 const I32 gimme = GIMME_V;
3998 /* might clobber stack_sp */
3999 entry = hv_iternext(hash);
4004 SV* const sv = hv_iterkeysv(entry);
4005 PUSHs(sv); /* won't clobber stack_sp */
4006 if (gimme == G_ARRAY) {
4009 /* might clobber stack_sp */
4010 val = hv_iterval(hash, entry);
4015 else if (gimme == G_SCALAR)
4025 const I32 gimme = GIMME_V;
4026 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4028 if (PL_op->op_private & OPpSLICE) {
4030 HV * const hv = (HV*)POPs;
4031 const U32 hvtype = SvTYPE(hv);
4032 if (hvtype == SVt_PVHV) { /* hash element */
4033 while (++MARK <= SP) {
4034 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4035 *MARK = sv ? sv : &PL_sv_undef;
4038 else if (hvtype == SVt_PVAV) { /* array element */
4039 if (PL_op->op_flags & OPf_SPECIAL) {
4040 while (++MARK <= SP) {
4041 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
4042 *MARK = sv ? sv : &PL_sv_undef;
4047 DIE(aTHX_ "Not a HASH reference");
4050 else if (gimme == G_SCALAR) {
4055 *++MARK = &PL_sv_undef;
4061 HV * const hv = (HV*)POPs;
4063 if (SvTYPE(hv) == SVt_PVHV)
4064 sv = hv_delete_ent(hv, keysv, discard, 0);
4065 else if (SvTYPE(hv) == SVt_PVAV) {
4066 if (PL_op->op_flags & OPf_SPECIAL)
4067 sv = av_delete((AV*)hv, SvIV(keysv), discard);
4069 DIE(aTHX_ "panic: avhv_delete no longer supported");
4072 DIE(aTHX_ "Not a HASH reference");
4088 if (PL_op->op_private & OPpEXISTS_SUB) {
4090 SV * const sv = POPs;
4091 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4094 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4100 if (SvTYPE(hv) == SVt_PVHV) {
4101 if (hv_exists_ent(hv, tmpsv, 0))
4104 else if (SvTYPE(hv) == SVt_PVAV) {
4105 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4106 if (av_exists((AV*)hv, SvIV(tmpsv)))
4111 DIE(aTHX_ "Not a HASH reference");
4118 dVAR; dSP; dMARK; dORIGMARK;
4119 register HV * const hv = (HV*)POPs;
4120 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4121 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4122 bool other_magic = FALSE;
4128 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4129 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4130 /* Try to preserve the existenceness of a tied hash
4131 * element by using EXISTS and DELETE if possible.
4132 * Fallback to FETCH and STORE otherwise */
4133 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4134 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4135 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4138 while (++MARK <= SP) {
4139 SV * const keysv = *MARK;
4142 bool preeminent = FALSE;
4145 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4146 hv_exists_ent(hv, keysv, 0);
4149 he = hv_fetch_ent(hv, keysv, lval, 0);
4150 svp = he ? &HeVAL(he) : NULL;
4153 if (!svp || *svp == &PL_sv_undef) {
4154 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4157 if (HvNAME_get(hv) && isGV(*svp))
4158 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4161 save_helem(hv, keysv, svp);
4164 const char * const key = SvPV_const(keysv, keylen);
4165 SAVEDELETE(hv, savepvn(key,keylen),
4166 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4171 *MARK = svp ? *svp : &PL_sv_undef;
4173 if (GIMME != G_ARRAY) {
4175 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4181 /* List operators. */
4186 if (GIMME != G_ARRAY) {
4188 *MARK = *SP; /* unwanted list, return last item */
4190 *MARK = &PL_sv_undef;
4200 SV ** const lastrelem = PL_stack_sp;
4201 SV ** const lastlelem = PL_stack_base + POPMARK;
4202 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4203 register SV ** const firstrelem = lastlelem + 1;
4204 const I32 arybase = CopARYBASE_get(PL_curcop);
4205 I32 is_something_there = FALSE;
4207 register const I32 max = lastrelem - lastlelem;
4208 register SV **lelem;
4210 if (GIMME != G_ARRAY) {
4211 I32 ix = SvIV(*lastlelem);
4216 if (ix < 0 || ix >= max)
4217 *firstlelem = &PL_sv_undef;
4219 *firstlelem = firstrelem[ix];
4225 SP = firstlelem - 1;
4229 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4230 I32 ix = SvIV(*lelem);
4235 if (ix < 0 || ix >= max)
4236 *lelem = &PL_sv_undef;
4238 is_something_there = TRUE;
4239 if (!(*lelem = firstrelem[ix]))
4240 *lelem = &PL_sv_undef;
4243 if (is_something_there)
4246 SP = firstlelem - 1;
4252 dVAR; dSP; dMARK; dORIGMARK;
4253 const I32 items = SP - MARK;
4254 SV * const av = (SV *) av_make(items, MARK+1);
4255 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4256 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4257 ? newRV_noinc(av) : av));
4263 dVAR; dSP; dMARK; dORIGMARK;
4264 HV* const hv = newHV();
4267 SV * const key = *++MARK;
4268 SV * const val = newSV(0);
4270 sv_setsv(val, *++MARK);
4271 else if (ckWARN(WARN_MISC))
4272 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4273 (void)hv_store_ent(hv,key,val,0);
4276 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4277 ? newRV_noinc((SV*) hv) : (SV*)hv));
4283 dVAR; dSP; dMARK; dORIGMARK;
4284 register AV *ary = (AV*)*++MARK;
4288 register I32 offset;
4289 register I32 length;
4293 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4296 *MARK-- = SvTIED_obj((SV*)ary, mg);
4300 call_method("SPLICE",GIMME_V);
4309 offset = i = SvIV(*MARK);
4311 offset += AvFILLp(ary) + 1;
4313 offset -= CopARYBASE_get(PL_curcop);
4315 DIE(aTHX_ PL_no_aelem, i);
4317 length = SvIVx(*MARK++);
4319 length += AvFILLp(ary) - offset + 1;
4325 length = AvMAX(ary) + 1; /* close enough to infinity */
4329 length = AvMAX(ary) + 1;
4331 if (offset > AvFILLp(ary) + 1) {
4332 if (ckWARN(WARN_MISC))
4333 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4334 offset = AvFILLp(ary) + 1;
4336 after = AvFILLp(ary) + 1 - (offset + length);
4337 if (after < 0) { /* not that much array */
4338 length += after; /* offset+length now in array */
4344 /* At this point, MARK .. SP-1 is our new LIST */
4347 diff = newlen - length;
4348 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4351 /* make new elements SVs now: avoid problems if they're from the array */
4352 for (dst = MARK, i = newlen; i; i--) {
4353 SV * const h = *dst;
4354 *dst++ = newSVsv(h);
4357 if (diff < 0) { /* shrinking the area */
4358 SV **tmparyval = NULL;
4360 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4361 Copy(MARK, tmparyval, newlen, SV*);
4364 MARK = ORIGMARK + 1;
4365 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4366 MEXTEND(MARK, length);
4367 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4369 EXTEND_MORTAL(length);
4370 for (i = length, dst = MARK; i; i--) {
4371 sv_2mortal(*dst); /* free them eventualy */
4378 *MARK = AvARRAY(ary)[offset+length-1];
4381 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4382 SvREFCNT_dec(*dst++); /* free them now */
4385 AvFILLp(ary) += diff;
4387 /* pull up or down? */
4389 if (offset < after) { /* easier to pull up */
4390 if (offset) { /* esp. if nothing to pull */
4391 src = &AvARRAY(ary)[offset-1];
4392 dst = src - diff; /* diff is negative */
4393 for (i = offset; i > 0; i--) /* can't trust Copy */
4397 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4401 if (after) { /* anything to pull down? */
4402 src = AvARRAY(ary) + offset + length;
4403 dst = src + diff; /* diff is negative */
4404 Move(src, dst, after, SV*);
4406 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4407 /* avoid later double free */
4411 dst[--i] = &PL_sv_undef;
4414 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4415 Safefree(tmparyval);
4418 else { /* no, expanding (or same) */
4419 SV** tmparyval = NULL;
4421 Newx(tmparyval, length, SV*); /* so remember deletion */
4422 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4425 if (diff > 0) { /* expanding */
4426 /* push up or down? */
4427 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4431 Move(src, dst, offset, SV*);
4433 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4435 AvFILLp(ary) += diff;
4438 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4439 av_extend(ary, AvFILLp(ary) + diff);
4440 AvFILLp(ary) += diff;
4443 dst = AvARRAY(ary) + AvFILLp(ary);
4445 for (i = after; i; i--) {
4453 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4456 MARK = ORIGMARK + 1;
4457 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4459 Copy(tmparyval, MARK, length, SV*);
4461 EXTEND_MORTAL(length);
4462 for (i = length, dst = MARK; i; i--) {
4463 sv_2mortal(*dst); /* free them eventualy */
4470 else if (length--) {
4471 *MARK = tmparyval[length];
4474 while (length-- > 0)
4475 SvREFCNT_dec(tmparyval[length]);
4479 *MARK = &PL_sv_undef;
4480 Safefree(tmparyval);
4488 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4489 register AV * const ary = (AV*)*++MARK;
4490 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4493 *MARK-- = SvTIED_obj((SV*)ary, mg);
4497 call_method("PUSH",G_SCALAR|G_DISCARD);
4501 PUSHi( AvFILL(ary) + 1 );
4504 PL_delaymagic = DM_DELAY;
4505 for (++MARK; MARK <= SP; MARK++) {
4506 SV * const sv = newSV(0);
4508 sv_setsv(sv, *MARK);
4509 av_store(ary, AvFILLp(ary)+1, sv);
4511 if (PL_delaymagic & DM_ARRAY)
4516 PUSHi( AvFILLp(ary) + 1 );
4525 AV * const av = (AV*)POPs;
4526 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4530 (void)sv_2mortal(sv);
4537 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4538 register AV *ary = (AV*)*++MARK;
4539 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4542 *MARK-- = SvTIED_obj((SV*)ary, mg);
4546 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4552 av_unshift(ary, SP - MARK);
4554 SV * const sv = newSVsv(*++MARK);
4555 (void)av_store(ary, i++, sv);
4559 PUSHi( AvFILL(ary) + 1 );
4566 SV ** const oldsp = SP;
4568 if (GIMME == G_ARRAY) {
4571 register SV * const tmp = *MARK;
4575 /* safe as long as stack cannot get extended in the above */
4580 register char *down;
4584 PADOFFSET padoff_du;
4586 SvUTF8_off(TARG); /* decontaminate */
4588 do_join(TARG, &PL_sv_no, MARK, SP);
4590 sv_setsv(TARG, (SP > MARK)
4592 : (padoff_du = find_rundefsvoffset(),
4593 (padoff_du == NOT_IN_PAD
4594 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4595 ? DEFSV : PAD_SVl(padoff_du)));
4596 up = SvPV_force(TARG, len);
4598 if (DO_UTF8(TARG)) { /* first reverse each character */
4599 U8* s = (U8*)SvPVX(TARG);
4600 const U8* send = (U8*)(s + len);
4602 if (UTF8_IS_INVARIANT(*s)) {
4607 if (!utf8_to_uvchr(s, 0))
4611 down = (char*)(s - 1);
4612 /* reverse this character */
4616 *down-- = (char)tmp;
4622 down = SvPVX(TARG) + len - 1;
4626 *down-- = (char)tmp;
4628 (void)SvPOK_only_UTF8(TARG);
4640 register IV limit = POPi; /* note, negative is forever */
4641 SV * const sv = POPs;
4643 register const char *s = SvPV_const(sv, len);
4644 const bool do_utf8 = DO_UTF8(sv);
4645 const char *strend = s + len;
4647 register REGEXP *rx;
4649 register const char *m;
4651 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4652 I32 maxiters = slen + 10;
4654 const I32 origlimit = limit;
4657 const I32 gimme = GIMME_V;
4658 const I32 oldsave = PL_savestack_ix;
4659 I32 make_mortal = 1;
4664 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4669 DIE(aTHX_ "panic: pp_split");
4672 TAINT_IF((rx->extflags & RXf_PMf_LOCALE) &&
4673 (rx->extflags & (RXf_WHITE | RXf_SKIPWHITE)));
4675 RX_MATCH_UTF8_set(rx, do_utf8);
4678 if (pm->op_pmreplrootu.op_pmtargetoff) {
4679 ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4682 if (pm->op_pmreplrootu.op_pmtargetgv) {
4683 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4686 else if (gimme != G_ARRAY)
4687 ary = GvAVn(PL_defgv);
4690 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4696 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4698 XPUSHs(SvTIED_obj((SV*)ary, mg));
4705 for (i = AvFILLp(ary); i >= 0; i--)
4706 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4708 /* temporarily switch stacks */
4709 SAVESWITCHSTACK(PL_curstack, ary);
4713 base = SP - PL_stack_base;
4715 if (rx->extflags & RXf_SKIPWHITE) {
4717 while (*s == ' ' || is_utf8_space((U8*)s))
4720 else if (rx->extflags & RXf_PMf_LOCALE) {
4721 while (isSPACE_LC(*s))
4729 if (rx->extflags & PMf_MULTILINE) {
4734 limit = maxiters + 2;
4735 if (rx->extflags & RXf_WHITE) {
4738 /* this one uses 'm' and is a negative test */
4740 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4741 const int t = UTF8SKIP(m);
4742 /* is_utf8_space returns FALSE for malform utf8 */
4748 } else if (rx->extflags & RXf_PMf_LOCALE) {
4749 while (m < strend && !isSPACE_LC(*m))
4752 while (m < strend && !isSPACE(*m))
4758 dstr = newSVpvn(s, m-s);
4762 (void)SvUTF8_on(dstr);
4765 /* skip the whitespace found last */
4767 s = m + UTF8SKIP(m);
4771 /* this one uses 's' and is a positive test */
4773 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4775 } else if (rx->extflags & RXf_PMf_LOCALE) {
4776 while (s < strend && isSPACE_LC(*s))
4779 while (s < strend && isSPACE(*s))
4784 else if (rx->extflags & RXf_START_ONLY) {
4786 for (m = s; m < strend && *m != '\n'; m++)
4791 dstr = newSVpvn(s, m-s);
4795 (void)SvUTF8_on(dstr);
4800 else if (rx->extflags & RXf_NULL && !(s >= strend)) {
4802 Pre-extend the stack, either the number of bytes or
4803 characters in the string or a limited amount, triggered by:
4805 my ($x, $y) = split //, $str;
4809 const U32 items = limit - 1;
4817 /* keep track of how many bytes we skip over */
4820 dstr = newSVpvn(m, s-m);
4825 (void)SvUTF8_on(dstr);
4833 dstr = newSVpvn(s, 1);
4847 else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
4848 (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
4849 && (rx->extflags & RXf_CHECK_ALL)
4850 && !(rx->extflags & RXf_ANCH)) {
4851 const int tail = (rx->extflags & RXf_INTUIT_TAIL);
4852 SV * const csv = CALLREG_INTUIT_STRING(rx);
4854 len = rx->minlenret;
4855 if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
4856 const char c = *SvPV_nolen_const(csv);
4858 for (m = s; m < strend && *m != c; m++)
4862 dstr = newSVpvn(s, m-s);
4866 (void)SvUTF8_on(dstr);
4868 /* The rx->minlen is in characters but we want to step
4869 * s ahead by bytes. */
4871 s = (char*)utf8_hop((U8*)m, len);
4873 s = m + len; /* Fake \n at the end */
4877 while (s < strend && --limit &&
4878 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4879 csv, multiline ? FBMrf_MULTILINE : 0)) )
4881 dstr = newSVpvn(s, m-s);
4885 (void)SvUTF8_on(dstr);
4887 /* The rx->minlen is in characters but we want to step
4888 * s ahead by bytes. */
4890 s = (char*)utf8_hop((U8*)m, len);
4892 s = m + len; /* Fake \n at the end */
4897 maxiters += slen * rx->nparens;
4898 while (s < strend && --limit)
4902 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4905 if (rex_return == 0)
4907 TAINT_IF(RX_MATCH_TAINTED(rx));
4908 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4913 strend = s + (strend - m);
4915 m = rx->offs[0].start + orig;
4916 dstr = newSVpvn(s, m-s);
4920 (void)SvUTF8_on(dstr);
4924 for (i = 1; i <= (I32)rx->nparens; i++) {
4925 s = rx->offs[i].start + orig;
4926 m = rx->offs[i].end + orig;
4928 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4929 parens that didn't match -- they should be set to
4930 undef, not the empty string */
4931 if (m >= orig && s >= orig) {
4932 dstr = newSVpvn(s, m-s);
4935 dstr = &PL_sv_undef; /* undef, not "" */
4939 (void)SvUTF8_on(dstr);
4943 s = rx->offs[0].end + orig;
4947 iters = (SP - PL_stack_base) - base;
4948 if (iters > maxiters)
4949 DIE(aTHX_ "Split loop");
4951 /* keep field after final delim? */
4952 if (s < strend || (iters && origlimit)) {
4953 const STRLEN l = strend - s;
4954 dstr = newSVpvn(s, l);
4958 (void)SvUTF8_on(dstr);
4962 else if (!origlimit) {
4963 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4964 if (TOPs && !make_mortal)
4967 *SP-- = &PL_sv_undef;
4972 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4976 if (SvSMAGICAL(ary)) {
4981 if (gimme == G_ARRAY) {
4983 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4991 call_method("PUSH",G_SCALAR|G_DISCARD);
4994 if (gimme == G_ARRAY) {
4996 /* EXTEND should not be needed - we just popped them */
4998 for (i=0; i < iters; i++) {
4999 SV **svp = av_fetch(ary, i, FALSE);
5000 PUSHs((svp) ? *svp : &PL_sv_undef);
5007 if (gimme == G_ARRAY)
5019 SV *const sv = PAD_SVl(PL_op->op_targ);
5021 if (SvPADSTALE(sv)) {
5024 RETURNOP(cLOGOP->op_other);
5026 RETURNOP(cLOGOP->op_next);
5036 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5037 || SvTYPE(retsv) == SVt_PVCV) {
5038 retsv = refto(retsv);
5045 PP(unimplemented_op)
5048 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5054 * c-indentation-style: bsd
5056 * indent-tabs-mode: t
5059 * ex: set ts=8 sts=4 sw=4 noet: