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 = newSVpvs_flags("_;$", SVs_TEMP);
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 = newSVpvn_flags(str, n - 1, SVs_TEMP);
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 = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
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 = newSVhek(GvNAME_HEK(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; 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;
3021 if (SvGAMAGIC(sv)) {
3022 /* For an overloaded or magic scalar, we can't know in advance if
3023 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3024 it likes to cache the length. Maybe that should be a documented
3029 = sv_2pv_flags(sv, &len,
3030 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3034 else if (DO_UTF8(sv)) {
3035 SETi(utf8_length((U8*)p, (U8*)p + len));
3039 } else if (SvOK(sv)) {
3040 /* Neither magic nor overloaded. */
3042 SETi(sv_len_utf8(sv));
3061 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3063 const I32 arybase = CopARYBASE_get(PL_curcop);
3065 const char *repl = NULL;
3067 const int num_args = PL_op->op_private & 7;
3068 bool repl_need_utf8_upgrade = FALSE;
3069 bool repl_is_utf8 = FALSE;
3071 SvTAINTED_off(TARG); /* decontaminate */
3072 SvUTF8_off(TARG); /* decontaminate */
3076 repl = SvPV_const(repl_sv, repl_len);
3077 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3087 sv_utf8_upgrade(sv);
3089 else if (DO_UTF8(sv))
3090 repl_need_utf8_upgrade = TRUE;
3092 tmps = SvPV_const(sv, curlen);
3094 utf8_curlen = sv_len_utf8(sv);
3095 if (utf8_curlen == curlen)
3098 curlen = utf8_curlen;
3103 if (pos >= arybase) {
3121 else if (len >= 0) {
3123 if (rem > (I32)curlen)
3138 Perl_croak(aTHX_ "substr outside of string");
3139 if (ckWARN(WARN_SUBSTR))
3140 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3144 const I32 upos = pos;
3145 const I32 urem = rem;
3147 sv_pos_u2b(sv, &pos, &rem);
3149 /* we either return a PV or an LV. If the TARG hasn't been used
3150 * before, or is of that type, reuse it; otherwise use a mortal
3151 * instead. Note that LVs can have an extended lifetime, so also
3152 * dont reuse if refcount > 1 (bug #20933) */
3153 if (SvTYPE(TARG) > SVt_NULL) {
3154 if ( (SvTYPE(TARG) == SVt_PVLV)
3155 ? (!lvalue || SvREFCNT(TARG) > 1)
3158 TARG = sv_newmortal();
3162 sv_setpvn(TARG, tmps, rem);
3163 #ifdef USE_LOCALE_COLLATE
3164 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3169 SV* repl_sv_copy = NULL;
3171 if (repl_need_utf8_upgrade) {
3172 repl_sv_copy = newSVsv(repl_sv);
3173 sv_utf8_upgrade(repl_sv_copy);
3174 repl = SvPV_const(repl_sv_copy, repl_len);
3175 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3177 sv_insert(sv, pos, rem, repl, repl_len);
3181 SvREFCNT_dec(repl_sv_copy);
3183 else if (lvalue) { /* it's an lvalue! */
3184 if (!SvGMAGICAL(sv)) {
3186 SvPV_force_nolen(sv);
3187 if (ckWARN(WARN_SUBSTR))
3188 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3189 "Attempt to use reference as lvalue in substr");
3191 if (isGV_with_GP(sv))
3192 SvPV_force_nolen(sv);
3193 else if (SvOK(sv)) /* is it defined ? */
3194 (void)SvPOK_only_UTF8(sv);
3196 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3199 if (SvTYPE(TARG) < SVt_PVLV) {
3200 sv_upgrade(TARG, SVt_PVLV);
3201 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3205 if (LvTARG(TARG) != sv) {
3207 SvREFCNT_dec(LvTARG(TARG));
3208 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3210 LvTARGOFF(TARG) = upos;
3211 LvTARGLEN(TARG) = urem;
3215 PUSHs(TARG); /* avoid SvSETMAGIC here */
3222 register const IV size = POPi;
3223 register const IV offset = POPi;
3224 register SV * const src = POPs;
3225 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3227 SvTAINTED_off(TARG); /* decontaminate */
3228 if (lvalue) { /* it's an lvalue! */
3229 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3230 TARG = sv_newmortal();
3231 if (SvTYPE(TARG) < SVt_PVLV) {
3232 sv_upgrade(TARG, SVt_PVLV);
3233 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3236 if (LvTARG(TARG) != src) {
3238 SvREFCNT_dec(LvTARG(TARG));
3239 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3241 LvTARGOFF(TARG) = offset;
3242 LvTARGLEN(TARG) = size;
3245 sv_setuv(TARG, do_vecget(src, offset, size));
3261 const char *little_p;
3262 const I32 arybase = CopARYBASE_get(PL_curcop);
3265 const bool is_index = PL_op->op_type == OP_INDEX;
3268 /* arybase is in characters, like offset, so combine prior to the
3269 UTF-8 to bytes calculation. */
3270 offset = POPi - arybase;
3274 big_p = SvPV_const(big, biglen);
3275 little_p = SvPV_const(little, llen);
3277 big_utf8 = DO_UTF8(big);
3278 little_utf8 = DO_UTF8(little);
3279 if (big_utf8 ^ little_utf8) {
3280 /* One needs to be upgraded. */
3281 if (little_utf8 && !PL_encoding) {
3282 /* Well, maybe instead we might be able to downgrade the small
3284 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3287 /* If the large string is ISO-8859-1, and it's not possible to
3288 convert the small string to ISO-8859-1, then there is no
3289 way that it could be found anywhere by index. */
3294 /* At this point, pv is a malloc()ed string. So donate it to temp
3295 to ensure it will get free()d */
3296 little = temp = newSV(0);
3297 sv_usepvn(temp, pv, llen);
3298 little_p = SvPVX(little);
3301 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3304 sv_recode_to_utf8(temp, PL_encoding);
3306 sv_utf8_upgrade(temp);
3311 big_p = SvPV_const(big, biglen);
3314 little_p = SvPV_const(little, llen);
3318 if (SvGAMAGIC(big)) {
3319 /* Life just becomes a lot easier if I use a temporary here.
3320 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3321 will trigger magic and overloading again, as will fbm_instr()
3323 big = newSVpvn_flags(big_p, biglen,
3324 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3327 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3328 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3329 warn on undef, and we've already triggered a warning with the
3330 SvPV_const some lines above. We can't remove that, as we need to
3331 call some SvPV to trigger overloading early and find out if the
3333 This is all getting to messy. The API isn't quite clean enough,
3334 because data access has side effects.
3336 little = newSVpvn_flags(little_p, llen,
3337 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3338 little_p = SvPVX(little);
3342 offset = is_index ? 0 : biglen;
3344 if (big_utf8 && offset > 0)
3345 sv_pos_u2b(big, &offset, 0);
3351 else if (offset > (I32)biglen)
3353 if (!(little_p = is_index
3354 ? fbm_instr((unsigned char*)big_p + offset,
3355 (unsigned char*)big_p + biglen, little, 0)
3356 : rninstr(big_p, big_p + offset,
3357 little_p, little_p + llen)))
3360 retval = little_p - big_p;
3361 if (retval > 0 && big_utf8)
3362 sv_pos_b2u(big, &retval);
3367 PUSHi(retval + arybase);
3373 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3374 if (SvTAINTED(MARK[1]))
3375 TAINT_PROPER("sprintf");
3376 do_sprintf(TARG, SP-MARK, MARK+1);
3377 TAINT_IF(SvTAINTED(TARG));
3389 const U8 *s = (U8*)SvPV_const(argsv, len);
3391 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3392 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3393 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3397 XPUSHu(DO_UTF8(argsv) ?
3398 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3410 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3412 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3414 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3416 (void) POPs; /* Ignore the argument value. */
3417 value = UNICODE_REPLACEMENT;
3423 SvUPGRADE(TARG,SVt_PV);
3425 if (value > 255 && !IN_BYTES) {
3426 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3427 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3428 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3430 (void)SvPOK_only(TARG);
3439 *tmps++ = (char)value;
3441 (void)SvPOK_only(TARG);
3443 if (PL_encoding && !IN_BYTES) {
3444 sv_recode_to_utf8(TARG, PL_encoding);
3446 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3447 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3451 *tmps++ = (char)value;
3467 const char *tmps = SvPV_const(left, len);
3469 if (DO_UTF8(left)) {
3470 /* If Unicode, try to downgrade.
3471 * If not possible, croak.
3472 * Yes, we made this up. */
3473 SV* const tsv = sv_2mortal(newSVsv(left));
3476 sv_utf8_downgrade(tsv, FALSE);
3477 tmps = SvPV_const(tsv, len);
3479 # ifdef USE_ITHREADS
3481 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3482 /* This should be threadsafe because in ithreads there is only
3483 * one thread per interpreter. If this would not be true,
3484 * we would need a mutex to protect this malloc. */
3485 PL_reentrant_buffer->_crypt_struct_buffer =
3486 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3487 #if defined(__GLIBC__) || defined(__EMX__)
3488 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3489 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3490 /* work around glibc-2.2.5 bug */
3491 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3495 # endif /* HAS_CRYPT_R */
3496 # endif /* USE_ITHREADS */
3498 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3500 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3506 "The crypt() function is unimplemented due to excessive paranoia.");
3518 bool inplace = TRUE;
3520 const int op_type = PL_op->op_type;
3523 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3529 s = (const U8*)SvPV_nomg_const(source, slen);
3535 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3537 utf8_to_uvchr(s, &ulen);
3538 if (op_type == OP_UCFIRST) {
3539 toTITLE_utf8(s, tmpbuf, &tculen);
3541 toLOWER_utf8(s, tmpbuf, &tculen);
3543 /* If the two differ, we definately cannot do inplace. */
3544 inplace = (ulen == tculen);
3545 need = slen + 1 - ulen + tculen;
3551 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3552 /* We can convert in place. */
3555 s = d = (U8*)SvPV_force_nomg(source, slen);
3561 SvUPGRADE(dest, SVt_PV);
3562 d = (U8*)SvGROW(dest, need);
3563 (void)SvPOK_only(dest);
3572 /* slen is the byte length of the whole SV.
3573 * ulen is the byte length of the original Unicode character
3574 * stored as UTF-8 at s.
3575 * tculen is the byte length of the freshly titlecased (or
3576 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3577 * We first set the result to be the titlecased (/lowercased)
3578 * character, and then append the rest of the SV data. */
3579 sv_setpvn(dest, (char*)tmpbuf, tculen);
3581 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3585 Copy(tmpbuf, d, tculen, U8);
3586 SvCUR_set(dest, need - 1);
3591 if (IN_LOCALE_RUNTIME) {
3594 *d = (op_type == OP_UCFIRST)
3595 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3598 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3600 /* See bug #39028 */
3608 /* This will copy the trailing NUL */
3609 Copy(s + 1, d + 1, slen, U8);
3610 SvCUR_set(dest, need - 1);
3617 /* There's so much setup/teardown code common between uc and lc, I wonder if
3618 it would be worth merging the two, and just having a switch outside each
3619 of the three tight loops. */
3633 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3634 && SvTEMP(source) && !DO_UTF8(source)) {
3635 /* We can convert in place. */
3638 s = d = (U8*)SvPV_force_nomg(source, len);
3645 /* The old implementation would copy source into TARG at this point.
3646 This had the side effect that if source was undef, TARG was now
3647 an undefined SV with PADTMP set, and they don't warn inside
3648 sv_2pv_flags(). However, we're now getting the PV direct from
3649 source, which doesn't have PADTMP set, so it would warn. Hence the
3653 s = (const U8*)SvPV_nomg_const(source, len);
3660 SvUPGRADE(dest, SVt_PV);
3661 d = (U8*)SvGROW(dest, min);
3662 (void)SvPOK_only(dest);
3667 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3668 to check DO_UTF8 again here. */
3670 if (DO_UTF8(source)) {
3671 const U8 *const send = s + len;
3672 U8 tmpbuf[UTF8_MAXBYTES+1];
3675 const STRLEN u = UTF8SKIP(s);
3678 toUPPER_utf8(s, tmpbuf, &ulen);
3679 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3680 /* If the eventually required minimum size outgrows
3681 * the available space, we need to grow. */
3682 const UV o = d - (U8*)SvPVX_const(dest);
3684 /* If someone uppercases one million U+03B0s we SvGROW() one
3685 * million times. Or we could try guessing how much to
3686 allocate without allocating too much. Such is life. */
3688 d = (U8*)SvPVX(dest) + o;
3690 Copy(tmpbuf, d, ulen, U8);
3696 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3699 const U8 *const send = s + len;
3700 if (IN_LOCALE_RUNTIME) {
3703 for (; s < send; d++, s++)
3704 *d = toUPPER_LC(*s);
3707 for (; s < send; d++, s++)
3711 if (source != dest) {
3713 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3733 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3734 && SvTEMP(source) && !DO_UTF8(source)) {
3735 /* We can convert in place. */
3738 s = d = (U8*)SvPV_force_nomg(source, len);
3745 /* The old implementation would copy source into TARG at this point.
3746 This had the side effect that if source was undef, TARG was now
3747 an undefined SV with PADTMP set, and they don't warn inside
3748 sv_2pv_flags(). However, we're now getting the PV direct from
3749 source, which doesn't have PADTMP set, so it would warn. Hence the
3753 s = (const U8*)SvPV_nomg_const(source, len);
3760 SvUPGRADE(dest, SVt_PV);
3761 d = (U8*)SvGROW(dest, min);
3762 (void)SvPOK_only(dest);
3767 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3768 to check DO_UTF8 again here. */
3770 if (DO_UTF8(source)) {
3771 const U8 *const send = s + len;
3772 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3775 const STRLEN u = UTF8SKIP(s);
3777 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3779 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3780 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3783 * Now if the sigma is NOT followed by
3784 * /$ignorable_sequence$cased_letter/;
3785 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3786 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3787 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3788 * then it should be mapped to 0x03C2,
3789 * (GREEK SMALL LETTER FINAL SIGMA),
3790 * instead of staying 0x03A3.
3791 * "should be": in other words, this is not implemented yet.
3792 * See lib/unicore/SpecialCasing.txt.
3795 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3796 /* If the eventually required minimum size outgrows
3797 * the available space, we need to grow. */
3798 const UV o = d - (U8*)SvPVX_const(dest);
3800 /* If someone lowercases one million U+0130s we SvGROW() one
3801 * million times. Or we could try guessing how much to
3802 allocate without allocating too much. Such is life. */
3804 d = (U8*)SvPVX(dest) + o;
3806 Copy(tmpbuf, d, ulen, U8);
3812 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3815 const U8 *const send = s + len;
3816 if (IN_LOCALE_RUNTIME) {
3819 for (; s < send; d++, s++)
3820 *d = toLOWER_LC(*s);
3823 for (; s < send; d++, s++)
3827 if (source != dest) {
3829 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3839 SV * const sv = TOPs;
3841 register const char *s = SvPV_const(sv,len);
3843 SvUTF8_off(TARG); /* decontaminate */
3846 SvUPGRADE(TARG, SVt_PV);
3847 SvGROW(TARG, (len * 2) + 1);
3851 if (UTF8_IS_CONTINUED(*s)) {
3852 STRLEN ulen = UTF8SKIP(s);
3876 SvCUR_set(TARG, d - SvPVX_const(TARG));
3877 (void)SvPOK_only_UTF8(TARG);
3880 sv_setpvn(TARG, s, len);
3882 if (SvSMAGICAL(TARG))
3891 dVAR; dSP; dMARK; dORIGMARK;
3892 register AV* const av = (AV*)POPs;
3893 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3895 if (SvTYPE(av) == SVt_PVAV) {
3896 const I32 arybase = CopARYBASE_get(PL_curcop);
3897 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3900 for (svp = MARK + 1; svp <= SP; svp++) {
3901 const I32 elem = SvIV(*svp);
3905 if (max > AvMAX(av))
3908 while (++MARK <= SP) {
3910 I32 elem = SvIV(*MARK);
3914 svp = av_fetch(av, elem, lval);
3916 if (!svp || *svp == &PL_sv_undef)
3917 DIE(aTHX_ PL_no_aelem, elem);
3918 if (PL_op->op_private & OPpLVAL_INTRO)
3919 save_aelem(av, elem, svp);
3921 *MARK = svp ? *svp : &PL_sv_undef;
3924 if (GIMME != G_ARRAY) {
3926 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3936 AV *array = (AV*)POPs;
3937 const I32 gimme = GIMME_V;
3938 IV *iterp = Perl_av_iter_p(aTHX_ array);
3939 const IV current = (*iterp)++;
3941 if (current > av_len(array)) {
3943 if (gimme == G_SCALAR)
3950 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3951 if (gimme == G_ARRAY) {
3952 SV **const element = av_fetch(array, current, 0);
3953 PUSHs(element ? *element : &PL_sv_undef);
3962 AV *array = (AV*)POPs;
3963 const I32 gimme = GIMME_V;
3965 *Perl_av_iter_p(aTHX_ array) = 0;
3967 if (gimme == G_SCALAR) {
3969 PUSHi(av_len(array) + 1);
3971 else if (gimme == G_ARRAY) {
3972 IV n = Perl_av_len(aTHX_ array);
3973 IV i = CopARYBASE_get(PL_curcop);
3977 if (PL_op->op_type == OP_AKEYS) {
3979 for (; i <= n; i++) {
3984 for (i = 0; i <= n; i++) {
3985 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
3986 PUSHs(elem ? *elem : &PL_sv_undef);
3993 /* Associative arrays. */
3999 HV * hash = (HV*)POPs;
4001 const I32 gimme = GIMME_V;
4004 /* might clobber stack_sp */
4005 entry = hv_iternext(hash);
4010 SV* const sv = hv_iterkeysv(entry);
4011 PUSHs(sv); /* won't clobber stack_sp */
4012 if (gimme == G_ARRAY) {
4015 /* might clobber stack_sp */
4016 val = hv_iterval(hash, entry);
4021 else if (gimme == G_SCALAR)
4031 const I32 gimme = GIMME_V;
4032 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4034 if (PL_op->op_private & OPpSLICE) {
4036 HV * const hv = (HV*)POPs;
4037 const U32 hvtype = SvTYPE(hv);
4038 if (hvtype == SVt_PVHV) { /* hash element */
4039 while (++MARK <= SP) {
4040 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4041 *MARK = sv ? sv : &PL_sv_undef;
4044 else if (hvtype == SVt_PVAV) { /* array element */
4045 if (PL_op->op_flags & OPf_SPECIAL) {
4046 while (++MARK <= SP) {
4047 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
4048 *MARK = sv ? sv : &PL_sv_undef;
4053 DIE(aTHX_ "Not a HASH reference");
4056 else if (gimme == G_SCALAR) {
4061 *++MARK = &PL_sv_undef;
4067 HV * const hv = (HV*)POPs;
4069 if (SvTYPE(hv) == SVt_PVHV)
4070 sv = hv_delete_ent(hv, keysv, discard, 0);
4071 else if (SvTYPE(hv) == SVt_PVAV) {
4072 if (PL_op->op_flags & OPf_SPECIAL)
4073 sv = av_delete((AV*)hv, SvIV(keysv), discard);
4075 DIE(aTHX_ "panic: avhv_delete no longer supported");
4078 DIE(aTHX_ "Not a HASH reference");
4094 if (PL_op->op_private & OPpEXISTS_SUB) {
4096 SV * const sv = POPs;
4097 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4100 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4106 if (SvTYPE(hv) == SVt_PVHV) {
4107 if (hv_exists_ent(hv, tmpsv, 0))
4110 else if (SvTYPE(hv) == SVt_PVAV) {
4111 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4112 if (av_exists((AV*)hv, SvIV(tmpsv)))
4117 DIE(aTHX_ "Not a HASH reference");
4124 dVAR; dSP; dMARK; dORIGMARK;
4125 register HV * const hv = (HV*)POPs;
4126 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4127 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4128 bool other_magic = FALSE;
4134 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4135 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4136 /* Try to preserve the existenceness of a tied hash
4137 * element by using EXISTS and DELETE if possible.
4138 * Fallback to FETCH and STORE otherwise */
4139 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4140 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4141 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4144 while (++MARK <= SP) {
4145 SV * const keysv = *MARK;
4148 bool preeminent = FALSE;
4151 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4152 hv_exists_ent(hv, keysv, 0);
4155 he = hv_fetch_ent(hv, keysv, lval, 0);
4156 svp = he ? &HeVAL(he) : NULL;
4159 if (!svp || *svp == &PL_sv_undef) {
4160 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4163 if (HvNAME_get(hv) && isGV(*svp))
4164 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4167 save_helem(hv, keysv, svp);
4170 const char * const key = SvPV_const(keysv, keylen);
4171 SAVEDELETE(hv, savepvn(key,keylen),
4172 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4177 *MARK = svp ? *svp : &PL_sv_undef;
4179 if (GIMME != G_ARRAY) {
4181 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4187 /* List operators. */
4192 if (GIMME != G_ARRAY) {
4194 *MARK = *SP; /* unwanted list, return last item */
4196 *MARK = &PL_sv_undef;
4206 SV ** const lastrelem = PL_stack_sp;
4207 SV ** const lastlelem = PL_stack_base + POPMARK;
4208 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4209 register SV ** const firstrelem = lastlelem + 1;
4210 const I32 arybase = CopARYBASE_get(PL_curcop);
4211 I32 is_something_there = FALSE;
4213 register const I32 max = lastrelem - lastlelem;
4214 register SV **lelem;
4216 if (GIMME != G_ARRAY) {
4217 I32 ix = SvIV(*lastlelem);
4222 if (ix < 0 || ix >= max)
4223 *firstlelem = &PL_sv_undef;
4225 *firstlelem = firstrelem[ix];
4231 SP = firstlelem - 1;
4235 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4236 I32 ix = SvIV(*lelem);
4241 if (ix < 0 || ix >= max)
4242 *lelem = &PL_sv_undef;
4244 is_something_there = TRUE;
4245 if (!(*lelem = firstrelem[ix]))
4246 *lelem = &PL_sv_undef;
4249 if (is_something_there)
4252 SP = firstlelem - 1;
4258 dVAR; dSP; dMARK; dORIGMARK;
4259 const I32 items = SP - MARK;
4260 SV * const av = (SV *) av_make(items, MARK+1);
4261 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4262 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4263 ? newRV_noinc(av) : av);
4269 dVAR; dSP; dMARK; dORIGMARK;
4270 HV* const hv = newHV();
4273 SV * const key = *++MARK;
4274 SV * const val = newSV(0);
4276 sv_setsv(val, *++MARK);
4277 else if (ckWARN(WARN_MISC))
4278 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4279 (void)hv_store_ent(hv,key,val,0);
4282 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4283 ? newRV_noinc((SV*) hv) : (SV*) hv);
4289 dVAR; dSP; dMARK; dORIGMARK;
4290 register AV *ary = (AV*)*++MARK;
4294 register I32 offset;
4295 register I32 length;
4299 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4302 *MARK-- = SvTIED_obj((SV*)ary, mg);
4306 call_method("SPLICE",GIMME_V);
4315 offset = i = SvIV(*MARK);
4317 offset += AvFILLp(ary) + 1;
4319 offset -= CopARYBASE_get(PL_curcop);
4321 DIE(aTHX_ PL_no_aelem, i);
4323 length = SvIVx(*MARK++);
4325 length += AvFILLp(ary) - offset + 1;
4331 length = AvMAX(ary) + 1; /* close enough to infinity */
4335 length = AvMAX(ary) + 1;
4337 if (offset > AvFILLp(ary) + 1) {
4338 if (ckWARN(WARN_MISC))
4339 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4340 offset = AvFILLp(ary) + 1;
4342 after = AvFILLp(ary) + 1 - (offset + length);
4343 if (after < 0) { /* not that much array */
4344 length += after; /* offset+length now in array */
4350 /* At this point, MARK .. SP-1 is our new LIST */
4353 diff = newlen - length;
4354 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4357 /* make new elements SVs now: avoid problems if they're from the array */
4358 for (dst = MARK, i = newlen; i; i--) {
4359 SV * const h = *dst;
4360 *dst++ = newSVsv(h);
4363 if (diff < 0) { /* shrinking the area */
4364 SV **tmparyval = NULL;
4366 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4367 Copy(MARK, tmparyval, newlen, SV*);
4370 MARK = ORIGMARK + 1;
4371 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4372 MEXTEND(MARK, length);
4373 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4375 EXTEND_MORTAL(length);
4376 for (i = length, dst = MARK; i; i--) {
4377 sv_2mortal(*dst); /* free them eventualy */
4384 *MARK = AvARRAY(ary)[offset+length-1];
4387 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4388 SvREFCNT_dec(*dst++); /* free them now */
4391 AvFILLp(ary) += diff;
4393 /* pull up or down? */
4395 if (offset < after) { /* easier to pull up */
4396 if (offset) { /* esp. if nothing to pull */
4397 src = &AvARRAY(ary)[offset-1];
4398 dst = src - diff; /* diff is negative */
4399 for (i = offset; i > 0; i--) /* can't trust Copy */
4403 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4407 if (after) { /* anything to pull down? */
4408 src = AvARRAY(ary) + offset + length;
4409 dst = src + diff; /* diff is negative */
4410 Move(src, dst, after, SV*);
4412 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4413 /* avoid later double free */
4417 dst[--i] = &PL_sv_undef;
4420 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4421 Safefree(tmparyval);
4424 else { /* no, expanding (or same) */
4425 SV** tmparyval = NULL;
4427 Newx(tmparyval, length, SV*); /* so remember deletion */
4428 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4431 if (diff > 0) { /* expanding */
4432 /* push up or down? */
4433 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4437 Move(src, dst, offset, SV*);
4439 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4441 AvFILLp(ary) += diff;
4444 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4445 av_extend(ary, AvFILLp(ary) + diff);
4446 AvFILLp(ary) += diff;
4449 dst = AvARRAY(ary) + AvFILLp(ary);
4451 for (i = after; i; i--) {
4459 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4462 MARK = ORIGMARK + 1;
4463 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4465 Copy(tmparyval, MARK, length, SV*);
4467 EXTEND_MORTAL(length);
4468 for (i = length, dst = MARK; i; i--) {
4469 sv_2mortal(*dst); /* free them eventualy */
4476 else if (length--) {
4477 *MARK = tmparyval[length];
4480 while (length-- > 0)
4481 SvREFCNT_dec(tmparyval[length]);
4485 *MARK = &PL_sv_undef;
4486 Safefree(tmparyval);
4494 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4495 register AV * const ary = (AV*)*++MARK;
4496 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4499 *MARK-- = SvTIED_obj((SV*)ary, mg);
4503 call_method("PUSH",G_SCALAR|G_DISCARD);
4507 PUSHi( AvFILL(ary) + 1 );
4510 PL_delaymagic = DM_DELAY;
4511 for (++MARK; MARK <= SP; MARK++) {
4512 SV * const sv = newSV(0);
4514 sv_setsv(sv, *MARK);
4515 av_store(ary, AvFILLp(ary)+1, sv);
4517 if (PL_delaymagic & DM_ARRAY)
4522 PUSHi( AvFILLp(ary) + 1 );
4531 AV * const av = (AV*)POPs;
4532 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4536 (void)sv_2mortal(sv);
4543 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4544 register AV *ary = (AV*)*++MARK;
4545 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4548 *MARK-- = SvTIED_obj((SV*)ary, mg);
4552 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4558 av_unshift(ary, SP - MARK);
4560 SV * const sv = newSVsv(*++MARK);
4561 (void)av_store(ary, i++, sv);
4565 PUSHi( AvFILL(ary) + 1 );
4572 SV ** const oldsp = SP;
4574 if (GIMME == G_ARRAY) {
4577 register SV * const tmp = *MARK;
4581 /* safe as long as stack cannot get extended in the above */
4586 register char *down;
4590 PADOFFSET padoff_du;
4592 SvUTF8_off(TARG); /* decontaminate */
4594 do_join(TARG, &PL_sv_no, MARK, SP);
4596 sv_setsv(TARG, (SP > MARK)
4598 : (padoff_du = find_rundefsvoffset(),
4599 (padoff_du == NOT_IN_PAD
4600 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4601 ? DEFSV : PAD_SVl(padoff_du)));
4602 up = SvPV_force(TARG, len);
4604 if (DO_UTF8(TARG)) { /* first reverse each character */
4605 U8* s = (U8*)SvPVX(TARG);
4606 const U8* send = (U8*)(s + len);
4608 if (UTF8_IS_INVARIANT(*s)) {
4613 if (!utf8_to_uvchr(s, 0))
4617 down = (char*)(s - 1);
4618 /* reverse this character */
4622 *down-- = (char)tmp;
4628 down = SvPVX(TARG) + len - 1;
4632 *down-- = (char)tmp;
4634 (void)SvPOK_only_UTF8(TARG);
4646 register IV limit = POPi; /* note, negative is forever */
4647 SV * const sv = POPs;
4649 register const char *s = SvPV_const(sv, len);
4650 const bool do_utf8 = DO_UTF8(sv);
4651 const char *strend = s + len;
4653 register REGEXP *rx;
4655 register const char *m;
4657 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4658 I32 maxiters = slen + 10;
4660 const I32 origlimit = limit;
4663 const I32 gimme = GIMME_V;
4664 const I32 oldsave = PL_savestack_ix;
4665 I32 make_mortal = 1;
4670 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4675 DIE(aTHX_ "panic: pp_split");
4678 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4679 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4681 RX_MATCH_UTF8_set(rx, do_utf8);
4684 if (pm->op_pmreplrootu.op_pmtargetoff) {
4685 ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4688 if (pm->op_pmreplrootu.op_pmtargetgv) {
4689 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4692 else if (gimme != G_ARRAY)
4693 ary = GvAVn(PL_defgv);
4696 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4702 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4704 XPUSHs(SvTIED_obj((SV*)ary, mg));
4711 for (i = AvFILLp(ary); i >= 0; i--)
4712 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4714 /* temporarily switch stacks */
4715 SAVESWITCHSTACK(PL_curstack, ary);
4719 base = SP - PL_stack_base;
4721 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4723 while (*s == ' ' || is_utf8_space((U8*)s))
4726 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4727 while (isSPACE_LC(*s))
4735 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4740 limit = maxiters + 2;
4741 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4744 /* this one uses 'm' and is a negative test */
4746 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4747 const int t = UTF8SKIP(m);
4748 /* is_utf8_space returns FALSE for malform utf8 */
4754 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4755 while (m < strend && !isSPACE_LC(*m))
4758 while (m < strend && !isSPACE(*m))
4764 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4769 /* skip the whitespace found last */
4771 s = m + UTF8SKIP(m);
4775 /* this one uses 's' and is a positive test */
4777 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4779 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4780 while (s < strend && isSPACE_LC(*s))
4783 while (s < strend && isSPACE(*s))
4788 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4790 for (m = s; m < strend && *m != '\n'; m++)
4795 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4802 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4804 Pre-extend the stack, either the number of bytes or
4805 characters in the string or a limited amount, triggered by:
4807 my ($x, $y) = split //, $str;
4811 const U32 items = limit - 1;
4819 /* keep track of how many bytes we skip over */
4822 dstr = newSVpvn_utf8(m, s-m, TRUE);
4834 dstr = newSVpvn(s, 1);
4848 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4849 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4850 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4851 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4852 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4853 SV * const csv = CALLREG_INTUIT_STRING(rx);
4855 len = RX_MINLENRET(rx);
4856 if (len == 1 && !RX_UTF8(rx) && !tail) {
4857 const char c = *SvPV_nolen_const(csv);
4859 for (m = s; m < strend && *m != c; m++)
4863 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4867 /* The rx->minlen is in characters but we want to step
4868 * s ahead by bytes. */
4870 s = (char*)utf8_hop((U8*)m, len);
4872 s = m + len; /* Fake \n at the end */
4876 while (s < strend && --limit &&
4877 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4878 csv, multiline ? FBMrf_MULTILINE : 0)) )
4880 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4884 /* The rx->minlen is in characters but we want to step
4885 * s ahead by bytes. */
4887 s = (char*)utf8_hop((U8*)m, len);
4889 s = m + len; /* Fake \n at the end */
4894 maxiters += slen * RX_NPARENS(rx);
4895 while (s < strend && --limit)
4899 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4902 if (rex_return == 0)
4904 TAINT_IF(RX_MATCH_TAINTED(rx));
4905 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4908 orig = RX_SUBBEG(rx);
4910 strend = s + (strend - m);
4912 m = RX_OFFS(rx)[0].start + orig;
4913 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4917 if (RX_NPARENS(rx)) {
4919 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4920 s = RX_OFFS(rx)[i].start + orig;
4921 m = RX_OFFS(rx)[i].end + orig;
4923 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4924 parens that didn't match -- they should be set to
4925 undef, not the empty string */
4926 if (m >= orig && s >= orig) {
4927 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4930 dstr = &PL_sv_undef; /* undef, not "" */
4936 s = RX_OFFS(rx)[0].end + orig;
4940 iters = (SP - PL_stack_base) - base;
4941 if (iters > maxiters)
4942 DIE(aTHX_ "Split loop");
4944 /* keep field after final delim? */
4945 if (s < strend || (iters && origlimit)) {
4946 const STRLEN l = strend - s;
4947 dstr = newSVpvn_utf8(s, l, do_utf8);
4953 else if (!origlimit) {
4954 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4955 if (TOPs && !make_mortal)
4958 *SP-- = &PL_sv_undef;
4963 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4967 if (SvSMAGICAL(ary)) {
4972 if (gimme == G_ARRAY) {
4974 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4982 call_method("PUSH",G_SCALAR|G_DISCARD);
4985 if (gimme == G_ARRAY) {
4987 /* EXTEND should not be needed - we just popped them */
4989 for (i=0; i < iters; i++) {
4990 SV **svp = av_fetch(ary, i, FALSE);
4991 PUSHs((svp) ? *svp : &PL_sv_undef);
4998 if (gimme == G_ARRAY)
5010 SV *const sv = PAD_SVl(PL_op->op_targ);
5012 if (SvPADSTALE(sv)) {
5015 RETURNOP(cLOGOP->op_other);
5017 RETURNOP(cLOGOP->op_next);
5027 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5028 || SvTYPE(retsv) == SVt_PVCV) {
5029 retsv = refto(retsv);
5036 PP(unimplemented_op)
5039 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5045 * c-indentation-style: bsd
5047 * indent-tabs-mode: t
5050 * ex: set ts=8 sts=4 sw=4 noet: