3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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(MUTABLE_AV(TARG)) + 1;
80 if (SvMAGICAL(TARG)) {
82 for (i=0; i < (U32)maxarg; i++) {
83 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
84 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
88 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
92 else if (gimme == G_SCALAR) {
93 SV* const sv = sv_newmortal();
94 const I32 maxarg = AvFILL(MUTABLE_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_ MUTABLE_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) = MUTABLE_IO(sv);
143 SvREFCNT_inc_void_NN(sv);
146 else if (!isGV_with_GP(sv))
147 DIE(aTHX_ "Not a GLOB reference");
150 if (!isGV_with_GP(sv)) {
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,
222 const svtype type, SV ***spp)
227 PERL_ARGS_ASSERT_SOFTREF2XV;
229 if (PL_op->op_private & HINT_STRICT_REFS) {
231 Perl_die(aTHX_ PL_no_symref_sv, sv, what);
233 Perl_die(aTHX_ PL_no_usym, what);
236 if (PL_op->op_flags & OPf_REF)
237 Perl_die(aTHX_ PL_no_usym, what);
238 if (ckWARN(WARN_UNINITIALIZED))
240 if (type != SVt_PV && GIMME_V == G_ARRAY) {
244 **spp = &PL_sv_undef;
247 if ((PL_op->op_flags & OPf_SPECIAL) &&
248 !(PL_op->op_flags & OPf_MOD))
250 gv = gv_fetchsv(sv, 0, type);
252 && (!is_gv_magical_sv(sv,0)
253 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
255 **spp = &PL_sv_undef;
260 gv = gv_fetchsv(sv, GV_ADD, type);
272 tryAMAGICunDEREF(to_sv);
275 switch (SvTYPE(sv)) {
281 DIE(aTHX_ "Not a SCALAR reference");
288 if (!isGV_with_GP(gv)) {
289 if (SvGMAGICAL(sv)) {
294 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
300 if (PL_op->op_flags & OPf_MOD) {
301 if (PL_op->op_private & OPpLVAL_INTRO) {
302 if (cUNOP->op_first->op_type == OP_NULL)
303 sv = save_scalar((GV*)TOPs);
305 sv = save_scalar(gv);
307 Perl_croak(aTHX_ PL_no_localize_ref);
309 else if (PL_op->op_private & OPpDEREF)
310 vivify_ref(sv, PL_op->op_private & OPpDEREF);
319 AV * const av = MUTABLE_AV(TOPs);
320 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
322 *sv = newSV_type(SVt_PVMG);
323 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
331 dVAR; dSP; dTARGET; dPOPss;
333 if (PL_op->op_flags & OPf_MOD || LVRET) {
334 if (SvTYPE(TARG) < SVt_PVLV) {
335 sv_upgrade(TARG, SVt_PVLV);
336 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
340 if (LvTARG(TARG) != sv) {
342 SvREFCNT_dec(LvTARG(TARG));
343 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
345 PUSHs(TARG); /* no SvSETMAGIC */
349 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
350 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
351 if (mg && mg->mg_len >= 0) {
355 PUSHi(i + CopARYBASE_get(PL_curcop));
368 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
370 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
373 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
374 /* (But not in defined().) */
376 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
379 cv = MUTABLE_CV(sv_2mortal((SV*)cv_clone(cv)));
380 if ((PL_op->op_private & OPpLVAL_INTRO)) {
381 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
384 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
387 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
391 cv = MUTABLE_CV(&PL_sv_undef);
402 SV *ret = &PL_sv_undef;
404 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
405 const char * s = SvPVX_const(TOPs);
406 if (strnEQ(s, "CORE::", 6)) {
407 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
408 if (code < 0) { /* Overridable. */
409 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
410 int i = 0, n = 0, seen_question = 0, defgv = 0;
412 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
414 if (code == -KEY_chop || code == -KEY_chomp
415 || code == -KEY_exec || code == -KEY_system)
417 if (code == -KEY_mkdir) {
418 ret = newSVpvs_flags("_;$", SVs_TEMP);
421 if (code == -KEY_readpipe) {
422 s = "CORE::backtick";
424 while (i < MAXO) { /* The slow way. */
425 if (strEQ(s + 6, PL_op_name[i])
426 || strEQ(s + 6, PL_op_desc[i]))
432 goto nonesuch; /* Should not happen... */
434 defgv = PL_opargs[i] & OA_DEFGV;
435 oa = PL_opargs[i] >> OASHIFT;
437 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
441 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
442 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
443 /* But globs are already references (kinda) */
444 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
448 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
451 if (defgv && str[n - 1] == '$')
454 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
456 else if (code) /* Non-Overridable */
458 else { /* None such */
460 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
464 cv = sv_2cv(TOPs, &stash, &gv, 0);
466 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
475 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
477 cv = MUTABLE_CV(sv_2mortal((SV*)cv_clone(cv)));
493 if (GIMME != G_ARRAY) {
497 *MARK = &PL_sv_undef;
498 *MARK = refto(*MARK);
502 EXTEND_MORTAL(SP - MARK);
504 *MARK = refto(*MARK);
509 S_refto(pTHX_ SV *sv)
514 PERL_ARGS_ASSERT_REFTO;
516 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
519 if (!(sv = LvTARG(sv)))
522 SvREFCNT_inc_void_NN(sv);
524 else if (SvTYPE(sv) == SVt_PVAV) {
525 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
526 av_reify(MUTABLE_AV(sv));
528 SvREFCNT_inc_void_NN(sv);
530 else if (SvPADTMP(sv) && !IS_PADGV(sv))
534 SvREFCNT_inc_void_NN(sv);
537 sv_upgrade(rv, SVt_IV);
547 SV * const sv = POPs;
552 if (!sv || !SvROK(sv))
555 pv = sv_reftype(SvRV(sv),TRUE);
556 PUSHp(pv, strlen(pv));
566 stash = CopSTASH(PL_curcop);
568 SV * const ssv = POPs;
572 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
573 Perl_croak(aTHX_ "Attempt to bless into a reference");
574 ptr = SvPV_const(ssv,len);
575 if (len == 0 && ckWARN(WARN_MISC))
576 Perl_warner(aTHX_ packWARN(WARN_MISC),
577 "Explicit blessing to '' (assuming package main)");
578 stash = gv_stashpvn(ptr, len, GV_ADD);
581 (void)sv_bless(TOPs, stash);
590 const char * const elem = SvPV_nolen_const(sv);
591 GV * const gv = (GV*)POPs;
596 /* elem will always be NUL terminated. */
597 const char * const second_letter = elem + 1;
600 if (strEQ(second_letter, "RRAY"))
601 tmpRef = (SV*)GvAV(gv);
604 if (strEQ(second_letter, "ODE"))
605 tmpRef = (SV*)GvCVu(gv);
608 if (strEQ(second_letter, "ILEHANDLE")) {
609 /* finally deprecated in 5.8.0 */
610 deprecate("*glob{FILEHANDLE}");
611 tmpRef = (SV*)GvIOp(gv);
614 if (strEQ(second_letter, "ORMAT"))
615 tmpRef = (SV*)GvFORM(gv);
618 if (strEQ(second_letter, "LOB"))
622 if (strEQ(second_letter, "ASH"))
623 tmpRef = (SV*)GvHV(gv);
626 if (*second_letter == 'O' && !elem[2])
627 tmpRef = (SV*)GvIOp(gv);
630 if (strEQ(second_letter, "AME"))
631 sv = newSVhek(GvNAME_HEK(gv));
634 if (strEQ(second_letter, "ACKAGE")) {
635 const HV * const stash = GvSTASH(gv);
636 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
637 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
641 if (strEQ(second_letter, "CALAR"))
656 /* Pattern matching */
661 register unsigned char *s;
664 register I32 *sfirst;
668 if (sv == PL_lastscream) {
672 s = (unsigned char*)(SvPV(sv, len));
674 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
675 /* No point in studying a zero length string, and not safe to study
676 anything that doesn't appear to be a simple scalar (and hence might
677 change between now and when the regexp engine runs without our set
678 magic ever running) such as a reference to an object with overloaded
684 SvSCREAM_off(PL_lastscream);
685 SvREFCNT_dec(PL_lastscream);
687 PL_lastscream = SvREFCNT_inc_simple(sv);
689 s = (unsigned char*)(SvPV(sv, len));
693 if (pos > PL_maxscream) {
694 if (PL_maxscream < 0) {
695 PL_maxscream = pos + 80;
696 Newx(PL_screamfirst, 256, I32);
697 Newx(PL_screamnext, PL_maxscream, I32);
700 PL_maxscream = pos + pos / 4;
701 Renew(PL_screamnext, PL_maxscream, I32);
705 sfirst = PL_screamfirst;
706 snext = PL_screamnext;
708 if (!sfirst || !snext)
709 DIE(aTHX_ "do_study: out of memory");
711 for (ch = 256; ch; --ch)
716 register const I32 ch = s[pos];
718 snext[pos] = sfirst[ch] - pos;
725 /* piggyback on m//g magic */
726 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
735 if (PL_op->op_flags & OPf_STACKED)
737 else if (PL_op->op_private & OPpTARGET_MY)
743 TARG = sv_newmortal();
748 /* Lvalue operators. */
760 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
762 do_chop(TARG, *++MARK);
771 SETi(do_chomp(TOPs));
777 dVAR; dSP; dMARK; dTARGET;
778 register I32 count = 0;
781 count += do_chomp(POPs);
791 if (!PL_op->op_private) {
800 SV_CHECK_THINKFIRST_COW_DROP(sv);
802 switch (SvTYPE(sv)) {
806 av_undef(MUTABLE_AV(sv));
809 hv_undef(MUTABLE_HV(sv));
812 if (cv_const_sv((const CV *)sv) && ckWARN(WARN_MISC))
813 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
814 CvANON((const CV *)sv) ? "(anonymous)"
815 : GvENAME(CvGV((const CV *)sv)));
819 /* let user-undef'd sub keep its identity */
820 GV* const gv = CvGV((const CV *)sv);
821 cv_undef(MUTABLE_CV(sv));
822 CvGV((const CV *)sv) = gv;
827 SvSetMagicSV(sv, &PL_sv_undef);
830 else if (isGV_with_GP(sv)) {
835 if((stash = GvHV((GV*)sv)) && HvNAME_get(stash))
836 mro_isa_changed_in(stash);
837 /* undef *Pkg::meth_name ... */
838 else if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
839 mro_method_changed_in(stash);
843 GvGP(sv) = gp_ref(gp);
845 GvLINE(sv) = CopLINE(PL_curcop);
852 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
867 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
868 DIE(aTHX_ PL_no_modify);
869 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
870 && SvIVX(TOPs) != IV_MIN)
872 SvIV_set(TOPs, SvIVX(TOPs) - 1);
873 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
884 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
885 DIE(aTHX_ PL_no_modify);
886 sv_setsv(TARG, TOPs);
887 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
888 && SvIVX(TOPs) != IV_MAX)
890 SvIV_set(TOPs, SvIVX(TOPs) + 1);
891 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
896 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
906 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
907 DIE(aTHX_ PL_no_modify);
908 sv_setsv(TARG, TOPs);
909 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
910 && SvIVX(TOPs) != IV_MIN)
912 SvIV_set(TOPs, SvIVX(TOPs) - 1);
913 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
922 /* Ordinary operators. */
926 dVAR; dSP; dATARGET; SV *svl, *svr;
927 #ifdef PERL_PRESERVE_IVUV
930 tryAMAGICbin(pow,opASSIGN);
931 svl = sv_2num(TOPm1s);
933 #ifdef PERL_PRESERVE_IVUV
934 /* For integer to integer power, we do the calculation by hand wherever
935 we're sure it is safe; otherwise we call pow() and try to convert to
936 integer afterwards. */
949 const IV iv = SvIVX(svr);
953 goto float_it; /* Can't do negative powers this way. */
957 baseuok = SvUOK(svl);
961 const IV iv = SvIVX(svl);
964 baseuok = TRUE; /* effectively it's a UV now */
966 baseuv = -iv; /* abs, baseuok == false records sign */
969 /* now we have integer ** positive integer. */
972 /* foo & (foo - 1) is zero only for a power of 2. */
973 if (!(baseuv & (baseuv - 1))) {
974 /* We are raising power-of-2 to a positive integer.
975 The logic here will work for any base (even non-integer
976 bases) but it can be less accurate than
977 pow (base,power) or exp (power * log (base)) when the
978 intermediate values start to spill out of the mantissa.
979 With powers of 2 we know this can't happen.
980 And powers of 2 are the favourite thing for perl
981 programmers to notice ** not doing what they mean. */
983 NV base = baseuok ? baseuv : -(NV)baseuv;
988 while (power >>= 1) {
999 register unsigned int highbit = 8 * sizeof(UV);
1000 register unsigned int diff = 8 * sizeof(UV);
1001 while (diff >>= 1) {
1003 if (baseuv >> highbit) {
1007 /* we now have baseuv < 2 ** highbit */
1008 if (power * highbit <= 8 * sizeof(UV)) {
1009 /* result will definitely fit in UV, so use UV math
1010 on same algorithm as above */
1011 register UV result = 1;
1012 register UV base = baseuv;
1013 const bool odd_power = (bool)(power & 1);
1017 while (power >>= 1) {
1024 if (baseuok || !odd_power)
1025 /* answer is positive */
1027 else if (result <= (UV)IV_MAX)
1028 /* answer negative, fits in IV */
1029 SETi( -(IV)result );
1030 else if (result == (UV)IV_MIN)
1031 /* 2's complement assumption: special case IV_MIN */
1034 /* answer negative, doesn't fit */
1035 SETn( -(NV)result );
1045 NV right = SvNV(svr);
1046 NV left = SvNV(svl);
1049 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1051 We are building perl with long double support and are on an AIX OS
1052 afflicted with a powl() function that wrongly returns NaNQ for any
1053 negative base. This was reported to IBM as PMR #23047-379 on
1054 03/06/2006. The problem exists in at least the following versions
1055 of AIX and the libm fileset, and no doubt others as well:
1057 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1058 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1059 AIX 5.2.0 bos.adt.libm 5.2.0.85
1061 So, until IBM fixes powl(), we provide the following workaround to
1062 handle the problem ourselves. Our logic is as follows: for
1063 negative bases (left), we use fmod(right, 2) to check if the
1064 exponent is an odd or even integer:
1066 - if odd, powl(left, right) == -powl(-left, right)
1067 - if even, powl(left, right) == powl(-left, right)
1069 If the exponent is not an integer, the result is rightly NaNQ, so
1070 we just return that (as NV_NAN).
1074 NV mod2 = Perl_fmod( right, 2.0 );
1075 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1076 SETn( -Perl_pow( -left, right) );
1077 } else if (mod2 == 0.0) { /* even integer */
1078 SETn( Perl_pow( -left, right) );
1079 } else { /* fractional power */
1083 SETn( Perl_pow( left, right) );
1086 SETn( Perl_pow( left, right) );
1087 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1089 #ifdef PERL_PRESERVE_IVUV
1099 dVAR; dSP; dATARGET; SV *svl, *svr;
1100 tryAMAGICbin(mult,opASSIGN);
1101 svl = sv_2num(TOPm1s);
1102 svr = sv_2num(TOPs);
1103 #ifdef PERL_PRESERVE_IVUV
1106 /* Unless the left argument is integer in range we are going to have to
1107 use NV maths. Hence only attempt to coerce the right argument if
1108 we know the left is integer. */
1109 /* Left operand is defined, so is it IV? */
1112 bool auvok = SvUOK(svl);
1113 bool buvok = SvUOK(svr);
1114 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1115 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1124 const IV aiv = SvIVX(svl);
1127 auvok = TRUE; /* effectively it's a UV now */
1129 alow = -aiv; /* abs, auvok == false records sign */
1135 const IV biv = SvIVX(svr);
1138 buvok = TRUE; /* effectively it's a UV now */
1140 blow = -biv; /* abs, buvok == false records sign */
1144 /* If this does sign extension on unsigned it's time for plan B */
1145 ahigh = alow >> (4 * sizeof (UV));
1147 bhigh = blow >> (4 * sizeof (UV));
1149 if (ahigh && bhigh) {
1151 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1152 which is overflow. Drop to NVs below. */
1153 } else if (!ahigh && !bhigh) {
1154 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1155 so the unsigned multiply cannot overflow. */
1156 const UV product = alow * blow;
1157 if (auvok == buvok) {
1158 /* -ve * -ve or +ve * +ve gives a +ve result. */
1162 } else if (product <= (UV)IV_MIN) {
1163 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1164 /* -ve result, which could overflow an IV */
1166 SETi( -(IV)product );
1168 } /* else drop to NVs below. */
1170 /* One operand is large, 1 small */
1173 /* swap the operands */
1175 bhigh = blow; /* bhigh now the temp var for the swap */
1179 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1180 multiplies can't overflow. shift can, add can, -ve can. */
1181 product_middle = ahigh * blow;
1182 if (!(product_middle & topmask)) {
1183 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1185 product_middle <<= (4 * sizeof (UV));
1186 product_low = alow * blow;
1188 /* as for pp_add, UV + something mustn't get smaller.
1189 IIRC ANSI mandates this wrapping *behaviour* for
1190 unsigned whatever the actual representation*/
1191 product_low += product_middle;
1192 if (product_low >= product_middle) {
1193 /* didn't overflow */
1194 if (auvok == buvok) {
1195 /* -ve * -ve or +ve * +ve gives a +ve result. */
1197 SETu( product_low );
1199 } else if (product_low <= (UV)IV_MIN) {
1200 /* 2s complement assumption again */
1201 /* -ve result, which could overflow an IV */
1203 SETi( -(IV)product_low );
1205 } /* else drop to NVs below. */
1207 } /* product_middle too large */
1208 } /* ahigh && bhigh */
1213 NV right = SvNV(svr);
1214 NV left = SvNV(svl);
1216 SETn( left * right );
1223 dVAR; dSP; dATARGET; SV *svl, *svr;
1224 tryAMAGICbin(div,opASSIGN);
1225 svl = sv_2num(TOPm1s);
1226 svr = sv_2num(TOPs);
1227 /* Only try to do UV divide first
1228 if ((SLOPPYDIVIDE is true) or
1229 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1231 The assumption is that it is better to use floating point divide
1232 whenever possible, only doing integer divide first if we can't be sure.
1233 If NV_PRESERVES_UV is true then we know at compile time that no UV
1234 can be too large to preserve, so don't need to compile the code to
1235 test the size of UVs. */
1238 # define PERL_TRY_UV_DIVIDE
1239 /* ensure that 20./5. == 4. */
1241 # ifdef PERL_PRESERVE_IVUV
1242 # ifndef NV_PRESERVES_UV
1243 # define PERL_TRY_UV_DIVIDE
1248 #ifdef PERL_TRY_UV_DIVIDE
1253 bool left_non_neg = SvUOK(svl);
1254 bool right_non_neg = SvUOK(svr);
1258 if (right_non_neg) {
1262 const IV biv = SvIVX(svr);
1265 right_non_neg = TRUE; /* effectively it's a UV now */
1271 /* historically undef()/0 gives a "Use of uninitialized value"
1272 warning before dieing, hence this test goes here.
1273 If it were immediately before the second SvIV_please, then
1274 DIE() would be invoked before left was even inspected, so
1275 no inpsection would give no warning. */
1277 DIE(aTHX_ "Illegal division by zero");
1283 const IV aiv = SvIVX(svl);
1286 left_non_neg = TRUE; /* effectively it's a UV now */
1295 /* For sloppy divide we always attempt integer division. */
1297 /* Otherwise we only attempt it if either or both operands
1298 would not be preserved by an NV. If both fit in NVs
1299 we fall through to the NV divide code below. However,
1300 as left >= right to ensure integer result here, we know that
1301 we can skip the test on the right operand - right big
1302 enough not to be preserved can't get here unless left is
1305 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1308 /* Integer division can't overflow, but it can be imprecise. */
1309 const UV result = left / right;
1310 if (result * right == left) {
1311 SP--; /* result is valid */
1312 if (left_non_neg == right_non_neg) {
1313 /* signs identical, result is positive. */
1317 /* 2s complement assumption */
1318 if (result <= (UV)IV_MIN)
1319 SETi( -(IV)result );
1321 /* It's exact but too negative for IV. */
1322 SETn( -(NV)result );
1325 } /* tried integer divide but it was not an integer result */
1326 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1327 } /* left wasn't SvIOK */
1328 } /* right wasn't SvIOK */
1329 #endif /* PERL_TRY_UV_DIVIDE */
1331 NV right = SvNV(svr);
1332 NV left = SvNV(svl);
1333 (void)POPs;(void)POPs;
1334 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1335 if (! Perl_isnan(right) && right == 0.0)
1339 DIE(aTHX_ "Illegal division by zero");
1340 PUSHn( left / right );
1347 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1351 bool left_neg = FALSE;
1352 bool right_neg = FALSE;
1353 bool use_double = FALSE;
1354 bool dright_valid = FALSE;
1358 SV * const svr = sv_2num(TOPs);
1361 right_neg = !SvUOK(svr);
1365 const IV biv = SvIVX(svr);
1368 right_neg = FALSE; /* effectively it's a UV now */
1376 right_neg = dright < 0;
1379 if (dright < UV_MAX_P1) {
1380 right = U_V(dright);
1381 dright_valid = TRUE; /* In case we need to use double below. */
1388 /* At this point use_double is only true if right is out of range for
1389 a UV. In range NV has been rounded down to nearest UV and
1390 use_double false. */
1391 svl = sv_2num(TOPs);
1393 if (!use_double && SvIOK(svl)) {
1395 left_neg = !SvUOK(svl);
1399 const IV aiv = SvIVX(svl);
1402 left_neg = FALSE; /* effectively it's a UV now */
1411 left_neg = dleft < 0;
1415 /* This should be exactly the 5.6 behaviour - if left and right are
1416 both in range for UV then use U_V() rather than floor. */
1418 if (dleft < UV_MAX_P1) {
1419 /* right was in range, so is dleft, so use UVs not double.
1423 /* left is out of range for UV, right was in range, so promote
1424 right (back) to double. */
1426 /* The +0.5 is used in 5.6 even though it is not strictly
1427 consistent with the implicit +0 floor in the U_V()
1428 inside the #if 1. */
1429 dleft = Perl_floor(dleft + 0.5);
1432 dright = Perl_floor(dright + 0.5);
1443 DIE(aTHX_ "Illegal modulus zero");
1445 dans = Perl_fmod(dleft, dright);
1446 if ((left_neg != right_neg) && dans)
1447 dans = dright - dans;
1450 sv_setnv(TARG, dans);
1456 DIE(aTHX_ "Illegal modulus zero");
1459 if ((left_neg != right_neg) && ans)
1462 /* XXX may warn: unary minus operator applied to unsigned type */
1463 /* could change -foo to be (~foo)+1 instead */
1464 if (ans <= ~((UV)IV_MAX)+1)
1465 sv_setiv(TARG, ~ans+1);
1467 sv_setnv(TARG, -(NV)ans);
1470 sv_setuv(TARG, ans);
1479 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1486 const UV uv = SvUV(sv);
1488 count = IV_MAX; /* The best we can do? */
1492 const IV iv = SvIV(sv);
1499 else if (SvNOKp(sv)) {
1500 const NV nv = SvNV(sv);
1508 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1510 static const char oom_list_extend[] = "Out of memory during list extend";
1511 const I32 items = SP - MARK;
1512 const I32 max = items * count;
1514 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1515 /* Did the max computation overflow? */
1516 if (items > 0 && max > 0 && (max < items || max < count))
1517 Perl_croak(aTHX_ oom_list_extend);
1522 /* This code was intended to fix 20010809.028:
1525 for (($x =~ /./g) x 2) {
1526 print chop; # "abcdabcd" expected as output.
1529 * but that change (#11635) broke this code:
1531 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1533 * I can't think of a better fix that doesn't introduce
1534 * an efficiency hit by copying the SVs. The stack isn't
1535 * refcounted, and mortalisation obviously doesn't
1536 * Do The Right Thing when the stack has more than
1537 * one pointer to the same mortal value.
1541 *SP = sv_2mortal(newSVsv(*SP));
1551 repeatcpy((char*)(MARK + items), (char*)MARK,
1552 items * sizeof(SV*), count - 1);
1555 else if (count <= 0)
1558 else { /* Note: mark already snarfed by pp_list */
1559 SV * const tmpstr = POPs;
1562 static const char oom_string_extend[] =
1563 "Out of memory during string extend";
1565 SvSetSV(TARG, tmpstr);
1566 SvPV_force(TARG, len);
1567 isutf = DO_UTF8(TARG);
1572 const STRLEN max = (UV)count * len;
1573 if (len > MEM_SIZE_MAX / count)
1574 Perl_croak(aTHX_ oom_string_extend);
1575 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1576 SvGROW(TARG, max + 1);
1577 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1578 SvCUR_set(TARG, SvCUR(TARG) * count);
1580 *SvEND(TARG) = '\0';
1583 (void)SvPOK_only_UTF8(TARG);
1585 (void)SvPOK_only(TARG);
1587 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1588 /* The parser saw this as a list repeat, and there
1589 are probably several items on the stack. But we're
1590 in scalar context, and there's no pp_list to save us
1591 now. So drop the rest of the items -- robin@kitsite.com
1604 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1605 tryAMAGICbin(subtr,opASSIGN);
1606 svl = sv_2num(TOPm1s);
1607 svr = sv_2num(TOPs);
1608 useleft = USE_LEFT(svl);
1609 #ifdef PERL_PRESERVE_IVUV
1610 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1611 "bad things" happen if you rely on signed integers wrapping. */
1614 /* Unless the left argument is integer in range we are going to have to
1615 use NV maths. Hence only attempt to coerce the right argument if
1616 we know the left is integer. */
1617 register UV auv = 0;
1623 a_valid = auvok = 1;
1624 /* left operand is undef, treat as zero. */
1626 /* Left operand is defined, so is it IV? */
1629 if ((auvok = SvUOK(svl)))
1632 register const IV aiv = SvIVX(svl);
1635 auvok = 1; /* Now acting as a sign flag. */
1636 } else { /* 2s complement assumption for IV_MIN */
1644 bool result_good = 0;
1647 bool buvok = SvUOK(svr);
1652 register const IV biv = SvIVX(svr);
1659 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1660 else "IV" now, independent of how it came in.
1661 if a, b represents positive, A, B negative, a maps to -A etc
1666 all UV maths. negate result if A negative.
1667 subtract if signs same, add if signs differ. */
1669 if (auvok ^ buvok) {
1678 /* Must get smaller */
1683 if (result <= buv) {
1684 /* result really should be -(auv-buv). as its negation
1685 of true value, need to swap our result flag */
1697 if (result <= (UV)IV_MIN)
1698 SETi( -(IV)result );
1700 /* result valid, but out of range for IV. */
1701 SETn( -(NV)result );
1705 } /* Overflow, drop through to NVs. */
1710 NV value = SvNV(svr);
1714 /* left operand is undef, treat as zero - value */
1718 SETn( SvNV(svl) - value );
1725 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1727 const IV shift = POPi;
1728 if (PL_op->op_private & HINT_INTEGER) {
1742 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1744 const IV shift = POPi;
1745 if (PL_op->op_private & HINT_INTEGER) {
1759 dVAR; dSP; tryAMAGICbinSET(lt,0);
1760 #ifdef PERL_PRESERVE_IVUV
1763 SvIV_please(TOPm1s);
1764 if (SvIOK(TOPm1s)) {
1765 bool auvok = SvUOK(TOPm1s);
1766 bool buvok = SvUOK(TOPs);
1768 if (!auvok && !buvok) { /* ## IV < IV ## */
1769 const IV aiv = SvIVX(TOPm1s);
1770 const IV biv = SvIVX(TOPs);
1773 SETs(boolSV(aiv < biv));
1776 if (auvok && buvok) { /* ## UV < UV ## */
1777 const UV auv = SvUVX(TOPm1s);
1778 const UV buv = SvUVX(TOPs);
1781 SETs(boolSV(auv < buv));
1784 if (auvok) { /* ## UV < IV ## */
1786 const IV biv = SvIVX(TOPs);
1789 /* As (a) is a UV, it's >=0, so it cannot be < */
1794 SETs(boolSV(auv < (UV)biv));
1797 { /* ## IV < UV ## */
1798 const IV aiv = SvIVX(TOPm1s);
1802 /* As (b) is a UV, it's >=0, so it must be < */
1809 SETs(boolSV((UV)aiv < buv));
1815 #ifndef NV_PRESERVES_UV
1816 #ifdef PERL_PRESERVE_IVUV
1819 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1821 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1826 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1828 if (Perl_isnan(left) || Perl_isnan(right))
1830 SETs(boolSV(left < right));
1833 SETs(boolSV(TOPn < value));
1841 dVAR; dSP; tryAMAGICbinSET(gt,0);
1842 #ifdef PERL_PRESERVE_IVUV
1845 SvIV_please(TOPm1s);
1846 if (SvIOK(TOPm1s)) {
1847 bool auvok = SvUOK(TOPm1s);
1848 bool buvok = SvUOK(TOPs);
1850 if (!auvok && !buvok) { /* ## IV > IV ## */
1851 const IV aiv = SvIVX(TOPm1s);
1852 const IV biv = SvIVX(TOPs);
1855 SETs(boolSV(aiv > biv));
1858 if (auvok && buvok) { /* ## UV > UV ## */
1859 const UV auv = SvUVX(TOPm1s);
1860 const UV buv = SvUVX(TOPs);
1863 SETs(boolSV(auv > buv));
1866 if (auvok) { /* ## UV > IV ## */
1868 const IV biv = SvIVX(TOPs);
1872 /* As (a) is a UV, it's >=0, so it must be > */
1877 SETs(boolSV(auv > (UV)biv));
1880 { /* ## IV > UV ## */
1881 const IV aiv = SvIVX(TOPm1s);
1885 /* As (b) is a UV, it's >=0, so it cannot be > */
1892 SETs(boolSV((UV)aiv > buv));
1898 #ifndef NV_PRESERVES_UV
1899 #ifdef PERL_PRESERVE_IVUV
1902 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1904 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1909 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1911 if (Perl_isnan(left) || Perl_isnan(right))
1913 SETs(boolSV(left > right));
1916 SETs(boolSV(TOPn > value));
1924 dVAR; dSP; tryAMAGICbinSET(le,0);
1925 #ifdef PERL_PRESERVE_IVUV
1928 SvIV_please(TOPm1s);
1929 if (SvIOK(TOPm1s)) {
1930 bool auvok = SvUOK(TOPm1s);
1931 bool buvok = SvUOK(TOPs);
1933 if (!auvok && !buvok) { /* ## IV <= IV ## */
1934 const IV aiv = SvIVX(TOPm1s);
1935 const IV biv = SvIVX(TOPs);
1938 SETs(boolSV(aiv <= biv));
1941 if (auvok && buvok) { /* ## UV <= UV ## */
1942 UV auv = SvUVX(TOPm1s);
1943 UV buv = SvUVX(TOPs);
1946 SETs(boolSV(auv <= buv));
1949 if (auvok) { /* ## UV <= IV ## */
1951 const IV biv = SvIVX(TOPs);
1955 /* As (a) is a UV, it's >=0, so a cannot be <= */
1960 SETs(boolSV(auv <= (UV)biv));
1963 { /* ## IV <= UV ## */
1964 const IV aiv = SvIVX(TOPm1s);
1968 /* As (b) is a UV, it's >=0, so a must be <= */
1975 SETs(boolSV((UV)aiv <= buv));
1981 #ifndef NV_PRESERVES_UV
1982 #ifdef PERL_PRESERVE_IVUV
1985 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1987 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1992 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1994 if (Perl_isnan(left) || Perl_isnan(right))
1996 SETs(boolSV(left <= right));
1999 SETs(boolSV(TOPn <= value));
2007 dVAR; dSP; tryAMAGICbinSET(ge,0);
2008 #ifdef PERL_PRESERVE_IVUV
2011 SvIV_please(TOPm1s);
2012 if (SvIOK(TOPm1s)) {
2013 bool auvok = SvUOK(TOPm1s);
2014 bool buvok = SvUOK(TOPs);
2016 if (!auvok && !buvok) { /* ## IV >= IV ## */
2017 const IV aiv = SvIVX(TOPm1s);
2018 const IV biv = SvIVX(TOPs);
2021 SETs(boolSV(aiv >= biv));
2024 if (auvok && buvok) { /* ## UV >= UV ## */
2025 const UV auv = SvUVX(TOPm1s);
2026 const UV buv = SvUVX(TOPs);
2029 SETs(boolSV(auv >= buv));
2032 if (auvok) { /* ## UV >= IV ## */
2034 const IV biv = SvIVX(TOPs);
2038 /* As (a) is a UV, it's >=0, so it must be >= */
2043 SETs(boolSV(auv >= (UV)biv));
2046 { /* ## IV >= UV ## */
2047 const IV aiv = SvIVX(TOPm1s);
2051 /* As (b) is a UV, it's >=0, so a cannot be >= */
2058 SETs(boolSV((UV)aiv >= buv));
2064 #ifndef NV_PRESERVES_UV
2065 #ifdef PERL_PRESERVE_IVUV
2068 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2070 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2075 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2077 if (Perl_isnan(left) || Perl_isnan(right))
2079 SETs(boolSV(left >= right));
2082 SETs(boolSV(TOPn >= value));
2090 dVAR; dSP; tryAMAGICbinSET(ne,0);
2091 #ifndef NV_PRESERVES_UV
2092 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2094 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2098 #ifdef PERL_PRESERVE_IVUV
2101 SvIV_please(TOPm1s);
2102 if (SvIOK(TOPm1s)) {
2103 const bool auvok = SvUOK(TOPm1s);
2104 const bool buvok = SvUOK(TOPs);
2106 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2107 /* Casting IV to UV before comparison isn't going to matter
2108 on 2s complement. On 1s complement or sign&magnitude
2109 (if we have any of them) it could make negative zero
2110 differ from normal zero. As I understand it. (Need to
2111 check - is negative zero implementation defined behaviour
2113 const UV buv = SvUVX(POPs);
2114 const UV auv = SvUVX(TOPs);
2116 SETs(boolSV(auv != buv));
2119 { /* ## Mixed IV,UV ## */
2123 /* != is commutative so swap if needed (save code) */
2125 /* swap. top of stack (b) is the iv */
2129 /* As (a) is a UV, it's >0, so it cannot be == */
2138 /* As (b) is a UV, it's >0, so it cannot be == */
2142 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2144 SETs(boolSV((UV)iv != uv));
2151 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2153 if (Perl_isnan(left) || Perl_isnan(right))
2155 SETs(boolSV(left != right));
2158 SETs(boolSV(TOPn != value));
2166 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2167 #ifndef NV_PRESERVES_UV
2168 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2169 const UV right = PTR2UV(SvRV(POPs));
2170 const UV left = PTR2UV(SvRV(TOPs));
2171 SETi((left > right) - (left < right));
2175 #ifdef PERL_PRESERVE_IVUV
2176 /* Fortunately it seems NaN isn't IOK */
2179 SvIV_please(TOPm1s);
2180 if (SvIOK(TOPm1s)) {
2181 const bool leftuvok = SvUOK(TOPm1s);
2182 const bool rightuvok = SvUOK(TOPs);
2184 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2185 const IV leftiv = SvIVX(TOPm1s);
2186 const IV rightiv = SvIVX(TOPs);
2188 if (leftiv > rightiv)
2190 else if (leftiv < rightiv)
2194 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2195 const UV leftuv = SvUVX(TOPm1s);
2196 const UV rightuv = SvUVX(TOPs);
2198 if (leftuv > rightuv)
2200 else if (leftuv < rightuv)
2204 } else if (leftuvok) { /* ## UV <=> IV ## */
2205 const IV rightiv = SvIVX(TOPs);
2207 /* As (a) is a UV, it's >=0, so it cannot be < */
2210 const UV leftuv = SvUVX(TOPm1s);
2211 if (leftuv > (UV)rightiv) {
2213 } else if (leftuv < (UV)rightiv) {
2219 } else { /* ## IV <=> UV ## */
2220 const IV leftiv = SvIVX(TOPm1s);
2222 /* As (b) is a UV, it's >=0, so it must be < */
2225 const UV rightuv = SvUVX(TOPs);
2226 if ((UV)leftiv > rightuv) {
2228 } else if ((UV)leftiv < rightuv) {
2246 if (Perl_isnan(left) || Perl_isnan(right)) {
2250 value = (left > right) - (left < right);
2254 else if (left < right)
2256 else if (left > right)
2272 int amg_type = sle_amg;
2276 switch (PL_op->op_type) {
2295 tryAMAGICbinSET_var(amg_type,0);
2298 const int cmp = (IN_LOCALE_RUNTIME
2299 ? sv_cmp_locale(left, right)
2300 : sv_cmp(left, right));
2301 SETs(boolSV(cmp * multiplier < rhs));
2308 dVAR; dSP; tryAMAGICbinSET(seq,0);
2311 SETs(boolSV(sv_eq(left, right)));
2318 dVAR; dSP; tryAMAGICbinSET(sne,0);
2321 SETs(boolSV(!sv_eq(left, right)));
2328 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2331 const int cmp = (IN_LOCALE_RUNTIME
2332 ? sv_cmp_locale(left, right)
2333 : sv_cmp(left, right));
2341 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2346 if (SvNIOKp(left) || SvNIOKp(right)) {
2347 if (PL_op->op_private & HINT_INTEGER) {
2348 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2352 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2357 do_vop(PL_op->op_type, TARG, left, right);
2366 dVAR; dSP; dATARGET;
2367 const int op_type = PL_op->op_type;
2369 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2374 if (SvNIOKp(left) || SvNIOKp(right)) {
2375 if (PL_op->op_private & HINT_INTEGER) {
2376 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2377 const IV r = SvIV_nomg(right);
2378 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2382 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2383 const UV r = SvUV_nomg(right);
2384 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2389 do_vop(op_type, TARG, left, right);
2398 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2400 SV * const sv = sv_2num(TOPs);
2401 const int flags = SvFLAGS(sv);
2403 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2404 /* It's publicly an integer, or privately an integer-not-float */
2407 if (SvIVX(sv) == IV_MIN) {
2408 /* 2s complement assumption. */
2409 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2412 else if (SvUVX(sv) <= IV_MAX) {
2417 else if (SvIVX(sv) != IV_MIN) {
2421 #ifdef PERL_PRESERVE_IVUV
2430 else if (SvPOKp(sv)) {
2432 const char * const s = SvPV_const(sv, len);
2433 if (isIDFIRST(*s)) {
2434 sv_setpvs(TARG, "-");
2437 else if (*s == '+' || *s == '-') {
2439 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2441 else if (DO_UTF8(sv)) {
2444 goto oops_its_an_int;
2446 sv_setnv(TARG, -SvNV(sv));
2448 sv_setpvs(TARG, "-");
2455 goto oops_its_an_int;
2456 sv_setnv(TARG, -SvNV(sv));
2468 dVAR; dSP; tryAMAGICunSET(not);
2469 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2475 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2480 if (PL_op->op_private & HINT_INTEGER) {
2481 const IV i = ~SvIV_nomg(sv);
2485 const UV u = ~SvUV_nomg(sv);
2494 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2495 sv_setsv_nomg(TARG, sv);
2496 tmps = (U8*)SvPV_force(TARG, len);
2499 /* Calculate exact length, let's not estimate. */
2504 U8 * const send = tmps + len;
2505 U8 * const origtmps = tmps;
2506 const UV utf8flags = UTF8_ALLOW_ANYUV;
2508 while (tmps < send) {
2509 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2511 targlen += UNISKIP(~c);
2517 /* Now rewind strings and write them. */
2524 Newx(result, targlen + 1, U8);
2526 while (tmps < send) {
2527 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2529 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2532 sv_usepvn_flags(TARG, (char*)result, targlen,
2533 SV_HAS_TRAILING_NUL);
2540 Newx(result, nchar + 1, U8);
2542 while (tmps < send) {
2543 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2548 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2556 register long *tmpl;
2557 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2560 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2565 for ( ; anum > 0; anum--, tmps++)
2574 /* integer versions of some of the above */
2578 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2581 SETi( left * right );
2589 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2593 DIE(aTHX_ "Illegal division by zero");
2596 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2600 value = num / value;
2606 #if defined(__GLIBC__) && IVSIZE == 8
2613 /* This is the vanilla old i_modulo. */
2614 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2618 DIE(aTHX_ "Illegal modulus zero");
2619 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2623 SETi( left % right );
2628 #if defined(__GLIBC__) && IVSIZE == 8
2633 /* This is the i_modulo with the workaround for the _moddi3 bug
2634 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2635 * See below for pp_i_modulo. */
2636 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2640 DIE(aTHX_ "Illegal modulus zero");
2641 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2645 SETi( left % PERL_ABS(right) );
2652 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2656 DIE(aTHX_ "Illegal modulus zero");
2657 /* The assumption is to use hereafter the old vanilla version... */
2659 PL_ppaddr[OP_I_MODULO] =
2661 /* .. but if we have glibc, we might have a buggy _moddi3
2662 * (at least glicb 2.2.5 is known to have this bug), in other
2663 * words our integer modulus with negative quad as the second
2664 * argument might be broken. Test for this and re-patch the
2665 * opcode dispatch table if that is the case, remembering to
2666 * also apply the workaround so that this first round works
2667 * right, too. See [perl #9402] for more information. */
2671 /* Cannot do this check with inlined IV constants since
2672 * that seems to work correctly even with the buggy glibc. */
2674 /* Yikes, we have the bug.
2675 * Patch in the workaround version. */
2677 PL_ppaddr[OP_I_MODULO] =
2678 &Perl_pp_i_modulo_1;
2679 /* Make certain we work right this time, too. */
2680 right = PERL_ABS(right);
2683 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2687 SETi( left % right );
2695 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2698 SETi( left + right );
2705 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2708 SETi( left - right );
2715 dVAR; dSP; tryAMAGICbinSET(lt,0);
2718 SETs(boolSV(left < right));
2725 dVAR; dSP; tryAMAGICbinSET(gt,0);
2728 SETs(boolSV(left > right));
2735 dVAR; dSP; tryAMAGICbinSET(le,0);
2738 SETs(boolSV(left <= right));
2745 dVAR; dSP; tryAMAGICbinSET(ge,0);
2748 SETs(boolSV(left >= right));
2755 dVAR; dSP; tryAMAGICbinSET(eq,0);
2758 SETs(boolSV(left == right));
2765 dVAR; dSP; tryAMAGICbinSET(ne,0);
2768 SETs(boolSV(left != right));
2775 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2782 else if (left < right)
2793 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2798 /* High falutin' math. */
2802 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2805 SETn(Perl_atan2(left, right));
2813 int amg_type = sin_amg;
2814 const char *neg_report = NULL;
2815 NV (*func)(NV) = Perl_sin;
2816 const int op_type = PL_op->op_type;
2833 amg_type = sqrt_amg;
2835 neg_report = "sqrt";
2839 tryAMAGICun_var(amg_type);
2841 const NV value = POPn;
2843 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2844 SET_NUMERIC_STANDARD();
2845 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2848 XPUSHn(func(value));
2853 /* Support Configure command-line overrides for rand() functions.
2854 After 5.005, perhaps we should replace this by Configure support
2855 for drand48(), random(), or rand(). For 5.005, though, maintain
2856 compatibility by calling rand() but allow the user to override it.
2857 See INSTALL for details. --Andy Dougherty 15 July 1998
2859 /* Now it's after 5.005, and Configure supports drand48() and random(),
2860 in addition to rand(). So the overrides should not be needed any more.
2861 --Jarkko Hietaniemi 27 September 1998
2864 #ifndef HAS_DRAND48_PROTO
2865 extern double drand48 (void);
2878 if (!PL_srand_called) {
2879 (void)seedDrand01((Rand_seed_t)seed());
2880 PL_srand_called = TRUE;
2890 const UV anum = (MAXARG < 1) ? seed() : POPu;
2891 (void)seedDrand01((Rand_seed_t)anum);
2892 PL_srand_called = TRUE;
2899 dVAR; dSP; dTARGET; tryAMAGICun(int);
2901 SV * const sv = sv_2num(TOPs);
2902 const IV iv = SvIV(sv);
2903 /* XXX it's arguable that compiler casting to IV might be subtly
2904 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2905 else preferring IV has introduced a subtle behaviour change bug. OTOH
2906 relying on floating point to be accurate is a bug. */
2911 else if (SvIOK(sv)) {
2918 const NV value = SvNV(sv);
2920 if (value < (NV)UV_MAX + 0.5) {
2923 SETn(Perl_floor(value));
2927 if (value > (NV)IV_MIN - 0.5) {
2930 SETn(Perl_ceil(value));
2940 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2942 SV * const sv = sv_2num(TOPs);
2943 /* This will cache the NV value if string isn't actually integer */
2944 const IV iv = SvIV(sv);
2949 else if (SvIOK(sv)) {
2950 /* IVX is precise */
2952 SETu(SvUV(sv)); /* force it to be numeric only */
2960 /* 2s complement assumption. Also, not really needed as
2961 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2967 const NV value = SvNV(sv);
2981 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2985 SV* const sv = POPs;
2987 tmps = (SvPV_const(sv, len));
2989 /* If Unicode, try to downgrade
2990 * If not possible, croak. */
2991 SV* const tsv = sv_2mortal(newSVsv(sv));
2994 sv_utf8_downgrade(tsv, FALSE);
2995 tmps = SvPV_const(tsv, len);
2997 if (PL_op->op_type == OP_HEX)
3000 while (*tmps && len && isSPACE(*tmps))
3006 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3008 else if (*tmps == 'b')
3009 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3011 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3013 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3027 SV * const sv = TOPs;
3029 if (SvGAMAGIC(sv)) {
3030 /* For an overloaded or magic scalar, we can't know in advance if
3031 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3032 it likes to cache the length. Maybe that should be a documented
3037 = sv_2pv_flags(sv, &len,
3038 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3042 else if (DO_UTF8(sv)) {
3043 SETi(utf8_length((U8*)p, (U8*)p + len));
3047 } else if (SvOK(sv)) {
3048 /* Neither magic nor overloaded. */
3050 SETi(sv_len_utf8(sv));
3069 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3071 const I32 arybase = CopARYBASE_get(PL_curcop);
3073 const char *repl = NULL;
3075 const int num_args = PL_op->op_private & 7;
3076 bool repl_need_utf8_upgrade = FALSE;
3077 bool repl_is_utf8 = FALSE;
3079 SvTAINTED_off(TARG); /* decontaminate */
3080 SvUTF8_off(TARG); /* decontaminate */
3084 repl = SvPV_const(repl_sv, repl_len);
3085 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3095 sv_utf8_upgrade(sv);
3097 else if (DO_UTF8(sv))
3098 repl_need_utf8_upgrade = TRUE;
3100 tmps = SvPV_const(sv, curlen);
3102 utf8_curlen = sv_len_utf8(sv);
3103 if (utf8_curlen == curlen)
3106 curlen = utf8_curlen;
3111 if (pos >= arybase) {
3129 else if (len >= 0) {
3131 if (rem > (I32)curlen)
3146 Perl_croak(aTHX_ "substr outside of string");
3147 if (ckWARN(WARN_SUBSTR))
3148 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3152 const I32 upos = pos;
3153 const I32 urem = rem;
3155 sv_pos_u2b(sv, &pos, &rem);
3157 /* we either return a PV or an LV. If the TARG hasn't been used
3158 * before, or is of that type, reuse it; otherwise use a mortal
3159 * instead. Note that LVs can have an extended lifetime, so also
3160 * dont reuse if refcount > 1 (bug #20933) */
3161 if (SvTYPE(TARG) > SVt_NULL) {
3162 if ( (SvTYPE(TARG) == SVt_PVLV)
3163 ? (!lvalue || SvREFCNT(TARG) > 1)
3166 TARG = sv_newmortal();
3170 sv_setpvn(TARG, tmps, rem);
3171 #ifdef USE_LOCALE_COLLATE
3172 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3177 SV* repl_sv_copy = NULL;
3179 if (repl_need_utf8_upgrade) {
3180 repl_sv_copy = newSVsv(repl_sv);
3181 sv_utf8_upgrade(repl_sv_copy);
3182 repl = SvPV_const(repl_sv_copy, repl_len);
3183 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3187 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3191 SvREFCNT_dec(repl_sv_copy);
3193 else if (lvalue) { /* it's an lvalue! */
3194 if (!SvGMAGICAL(sv)) {
3196 SvPV_force_nolen(sv);
3197 if (ckWARN(WARN_SUBSTR))
3198 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3199 "Attempt to use reference as lvalue in substr");
3201 if (isGV_with_GP(sv))
3202 SvPV_force_nolen(sv);
3203 else if (SvOK(sv)) /* is it defined ? */
3204 (void)SvPOK_only_UTF8(sv);
3206 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3209 if (SvTYPE(TARG) < SVt_PVLV) {
3210 sv_upgrade(TARG, SVt_PVLV);
3211 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3215 if (LvTARG(TARG) != sv) {
3217 SvREFCNT_dec(LvTARG(TARG));
3218 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3220 LvTARGOFF(TARG) = upos;
3221 LvTARGLEN(TARG) = urem;
3225 PUSHs(TARG); /* avoid SvSETMAGIC here */
3232 register const IV size = POPi;
3233 register const IV offset = POPi;
3234 register SV * const src = POPs;
3235 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3237 SvTAINTED_off(TARG); /* decontaminate */
3238 if (lvalue) { /* it's an lvalue! */
3239 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3240 TARG = sv_newmortal();
3241 if (SvTYPE(TARG) < SVt_PVLV) {
3242 sv_upgrade(TARG, SVt_PVLV);
3243 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3246 if (LvTARG(TARG) != src) {
3248 SvREFCNT_dec(LvTARG(TARG));
3249 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3251 LvTARGOFF(TARG) = offset;
3252 LvTARGLEN(TARG) = size;
3255 sv_setuv(TARG, do_vecget(src, offset, size));
3271 const char *little_p;
3272 const I32 arybase = CopARYBASE_get(PL_curcop);
3275 const bool is_index = PL_op->op_type == OP_INDEX;
3278 /* arybase is in characters, like offset, so combine prior to the
3279 UTF-8 to bytes calculation. */
3280 offset = POPi - arybase;
3284 big_p = SvPV_const(big, biglen);
3285 little_p = SvPV_const(little, llen);
3287 big_utf8 = DO_UTF8(big);
3288 little_utf8 = DO_UTF8(little);
3289 if (big_utf8 ^ little_utf8) {
3290 /* One needs to be upgraded. */
3291 if (little_utf8 && !PL_encoding) {
3292 /* Well, maybe instead we might be able to downgrade the small
3294 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3297 /* If the large string is ISO-8859-1, and it's not possible to
3298 convert the small string to ISO-8859-1, then there is no
3299 way that it could be found anywhere by index. */
3304 /* At this point, pv is a malloc()ed string. So donate it to temp
3305 to ensure it will get free()d */
3306 little = temp = newSV(0);
3307 sv_usepvn(temp, pv, llen);
3308 little_p = SvPVX(little);
3311 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3314 sv_recode_to_utf8(temp, PL_encoding);
3316 sv_utf8_upgrade(temp);
3321 big_p = SvPV_const(big, biglen);
3324 little_p = SvPV_const(little, llen);
3328 if (SvGAMAGIC(big)) {
3329 /* Life just becomes a lot easier if I use a temporary here.
3330 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3331 will trigger magic and overloading again, as will fbm_instr()
3333 big = newSVpvn_flags(big_p, biglen,
3334 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3337 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3338 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3339 warn on undef, and we've already triggered a warning with the
3340 SvPV_const some lines above. We can't remove that, as we need to
3341 call some SvPV to trigger overloading early and find out if the
3343 This is all getting to messy. The API isn't quite clean enough,
3344 because data access has side effects.
3346 little = newSVpvn_flags(little_p, llen,
3347 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3348 little_p = SvPVX(little);
3352 offset = is_index ? 0 : biglen;
3354 if (big_utf8 && offset > 0)
3355 sv_pos_u2b(big, &offset, 0);
3361 else if (offset > (I32)biglen)
3363 if (!(little_p = is_index
3364 ? fbm_instr((unsigned char*)big_p + offset,
3365 (unsigned char*)big_p + biglen, little, 0)
3366 : rninstr(big_p, big_p + offset,
3367 little_p, little_p + llen)))
3370 retval = little_p - big_p;
3371 if (retval > 0 && big_utf8)
3372 sv_pos_b2u(big, &retval);
3377 PUSHi(retval + arybase);
3383 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3384 if (SvTAINTED(MARK[1]))
3385 TAINT_PROPER("sprintf");
3386 do_sprintf(TARG, SP-MARK, MARK+1);
3387 TAINT_IF(SvTAINTED(TARG));
3399 const U8 *s = (U8*)SvPV_const(argsv, len);
3401 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3402 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3403 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3407 XPUSHu(DO_UTF8(argsv) ?
3408 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3420 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3422 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3424 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3426 (void) POPs; /* Ignore the argument value. */
3427 value = UNICODE_REPLACEMENT;
3433 SvUPGRADE(TARG,SVt_PV);
3435 if (value > 255 && !IN_BYTES) {
3436 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3437 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3438 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3440 (void)SvPOK_only(TARG);
3449 *tmps++ = (char)value;
3451 (void)SvPOK_only(TARG);
3453 if (PL_encoding && !IN_BYTES) {
3454 sv_recode_to_utf8(TARG, PL_encoding);
3456 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3457 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3461 *tmps++ = (char)value;
3477 const char *tmps = SvPV_const(left, len);
3479 if (DO_UTF8(left)) {
3480 /* If Unicode, try to downgrade.
3481 * If not possible, croak.
3482 * Yes, we made this up. */
3483 SV* const tsv = sv_2mortal(newSVsv(left));
3486 sv_utf8_downgrade(tsv, FALSE);
3487 tmps = SvPV_const(tsv, len);
3489 # ifdef USE_ITHREADS
3491 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3492 /* This should be threadsafe because in ithreads there is only
3493 * one thread per interpreter. If this would not be true,
3494 * we would need a mutex to protect this malloc. */
3495 PL_reentrant_buffer->_crypt_struct_buffer =
3496 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3497 #if defined(__GLIBC__) || defined(__EMX__)
3498 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3499 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3500 /* work around glibc-2.2.5 bug */
3501 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3505 # endif /* HAS_CRYPT_R */
3506 # endif /* USE_ITHREADS */
3508 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3510 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3516 "The crypt() function is unimplemented due to excessive paranoia.");
3528 bool inplace = TRUE;
3530 const int op_type = PL_op->op_type;
3533 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3539 s = (const U8*)SvPV_nomg_const(source, slen);
3541 if (ckWARN(WARN_UNINITIALIZED))
3542 report_uninit(source);
3547 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3549 utf8_to_uvchr(s, &ulen);
3550 if (op_type == OP_UCFIRST) {
3551 toTITLE_utf8(s, tmpbuf, &tculen);
3553 toLOWER_utf8(s, tmpbuf, &tculen);
3555 /* If the two differ, we definately cannot do inplace. */
3556 inplace = (ulen == tculen);
3557 need = slen + 1 - ulen + tculen;
3563 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3564 /* We can convert in place. */
3567 s = d = (U8*)SvPV_force_nomg(source, slen);
3573 SvUPGRADE(dest, SVt_PV);
3574 d = (U8*)SvGROW(dest, need);
3575 (void)SvPOK_only(dest);
3584 /* slen is the byte length of the whole SV.
3585 * ulen is the byte length of the original Unicode character
3586 * stored as UTF-8 at s.
3587 * tculen is the byte length of the freshly titlecased (or
3588 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3589 * We first set the result to be the titlecased (/lowercased)
3590 * character, and then append the rest of the SV data. */
3591 sv_setpvn(dest, (char*)tmpbuf, tculen);
3593 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3597 Copy(tmpbuf, d, tculen, U8);
3598 SvCUR_set(dest, need - 1);
3603 if (IN_LOCALE_RUNTIME) {
3606 *d = (op_type == OP_UCFIRST)
3607 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3610 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3612 /* See bug #39028 */
3620 /* This will copy the trailing NUL */
3621 Copy(s + 1, d + 1, slen, U8);
3622 SvCUR_set(dest, need - 1);
3629 /* There's so much setup/teardown code common between uc and lc, I wonder if
3630 it would be worth merging the two, and just having a switch outside each
3631 of the three tight loops. */
3645 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3646 && SvTEMP(source) && !DO_UTF8(source)) {
3647 /* We can convert in place. */
3650 s = d = (U8*)SvPV_force_nomg(source, len);
3657 /* The old implementation would copy source into TARG at this point.
3658 This had the side effect that if source was undef, TARG was now
3659 an undefined SV with PADTMP set, and they don't warn inside
3660 sv_2pv_flags(). However, we're now getting the PV direct from
3661 source, which doesn't have PADTMP set, so it would warn. Hence the
3665 s = (const U8*)SvPV_nomg_const(source, len);
3667 if (ckWARN(WARN_UNINITIALIZED))
3668 report_uninit(source);
3674 SvUPGRADE(dest, SVt_PV);
3675 d = (U8*)SvGROW(dest, min);
3676 (void)SvPOK_only(dest);
3681 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3682 to check DO_UTF8 again here. */
3684 if (DO_UTF8(source)) {
3685 const U8 *const send = s + len;
3686 U8 tmpbuf[UTF8_MAXBYTES+1];
3689 const STRLEN u = UTF8SKIP(s);
3692 toUPPER_utf8(s, tmpbuf, &ulen);
3693 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3694 /* If the eventually required minimum size outgrows
3695 * the available space, we need to grow. */
3696 const UV o = d - (U8*)SvPVX_const(dest);
3698 /* If someone uppercases one million U+03B0s we SvGROW() one
3699 * million times. Or we could try guessing how much to
3700 allocate without allocating too much. Such is life. */
3702 d = (U8*)SvPVX(dest) + o;
3704 Copy(tmpbuf, d, ulen, U8);
3710 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3713 const U8 *const send = s + len;
3714 if (IN_LOCALE_RUNTIME) {
3717 for (; s < send; d++, s++)
3718 *d = toUPPER_LC(*s);
3721 for (; s < send; d++, s++)
3725 if (source != dest) {
3727 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3747 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3748 && SvTEMP(source) && !DO_UTF8(source)) {
3749 /* We can convert in place. */
3752 s = d = (U8*)SvPV_force_nomg(source, len);
3759 /* The old implementation would copy source into TARG at this point.
3760 This had the side effect that if source was undef, TARG was now
3761 an undefined SV with PADTMP set, and they don't warn inside
3762 sv_2pv_flags(). However, we're now getting the PV direct from
3763 source, which doesn't have PADTMP set, so it would warn. Hence the
3767 s = (const U8*)SvPV_nomg_const(source, len);
3769 if (ckWARN(WARN_UNINITIALIZED))
3770 report_uninit(source);
3776 SvUPGRADE(dest, SVt_PV);
3777 d = (U8*)SvGROW(dest, min);
3778 (void)SvPOK_only(dest);
3783 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3784 to check DO_UTF8 again here. */
3786 if (DO_UTF8(source)) {
3787 const U8 *const send = s + len;
3788 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3791 const STRLEN u = UTF8SKIP(s);
3793 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3795 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3796 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3799 * Now if the sigma is NOT followed by
3800 * /$ignorable_sequence$cased_letter/;
3801 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3802 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3803 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3804 * then it should be mapped to 0x03C2,
3805 * (GREEK SMALL LETTER FINAL SIGMA),
3806 * instead of staying 0x03A3.
3807 * "should be": in other words, this is not implemented yet.
3808 * See lib/unicore/SpecialCasing.txt.
3811 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3812 /* If the eventually required minimum size outgrows
3813 * the available space, we need to grow. */
3814 const UV o = d - (U8*)SvPVX_const(dest);
3816 /* If someone lowercases one million U+0130s we SvGROW() one
3817 * million times. Or we could try guessing how much to
3818 allocate without allocating too much. Such is life. */
3820 d = (U8*)SvPVX(dest) + o;
3822 Copy(tmpbuf, d, ulen, U8);
3828 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3831 const U8 *const send = s + len;
3832 if (IN_LOCALE_RUNTIME) {
3835 for (; s < send; d++, s++)
3836 *d = toLOWER_LC(*s);
3839 for (; s < send; d++, s++)
3843 if (source != dest) {
3845 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3855 SV * const sv = TOPs;
3857 register const char *s = SvPV_const(sv,len);
3859 SvUTF8_off(TARG); /* decontaminate */
3862 SvUPGRADE(TARG, SVt_PV);
3863 SvGROW(TARG, (len * 2) + 1);
3867 if (UTF8_IS_CONTINUED(*s)) {
3868 STRLEN ulen = UTF8SKIP(s);
3892 SvCUR_set(TARG, d - SvPVX_const(TARG));
3893 (void)SvPOK_only_UTF8(TARG);
3896 sv_setpvn(TARG, s, len);
3898 if (SvSMAGICAL(TARG))
3907 dVAR; dSP; dMARK; dORIGMARK;
3908 register AV *const av = MUTABLE_AV(POPs);
3909 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3911 if (SvTYPE(av) == SVt_PVAV) {
3912 const I32 arybase = CopARYBASE_get(PL_curcop);
3913 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3916 for (svp = MARK + 1; svp <= SP; svp++) {
3917 const I32 elem = SvIV(*svp);
3921 if (max > AvMAX(av))
3924 while (++MARK <= SP) {
3926 I32 elem = SvIV(*MARK);
3930 svp = av_fetch(av, elem, lval);
3932 if (!svp || *svp == &PL_sv_undef)
3933 DIE(aTHX_ PL_no_aelem, elem);
3934 if (PL_op->op_private & OPpLVAL_INTRO)
3935 save_aelem(av, elem, svp);
3937 *MARK = svp ? *svp : &PL_sv_undef;
3940 if (GIMME != G_ARRAY) {
3942 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3952 AV *array = MUTABLE_AV(POPs);
3953 const I32 gimme = GIMME_V;
3954 IV *iterp = Perl_av_iter_p(aTHX_ array);
3955 const IV current = (*iterp)++;
3957 if (current > av_len(array)) {
3959 if (gimme == G_SCALAR)
3966 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3967 if (gimme == G_ARRAY) {
3968 SV **const element = av_fetch(array, current, 0);
3969 PUSHs(element ? *element : &PL_sv_undef);
3978 AV *array = MUTABLE_AV(POPs);
3979 const I32 gimme = GIMME_V;
3981 *Perl_av_iter_p(aTHX_ array) = 0;
3983 if (gimme == G_SCALAR) {
3985 PUSHi(av_len(array) + 1);
3987 else if (gimme == G_ARRAY) {
3988 IV n = Perl_av_len(aTHX_ array);
3989 IV i = CopARYBASE_get(PL_curcop);
3993 if (PL_op->op_type == OP_AKEYS) {
3995 for (; i <= n; i++) {
4000 for (i = 0; i <= n; i++) {
4001 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4002 PUSHs(elem ? *elem : &PL_sv_undef);
4009 /* Associative arrays. */
4015 HV * hash = MUTABLE_HV(POPs);
4017 const I32 gimme = GIMME_V;
4020 /* might clobber stack_sp */
4021 entry = hv_iternext(hash);
4026 SV* const sv = hv_iterkeysv(entry);
4027 PUSHs(sv); /* won't clobber stack_sp */
4028 if (gimme == G_ARRAY) {
4031 /* might clobber stack_sp */
4032 val = hv_iterval(hash, entry);
4037 else if (gimme == G_SCALAR)
4047 const I32 gimme = GIMME_V;
4048 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4050 if (PL_op->op_private & OPpSLICE) {
4052 HV * const hv = MUTABLE_HV(POPs);
4053 const U32 hvtype = SvTYPE(hv);
4054 if (hvtype == SVt_PVHV) { /* hash element */
4055 while (++MARK <= SP) {
4056 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4057 *MARK = sv ? sv : &PL_sv_undef;
4060 else if (hvtype == SVt_PVAV) { /* array element */
4061 if (PL_op->op_flags & OPf_SPECIAL) {
4062 while (++MARK <= SP) {
4063 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4064 *MARK = sv ? sv : &PL_sv_undef;
4069 DIE(aTHX_ "Not a HASH reference");
4072 else if (gimme == G_SCALAR) {
4077 *++MARK = &PL_sv_undef;
4083 HV * const hv = MUTABLE_HV(POPs);
4085 if (SvTYPE(hv) == SVt_PVHV)
4086 sv = hv_delete_ent(hv, keysv, discard, 0);
4087 else if (SvTYPE(hv) == SVt_PVAV) {
4088 if (PL_op->op_flags & OPf_SPECIAL)
4089 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4091 DIE(aTHX_ "panic: avhv_delete no longer supported");
4094 DIE(aTHX_ "Not a HASH reference");
4110 if (PL_op->op_private & OPpEXISTS_SUB) {
4112 SV * const sv = POPs;
4113 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4116 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4121 hv = MUTABLE_HV(POPs);
4122 if (SvTYPE(hv) == SVt_PVHV) {
4123 if (hv_exists_ent(hv, tmpsv, 0))
4126 else if (SvTYPE(hv) == SVt_PVAV) {
4127 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4128 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4133 DIE(aTHX_ "Not a HASH reference");
4140 dVAR; dSP; dMARK; dORIGMARK;
4141 register HV * const hv = MUTABLE_HV(POPs);
4142 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4143 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4144 bool other_magic = FALSE;
4150 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4151 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4152 /* Try to preserve the existenceness of a tied hash
4153 * element by using EXISTS and DELETE if possible.
4154 * Fallback to FETCH and STORE otherwise */
4155 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4156 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4157 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4160 while (++MARK <= SP) {
4161 SV * const keysv = *MARK;
4164 bool preeminent = FALSE;
4167 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4168 hv_exists_ent(hv, keysv, 0);
4171 he = hv_fetch_ent(hv, keysv, lval, 0);
4172 svp = he ? &HeVAL(he) : NULL;
4175 if (!svp || *svp == &PL_sv_undef) {
4176 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4179 if (HvNAME_get(hv) && isGV(*svp))
4180 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4183 save_helem(hv, keysv, svp);
4186 const char * const key = SvPV_const(keysv, keylen);
4187 SAVEDELETE(hv, savepvn(key,keylen),
4188 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4193 *MARK = svp ? *svp : &PL_sv_undef;
4195 if (GIMME != G_ARRAY) {
4197 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4203 /* List operators. */
4208 if (GIMME != G_ARRAY) {
4210 *MARK = *SP; /* unwanted list, return last item */
4212 *MARK = &PL_sv_undef;
4222 SV ** const lastrelem = PL_stack_sp;
4223 SV ** const lastlelem = PL_stack_base + POPMARK;
4224 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4225 register SV ** const firstrelem = lastlelem + 1;
4226 const I32 arybase = CopARYBASE_get(PL_curcop);
4227 I32 is_something_there = FALSE;
4229 register const I32 max = lastrelem - lastlelem;
4230 register SV **lelem;
4232 if (GIMME != G_ARRAY) {
4233 I32 ix = SvIV(*lastlelem);
4238 if (ix < 0 || ix >= max)
4239 *firstlelem = &PL_sv_undef;
4241 *firstlelem = firstrelem[ix];
4247 SP = firstlelem - 1;
4251 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4252 I32 ix = SvIV(*lelem);
4257 if (ix < 0 || ix >= max)
4258 *lelem = &PL_sv_undef;
4260 is_something_there = TRUE;
4261 if (!(*lelem = firstrelem[ix]))
4262 *lelem = &PL_sv_undef;
4265 if (is_something_there)
4268 SP = firstlelem - 1;
4274 dVAR; dSP; dMARK; dORIGMARK;
4275 const I32 items = SP - MARK;
4276 SV * const av = (SV *) av_make(items, MARK+1);
4277 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4278 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4279 ? newRV_noinc(av) : av);
4285 dVAR; dSP; dMARK; dORIGMARK;
4286 HV* const hv = newHV();
4289 SV * const key = *++MARK;
4290 SV * const val = newSV(0);
4292 sv_setsv(val, *++MARK);
4293 else if (ckWARN(WARN_MISC))
4294 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4295 (void)hv_store_ent(hv,key,val,0);
4298 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4299 ? newRV_noinc((SV*) hv) : (SV*) hv);
4305 dVAR; dSP; dMARK; dORIGMARK;
4306 register AV *ary = MUTABLE_AV(*++MARK);
4310 register I32 offset;
4311 register I32 length;
4315 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4318 *MARK-- = SvTIED_obj((SV*)ary, mg);
4322 call_method("SPLICE",GIMME_V);
4331 offset = i = SvIV(*MARK);
4333 offset += AvFILLp(ary) + 1;
4335 offset -= CopARYBASE_get(PL_curcop);
4337 DIE(aTHX_ PL_no_aelem, i);
4339 length = SvIVx(*MARK++);
4341 length += AvFILLp(ary) - offset + 1;
4347 length = AvMAX(ary) + 1; /* close enough to infinity */
4351 length = AvMAX(ary) + 1;
4353 if (offset > AvFILLp(ary) + 1) {
4354 if (ckWARN(WARN_MISC))
4355 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4356 offset = AvFILLp(ary) + 1;
4358 after = AvFILLp(ary) + 1 - (offset + length);
4359 if (after < 0) { /* not that much array */
4360 length += after; /* offset+length now in array */
4366 /* At this point, MARK .. SP-1 is our new LIST */
4369 diff = newlen - length;
4370 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4373 /* make new elements SVs now: avoid problems if they're from the array */
4374 for (dst = MARK, i = newlen; i; i--) {
4375 SV * const h = *dst;
4376 *dst++ = newSVsv(h);
4379 if (diff < 0) { /* shrinking the area */
4380 SV **tmparyval = NULL;
4382 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4383 Copy(MARK, tmparyval, newlen, SV*);
4386 MARK = ORIGMARK + 1;
4387 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4388 MEXTEND(MARK, length);
4389 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4391 EXTEND_MORTAL(length);
4392 for (i = length, dst = MARK; i; i--) {
4393 sv_2mortal(*dst); /* free them eventualy */
4400 *MARK = AvARRAY(ary)[offset+length-1];
4403 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4404 SvREFCNT_dec(*dst++); /* free them now */
4407 AvFILLp(ary) += diff;
4409 /* pull up or down? */
4411 if (offset < after) { /* easier to pull up */
4412 if (offset) { /* esp. if nothing to pull */
4413 src = &AvARRAY(ary)[offset-1];
4414 dst = src - diff; /* diff is negative */
4415 for (i = offset; i > 0; i--) /* can't trust Copy */
4419 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4423 if (after) { /* anything to pull down? */
4424 src = AvARRAY(ary) + offset + length;
4425 dst = src + diff; /* diff is negative */
4426 Move(src, dst, after, SV*);
4428 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4429 /* avoid later double free */
4433 dst[--i] = &PL_sv_undef;
4436 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4437 Safefree(tmparyval);
4440 else { /* no, expanding (or same) */
4441 SV** tmparyval = NULL;
4443 Newx(tmparyval, length, SV*); /* so remember deletion */
4444 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4447 if (diff > 0) { /* expanding */
4448 /* push up or down? */
4449 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4453 Move(src, dst, offset, SV*);
4455 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4457 AvFILLp(ary) += diff;
4460 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4461 av_extend(ary, AvFILLp(ary) + diff);
4462 AvFILLp(ary) += diff;
4465 dst = AvARRAY(ary) + AvFILLp(ary);
4467 for (i = after; i; i--) {
4475 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4478 MARK = ORIGMARK + 1;
4479 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4481 Copy(tmparyval, MARK, length, SV*);
4483 EXTEND_MORTAL(length);
4484 for (i = length, dst = MARK; i; i--) {
4485 sv_2mortal(*dst); /* free them eventualy */
4492 else if (length--) {
4493 *MARK = tmparyval[length];
4496 while (length-- > 0)
4497 SvREFCNT_dec(tmparyval[length]);
4501 *MARK = &PL_sv_undef;
4502 Safefree(tmparyval);
4510 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4511 register AV * const ary = MUTABLE_AV(*++MARK);
4512 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4515 *MARK-- = SvTIED_obj((SV*)ary, mg);
4519 call_method("PUSH",G_SCALAR|G_DISCARD);
4523 PUSHi( AvFILL(ary) + 1 );
4526 PL_delaymagic = DM_DELAY;
4527 for (++MARK; MARK <= SP; MARK++) {
4528 SV * const sv = newSV(0);
4530 sv_setsv(sv, *MARK);
4531 av_store(ary, AvFILLp(ary)+1, sv);
4533 if (PL_delaymagic & DM_ARRAY)
4538 PUSHi( AvFILLp(ary) + 1 );
4547 AV * const av = MUTABLE_AV(POPs);
4548 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4552 (void)sv_2mortal(sv);
4559 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4560 register AV *ary = MUTABLE_AV(*++MARK);
4561 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4564 *MARK-- = SvTIED_obj((SV*)ary, mg);
4568 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4574 av_unshift(ary, SP - MARK);
4576 SV * const sv = newSVsv(*++MARK);
4577 (void)av_store(ary, i++, sv);
4581 PUSHi( AvFILL(ary) + 1 );
4588 SV ** const oldsp = SP;
4590 if (GIMME == G_ARRAY) {
4593 register SV * const tmp = *MARK;
4597 /* safe as long as stack cannot get extended in the above */
4602 register char *down;
4606 PADOFFSET padoff_du;
4608 SvUTF8_off(TARG); /* decontaminate */
4610 do_join(TARG, &PL_sv_no, MARK, SP);
4612 sv_setsv(TARG, (SP > MARK)
4614 : (padoff_du = find_rundefsvoffset(),
4615 (padoff_du == NOT_IN_PAD
4616 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4617 ? DEFSV : PAD_SVl(padoff_du)));
4619 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4620 report_uninit(TARG);
4623 up = SvPV_force(TARG, len);
4625 if (DO_UTF8(TARG)) { /* first reverse each character */
4626 U8* s = (U8*)SvPVX(TARG);
4627 const U8* send = (U8*)(s + len);
4629 if (UTF8_IS_INVARIANT(*s)) {
4634 if (!utf8_to_uvchr(s, 0))
4638 down = (char*)(s - 1);
4639 /* reverse this character */
4643 *down-- = (char)tmp;
4649 down = SvPVX(TARG) + len - 1;
4653 *down-- = (char)tmp;
4655 (void)SvPOK_only_UTF8(TARG);
4667 register IV limit = POPi; /* note, negative is forever */
4668 SV * const sv = POPs;
4670 register const char *s = SvPV_const(sv, len);
4671 const bool do_utf8 = DO_UTF8(sv);
4672 const char *strend = s + len;
4674 register REGEXP *rx;
4676 register const char *m;
4678 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4679 I32 maxiters = slen + 10;
4681 const I32 origlimit = limit;
4684 const I32 gimme = GIMME_V;
4685 const I32 oldsave = PL_savestack_ix;
4686 U32 make_mortal = SVs_TEMP;
4691 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4696 DIE(aTHX_ "panic: pp_split");
4699 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4700 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4702 RX_MATCH_UTF8_set(rx, do_utf8);
4705 if (pm->op_pmreplrootu.op_pmtargetoff) {
4706 ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4709 if (pm->op_pmreplrootu.op_pmtargetgv) {
4710 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4713 else if (gimme != G_ARRAY)
4714 ary = GvAVn(PL_defgv);
4717 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4723 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4725 XPUSHs(SvTIED_obj((SV*)ary, mg));
4732 for (i = AvFILLp(ary); i >= 0; i--)
4733 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4735 /* temporarily switch stacks */
4736 SAVESWITCHSTACK(PL_curstack, ary);
4740 base = SP - PL_stack_base;
4742 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4744 while (*s == ' ' || is_utf8_space((U8*)s))
4747 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4748 while (isSPACE_LC(*s))
4756 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4761 limit = maxiters + 2;
4762 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4765 /* this one uses 'm' and is a negative test */
4767 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4768 const int t = UTF8SKIP(m);
4769 /* is_utf8_space returns FALSE for malform utf8 */
4775 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4776 while (m < strend && !isSPACE_LC(*m))
4779 while (m < strend && !isSPACE(*m))
4785 dstr = newSVpvn_flags(s, m-s,
4786 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4789 /* skip the whitespace found last */
4791 s = m + UTF8SKIP(m);
4795 /* this one uses 's' and is a positive test */
4797 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4799 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4800 while (s < strend && isSPACE_LC(*s))
4803 while (s < strend && isSPACE(*s))
4808 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4810 for (m = s; m < strend && *m != '\n'; m++)
4815 dstr = newSVpvn_flags(s, m-s,
4816 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4821 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4823 Pre-extend the stack, either the number of bytes or
4824 characters in the string or a limited amount, triggered by:
4826 my ($x, $y) = split //, $str;
4830 const U32 items = limit - 1;
4838 /* keep track of how many bytes we skip over */
4841 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
4850 dstr = newSVpvn(s, 1);
4864 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4865 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4866 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4867 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4868 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4869 SV * const csv = CALLREG_INTUIT_STRING(rx);
4871 len = RX_MINLENRET(rx);
4872 if (len == 1 && !RX_UTF8(rx) && !tail) {
4873 const char c = *SvPV_nolen_const(csv);
4875 for (m = s; m < strend && *m != c; m++)
4879 dstr = newSVpvn_flags(s, m-s,
4880 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4882 /* The rx->minlen is in characters but we want to step
4883 * s ahead by bytes. */
4885 s = (char*)utf8_hop((U8*)m, len);
4887 s = m + len; /* Fake \n at the end */
4891 while (s < strend && --limit &&
4892 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4893 csv, multiline ? FBMrf_MULTILINE : 0)) )
4895 dstr = newSVpvn_flags(s, m-s,
4896 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4898 /* The rx->minlen is in characters but we want to step
4899 * s ahead by bytes. */
4901 s = (char*)utf8_hop((U8*)m, len);
4903 s = m + len; /* Fake \n at the end */
4908 maxiters += slen * RX_NPARENS(rx);
4909 while (s < strend && --limit)
4913 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4916 if (rex_return == 0)
4918 TAINT_IF(RX_MATCH_TAINTED(rx));
4919 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4922 orig = RX_SUBBEG(rx);
4924 strend = s + (strend - m);
4926 m = RX_OFFS(rx)[0].start + orig;
4927 dstr = newSVpvn_flags(s, m-s,
4928 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4930 if (RX_NPARENS(rx)) {
4932 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4933 s = RX_OFFS(rx)[i].start + orig;
4934 m = RX_OFFS(rx)[i].end + orig;
4936 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4937 parens that didn't match -- they should be set to
4938 undef, not the empty string */
4939 if (m >= orig && s >= orig) {
4940 dstr = newSVpvn_flags(s, m-s,
4941 (do_utf8 ? SVf_UTF8 : 0)
4945 dstr = &PL_sv_undef; /* undef, not "" */
4949 s = RX_OFFS(rx)[0].end + orig;
4953 iters = (SP - PL_stack_base) - base;
4954 if (iters > maxiters)
4955 DIE(aTHX_ "Split loop");
4957 /* keep field after final delim? */
4958 if (s < strend || (iters && origlimit)) {
4959 const STRLEN l = strend - s;
4960 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4964 else if (!origlimit) {
4965 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4966 if (TOPs && !make_mortal)
4969 *SP-- = &PL_sv_undef;
4974 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4978 if (SvSMAGICAL(ary)) {
4983 if (gimme == G_ARRAY) {
4985 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4993 call_method("PUSH",G_SCALAR|G_DISCARD);
4996 if (gimme == G_ARRAY) {
4998 /* EXTEND should not be needed - we just popped them */
5000 for (i=0; i < iters; i++) {
5001 SV **svp = av_fetch(ary, i, FALSE);
5002 PUSHs((svp) ? *svp : &PL_sv_undef);
5009 if (gimme == G_ARRAY)
5021 SV *const sv = PAD_SVl(PL_op->op_targ);
5023 if (SvPADSTALE(sv)) {
5026 RETURNOP(cLOGOP->op_other);
5028 RETURNOP(cLOGOP->op_next);
5038 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5039 || SvTYPE(retsv) == SVt_PVCV) {
5040 retsv = refto(retsv);
5047 PP(unimplemented_op)
5050 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5056 * c-indentation-style: bsd
5058 * indent-tabs-mode: t
5061 * ex: set ts=8 sts=4 sw=4 noet: