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 (!SvOK(sv) && !SvGMAGICAL(sv)) {
3022 /* FIXME - this doesn't allow GMAGIC to return undef for consistency.
3025 } else if (SvGAMAGIC(sv)) {
3026 /* For an overloaded or magic scalar, we can't know in advance if
3027 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3028 it likes to cache the length. Maybe that should be a documented
3033 = sv_2pv_flags(sv, &len,
3034 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3038 else if (DO_UTF8(sv)) {
3039 SETi(utf8_length((U8*)p, (U8*)p + len));
3044 /* Neither magic nor overloaded. */
3046 SETi(sv_len_utf8(sv));
3063 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3065 const I32 arybase = CopARYBASE_get(PL_curcop);
3067 const char *repl = NULL;
3069 const int num_args = PL_op->op_private & 7;
3070 bool repl_need_utf8_upgrade = FALSE;
3071 bool repl_is_utf8 = FALSE;
3073 SvTAINTED_off(TARG); /* decontaminate */
3074 SvUTF8_off(TARG); /* decontaminate */
3078 repl = SvPV_const(repl_sv, repl_len);
3079 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3089 sv_utf8_upgrade(sv);
3091 else if (DO_UTF8(sv))
3092 repl_need_utf8_upgrade = TRUE;
3094 tmps = SvPV_const(sv, curlen);
3096 utf8_curlen = sv_len_utf8(sv);
3097 if (utf8_curlen == curlen)
3100 curlen = utf8_curlen;
3105 if (pos >= arybase) {
3123 else if (len >= 0) {
3125 if (rem > (I32)curlen)
3140 Perl_croak(aTHX_ "substr outside of string");
3141 if (ckWARN(WARN_SUBSTR))
3142 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3146 const I32 upos = pos;
3147 const I32 urem = rem;
3149 sv_pos_u2b(sv, &pos, &rem);
3151 /* we either return a PV or an LV. If the TARG hasn't been used
3152 * before, or is of that type, reuse it; otherwise use a mortal
3153 * instead. Note that LVs can have an extended lifetime, so also
3154 * dont reuse if refcount > 1 (bug #20933) */
3155 if (SvTYPE(TARG) > SVt_NULL) {
3156 if ( (SvTYPE(TARG) == SVt_PVLV)
3157 ? (!lvalue || SvREFCNT(TARG) > 1)
3160 TARG = sv_newmortal();
3164 sv_setpvn(TARG, tmps, rem);
3165 #ifdef USE_LOCALE_COLLATE
3166 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3171 SV* repl_sv_copy = NULL;
3173 if (repl_need_utf8_upgrade) {
3174 repl_sv_copy = newSVsv(repl_sv);
3175 sv_utf8_upgrade(repl_sv_copy);
3176 repl = SvPV_const(repl_sv_copy, repl_len);
3177 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3179 sv_insert(sv, pos, rem, repl, repl_len);
3183 SvREFCNT_dec(repl_sv_copy);
3185 else if (lvalue) { /* it's an lvalue! */
3186 if (!SvGMAGICAL(sv)) {
3188 SvPV_force_nolen(sv);
3189 if (ckWARN(WARN_SUBSTR))
3190 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3191 "Attempt to use reference as lvalue in substr");
3193 if (isGV_with_GP(sv))
3194 SvPV_force_nolen(sv);
3195 else if (SvOK(sv)) /* is it defined ? */
3196 (void)SvPOK_only_UTF8(sv);
3198 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3201 if (SvTYPE(TARG) < SVt_PVLV) {
3202 sv_upgrade(TARG, SVt_PVLV);
3203 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3207 if (LvTARG(TARG) != sv) {
3209 SvREFCNT_dec(LvTARG(TARG));
3210 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3212 LvTARGOFF(TARG) = upos;
3213 LvTARGLEN(TARG) = urem;
3217 PUSHs(TARG); /* avoid SvSETMAGIC here */
3224 register const IV size = POPi;
3225 register const IV offset = POPi;
3226 register SV * const src = POPs;
3227 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3229 SvTAINTED_off(TARG); /* decontaminate */
3230 if (lvalue) { /* it's an lvalue! */
3231 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3232 TARG = sv_newmortal();
3233 if (SvTYPE(TARG) < SVt_PVLV) {
3234 sv_upgrade(TARG, SVt_PVLV);
3235 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3238 if (LvTARG(TARG) != src) {
3240 SvREFCNT_dec(LvTARG(TARG));
3241 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3243 LvTARGOFF(TARG) = offset;
3244 LvTARGLEN(TARG) = size;
3247 sv_setuv(TARG, do_vecget(src, offset, size));
3263 const char *little_p;
3264 const I32 arybase = CopARYBASE_get(PL_curcop);
3267 const bool is_index = PL_op->op_type == OP_INDEX;
3270 /* arybase is in characters, like offset, so combine prior to the
3271 UTF-8 to bytes calculation. */
3272 offset = POPi - arybase;
3276 big_p = SvPV_const(big, biglen);
3277 little_p = SvPV_const(little, llen);
3279 big_utf8 = DO_UTF8(big);
3280 little_utf8 = DO_UTF8(little);
3281 if (big_utf8 ^ little_utf8) {
3282 /* One needs to be upgraded. */
3283 if (little_utf8 && !PL_encoding) {
3284 /* Well, maybe instead we might be able to downgrade the small
3286 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3289 /* If the large string is ISO-8859-1, and it's not possible to
3290 convert the small string to ISO-8859-1, then there is no
3291 way that it could be found anywhere by index. */
3296 /* At this point, pv is a malloc()ed string. So donate it to temp
3297 to ensure it will get free()d */
3298 little = temp = newSV(0);
3299 sv_usepvn(temp, pv, llen);
3300 little_p = SvPVX(little);
3303 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3306 sv_recode_to_utf8(temp, PL_encoding);
3308 sv_utf8_upgrade(temp);
3313 big_p = SvPV_const(big, biglen);
3316 little_p = SvPV_const(little, llen);
3320 if (SvGAMAGIC(big)) {
3321 /* Life just becomes a lot easier if I use a temporary here.
3322 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3323 will trigger magic and overloading again, as will fbm_instr()
3325 big = newSVpvn_flags(big_p, biglen,
3326 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3329 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3330 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3331 warn on undef, and we've already triggered a warning with the
3332 SvPV_const some lines above. We can't remove that, as we need to
3333 call some SvPV to trigger overloading early and find out if the
3335 This is all getting to messy. The API isn't quite clean enough,
3336 because data access has side effects.
3338 little = newSVpvn_flags(little_p, llen,
3339 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3340 little_p = SvPVX(little);
3344 offset = is_index ? 0 : biglen;
3346 if (big_utf8 && offset > 0)
3347 sv_pos_u2b(big, &offset, 0);
3353 else if (offset > (I32)biglen)
3355 if (!(little_p = is_index
3356 ? fbm_instr((unsigned char*)big_p + offset,
3357 (unsigned char*)big_p + biglen, little, 0)
3358 : rninstr(big_p, big_p + offset,
3359 little_p, little_p + llen)))
3362 retval = little_p - big_p;
3363 if (retval > 0 && big_utf8)
3364 sv_pos_b2u(big, &retval);
3369 PUSHi(retval + arybase);
3375 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3376 if (SvTAINTED(MARK[1]))
3377 TAINT_PROPER("sprintf");
3378 do_sprintf(TARG, SP-MARK, MARK+1);
3379 TAINT_IF(SvTAINTED(TARG));
3391 const U8 *s = (U8*)SvPV_const(argsv, len);
3393 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3394 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3395 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3399 XPUSHu(DO_UTF8(argsv) ?
3400 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3412 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3414 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3416 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3418 (void) POPs; /* Ignore the argument value. */
3419 value = UNICODE_REPLACEMENT;
3425 SvUPGRADE(TARG,SVt_PV);
3427 if (value > 255 && !IN_BYTES) {
3428 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3429 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3430 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3432 (void)SvPOK_only(TARG);
3441 *tmps++ = (char)value;
3443 (void)SvPOK_only(TARG);
3445 if (PL_encoding && !IN_BYTES) {
3446 sv_recode_to_utf8(TARG, PL_encoding);
3448 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3449 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3453 *tmps++ = (char)value;
3469 const char *tmps = SvPV_const(left, len);
3471 if (DO_UTF8(left)) {
3472 /* If Unicode, try to downgrade.
3473 * If not possible, croak.
3474 * Yes, we made this up. */
3475 SV* const tsv = sv_2mortal(newSVsv(left));
3478 sv_utf8_downgrade(tsv, FALSE);
3479 tmps = SvPV_const(tsv, len);
3481 # ifdef USE_ITHREADS
3483 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3484 /* This should be threadsafe because in ithreads there is only
3485 * one thread per interpreter. If this would not be true,
3486 * we would need a mutex to protect this malloc. */
3487 PL_reentrant_buffer->_crypt_struct_buffer =
3488 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3489 #if defined(__GLIBC__) || defined(__EMX__)
3490 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3491 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3492 /* work around glibc-2.2.5 bug */
3493 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3497 # endif /* HAS_CRYPT_R */
3498 # endif /* USE_ITHREADS */
3500 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3502 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3508 "The crypt() function is unimplemented due to excessive paranoia.");
3520 bool inplace = TRUE;
3522 const int op_type = PL_op->op_type;
3525 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3531 s = (const U8*)SvPV_nomg_const(source, slen);
3537 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3539 utf8_to_uvchr(s, &ulen);
3540 if (op_type == OP_UCFIRST) {
3541 toTITLE_utf8(s, tmpbuf, &tculen);
3543 toLOWER_utf8(s, tmpbuf, &tculen);
3545 /* If the two differ, we definately cannot do inplace. */
3546 inplace = (ulen == tculen);
3547 need = slen + 1 - ulen + tculen;
3553 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3554 /* We can convert in place. */
3557 s = d = (U8*)SvPV_force_nomg(source, slen);
3563 SvUPGRADE(dest, SVt_PV);
3564 d = (U8*)SvGROW(dest, need);
3565 (void)SvPOK_only(dest);
3574 /* slen is the byte length of the whole SV.
3575 * ulen is the byte length of the original Unicode character
3576 * stored as UTF-8 at s.
3577 * tculen is the byte length of the freshly titlecased (or
3578 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3579 * We first set the result to be the titlecased (/lowercased)
3580 * character, and then append the rest of the SV data. */
3581 sv_setpvn(dest, (char*)tmpbuf, tculen);
3583 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3587 Copy(tmpbuf, d, tculen, U8);
3588 SvCUR_set(dest, need - 1);
3593 if (IN_LOCALE_RUNTIME) {
3596 *d = (op_type == OP_UCFIRST)
3597 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3600 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3602 /* See bug #39028 */
3610 /* This will copy the trailing NUL */
3611 Copy(s + 1, d + 1, slen, U8);
3612 SvCUR_set(dest, need - 1);
3619 /* There's so much setup/teardown code common between uc and lc, I wonder if
3620 it would be worth merging the two, and just having a switch outside each
3621 of the three tight loops. */
3635 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3636 && SvTEMP(source) && !DO_UTF8(source)) {
3637 /* We can convert in place. */
3640 s = d = (U8*)SvPV_force_nomg(source, len);
3647 /* The old implementation would copy source into TARG at this point.
3648 This had the side effect that if source was undef, TARG was now
3649 an undefined SV with PADTMP set, and they don't warn inside
3650 sv_2pv_flags(). However, we're now getting the PV direct from
3651 source, which doesn't have PADTMP set, so it would warn. Hence the
3655 s = (const U8*)SvPV_nomg_const(source, len);
3662 SvUPGRADE(dest, SVt_PV);
3663 d = (U8*)SvGROW(dest, min);
3664 (void)SvPOK_only(dest);
3669 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3670 to check DO_UTF8 again here. */
3672 if (DO_UTF8(source)) {
3673 const U8 *const send = s + len;
3674 U8 tmpbuf[UTF8_MAXBYTES+1];
3677 const STRLEN u = UTF8SKIP(s);
3680 toUPPER_utf8(s, tmpbuf, &ulen);
3681 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3682 /* If the eventually required minimum size outgrows
3683 * the available space, we need to grow. */
3684 const UV o = d - (U8*)SvPVX_const(dest);
3686 /* If someone uppercases one million U+03B0s we SvGROW() one
3687 * million times. Or we could try guessing how much to
3688 allocate without allocating too much. Such is life. */
3690 d = (U8*)SvPVX(dest) + o;
3692 Copy(tmpbuf, d, ulen, U8);
3698 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3701 const U8 *const send = s + len;
3702 if (IN_LOCALE_RUNTIME) {
3705 for (; s < send; d++, s++)
3706 *d = toUPPER_LC(*s);
3709 for (; s < send; d++, s++)
3713 if (source != dest) {
3715 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3735 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3736 && SvTEMP(source) && !DO_UTF8(source)) {
3737 /* We can convert in place. */
3740 s = d = (U8*)SvPV_force_nomg(source, len);
3747 /* The old implementation would copy source into TARG at this point.
3748 This had the side effect that if source was undef, TARG was now
3749 an undefined SV with PADTMP set, and they don't warn inside
3750 sv_2pv_flags(). However, we're now getting the PV direct from
3751 source, which doesn't have PADTMP set, so it would warn. Hence the
3755 s = (const U8*)SvPV_nomg_const(source, len);
3762 SvUPGRADE(dest, SVt_PV);
3763 d = (U8*)SvGROW(dest, min);
3764 (void)SvPOK_only(dest);
3769 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3770 to check DO_UTF8 again here. */
3772 if (DO_UTF8(source)) {
3773 const U8 *const send = s + len;
3774 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3777 const STRLEN u = UTF8SKIP(s);
3779 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3781 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3782 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3785 * Now if the sigma is NOT followed by
3786 * /$ignorable_sequence$cased_letter/;
3787 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3788 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3789 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3790 * then it should be mapped to 0x03C2,
3791 * (GREEK SMALL LETTER FINAL SIGMA),
3792 * instead of staying 0x03A3.
3793 * "should be": in other words, this is not implemented yet.
3794 * See lib/unicore/SpecialCasing.txt.
3797 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3798 /* If the eventually required minimum size outgrows
3799 * the available space, we need to grow. */
3800 const UV o = d - (U8*)SvPVX_const(dest);
3802 /* If someone lowercases one million U+0130s we SvGROW() one
3803 * million times. Or we could try guessing how much to
3804 allocate without allocating too much. Such is life. */
3806 d = (U8*)SvPVX(dest) + o;
3808 Copy(tmpbuf, d, ulen, U8);
3814 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3817 const U8 *const send = s + len;
3818 if (IN_LOCALE_RUNTIME) {
3821 for (; s < send; d++, s++)
3822 *d = toLOWER_LC(*s);
3825 for (; s < send; d++, s++)
3829 if (source != dest) {
3831 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3841 SV * const sv = TOPs;
3843 register const char *s = SvPV_const(sv,len);
3845 SvUTF8_off(TARG); /* decontaminate */
3848 SvUPGRADE(TARG, SVt_PV);
3849 SvGROW(TARG, (len * 2) + 1);
3853 if (UTF8_IS_CONTINUED(*s)) {
3854 STRLEN ulen = UTF8SKIP(s);
3878 SvCUR_set(TARG, d - SvPVX_const(TARG));
3879 (void)SvPOK_only_UTF8(TARG);
3882 sv_setpvn(TARG, s, len);
3884 if (SvSMAGICAL(TARG))
3893 dVAR; dSP; dMARK; dORIGMARK;
3894 register AV* const av = (AV*)POPs;
3895 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3897 if (SvTYPE(av) == SVt_PVAV) {
3898 const I32 arybase = CopARYBASE_get(PL_curcop);
3899 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3902 for (svp = MARK + 1; svp <= SP; svp++) {
3903 const I32 elem = SvIV(*svp);
3907 if (max > AvMAX(av))
3910 while (++MARK <= SP) {
3912 I32 elem = SvIV(*MARK);
3916 svp = av_fetch(av, elem, lval);
3918 if (!svp || *svp == &PL_sv_undef)
3919 DIE(aTHX_ PL_no_aelem, elem);
3920 if (PL_op->op_private & OPpLVAL_INTRO)
3921 save_aelem(av, elem, svp);
3923 *MARK = svp ? *svp : &PL_sv_undef;
3926 if (GIMME != G_ARRAY) {
3928 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3938 AV *array = (AV*)POPs;
3939 const I32 gimme = GIMME_V;
3940 IV *iterp = Perl_av_iter_p(aTHX_ array);
3941 const IV current = (*iterp)++;
3943 if (current > av_len(array)) {
3945 if (gimme == G_SCALAR)
3952 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3953 if (gimme == G_ARRAY) {
3954 SV **const element = av_fetch(array, current, 0);
3955 PUSHs(element ? *element : &PL_sv_undef);
3964 AV *array = (AV*)POPs;
3965 const I32 gimme = GIMME_V;
3967 *Perl_av_iter_p(aTHX_ array) = 0;
3969 if (gimme == G_SCALAR) {
3971 PUSHi(av_len(array) + 1);
3973 else if (gimme == G_ARRAY) {
3974 IV n = Perl_av_len(aTHX_ array);
3975 IV i = CopARYBASE_get(PL_curcop);
3979 if (PL_op->op_type == OP_AKEYS) {
3981 for (; i <= n; i++) {
3986 for (i = 0; i <= n; i++) {
3987 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
3988 PUSHs(elem ? *elem : &PL_sv_undef);
3995 /* Associative arrays. */
4001 HV * hash = (HV*)POPs;
4003 const I32 gimme = GIMME_V;
4006 /* might clobber stack_sp */
4007 entry = hv_iternext(hash);
4012 SV* const sv = hv_iterkeysv(entry);
4013 PUSHs(sv); /* won't clobber stack_sp */
4014 if (gimme == G_ARRAY) {
4017 /* might clobber stack_sp */
4018 val = hv_iterval(hash, entry);
4023 else if (gimme == G_SCALAR)
4033 const I32 gimme = GIMME_V;
4034 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4036 if (PL_op->op_private & OPpSLICE) {
4038 HV * const hv = (HV*)POPs;
4039 const U32 hvtype = SvTYPE(hv);
4040 if (hvtype == SVt_PVHV) { /* hash element */
4041 while (++MARK <= SP) {
4042 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4043 *MARK = sv ? sv : &PL_sv_undef;
4046 else if (hvtype == SVt_PVAV) { /* array element */
4047 if (PL_op->op_flags & OPf_SPECIAL) {
4048 while (++MARK <= SP) {
4049 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
4050 *MARK = sv ? sv : &PL_sv_undef;
4055 DIE(aTHX_ "Not a HASH reference");
4058 else if (gimme == G_SCALAR) {
4063 *++MARK = &PL_sv_undef;
4069 HV * const hv = (HV*)POPs;
4071 if (SvTYPE(hv) == SVt_PVHV)
4072 sv = hv_delete_ent(hv, keysv, discard, 0);
4073 else if (SvTYPE(hv) == SVt_PVAV) {
4074 if (PL_op->op_flags & OPf_SPECIAL)
4075 sv = av_delete((AV*)hv, SvIV(keysv), discard);
4077 DIE(aTHX_ "panic: avhv_delete no longer supported");
4080 DIE(aTHX_ "Not a HASH reference");
4096 if (PL_op->op_private & OPpEXISTS_SUB) {
4098 SV * const sv = POPs;
4099 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4102 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4108 if (SvTYPE(hv) == SVt_PVHV) {
4109 if (hv_exists_ent(hv, tmpsv, 0))
4112 else if (SvTYPE(hv) == SVt_PVAV) {
4113 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4114 if (av_exists((AV*)hv, SvIV(tmpsv)))
4119 DIE(aTHX_ "Not a HASH reference");
4126 dVAR; dSP; dMARK; dORIGMARK;
4127 register HV * const hv = (HV*)POPs;
4128 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4129 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4130 bool other_magic = FALSE;
4136 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4137 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4138 /* Try to preserve the existenceness of a tied hash
4139 * element by using EXISTS and DELETE if possible.
4140 * Fallback to FETCH and STORE otherwise */
4141 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4142 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4143 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4146 while (++MARK <= SP) {
4147 SV * const keysv = *MARK;
4150 bool preeminent = FALSE;
4153 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4154 hv_exists_ent(hv, keysv, 0);
4157 he = hv_fetch_ent(hv, keysv, lval, 0);
4158 svp = he ? &HeVAL(he) : NULL;
4161 if (!svp || *svp == &PL_sv_undef) {
4162 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4165 if (HvNAME_get(hv) && isGV(*svp))
4166 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4169 save_helem(hv, keysv, svp);
4172 const char * const key = SvPV_const(keysv, keylen);
4173 SAVEDELETE(hv, savepvn(key,keylen),
4174 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4179 *MARK = svp ? *svp : &PL_sv_undef;
4181 if (GIMME != G_ARRAY) {
4183 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4189 /* List operators. */
4194 if (GIMME != G_ARRAY) {
4196 *MARK = *SP; /* unwanted list, return last item */
4198 *MARK = &PL_sv_undef;
4208 SV ** const lastrelem = PL_stack_sp;
4209 SV ** const lastlelem = PL_stack_base + POPMARK;
4210 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4211 register SV ** const firstrelem = lastlelem + 1;
4212 const I32 arybase = CopARYBASE_get(PL_curcop);
4213 I32 is_something_there = FALSE;
4215 register const I32 max = lastrelem - lastlelem;
4216 register SV **lelem;
4218 if (GIMME != G_ARRAY) {
4219 I32 ix = SvIV(*lastlelem);
4224 if (ix < 0 || ix >= max)
4225 *firstlelem = &PL_sv_undef;
4227 *firstlelem = firstrelem[ix];
4233 SP = firstlelem - 1;
4237 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4238 I32 ix = SvIV(*lelem);
4243 if (ix < 0 || ix >= max)
4244 *lelem = &PL_sv_undef;
4246 is_something_there = TRUE;
4247 if (!(*lelem = firstrelem[ix]))
4248 *lelem = &PL_sv_undef;
4251 if (is_something_there)
4254 SP = firstlelem - 1;
4260 dVAR; dSP; dMARK; dORIGMARK;
4261 const I32 items = SP - MARK;
4262 SV * const av = (SV *) av_make(items, MARK+1);
4263 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4264 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4265 ? newRV_noinc(av) : av);
4271 dVAR; dSP; dMARK; dORIGMARK;
4272 HV* const hv = newHV();
4275 SV * const key = *++MARK;
4276 SV * const val = newSV(0);
4278 sv_setsv(val, *++MARK);
4279 else if (ckWARN(WARN_MISC))
4280 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4281 (void)hv_store_ent(hv,key,val,0);
4284 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4285 ? newRV_noinc((SV*) hv) : (SV*) hv);
4291 dVAR; dSP; dMARK; dORIGMARK;
4292 register AV *ary = (AV*)*++MARK;
4296 register I32 offset;
4297 register I32 length;
4301 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4304 *MARK-- = SvTIED_obj((SV*)ary, mg);
4308 call_method("SPLICE",GIMME_V);
4317 offset = i = SvIV(*MARK);
4319 offset += AvFILLp(ary) + 1;
4321 offset -= CopARYBASE_get(PL_curcop);
4323 DIE(aTHX_ PL_no_aelem, i);
4325 length = SvIVx(*MARK++);
4327 length += AvFILLp(ary) - offset + 1;
4333 length = AvMAX(ary) + 1; /* close enough to infinity */
4337 length = AvMAX(ary) + 1;
4339 if (offset > AvFILLp(ary) + 1) {
4340 if (ckWARN(WARN_MISC))
4341 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4342 offset = AvFILLp(ary) + 1;
4344 after = AvFILLp(ary) + 1 - (offset + length);
4345 if (after < 0) { /* not that much array */
4346 length += after; /* offset+length now in array */
4352 /* At this point, MARK .. SP-1 is our new LIST */
4355 diff = newlen - length;
4356 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4359 /* make new elements SVs now: avoid problems if they're from the array */
4360 for (dst = MARK, i = newlen; i; i--) {
4361 SV * const h = *dst;
4362 *dst++ = newSVsv(h);
4365 if (diff < 0) { /* shrinking the area */
4366 SV **tmparyval = NULL;
4368 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4369 Copy(MARK, tmparyval, newlen, SV*);
4372 MARK = ORIGMARK + 1;
4373 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4374 MEXTEND(MARK, length);
4375 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4377 EXTEND_MORTAL(length);
4378 for (i = length, dst = MARK; i; i--) {
4379 sv_2mortal(*dst); /* free them eventualy */
4386 *MARK = AvARRAY(ary)[offset+length-1];
4389 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4390 SvREFCNT_dec(*dst++); /* free them now */
4393 AvFILLp(ary) += diff;
4395 /* pull up or down? */
4397 if (offset < after) { /* easier to pull up */
4398 if (offset) { /* esp. if nothing to pull */
4399 src = &AvARRAY(ary)[offset-1];
4400 dst = src - diff; /* diff is negative */
4401 for (i = offset; i > 0; i--) /* can't trust Copy */
4405 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4409 if (after) { /* anything to pull down? */
4410 src = AvARRAY(ary) + offset + length;
4411 dst = src + diff; /* diff is negative */
4412 Move(src, dst, after, SV*);
4414 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4415 /* avoid later double free */
4419 dst[--i] = &PL_sv_undef;
4422 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4423 Safefree(tmparyval);
4426 else { /* no, expanding (or same) */
4427 SV** tmparyval = NULL;
4429 Newx(tmparyval, length, SV*); /* so remember deletion */
4430 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4433 if (diff > 0) { /* expanding */
4434 /* push up or down? */
4435 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4439 Move(src, dst, offset, SV*);
4441 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4443 AvFILLp(ary) += diff;
4446 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4447 av_extend(ary, AvFILLp(ary) + diff);
4448 AvFILLp(ary) += diff;
4451 dst = AvARRAY(ary) + AvFILLp(ary);
4453 for (i = after; i; i--) {
4461 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4464 MARK = ORIGMARK + 1;
4465 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4467 Copy(tmparyval, MARK, length, SV*);
4469 EXTEND_MORTAL(length);
4470 for (i = length, dst = MARK; i; i--) {
4471 sv_2mortal(*dst); /* free them eventualy */
4478 else if (length--) {
4479 *MARK = tmparyval[length];
4482 while (length-- > 0)
4483 SvREFCNT_dec(tmparyval[length]);
4487 *MARK = &PL_sv_undef;
4488 Safefree(tmparyval);
4496 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4497 register AV * const ary = (AV*)*++MARK;
4498 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4501 *MARK-- = SvTIED_obj((SV*)ary, mg);
4505 call_method("PUSH",G_SCALAR|G_DISCARD);
4509 PUSHi( AvFILL(ary) + 1 );
4512 PL_delaymagic = DM_DELAY;
4513 for (++MARK; MARK <= SP; MARK++) {
4514 SV * const sv = newSV(0);
4516 sv_setsv(sv, *MARK);
4517 av_store(ary, AvFILLp(ary)+1, sv);
4519 if (PL_delaymagic & DM_ARRAY)
4524 PUSHi( AvFILLp(ary) + 1 );
4533 AV * const av = (AV*)POPs;
4534 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4538 (void)sv_2mortal(sv);
4545 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4546 register AV *ary = (AV*)*++MARK;
4547 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4550 *MARK-- = SvTIED_obj((SV*)ary, mg);
4554 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4560 av_unshift(ary, SP - MARK);
4562 SV * const sv = newSVsv(*++MARK);
4563 (void)av_store(ary, i++, sv);
4567 PUSHi( AvFILL(ary) + 1 );
4574 SV ** const oldsp = SP;
4576 if (GIMME == G_ARRAY) {
4579 register SV * const tmp = *MARK;
4583 /* safe as long as stack cannot get extended in the above */
4588 register char *down;
4592 PADOFFSET padoff_du;
4594 SvUTF8_off(TARG); /* decontaminate */
4596 do_join(TARG, &PL_sv_no, MARK, SP);
4598 sv_setsv(TARG, (SP > MARK)
4600 : (padoff_du = find_rundefsvoffset(),
4601 (padoff_du == NOT_IN_PAD
4602 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4603 ? DEFSV : PAD_SVl(padoff_du)));
4604 up = SvPV_force(TARG, len);
4606 if (DO_UTF8(TARG)) { /* first reverse each character */
4607 U8* s = (U8*)SvPVX(TARG);
4608 const U8* send = (U8*)(s + len);
4610 if (UTF8_IS_INVARIANT(*s)) {
4615 if (!utf8_to_uvchr(s, 0))
4619 down = (char*)(s - 1);
4620 /* reverse this character */
4624 *down-- = (char)tmp;
4630 down = SvPVX(TARG) + len - 1;
4634 *down-- = (char)tmp;
4636 (void)SvPOK_only_UTF8(TARG);
4648 register IV limit = POPi; /* note, negative is forever */
4649 SV * const sv = POPs;
4651 register const char *s = SvPV_const(sv, len);
4652 const bool do_utf8 = DO_UTF8(sv);
4653 const char *strend = s + len;
4655 register REGEXP *rx;
4657 register const char *m;
4659 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4660 I32 maxiters = slen + 10;
4662 const I32 origlimit = limit;
4665 const I32 gimme = GIMME_V;
4666 const I32 oldsave = PL_savestack_ix;
4667 I32 make_mortal = 1;
4672 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4677 DIE(aTHX_ "panic: pp_split");
4680 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4681 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4683 RX_MATCH_UTF8_set(rx, do_utf8);
4686 if (pm->op_pmreplrootu.op_pmtargetoff) {
4687 ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4690 if (pm->op_pmreplrootu.op_pmtargetgv) {
4691 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4694 else if (gimme != G_ARRAY)
4695 ary = GvAVn(PL_defgv);
4698 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4704 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4706 XPUSHs(SvTIED_obj((SV*)ary, mg));
4713 for (i = AvFILLp(ary); i >= 0; i--)
4714 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4716 /* temporarily switch stacks */
4717 SAVESWITCHSTACK(PL_curstack, ary);
4721 base = SP - PL_stack_base;
4723 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4725 while (*s == ' ' || is_utf8_space((U8*)s))
4728 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4729 while (isSPACE_LC(*s))
4737 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4742 limit = maxiters + 2;
4743 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4746 /* this one uses 'm' and is a negative test */
4748 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4749 const int t = UTF8SKIP(m);
4750 /* is_utf8_space returns FALSE for malform utf8 */
4756 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4757 while (m < strend && !isSPACE_LC(*m))
4760 while (m < strend && !isSPACE(*m))
4766 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4771 /* skip the whitespace found last */
4773 s = m + UTF8SKIP(m);
4777 /* this one uses 's' and is a positive test */
4779 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4781 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4782 while (s < strend && isSPACE_LC(*s))
4785 while (s < strend && isSPACE(*s))
4790 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4792 for (m = s; m < strend && *m != '\n'; m++)
4797 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4804 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4806 Pre-extend the stack, either the number of bytes or
4807 characters in the string or a limited amount, triggered by:
4809 my ($x, $y) = split //, $str;
4813 const U32 items = limit - 1;
4821 /* keep track of how many bytes we skip over */
4824 dstr = newSVpvn_utf8(m, s-m, TRUE);
4836 dstr = newSVpvn(s, 1);
4850 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4851 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4852 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4853 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4854 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4855 SV * const csv = CALLREG_INTUIT_STRING(rx);
4857 len = RX_MINLENRET(rx);
4858 if (len == 1 && !RX_UTF8(rx) && !tail) {
4859 const char c = *SvPV_nolen_const(csv);
4861 for (m = s; m < strend && *m != c; m++)
4865 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4869 /* The rx->minlen is in characters but we want to step
4870 * s ahead by bytes. */
4872 s = (char*)utf8_hop((U8*)m, len);
4874 s = m + len; /* Fake \n at the end */
4878 while (s < strend && --limit &&
4879 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4880 csv, multiline ? FBMrf_MULTILINE : 0)) )
4882 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4886 /* The rx->minlen is in characters but we want to step
4887 * s ahead by bytes. */
4889 s = (char*)utf8_hop((U8*)m, len);
4891 s = m + len; /* Fake \n at the end */
4896 maxiters += slen * RX_NPARENS(rx);
4897 while (s < strend && --limit)
4901 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4904 if (rex_return == 0)
4906 TAINT_IF(RX_MATCH_TAINTED(rx));
4907 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4910 orig = RX_SUBBEG(rx);
4912 strend = s + (strend - m);
4914 m = RX_OFFS(rx)[0].start + orig;
4915 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4919 if (RX_NPARENS(rx)) {
4921 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4922 s = RX_OFFS(rx)[i].start + orig;
4923 m = RX_OFFS(rx)[i].end + orig;
4925 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4926 parens that didn't match -- they should be set to
4927 undef, not the empty string */
4928 if (m >= orig && s >= orig) {
4929 dstr = newSVpvn_utf8(s, m-s, do_utf8);
4932 dstr = &PL_sv_undef; /* undef, not "" */
4938 s = RX_OFFS(rx)[0].end + orig;
4942 iters = (SP - PL_stack_base) - base;
4943 if (iters > maxiters)
4944 DIE(aTHX_ "Split loop");
4946 /* keep field after final delim? */
4947 if (s < strend || (iters && origlimit)) {
4948 const STRLEN l = strend - s;
4949 dstr = newSVpvn_utf8(s, l, do_utf8);
4955 else if (!origlimit) {
4956 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4957 if (TOPs && !make_mortal)
4960 *SP-- = &PL_sv_undef;
4965 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4969 if (SvSMAGICAL(ary)) {
4974 if (gimme == G_ARRAY) {
4976 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4984 call_method("PUSH",G_SCALAR|G_DISCARD);
4987 if (gimme == G_ARRAY) {
4989 /* EXTEND should not be needed - we just popped them */
4991 for (i=0; i < iters; i++) {
4992 SV **svp = av_fetch(ary, i, FALSE);
4993 PUSHs((svp) ? *svp : &PL_sv_undef);
5000 if (gimme == G_ARRAY)
5012 SV *const sv = PAD_SVl(PL_op->op_targ);
5014 if (SvPADSTALE(sv)) {
5017 RETURNOP(cLOGOP->op_other);
5019 RETURNOP(cLOGOP->op_next);
5029 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5030 || SvTYPE(retsv) == SVt_PVCV) {
5031 retsv = refto(retsv);
5038 PP(unimplemented_op)
5041 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5047 * c-indentation-style: bsd
5049 * indent-tabs-mode: t
5052 * ex: set ts=8 sts=4 sw=4 noet: