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((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_ 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) = (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 = (AV*)TOPs;
320 SV ** const sv = Perl_av_arylen_p(aTHX_ (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 = (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 = (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 = (CV*)PAD_SV(PL_op->op_targ);
477 cv = (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((AV*)sv) && AvREIFY((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)) {
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((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
818 /* let user-undef'd sub keep its identity */
819 GV* const gv = CvGV((CV*)sv);
826 SvSetMagicSV(sv, &PL_sv_undef);
829 else if (isGV_with_GP(sv)) {
834 if((stash = GvHV((GV*)sv)) && HvNAME_get(stash))
835 mro_isa_changed_in(stash);
836 /* undef *Pkg::meth_name ... */
837 else if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
838 mro_method_changed_in(stash);
842 GvGP(sv) = gp_ref(gp);
844 GvLINE(sv) = CopLINE(PL_curcop);
851 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
866 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
867 DIE(aTHX_ PL_no_modify);
868 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
869 && SvIVX(TOPs) != IV_MIN)
871 SvIV_set(TOPs, SvIVX(TOPs) - 1);
872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
883 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
884 DIE(aTHX_ PL_no_modify);
885 sv_setsv(TARG, TOPs);
886 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
887 && SvIVX(TOPs) != IV_MAX)
889 SvIV_set(TOPs, SvIVX(TOPs) + 1);
890 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
895 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
905 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
906 DIE(aTHX_ PL_no_modify);
907 sv_setsv(TARG, TOPs);
908 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
909 && SvIVX(TOPs) != IV_MIN)
911 SvIV_set(TOPs, SvIVX(TOPs) - 1);
912 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
921 /* Ordinary operators. */
925 dVAR; dSP; dATARGET; SV *svl, *svr;
926 #ifdef PERL_PRESERVE_IVUV
929 tryAMAGICbin(pow,opASSIGN);
930 svl = sv_2num(TOPm1s);
932 #ifdef PERL_PRESERVE_IVUV
933 /* For integer to integer power, we do the calculation by hand wherever
934 we're sure it is safe; otherwise we call pow() and try to convert to
935 integer afterwards. */
948 const IV iv = SvIVX(svr);
952 goto float_it; /* Can't do negative powers this way. */
956 baseuok = SvUOK(svl);
960 const IV iv = SvIVX(svl);
963 baseuok = TRUE; /* effectively it's a UV now */
965 baseuv = -iv; /* abs, baseuok == false records sign */
968 /* now we have integer ** positive integer. */
971 /* foo & (foo - 1) is zero only for a power of 2. */
972 if (!(baseuv & (baseuv - 1))) {
973 /* We are raising power-of-2 to a positive integer.
974 The logic here will work for any base (even non-integer
975 bases) but it can be less accurate than
976 pow (base,power) or exp (power * log (base)) when the
977 intermediate values start to spill out of the mantissa.
978 With powers of 2 we know this can't happen.
979 And powers of 2 are the favourite thing for perl
980 programmers to notice ** not doing what they mean. */
982 NV base = baseuok ? baseuv : -(NV)baseuv;
987 while (power >>= 1) {
998 register unsigned int highbit = 8 * sizeof(UV);
999 register unsigned int diff = 8 * sizeof(UV);
1000 while (diff >>= 1) {
1002 if (baseuv >> highbit) {
1006 /* we now have baseuv < 2 ** highbit */
1007 if (power * highbit <= 8 * sizeof(UV)) {
1008 /* result will definitely fit in UV, so use UV math
1009 on same algorithm as above */
1010 register UV result = 1;
1011 register UV base = baseuv;
1012 const bool odd_power = (bool)(power & 1);
1016 while (power >>= 1) {
1023 if (baseuok || !odd_power)
1024 /* answer is positive */
1026 else if (result <= (UV)IV_MAX)
1027 /* answer negative, fits in IV */
1028 SETi( -(IV)result );
1029 else if (result == (UV)IV_MIN)
1030 /* 2's complement assumption: special case IV_MIN */
1033 /* answer negative, doesn't fit */
1034 SETn( -(NV)result );
1044 NV right = SvNV(svr);
1045 NV left = SvNV(svl);
1048 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1050 We are building perl with long double support and are on an AIX OS
1051 afflicted with a powl() function that wrongly returns NaNQ for any
1052 negative base. This was reported to IBM as PMR #23047-379 on
1053 03/06/2006. The problem exists in at least the following versions
1054 of AIX and the libm fileset, and no doubt others as well:
1056 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1057 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1058 AIX 5.2.0 bos.adt.libm 5.2.0.85
1060 So, until IBM fixes powl(), we provide the following workaround to
1061 handle the problem ourselves. Our logic is as follows: for
1062 negative bases (left), we use fmod(right, 2) to check if the
1063 exponent is an odd or even integer:
1065 - if odd, powl(left, right) == -powl(-left, right)
1066 - if even, powl(left, right) == powl(-left, right)
1068 If the exponent is not an integer, the result is rightly NaNQ, so
1069 we just return that (as NV_NAN).
1073 NV mod2 = Perl_fmod( right, 2.0 );
1074 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1075 SETn( -Perl_pow( -left, right) );
1076 } else if (mod2 == 0.0) { /* even integer */
1077 SETn( Perl_pow( -left, right) );
1078 } else { /* fractional power */
1082 SETn( Perl_pow( left, right) );
1085 SETn( Perl_pow( left, right) );
1086 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1088 #ifdef PERL_PRESERVE_IVUV
1098 dVAR; dSP; dATARGET; SV *svl, *svr;
1099 tryAMAGICbin(mult,opASSIGN);
1100 svl = sv_2num(TOPm1s);
1101 svr = sv_2num(TOPs);
1102 #ifdef PERL_PRESERVE_IVUV
1105 /* Unless the left argument is integer in range we are going to have to
1106 use NV maths. Hence only attempt to coerce the right argument if
1107 we know the left is integer. */
1108 /* Left operand is defined, so is it IV? */
1111 bool auvok = SvUOK(svl);
1112 bool buvok = SvUOK(svr);
1113 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1114 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1123 const IV aiv = SvIVX(svl);
1126 auvok = TRUE; /* effectively it's a UV now */
1128 alow = -aiv; /* abs, auvok == false records sign */
1134 const IV biv = SvIVX(svr);
1137 buvok = TRUE; /* effectively it's a UV now */
1139 blow = -biv; /* abs, buvok == false records sign */
1143 /* If this does sign extension on unsigned it's time for plan B */
1144 ahigh = alow >> (4 * sizeof (UV));
1146 bhigh = blow >> (4 * sizeof (UV));
1148 if (ahigh && bhigh) {
1150 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1151 which is overflow. Drop to NVs below. */
1152 } else if (!ahigh && !bhigh) {
1153 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1154 so the unsigned multiply cannot overflow. */
1155 const UV product = alow * blow;
1156 if (auvok == buvok) {
1157 /* -ve * -ve or +ve * +ve gives a +ve result. */
1161 } else if (product <= (UV)IV_MIN) {
1162 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1163 /* -ve result, which could overflow an IV */
1165 SETi( -(IV)product );
1167 } /* else drop to NVs below. */
1169 /* One operand is large, 1 small */
1172 /* swap the operands */
1174 bhigh = blow; /* bhigh now the temp var for the swap */
1178 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1179 multiplies can't overflow. shift can, add can, -ve can. */
1180 product_middle = ahigh * blow;
1181 if (!(product_middle & topmask)) {
1182 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1184 product_middle <<= (4 * sizeof (UV));
1185 product_low = alow * blow;
1187 /* as for pp_add, UV + something mustn't get smaller.
1188 IIRC ANSI mandates this wrapping *behaviour* for
1189 unsigned whatever the actual representation*/
1190 product_low += product_middle;
1191 if (product_low >= product_middle) {
1192 /* didn't overflow */
1193 if (auvok == buvok) {
1194 /* -ve * -ve or +ve * +ve gives a +ve result. */
1196 SETu( product_low );
1198 } else if (product_low <= (UV)IV_MIN) {
1199 /* 2s complement assumption again */
1200 /* -ve result, which could overflow an IV */
1202 SETi( -(IV)product_low );
1204 } /* else drop to NVs below. */
1206 } /* product_middle too large */
1207 } /* ahigh && bhigh */
1212 NV right = SvNV(svr);
1213 NV left = SvNV(svl);
1215 SETn( left * right );
1222 dVAR; dSP; dATARGET; SV *svl, *svr;
1223 tryAMAGICbin(div,opASSIGN);
1224 svl = sv_2num(TOPm1s);
1225 svr = sv_2num(TOPs);
1226 /* Only try to do UV divide first
1227 if ((SLOPPYDIVIDE is true) or
1228 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1230 The assumption is that it is better to use floating point divide
1231 whenever possible, only doing integer divide first if we can't be sure.
1232 If NV_PRESERVES_UV is true then we know at compile time that no UV
1233 can be too large to preserve, so don't need to compile the code to
1234 test the size of UVs. */
1237 # define PERL_TRY_UV_DIVIDE
1238 /* ensure that 20./5. == 4. */
1240 # ifdef PERL_PRESERVE_IVUV
1241 # ifndef NV_PRESERVES_UV
1242 # define PERL_TRY_UV_DIVIDE
1247 #ifdef PERL_TRY_UV_DIVIDE
1252 bool left_non_neg = SvUOK(svl);
1253 bool right_non_neg = SvUOK(svr);
1257 if (right_non_neg) {
1261 const IV biv = SvIVX(svr);
1264 right_non_neg = TRUE; /* effectively it's a UV now */
1270 /* historically undef()/0 gives a "Use of uninitialized value"
1271 warning before dieing, hence this test goes here.
1272 If it were immediately before the second SvIV_please, then
1273 DIE() would be invoked before left was even inspected, so
1274 no inpsection would give no warning. */
1276 DIE(aTHX_ "Illegal division by zero");
1282 const IV aiv = SvIVX(svl);
1285 left_non_neg = TRUE; /* effectively it's a UV now */
1294 /* For sloppy divide we always attempt integer division. */
1296 /* Otherwise we only attempt it if either or both operands
1297 would not be preserved by an NV. If both fit in NVs
1298 we fall through to the NV divide code below. However,
1299 as left >= right to ensure integer result here, we know that
1300 we can skip the test on the right operand - right big
1301 enough not to be preserved can't get here unless left is
1304 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1307 /* Integer division can't overflow, but it can be imprecise. */
1308 const UV result = left / right;
1309 if (result * right == left) {
1310 SP--; /* result is valid */
1311 if (left_non_neg == right_non_neg) {
1312 /* signs identical, result is positive. */
1316 /* 2s complement assumption */
1317 if (result <= (UV)IV_MIN)
1318 SETi( -(IV)result );
1320 /* It's exact but too negative for IV. */
1321 SETn( -(NV)result );
1324 } /* tried integer divide but it was not an integer result */
1325 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1326 } /* left wasn't SvIOK */
1327 } /* right wasn't SvIOK */
1328 #endif /* PERL_TRY_UV_DIVIDE */
1330 NV right = SvNV(svr);
1331 NV left = SvNV(svl);
1332 (void)POPs;(void)POPs;
1333 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1334 if (! Perl_isnan(right) && right == 0.0)
1338 DIE(aTHX_ "Illegal division by zero");
1339 PUSHn( left / right );
1346 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1350 bool left_neg = FALSE;
1351 bool right_neg = FALSE;
1352 bool use_double = FALSE;
1353 bool dright_valid = FALSE;
1357 SV * const svr = sv_2num(TOPs);
1360 right_neg = !SvUOK(svr);
1364 const IV biv = SvIVX(svr);
1367 right_neg = FALSE; /* effectively it's a UV now */
1375 right_neg = dright < 0;
1378 if (dright < UV_MAX_P1) {
1379 right = U_V(dright);
1380 dright_valid = TRUE; /* In case we need to use double below. */
1387 /* At this point use_double is only true if right is out of range for
1388 a UV. In range NV has been rounded down to nearest UV and
1389 use_double false. */
1390 svl = sv_2num(TOPs);
1392 if (!use_double && SvIOK(svl)) {
1394 left_neg = !SvUOK(svl);
1398 const IV aiv = SvIVX(svl);
1401 left_neg = FALSE; /* effectively it's a UV now */
1410 left_neg = dleft < 0;
1414 /* This should be exactly the 5.6 behaviour - if left and right are
1415 both in range for UV then use U_V() rather than floor. */
1417 if (dleft < UV_MAX_P1) {
1418 /* right was in range, so is dleft, so use UVs not double.
1422 /* left is out of range for UV, right was in range, so promote
1423 right (back) to double. */
1425 /* The +0.5 is used in 5.6 even though it is not strictly
1426 consistent with the implicit +0 floor in the U_V()
1427 inside the #if 1. */
1428 dleft = Perl_floor(dleft + 0.5);
1431 dright = Perl_floor(dright + 0.5);
1442 DIE(aTHX_ "Illegal modulus zero");
1444 dans = Perl_fmod(dleft, dright);
1445 if ((left_neg != right_neg) && dans)
1446 dans = dright - dans;
1449 sv_setnv(TARG, dans);
1455 DIE(aTHX_ "Illegal modulus zero");
1458 if ((left_neg != right_neg) && ans)
1461 /* XXX may warn: unary minus operator applied to unsigned type */
1462 /* could change -foo to be (~foo)+1 instead */
1463 if (ans <= ~((UV)IV_MAX)+1)
1464 sv_setiv(TARG, ~ans+1);
1466 sv_setnv(TARG, -(NV)ans);
1469 sv_setuv(TARG, ans);
1478 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1485 const UV uv = SvUV(sv);
1487 count = IV_MAX; /* The best we can do? */
1491 const IV iv = SvIV(sv);
1498 else if (SvNOKp(sv)) {
1499 const NV nv = SvNV(sv);
1507 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1509 static const char oom_list_extend[] = "Out of memory during list extend";
1510 const I32 items = SP - MARK;
1511 const I32 max = items * count;
1513 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1514 /* Did the max computation overflow? */
1515 if (items > 0 && max > 0 && (max < items || max < count))
1516 Perl_croak(aTHX_ oom_list_extend);
1521 /* This code was intended to fix 20010809.028:
1524 for (($x =~ /./g) x 2) {
1525 print chop; # "abcdabcd" expected as output.
1528 * but that change (#11635) broke this code:
1530 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1532 * I can't think of a better fix that doesn't introduce
1533 * an efficiency hit by copying the SVs. The stack isn't
1534 * refcounted, and mortalisation obviously doesn't
1535 * Do The Right Thing when the stack has more than
1536 * one pointer to the same mortal value.
1540 *SP = sv_2mortal(newSVsv(*SP));
1550 repeatcpy((char*)(MARK + items), (char*)MARK,
1551 items * sizeof(SV*), count - 1);
1554 else if (count <= 0)
1557 else { /* Note: mark already snarfed by pp_list */
1558 SV * const tmpstr = POPs;
1561 static const char oom_string_extend[] =
1562 "Out of memory during string extend";
1564 SvSetSV(TARG, tmpstr);
1565 SvPV_force(TARG, len);
1566 isutf = DO_UTF8(TARG);
1571 const STRLEN max = (UV)count * len;
1572 if (len > MEM_SIZE_MAX / count)
1573 Perl_croak(aTHX_ oom_string_extend);
1574 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1575 SvGROW(TARG, max + 1);
1576 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1577 SvCUR_set(TARG, SvCUR(TARG) * count);
1579 *SvEND(TARG) = '\0';
1582 (void)SvPOK_only_UTF8(TARG);
1584 (void)SvPOK_only(TARG);
1586 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1587 /* The parser saw this as a list repeat, and there
1588 are probably several items on the stack. But we're
1589 in scalar context, and there's no pp_list to save us
1590 now. So drop the rest of the items -- robin@kitsite.com
1603 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1604 tryAMAGICbin(subtr,opASSIGN);
1605 svl = sv_2num(TOPm1s);
1606 svr = sv_2num(TOPs);
1607 useleft = USE_LEFT(svl);
1608 #ifdef PERL_PRESERVE_IVUV
1609 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1610 "bad things" happen if you rely on signed integers wrapping. */
1613 /* Unless the left argument is integer in range we are going to have to
1614 use NV maths. Hence only attempt to coerce the right argument if
1615 we know the left is integer. */
1616 register UV auv = 0;
1622 a_valid = auvok = 1;
1623 /* left operand is undef, treat as zero. */
1625 /* Left operand is defined, so is it IV? */
1628 if ((auvok = SvUOK(svl)))
1631 register const IV aiv = SvIVX(svl);
1634 auvok = 1; /* Now acting as a sign flag. */
1635 } else { /* 2s complement assumption for IV_MIN */
1643 bool result_good = 0;
1646 bool buvok = SvUOK(svr);
1651 register const IV biv = SvIVX(svr);
1658 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1659 else "IV" now, independent of how it came in.
1660 if a, b represents positive, A, B negative, a maps to -A etc
1665 all UV maths. negate result if A negative.
1666 subtract if signs same, add if signs differ. */
1668 if (auvok ^ buvok) {
1677 /* Must get smaller */
1682 if (result <= buv) {
1683 /* result really should be -(auv-buv). as its negation
1684 of true value, need to swap our result flag */
1696 if (result <= (UV)IV_MIN)
1697 SETi( -(IV)result );
1699 /* result valid, but out of range for IV. */
1700 SETn( -(NV)result );
1704 } /* Overflow, drop through to NVs. */
1709 NV value = SvNV(svr);
1713 /* left operand is undef, treat as zero - value */
1717 SETn( SvNV(svl) - value );
1724 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1726 const IV shift = POPi;
1727 if (PL_op->op_private & HINT_INTEGER) {
1741 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1743 const IV shift = POPi;
1744 if (PL_op->op_private & HINT_INTEGER) {
1758 dVAR; dSP; tryAMAGICbinSET(lt,0);
1759 #ifdef PERL_PRESERVE_IVUV
1762 SvIV_please(TOPm1s);
1763 if (SvIOK(TOPm1s)) {
1764 bool auvok = SvUOK(TOPm1s);
1765 bool buvok = SvUOK(TOPs);
1767 if (!auvok && !buvok) { /* ## IV < IV ## */
1768 const IV aiv = SvIVX(TOPm1s);
1769 const IV biv = SvIVX(TOPs);
1772 SETs(boolSV(aiv < biv));
1775 if (auvok && buvok) { /* ## UV < UV ## */
1776 const UV auv = SvUVX(TOPm1s);
1777 const UV buv = SvUVX(TOPs);
1780 SETs(boolSV(auv < buv));
1783 if (auvok) { /* ## UV < IV ## */
1785 const IV biv = SvIVX(TOPs);
1788 /* As (a) is a UV, it's >=0, so it cannot be < */
1793 SETs(boolSV(auv < (UV)biv));
1796 { /* ## IV < UV ## */
1797 const IV aiv = SvIVX(TOPm1s);
1801 /* As (b) is a UV, it's >=0, so it must be < */
1808 SETs(boolSV((UV)aiv < buv));
1814 #ifndef NV_PRESERVES_UV
1815 #ifdef PERL_PRESERVE_IVUV
1818 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1820 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1825 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1827 if (Perl_isnan(left) || Perl_isnan(right))
1829 SETs(boolSV(left < right));
1832 SETs(boolSV(TOPn < value));
1840 dVAR; dSP; tryAMAGICbinSET(gt,0);
1841 #ifdef PERL_PRESERVE_IVUV
1844 SvIV_please(TOPm1s);
1845 if (SvIOK(TOPm1s)) {
1846 bool auvok = SvUOK(TOPm1s);
1847 bool buvok = SvUOK(TOPs);
1849 if (!auvok && !buvok) { /* ## IV > IV ## */
1850 const IV aiv = SvIVX(TOPm1s);
1851 const IV biv = SvIVX(TOPs);
1854 SETs(boolSV(aiv > biv));
1857 if (auvok && buvok) { /* ## UV > UV ## */
1858 const UV auv = SvUVX(TOPm1s);
1859 const UV buv = SvUVX(TOPs);
1862 SETs(boolSV(auv > buv));
1865 if (auvok) { /* ## UV > IV ## */
1867 const IV biv = SvIVX(TOPs);
1871 /* As (a) is a UV, it's >=0, so it must be > */
1876 SETs(boolSV(auv > (UV)biv));
1879 { /* ## IV > UV ## */
1880 const IV aiv = SvIVX(TOPm1s);
1884 /* As (b) is a UV, it's >=0, so it cannot be > */
1891 SETs(boolSV((UV)aiv > buv));
1897 #ifndef NV_PRESERVES_UV
1898 #ifdef PERL_PRESERVE_IVUV
1901 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1903 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1908 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1910 if (Perl_isnan(left) || Perl_isnan(right))
1912 SETs(boolSV(left > right));
1915 SETs(boolSV(TOPn > value));
1923 dVAR; dSP; tryAMAGICbinSET(le,0);
1924 #ifdef PERL_PRESERVE_IVUV
1927 SvIV_please(TOPm1s);
1928 if (SvIOK(TOPm1s)) {
1929 bool auvok = SvUOK(TOPm1s);
1930 bool buvok = SvUOK(TOPs);
1932 if (!auvok && !buvok) { /* ## IV <= IV ## */
1933 const IV aiv = SvIVX(TOPm1s);
1934 const IV biv = SvIVX(TOPs);
1937 SETs(boolSV(aiv <= biv));
1940 if (auvok && buvok) { /* ## UV <= UV ## */
1941 UV auv = SvUVX(TOPm1s);
1942 UV buv = SvUVX(TOPs);
1945 SETs(boolSV(auv <= buv));
1948 if (auvok) { /* ## UV <= IV ## */
1950 const IV biv = SvIVX(TOPs);
1954 /* As (a) is a UV, it's >=0, so a cannot be <= */
1959 SETs(boolSV(auv <= (UV)biv));
1962 { /* ## IV <= UV ## */
1963 const IV aiv = SvIVX(TOPm1s);
1967 /* As (b) is a UV, it's >=0, so a must be <= */
1974 SETs(boolSV((UV)aiv <= buv));
1980 #ifndef NV_PRESERVES_UV
1981 #ifdef PERL_PRESERVE_IVUV
1984 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1986 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1991 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1993 if (Perl_isnan(left) || Perl_isnan(right))
1995 SETs(boolSV(left <= right));
1998 SETs(boolSV(TOPn <= value));
2006 dVAR; dSP; tryAMAGICbinSET(ge,0);
2007 #ifdef PERL_PRESERVE_IVUV
2010 SvIV_please(TOPm1s);
2011 if (SvIOK(TOPm1s)) {
2012 bool auvok = SvUOK(TOPm1s);
2013 bool buvok = SvUOK(TOPs);
2015 if (!auvok && !buvok) { /* ## IV >= IV ## */
2016 const IV aiv = SvIVX(TOPm1s);
2017 const IV biv = SvIVX(TOPs);
2020 SETs(boolSV(aiv >= biv));
2023 if (auvok && buvok) { /* ## UV >= UV ## */
2024 const UV auv = SvUVX(TOPm1s);
2025 const UV buv = SvUVX(TOPs);
2028 SETs(boolSV(auv >= buv));
2031 if (auvok) { /* ## UV >= IV ## */
2033 const IV biv = SvIVX(TOPs);
2037 /* As (a) is a UV, it's >=0, so it must be >= */
2042 SETs(boolSV(auv >= (UV)biv));
2045 { /* ## IV >= UV ## */
2046 const IV aiv = SvIVX(TOPm1s);
2050 /* As (b) is a UV, it's >=0, so a cannot be >= */
2057 SETs(boolSV((UV)aiv >= buv));
2063 #ifndef NV_PRESERVES_UV
2064 #ifdef PERL_PRESERVE_IVUV
2067 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2069 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2074 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2076 if (Perl_isnan(left) || Perl_isnan(right))
2078 SETs(boolSV(left >= right));
2081 SETs(boolSV(TOPn >= value));
2089 dVAR; dSP; tryAMAGICbinSET(ne,0);
2090 #ifndef NV_PRESERVES_UV
2091 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2093 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2097 #ifdef PERL_PRESERVE_IVUV
2100 SvIV_please(TOPm1s);
2101 if (SvIOK(TOPm1s)) {
2102 const bool auvok = SvUOK(TOPm1s);
2103 const bool buvok = SvUOK(TOPs);
2105 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2106 /* Casting IV to UV before comparison isn't going to matter
2107 on 2s complement. On 1s complement or sign&magnitude
2108 (if we have any of them) it could make negative zero
2109 differ from normal zero. As I understand it. (Need to
2110 check - is negative zero implementation defined behaviour
2112 const UV buv = SvUVX(POPs);
2113 const UV auv = SvUVX(TOPs);
2115 SETs(boolSV(auv != buv));
2118 { /* ## Mixed IV,UV ## */
2122 /* != is commutative so swap if needed (save code) */
2124 /* swap. top of stack (b) is the iv */
2128 /* As (a) is a UV, it's >0, so it cannot be == */
2137 /* As (b) is a UV, it's >0, so it cannot be == */
2141 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2143 SETs(boolSV((UV)iv != uv));
2150 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2152 if (Perl_isnan(left) || Perl_isnan(right))
2154 SETs(boolSV(left != right));
2157 SETs(boolSV(TOPn != value));
2165 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2166 #ifndef NV_PRESERVES_UV
2167 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2168 const UV right = PTR2UV(SvRV(POPs));
2169 const UV left = PTR2UV(SvRV(TOPs));
2170 SETi((left > right) - (left < right));
2174 #ifdef PERL_PRESERVE_IVUV
2175 /* Fortunately it seems NaN isn't IOK */
2178 SvIV_please(TOPm1s);
2179 if (SvIOK(TOPm1s)) {
2180 const bool leftuvok = SvUOK(TOPm1s);
2181 const bool rightuvok = SvUOK(TOPs);
2183 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2184 const IV leftiv = SvIVX(TOPm1s);
2185 const IV rightiv = SvIVX(TOPs);
2187 if (leftiv > rightiv)
2189 else if (leftiv < rightiv)
2193 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2194 const UV leftuv = SvUVX(TOPm1s);
2195 const UV rightuv = SvUVX(TOPs);
2197 if (leftuv > rightuv)
2199 else if (leftuv < rightuv)
2203 } else if (leftuvok) { /* ## UV <=> IV ## */
2204 const IV rightiv = SvIVX(TOPs);
2206 /* As (a) is a UV, it's >=0, so it cannot be < */
2209 const UV leftuv = SvUVX(TOPm1s);
2210 if (leftuv > (UV)rightiv) {
2212 } else if (leftuv < (UV)rightiv) {
2218 } else { /* ## IV <=> UV ## */
2219 const IV leftiv = SvIVX(TOPm1s);
2221 /* As (b) is a UV, it's >=0, so it must be < */
2224 const UV rightuv = SvUVX(TOPs);
2225 if ((UV)leftiv > rightuv) {
2227 } else if ((UV)leftiv < rightuv) {
2245 if (Perl_isnan(left) || Perl_isnan(right)) {
2249 value = (left > right) - (left < right);
2253 else if (left < right)
2255 else if (left > right)
2271 int amg_type = sle_amg;
2275 switch (PL_op->op_type) {
2294 tryAMAGICbinSET_var(amg_type,0);
2297 const int cmp = (IN_LOCALE_RUNTIME
2298 ? sv_cmp_locale(left, right)
2299 : sv_cmp(left, right));
2300 SETs(boolSV(cmp * multiplier < rhs));
2307 dVAR; dSP; tryAMAGICbinSET(seq,0);
2310 SETs(boolSV(sv_eq(left, right)));
2317 dVAR; dSP; tryAMAGICbinSET(sne,0);
2320 SETs(boolSV(!sv_eq(left, right)));
2327 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2330 const int cmp = (IN_LOCALE_RUNTIME
2331 ? sv_cmp_locale(left, right)
2332 : sv_cmp(left, right));
2340 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2345 if (SvNIOKp(left) || SvNIOKp(right)) {
2346 if (PL_op->op_private & HINT_INTEGER) {
2347 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2351 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2356 do_vop(PL_op->op_type, TARG, left, right);
2365 dVAR; dSP; dATARGET;
2366 const int op_type = PL_op->op_type;
2368 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2373 if (SvNIOKp(left) || SvNIOKp(right)) {
2374 if (PL_op->op_private & HINT_INTEGER) {
2375 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2376 const IV r = SvIV_nomg(right);
2377 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2381 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2382 const UV r = SvUV_nomg(right);
2383 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2388 do_vop(op_type, TARG, left, right);
2397 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2399 SV * const sv = sv_2num(TOPs);
2400 const int flags = SvFLAGS(sv);
2402 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2403 /* It's publicly an integer, or privately an integer-not-float */
2406 if (SvIVX(sv) == IV_MIN) {
2407 /* 2s complement assumption. */
2408 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2411 else if (SvUVX(sv) <= IV_MAX) {
2416 else if (SvIVX(sv) != IV_MIN) {
2420 #ifdef PERL_PRESERVE_IVUV
2429 else if (SvPOKp(sv)) {
2431 const char * const s = SvPV_const(sv, len);
2432 if (isIDFIRST(*s)) {
2433 sv_setpvn(TARG, "-", 1);
2436 else if (*s == '+' || *s == '-') {
2438 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2440 else if (DO_UTF8(sv)) {
2443 goto oops_its_an_int;
2445 sv_setnv(TARG, -SvNV(sv));
2447 sv_setpvn(TARG, "-", 1);
2454 goto oops_its_an_int;
2455 sv_setnv(TARG, -SvNV(sv));
2467 dVAR; dSP; tryAMAGICunSET(not);
2468 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2474 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2479 if (PL_op->op_private & HINT_INTEGER) {
2480 const IV i = ~SvIV_nomg(sv);
2484 const UV u = ~SvUV_nomg(sv);
2493 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2494 sv_setsv_nomg(TARG, sv);
2495 tmps = (U8*)SvPV_force(TARG, len);
2498 /* Calculate exact length, let's not estimate. */
2503 U8 * const send = tmps + len;
2504 U8 * const origtmps = tmps;
2505 const UV utf8flags = UTF8_ALLOW_ANYUV;
2507 while (tmps < send) {
2508 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2510 targlen += UNISKIP(~c);
2516 /* Now rewind strings and write them. */
2523 Newx(result, targlen + 1, U8);
2525 while (tmps < send) {
2526 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2528 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2531 sv_usepvn_flags(TARG, (char*)result, targlen,
2532 SV_HAS_TRAILING_NUL);
2539 Newx(result, nchar + 1, U8);
2541 while (tmps < send) {
2542 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2547 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2555 register long *tmpl;
2556 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2559 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2564 for ( ; anum > 0; anum--, tmps++)
2573 /* integer versions of some of the above */
2577 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2580 SETi( left * right );
2588 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2592 DIE(aTHX_ "Illegal division by zero");
2595 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2599 value = num / value;
2605 #if defined(__GLIBC__) && IVSIZE == 8
2612 /* This is the vanilla old i_modulo. */
2613 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2617 DIE(aTHX_ "Illegal modulus zero");
2618 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2622 SETi( left % right );
2627 #if defined(__GLIBC__) && IVSIZE == 8
2632 /* This is the i_modulo with the workaround for the _moddi3 bug
2633 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2634 * See below for pp_i_modulo. */
2635 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2639 DIE(aTHX_ "Illegal modulus zero");
2640 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2644 SETi( left % PERL_ABS(right) );
2651 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2655 DIE(aTHX_ "Illegal modulus zero");
2656 /* The assumption is to use hereafter the old vanilla version... */
2658 PL_ppaddr[OP_I_MODULO] =
2660 /* .. but if we have glibc, we might have a buggy _moddi3
2661 * (at least glicb 2.2.5 is known to have this bug), in other
2662 * words our integer modulus with negative quad as the second
2663 * argument might be broken. Test for this and re-patch the
2664 * opcode dispatch table if that is the case, remembering to
2665 * also apply the workaround so that this first round works
2666 * right, too. See [perl #9402] for more information. */
2670 /* Cannot do this check with inlined IV constants since
2671 * that seems to work correctly even with the buggy glibc. */
2673 /* Yikes, we have the bug.
2674 * Patch in the workaround version. */
2676 PL_ppaddr[OP_I_MODULO] =
2677 &Perl_pp_i_modulo_1;
2678 /* Make certain we work right this time, too. */
2679 right = PERL_ABS(right);
2682 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2686 SETi( left % right );
2694 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2697 SETi( left + right );
2704 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2707 SETi( left - right );
2714 dVAR; dSP; tryAMAGICbinSET(lt,0);
2717 SETs(boolSV(left < right));
2724 dVAR; dSP; tryAMAGICbinSET(gt,0);
2727 SETs(boolSV(left > right));
2734 dVAR; dSP; tryAMAGICbinSET(le,0);
2737 SETs(boolSV(left <= right));
2744 dVAR; dSP; tryAMAGICbinSET(ge,0);
2747 SETs(boolSV(left >= right));
2754 dVAR; dSP; tryAMAGICbinSET(eq,0);
2757 SETs(boolSV(left == right));
2764 dVAR; dSP; tryAMAGICbinSET(ne,0);
2767 SETs(boolSV(left != right));
2774 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2781 else if (left < right)
2792 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2797 /* High falutin' math. */
2801 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2804 SETn(Perl_atan2(left, right));
2812 int amg_type = sin_amg;
2813 const char *neg_report = NULL;
2814 NV (*func)(NV) = Perl_sin;
2815 const int op_type = PL_op->op_type;
2832 amg_type = sqrt_amg;
2834 neg_report = "sqrt";
2838 tryAMAGICun_var(amg_type);
2840 const NV value = POPn;
2842 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2843 SET_NUMERIC_STANDARD();
2844 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2847 XPUSHn(func(value));
2852 /* Support Configure command-line overrides for rand() functions.
2853 After 5.005, perhaps we should replace this by Configure support
2854 for drand48(), random(), or rand(). For 5.005, though, maintain
2855 compatibility by calling rand() but allow the user to override it.
2856 See INSTALL for details. --Andy Dougherty 15 July 1998
2858 /* Now it's after 5.005, and Configure supports drand48() and random(),
2859 in addition to rand(). So the overrides should not be needed any more.
2860 --Jarkko Hietaniemi 27 September 1998
2863 #ifndef HAS_DRAND48_PROTO
2864 extern double drand48 (void);
2877 if (!PL_srand_called) {
2878 (void)seedDrand01((Rand_seed_t)seed());
2879 PL_srand_called = TRUE;
2889 const UV anum = (MAXARG < 1) ? seed() : POPu;
2890 (void)seedDrand01((Rand_seed_t)anum);
2891 PL_srand_called = TRUE;
2898 dVAR; dSP; dTARGET; tryAMAGICun(int);
2900 SV * const sv = sv_2num(TOPs);
2901 const IV iv = SvIV(sv);
2902 /* XXX it's arguable that compiler casting to IV might be subtly
2903 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2904 else preferring IV has introduced a subtle behaviour change bug. OTOH
2905 relying on floating point to be accurate is a bug. */
2910 else if (SvIOK(sv)) {
2917 const NV value = SvNV(sv);
2919 if (value < (NV)UV_MAX + 0.5) {
2922 SETn(Perl_floor(value));
2926 if (value > (NV)IV_MIN - 0.5) {
2929 SETn(Perl_ceil(value));
2939 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2941 SV * const sv = sv_2num(TOPs);
2942 /* This will cache the NV value if string isn't actually integer */
2943 const IV iv = SvIV(sv);
2948 else if (SvIOK(sv)) {
2949 /* IVX is precise */
2951 SETu(SvUV(sv)); /* force it to be numeric only */
2959 /* 2s complement assumption. Also, not really needed as
2960 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2966 const NV value = SvNV(sv);
2980 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2984 SV* const sv = POPs;
2986 tmps = (SvPV_const(sv, len));
2988 /* If Unicode, try to downgrade
2989 * If not possible, croak. */
2990 SV* const tsv = sv_2mortal(newSVsv(sv));
2993 sv_utf8_downgrade(tsv, FALSE);
2994 tmps = SvPV_const(tsv, len);
2996 if (PL_op->op_type == OP_HEX)
2999 while (*tmps && len && isSPACE(*tmps))
3005 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3007 else if (*tmps == 'b')
3008 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3010 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3012 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3026 SV * const sv = TOPs;
3028 if (SvGAMAGIC(sv)) {
3029 /* For an overloaded or magic scalar, we can't know in advance if
3030 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3031 it likes to cache the length. Maybe that should be a documented
3036 = sv_2pv_flags(sv, &len,
3037 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3041 else if (DO_UTF8(sv)) {
3042 SETi(utf8_length((U8*)p, (U8*)p + len));
3046 } else if (SvOK(sv)) {
3047 /* Neither magic nor overloaded. */
3049 SETi(sv_len_utf8(sv));
3068 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3070 const I32 arybase = CopARYBASE_get(PL_curcop);
3072 const char *repl = NULL;
3074 const int num_args = PL_op->op_private & 7;
3075 bool repl_need_utf8_upgrade = FALSE;
3076 bool repl_is_utf8 = FALSE;
3078 SvTAINTED_off(TARG); /* decontaminate */
3079 SvUTF8_off(TARG); /* decontaminate */
3083 repl = SvPV_const(repl_sv, repl_len);
3084 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3094 sv_utf8_upgrade(sv);
3096 else if (DO_UTF8(sv))
3097 repl_need_utf8_upgrade = TRUE;
3099 tmps = SvPV_const(sv, curlen);
3101 utf8_curlen = sv_len_utf8(sv);
3102 if (utf8_curlen == curlen)
3105 curlen = utf8_curlen;
3110 if (pos >= arybase) {
3128 else if (len >= 0) {
3130 if (rem > (I32)curlen)
3145 Perl_croak(aTHX_ "substr outside of string");
3146 if (ckWARN(WARN_SUBSTR))
3147 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3151 const I32 upos = pos;
3152 const I32 urem = rem;
3154 sv_pos_u2b(sv, &pos, &rem);
3156 /* we either return a PV or an LV. If the TARG hasn't been used
3157 * before, or is of that type, reuse it; otherwise use a mortal
3158 * instead. Note that LVs can have an extended lifetime, so also
3159 * dont reuse if refcount > 1 (bug #20933) */
3160 if (SvTYPE(TARG) > SVt_NULL) {
3161 if ( (SvTYPE(TARG) == SVt_PVLV)
3162 ? (!lvalue || SvREFCNT(TARG) > 1)
3165 TARG = sv_newmortal();
3169 sv_setpvn(TARG, tmps, rem);
3170 #ifdef USE_LOCALE_COLLATE
3171 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3176 SV* repl_sv_copy = NULL;
3178 if (repl_need_utf8_upgrade) {
3179 repl_sv_copy = newSVsv(repl_sv);
3180 sv_utf8_upgrade(repl_sv_copy);
3181 repl = SvPV_const(repl_sv_copy, repl_len);
3182 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3186 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3190 SvREFCNT_dec(repl_sv_copy);
3192 else if (lvalue) { /* it's an lvalue! */
3193 if (!SvGMAGICAL(sv)) {
3195 SvPV_force_nolen(sv);
3196 if (ckWARN(WARN_SUBSTR))
3197 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3198 "Attempt to use reference as lvalue in substr");
3200 if (isGV_with_GP(sv))
3201 SvPV_force_nolen(sv);
3202 else if (SvOK(sv)) /* is it defined ? */
3203 (void)SvPOK_only_UTF8(sv);
3205 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3208 if (SvTYPE(TARG) < SVt_PVLV) {
3209 sv_upgrade(TARG, SVt_PVLV);
3210 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3214 if (LvTARG(TARG) != sv) {
3216 SvREFCNT_dec(LvTARG(TARG));
3217 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3219 LvTARGOFF(TARG) = upos;
3220 LvTARGLEN(TARG) = urem;
3224 PUSHs(TARG); /* avoid SvSETMAGIC here */
3231 register const IV size = POPi;
3232 register const IV offset = POPi;
3233 register SV * const src = POPs;
3234 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3236 SvTAINTED_off(TARG); /* decontaminate */
3237 if (lvalue) { /* it's an lvalue! */
3238 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3239 TARG = sv_newmortal();
3240 if (SvTYPE(TARG) < SVt_PVLV) {
3241 sv_upgrade(TARG, SVt_PVLV);
3242 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3245 if (LvTARG(TARG) != src) {
3247 SvREFCNT_dec(LvTARG(TARG));
3248 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3250 LvTARGOFF(TARG) = offset;
3251 LvTARGLEN(TARG) = size;
3254 sv_setuv(TARG, do_vecget(src, offset, size));
3270 const char *little_p;
3271 const I32 arybase = CopARYBASE_get(PL_curcop);
3274 const bool is_index = PL_op->op_type == OP_INDEX;
3277 /* arybase is in characters, like offset, so combine prior to the
3278 UTF-8 to bytes calculation. */
3279 offset = POPi - arybase;
3283 big_p = SvPV_const(big, biglen);
3284 little_p = SvPV_const(little, llen);
3286 big_utf8 = DO_UTF8(big);
3287 little_utf8 = DO_UTF8(little);
3288 if (big_utf8 ^ little_utf8) {
3289 /* One needs to be upgraded. */
3290 if (little_utf8 && !PL_encoding) {
3291 /* Well, maybe instead we might be able to downgrade the small
3293 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3296 /* If the large string is ISO-8859-1, and it's not possible to
3297 convert the small string to ISO-8859-1, then there is no
3298 way that it could be found anywhere by index. */
3303 /* At this point, pv is a malloc()ed string. So donate it to temp
3304 to ensure it will get free()d */
3305 little = temp = newSV(0);
3306 sv_usepvn(temp, pv, llen);
3307 little_p = SvPVX(little);
3310 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3313 sv_recode_to_utf8(temp, PL_encoding);
3315 sv_utf8_upgrade(temp);
3320 big_p = SvPV_const(big, biglen);
3323 little_p = SvPV_const(little, llen);
3327 if (SvGAMAGIC(big)) {
3328 /* Life just becomes a lot easier if I use a temporary here.
3329 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3330 will trigger magic and overloading again, as will fbm_instr()
3332 big = newSVpvn_flags(big_p, biglen,
3333 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3336 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3337 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3338 warn on undef, and we've already triggered a warning with the
3339 SvPV_const some lines above. We can't remove that, as we need to
3340 call some SvPV to trigger overloading early and find out if the
3342 This is all getting to messy. The API isn't quite clean enough,
3343 because data access has side effects.
3345 little = newSVpvn_flags(little_p, llen,
3346 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3347 little_p = SvPVX(little);
3351 offset = is_index ? 0 : biglen;
3353 if (big_utf8 && offset > 0)
3354 sv_pos_u2b(big, &offset, 0);
3360 else if (offset > (I32)biglen)
3362 if (!(little_p = is_index
3363 ? fbm_instr((unsigned char*)big_p + offset,
3364 (unsigned char*)big_p + biglen, little, 0)
3365 : rninstr(big_p, big_p + offset,
3366 little_p, little_p + llen)))
3369 retval = little_p - big_p;
3370 if (retval > 0 && big_utf8)
3371 sv_pos_b2u(big, &retval);
3376 PUSHi(retval + arybase);
3382 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3383 if (SvTAINTED(MARK[1]))
3384 TAINT_PROPER("sprintf");
3385 do_sprintf(TARG, SP-MARK, MARK+1);
3386 TAINT_IF(SvTAINTED(TARG));
3398 const U8 *s = (U8*)SvPV_const(argsv, len);
3400 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3401 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3402 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3406 XPUSHu(DO_UTF8(argsv) ?
3407 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3419 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3421 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3423 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3425 (void) POPs; /* Ignore the argument value. */
3426 value = UNICODE_REPLACEMENT;
3432 SvUPGRADE(TARG,SVt_PV);
3434 if (value > 255 && !IN_BYTES) {
3435 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3436 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3437 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3439 (void)SvPOK_only(TARG);
3448 *tmps++ = (char)value;
3450 (void)SvPOK_only(TARG);
3452 if (PL_encoding && !IN_BYTES) {
3453 sv_recode_to_utf8(TARG, PL_encoding);
3455 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3456 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3460 *tmps++ = (char)value;
3476 const char *tmps = SvPV_const(left, len);
3478 if (DO_UTF8(left)) {
3479 /* If Unicode, try to downgrade.
3480 * If not possible, croak.
3481 * Yes, we made this up. */
3482 SV* const tsv = sv_2mortal(newSVsv(left));
3485 sv_utf8_downgrade(tsv, FALSE);
3486 tmps = SvPV_const(tsv, len);
3488 # ifdef USE_ITHREADS
3490 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3491 /* This should be threadsafe because in ithreads there is only
3492 * one thread per interpreter. If this would not be true,
3493 * we would need a mutex to protect this malloc. */
3494 PL_reentrant_buffer->_crypt_struct_buffer =
3495 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3496 #if defined(__GLIBC__) || defined(__EMX__)
3497 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3498 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3499 /* work around glibc-2.2.5 bug */
3500 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3504 # endif /* HAS_CRYPT_R */
3505 # endif /* USE_ITHREADS */
3507 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3509 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3515 "The crypt() function is unimplemented due to excessive paranoia.");
3527 bool inplace = TRUE;
3529 const int op_type = PL_op->op_type;
3532 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3538 s = (const U8*)SvPV_nomg_const(source, slen);
3540 if (ckWARN(WARN_UNINITIALIZED))
3541 report_uninit(source);
3546 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3548 utf8_to_uvchr(s, &ulen);
3549 if (op_type == OP_UCFIRST) {
3550 toTITLE_utf8(s, tmpbuf, &tculen);
3552 toLOWER_utf8(s, tmpbuf, &tculen);
3554 /* If the two differ, we definately cannot do inplace. */
3555 inplace = (ulen == tculen);
3556 need = slen + 1 - ulen + tculen;
3562 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3563 /* We can convert in place. */
3566 s = d = (U8*)SvPV_force_nomg(source, slen);
3572 SvUPGRADE(dest, SVt_PV);
3573 d = (U8*)SvGROW(dest, need);
3574 (void)SvPOK_only(dest);
3583 /* slen is the byte length of the whole SV.
3584 * ulen is the byte length of the original Unicode character
3585 * stored as UTF-8 at s.
3586 * tculen is the byte length of the freshly titlecased (or
3587 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3588 * We first set the result to be the titlecased (/lowercased)
3589 * character, and then append the rest of the SV data. */
3590 sv_setpvn(dest, (char*)tmpbuf, tculen);
3592 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3596 Copy(tmpbuf, d, tculen, U8);
3597 SvCUR_set(dest, need - 1);
3602 if (IN_LOCALE_RUNTIME) {
3605 *d = (op_type == OP_UCFIRST)
3606 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3609 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3611 /* See bug #39028 */
3619 /* This will copy the trailing NUL */
3620 Copy(s + 1, d + 1, slen, U8);
3621 SvCUR_set(dest, need - 1);
3628 /* There's so much setup/teardown code common between uc and lc, I wonder if
3629 it would be worth merging the two, and just having a switch outside each
3630 of the three tight loops. */
3644 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3645 && SvTEMP(source) && !DO_UTF8(source)) {
3646 /* We can convert in place. */
3649 s = d = (U8*)SvPV_force_nomg(source, len);
3656 /* The old implementation would copy source into TARG at this point.
3657 This had the side effect that if source was undef, TARG was now
3658 an undefined SV with PADTMP set, and they don't warn inside
3659 sv_2pv_flags(). However, we're now getting the PV direct from
3660 source, which doesn't have PADTMP set, so it would warn. Hence the
3664 s = (const U8*)SvPV_nomg_const(source, len);
3666 if (ckWARN(WARN_UNINITIALIZED))
3667 report_uninit(source);
3673 SvUPGRADE(dest, SVt_PV);
3674 d = (U8*)SvGROW(dest, min);
3675 (void)SvPOK_only(dest);
3680 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3681 to check DO_UTF8 again here. */
3683 if (DO_UTF8(source)) {
3684 const U8 *const send = s + len;
3685 U8 tmpbuf[UTF8_MAXBYTES+1];
3688 const STRLEN u = UTF8SKIP(s);
3691 toUPPER_utf8(s, tmpbuf, &ulen);
3692 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3693 /* If the eventually required minimum size outgrows
3694 * the available space, we need to grow. */
3695 const UV o = d - (U8*)SvPVX_const(dest);
3697 /* If someone uppercases one million U+03B0s we SvGROW() one
3698 * million times. Or we could try guessing how much to
3699 allocate without allocating too much. Such is life. */
3701 d = (U8*)SvPVX(dest) + o;
3703 Copy(tmpbuf, d, ulen, U8);
3709 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3712 const U8 *const send = s + len;
3713 if (IN_LOCALE_RUNTIME) {
3716 for (; s < send; d++, s++)
3717 *d = toUPPER_LC(*s);
3720 for (; s < send; d++, s++)
3724 if (source != dest) {
3726 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3746 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3747 && SvTEMP(source) && !DO_UTF8(source)) {
3748 /* We can convert in place. */
3751 s = d = (U8*)SvPV_force_nomg(source, len);
3758 /* The old implementation would copy source into TARG at this point.
3759 This had the side effect that if source was undef, TARG was now
3760 an undefined SV with PADTMP set, and they don't warn inside
3761 sv_2pv_flags(). However, we're now getting the PV direct from
3762 source, which doesn't have PADTMP set, so it would warn. Hence the
3766 s = (const U8*)SvPV_nomg_const(source, len);
3768 if (ckWARN(WARN_UNINITIALIZED))
3769 report_uninit(source);
3775 SvUPGRADE(dest, SVt_PV);
3776 d = (U8*)SvGROW(dest, min);
3777 (void)SvPOK_only(dest);
3782 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3783 to check DO_UTF8 again here. */
3785 if (DO_UTF8(source)) {
3786 const U8 *const send = s + len;
3787 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3790 const STRLEN u = UTF8SKIP(s);
3792 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3794 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3795 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3798 * Now if the sigma is NOT followed by
3799 * /$ignorable_sequence$cased_letter/;
3800 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3801 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3802 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3803 * then it should be mapped to 0x03C2,
3804 * (GREEK SMALL LETTER FINAL SIGMA),
3805 * instead of staying 0x03A3.
3806 * "should be": in other words, this is not implemented yet.
3807 * See lib/unicore/SpecialCasing.txt.
3810 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3811 /* If the eventually required minimum size outgrows
3812 * the available space, we need to grow. */
3813 const UV o = d - (U8*)SvPVX_const(dest);
3815 /* If someone lowercases one million U+0130s we SvGROW() one
3816 * million times. Or we could try guessing how much to
3817 allocate without allocating too much. Such is life. */
3819 d = (U8*)SvPVX(dest) + o;
3821 Copy(tmpbuf, d, ulen, U8);
3827 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3830 const U8 *const send = s + len;
3831 if (IN_LOCALE_RUNTIME) {
3834 for (; s < send; d++, s++)
3835 *d = toLOWER_LC(*s);
3838 for (; s < send; d++, s++)
3842 if (source != dest) {
3844 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3854 SV * const sv = TOPs;
3856 register const char *s = SvPV_const(sv,len);
3858 SvUTF8_off(TARG); /* decontaminate */
3861 SvUPGRADE(TARG, SVt_PV);
3862 SvGROW(TARG, (len * 2) + 1);
3866 if (UTF8_IS_CONTINUED(*s)) {
3867 STRLEN ulen = UTF8SKIP(s);
3891 SvCUR_set(TARG, d - SvPVX_const(TARG));
3892 (void)SvPOK_only_UTF8(TARG);
3895 sv_setpvn(TARG, s, len);
3897 if (SvSMAGICAL(TARG))
3906 dVAR; dSP; dMARK; dORIGMARK;
3907 register AV* const av = (AV*)POPs;
3908 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3910 if (SvTYPE(av) == SVt_PVAV) {
3911 const I32 arybase = CopARYBASE_get(PL_curcop);
3912 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3915 for (svp = MARK + 1; svp <= SP; svp++) {
3916 const I32 elem = SvIV(*svp);
3920 if (max > AvMAX(av))
3923 while (++MARK <= SP) {
3925 I32 elem = SvIV(*MARK);
3929 svp = av_fetch(av, elem, lval);
3931 if (!svp || *svp == &PL_sv_undef)
3932 DIE(aTHX_ PL_no_aelem, elem);
3933 if (PL_op->op_private & OPpLVAL_INTRO)
3934 save_aelem(av, elem, svp);
3936 *MARK = svp ? *svp : &PL_sv_undef;
3939 if (GIMME != G_ARRAY) {
3941 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3951 AV *array = (AV*)POPs;
3952 const I32 gimme = GIMME_V;
3953 IV *iterp = Perl_av_iter_p(aTHX_ array);
3954 const IV current = (*iterp)++;
3956 if (current > av_len(array)) {
3958 if (gimme == G_SCALAR)
3965 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3966 if (gimme == G_ARRAY) {
3967 SV **const element = av_fetch(array, current, 0);
3968 PUSHs(element ? *element : &PL_sv_undef);
3977 AV *array = (AV*)POPs;
3978 const I32 gimme = GIMME_V;
3980 *Perl_av_iter_p(aTHX_ array) = 0;
3982 if (gimme == G_SCALAR) {
3984 PUSHi(av_len(array) + 1);
3986 else if (gimme == G_ARRAY) {
3987 IV n = Perl_av_len(aTHX_ array);
3988 IV i = CopARYBASE_get(PL_curcop);
3992 if (PL_op->op_type == OP_AKEYS) {
3994 for (; i <= n; i++) {
3999 for (i = 0; i <= n; i++) {
4000 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4001 PUSHs(elem ? *elem : &PL_sv_undef);
4008 /* Associative arrays. */
4014 HV * hash = MUTABLE_HV(POPs);
4016 const I32 gimme = GIMME_V;
4019 /* might clobber stack_sp */
4020 entry = hv_iternext(hash);
4025 SV* const sv = hv_iterkeysv(entry);
4026 PUSHs(sv); /* won't clobber stack_sp */
4027 if (gimme == G_ARRAY) {
4030 /* might clobber stack_sp */
4031 val = hv_iterval(hash, entry);
4036 else if (gimme == G_SCALAR)
4046 const I32 gimme = GIMME_V;
4047 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4049 if (PL_op->op_private & OPpSLICE) {
4051 HV * const hv = MUTABLE_HV(POPs);
4052 const U32 hvtype = SvTYPE(hv);
4053 if (hvtype == SVt_PVHV) { /* hash element */
4054 while (++MARK <= SP) {
4055 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4056 *MARK = sv ? sv : &PL_sv_undef;
4059 else if (hvtype == SVt_PVAV) { /* array element */
4060 if (PL_op->op_flags & OPf_SPECIAL) {
4061 while (++MARK <= SP) {
4062 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
4063 *MARK = sv ? sv : &PL_sv_undef;
4068 DIE(aTHX_ "Not a HASH reference");
4071 else if (gimme == G_SCALAR) {
4076 *++MARK = &PL_sv_undef;
4082 HV * const hv = MUTABLE_HV(POPs);
4084 if (SvTYPE(hv) == SVt_PVHV)
4085 sv = hv_delete_ent(hv, keysv, discard, 0);
4086 else if (SvTYPE(hv) == SVt_PVAV) {
4087 if (PL_op->op_flags & OPf_SPECIAL)
4088 sv = av_delete((AV*)hv, SvIV(keysv), discard);
4090 DIE(aTHX_ "panic: avhv_delete no longer supported");
4093 DIE(aTHX_ "Not a HASH reference");
4109 if (PL_op->op_private & OPpEXISTS_SUB) {
4111 SV * const sv = POPs;
4112 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4115 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4120 hv = MUTABLE_HV(POPs);
4121 if (SvTYPE(hv) == SVt_PVHV) {
4122 if (hv_exists_ent(hv, tmpsv, 0))
4125 else if (SvTYPE(hv) == SVt_PVAV) {
4126 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4127 if (av_exists((AV*)hv, SvIV(tmpsv)))
4132 DIE(aTHX_ "Not a HASH reference");
4139 dVAR; dSP; dMARK; dORIGMARK;
4140 register HV * const hv = MUTABLE_HV(POPs);
4141 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4142 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4143 bool other_magic = FALSE;
4149 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4150 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4151 /* Try to preserve the existenceness of a tied hash
4152 * element by using EXISTS and DELETE if possible.
4153 * Fallback to FETCH and STORE otherwise */
4154 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4155 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4156 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4159 while (++MARK <= SP) {
4160 SV * const keysv = *MARK;
4163 bool preeminent = FALSE;
4166 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4167 hv_exists_ent(hv, keysv, 0);
4170 he = hv_fetch_ent(hv, keysv, lval, 0);
4171 svp = he ? &HeVAL(he) : NULL;
4174 if (!svp || *svp == &PL_sv_undef) {
4175 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4178 if (HvNAME_get(hv) && isGV(*svp))
4179 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4182 save_helem(hv, keysv, svp);
4185 const char * const key = SvPV_const(keysv, keylen);
4186 SAVEDELETE(hv, savepvn(key,keylen),
4187 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4192 *MARK = svp ? *svp : &PL_sv_undef;
4194 if (GIMME != G_ARRAY) {
4196 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4202 /* List operators. */
4207 if (GIMME != G_ARRAY) {
4209 *MARK = *SP; /* unwanted list, return last item */
4211 *MARK = &PL_sv_undef;
4221 SV ** const lastrelem = PL_stack_sp;
4222 SV ** const lastlelem = PL_stack_base + POPMARK;
4223 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4224 register SV ** const firstrelem = lastlelem + 1;
4225 const I32 arybase = CopARYBASE_get(PL_curcop);
4226 I32 is_something_there = FALSE;
4228 register const I32 max = lastrelem - lastlelem;
4229 register SV **lelem;
4231 if (GIMME != G_ARRAY) {
4232 I32 ix = SvIV(*lastlelem);
4237 if (ix < 0 || ix >= max)
4238 *firstlelem = &PL_sv_undef;
4240 *firstlelem = firstrelem[ix];
4246 SP = firstlelem - 1;
4250 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4251 I32 ix = SvIV(*lelem);
4256 if (ix < 0 || ix >= max)
4257 *lelem = &PL_sv_undef;
4259 is_something_there = TRUE;
4260 if (!(*lelem = firstrelem[ix]))
4261 *lelem = &PL_sv_undef;
4264 if (is_something_there)
4267 SP = firstlelem - 1;
4273 dVAR; dSP; dMARK; dORIGMARK;
4274 const I32 items = SP - MARK;
4275 SV * const av = (SV *) av_make(items, MARK+1);
4276 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4277 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4278 ? newRV_noinc(av) : av);
4284 dVAR; dSP; dMARK; dORIGMARK;
4285 HV* const hv = newHV();
4288 SV * const key = *++MARK;
4289 SV * const val = newSV(0);
4291 sv_setsv(val, *++MARK);
4292 else if (ckWARN(WARN_MISC))
4293 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4294 (void)hv_store_ent(hv,key,val,0);
4297 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4298 ? newRV_noinc((SV*) hv) : (SV*) hv);
4304 dVAR; dSP; dMARK; dORIGMARK;
4305 register AV *ary = (AV*)*++MARK;
4309 register I32 offset;
4310 register I32 length;
4314 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4317 *MARK-- = SvTIED_obj((SV*)ary, mg);
4321 call_method("SPLICE",GIMME_V);
4330 offset = i = SvIV(*MARK);
4332 offset += AvFILLp(ary) + 1;
4334 offset -= CopARYBASE_get(PL_curcop);
4336 DIE(aTHX_ PL_no_aelem, i);
4338 length = SvIVx(*MARK++);
4340 length += AvFILLp(ary) - offset + 1;
4346 length = AvMAX(ary) + 1; /* close enough to infinity */
4350 length = AvMAX(ary) + 1;
4352 if (offset > AvFILLp(ary) + 1) {
4353 if (ckWARN(WARN_MISC))
4354 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4355 offset = AvFILLp(ary) + 1;
4357 after = AvFILLp(ary) + 1 - (offset + length);
4358 if (after < 0) { /* not that much array */
4359 length += after; /* offset+length now in array */
4365 /* At this point, MARK .. SP-1 is our new LIST */
4368 diff = newlen - length;
4369 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4372 /* make new elements SVs now: avoid problems if they're from the array */
4373 for (dst = MARK, i = newlen; i; i--) {
4374 SV * const h = *dst;
4375 *dst++ = newSVsv(h);
4378 if (diff < 0) { /* shrinking the area */
4379 SV **tmparyval = NULL;
4381 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4382 Copy(MARK, tmparyval, newlen, SV*);
4385 MARK = ORIGMARK + 1;
4386 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4387 MEXTEND(MARK, length);
4388 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4390 EXTEND_MORTAL(length);
4391 for (i = length, dst = MARK; i; i--) {
4392 sv_2mortal(*dst); /* free them eventualy */
4399 *MARK = AvARRAY(ary)[offset+length-1];
4402 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4403 SvREFCNT_dec(*dst++); /* free them now */
4406 AvFILLp(ary) += diff;
4408 /* pull up or down? */
4410 if (offset < after) { /* easier to pull up */
4411 if (offset) { /* esp. if nothing to pull */
4412 src = &AvARRAY(ary)[offset-1];
4413 dst = src - diff; /* diff is negative */
4414 for (i = offset; i > 0; i--) /* can't trust Copy */
4418 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4422 if (after) { /* anything to pull down? */
4423 src = AvARRAY(ary) + offset + length;
4424 dst = src + diff; /* diff is negative */
4425 Move(src, dst, after, SV*);
4427 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4428 /* avoid later double free */
4432 dst[--i] = &PL_sv_undef;
4435 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4436 Safefree(tmparyval);
4439 else { /* no, expanding (or same) */
4440 SV** tmparyval = NULL;
4442 Newx(tmparyval, length, SV*); /* so remember deletion */
4443 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4446 if (diff > 0) { /* expanding */
4447 /* push up or down? */
4448 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4452 Move(src, dst, offset, SV*);
4454 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4456 AvFILLp(ary) += diff;
4459 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4460 av_extend(ary, AvFILLp(ary) + diff);
4461 AvFILLp(ary) += diff;
4464 dst = AvARRAY(ary) + AvFILLp(ary);
4466 for (i = after; i; i--) {
4474 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4477 MARK = ORIGMARK + 1;
4478 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4480 Copy(tmparyval, MARK, length, SV*);
4482 EXTEND_MORTAL(length);
4483 for (i = length, dst = MARK; i; i--) {
4484 sv_2mortal(*dst); /* free them eventualy */
4491 else if (length--) {
4492 *MARK = tmparyval[length];
4495 while (length-- > 0)
4496 SvREFCNT_dec(tmparyval[length]);
4500 *MARK = &PL_sv_undef;
4501 Safefree(tmparyval);
4509 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4510 register AV * const ary = (AV*)*++MARK;
4511 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4514 *MARK-- = SvTIED_obj((SV*)ary, mg);
4518 call_method("PUSH",G_SCALAR|G_DISCARD);
4522 PUSHi( AvFILL(ary) + 1 );
4525 PL_delaymagic = DM_DELAY;
4526 for (++MARK; MARK <= SP; MARK++) {
4527 SV * const sv = newSV(0);
4529 sv_setsv(sv, *MARK);
4530 av_store(ary, AvFILLp(ary)+1, sv);
4532 if (PL_delaymagic & DM_ARRAY)
4537 PUSHi( AvFILLp(ary) + 1 );
4546 AV * const av = (AV*)POPs;
4547 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4551 (void)sv_2mortal(sv);
4558 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4559 register AV *ary = (AV*)*++MARK;
4560 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4563 *MARK-- = SvTIED_obj((SV*)ary, mg);
4567 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4573 av_unshift(ary, SP - MARK);
4575 SV * const sv = newSVsv(*++MARK);
4576 (void)av_store(ary, i++, sv);
4580 PUSHi( AvFILL(ary) + 1 );
4587 SV ** const oldsp = SP;
4589 if (GIMME == G_ARRAY) {
4592 register SV * const tmp = *MARK;
4596 /* safe as long as stack cannot get extended in the above */
4601 register char *down;
4605 PADOFFSET padoff_du;
4607 SvUTF8_off(TARG); /* decontaminate */
4609 do_join(TARG, &PL_sv_no, MARK, SP);
4611 sv_setsv(TARG, (SP > MARK)
4613 : (padoff_du = find_rundefsvoffset(),
4614 (padoff_du == NOT_IN_PAD
4615 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4616 ? DEFSV : PAD_SVl(padoff_du)));
4618 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4619 report_uninit(TARG);
4622 up = SvPV_force(TARG, len);
4624 if (DO_UTF8(TARG)) { /* first reverse each character */
4625 U8* s = (U8*)SvPVX(TARG);
4626 const U8* send = (U8*)(s + len);
4628 if (UTF8_IS_INVARIANT(*s)) {
4633 if (!utf8_to_uvchr(s, 0))
4637 down = (char*)(s - 1);
4638 /* reverse this character */
4642 *down-- = (char)tmp;
4648 down = SvPVX(TARG) + len - 1;
4652 *down-- = (char)tmp;
4654 (void)SvPOK_only_UTF8(TARG);
4666 register IV limit = POPi; /* note, negative is forever */
4667 SV * const sv = POPs;
4669 register const char *s = SvPV_const(sv, len);
4670 const bool do_utf8 = DO_UTF8(sv);
4671 const char *strend = s + len;
4673 register REGEXP *rx;
4675 register const char *m;
4677 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4678 I32 maxiters = slen + 10;
4680 const I32 origlimit = limit;
4683 const I32 gimme = GIMME_V;
4684 const I32 oldsave = PL_savestack_ix;
4685 U32 make_mortal = SVs_TEMP;
4690 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4695 DIE(aTHX_ "panic: pp_split");
4698 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4699 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4701 RX_MATCH_UTF8_set(rx, do_utf8);
4704 if (pm->op_pmreplrootu.op_pmtargetoff) {
4705 ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4708 if (pm->op_pmreplrootu.op_pmtargetgv) {
4709 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4712 else if (gimme != G_ARRAY)
4713 ary = GvAVn(PL_defgv);
4716 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4722 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4724 XPUSHs(SvTIED_obj((SV*)ary, mg));
4731 for (i = AvFILLp(ary); i >= 0; i--)
4732 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4734 /* temporarily switch stacks */
4735 SAVESWITCHSTACK(PL_curstack, ary);
4739 base = SP - PL_stack_base;
4741 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4743 while (*s == ' ' || is_utf8_space((U8*)s))
4746 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4747 while (isSPACE_LC(*s))
4755 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4760 limit = maxiters + 2;
4761 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4764 /* this one uses 'm' and is a negative test */
4766 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4767 const int t = UTF8SKIP(m);
4768 /* is_utf8_space returns FALSE for malform utf8 */
4774 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4775 while (m < strend && !isSPACE_LC(*m))
4778 while (m < strend && !isSPACE(*m))
4784 dstr = newSVpvn_flags(s, m-s,
4785 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4788 /* skip the whitespace found last */
4790 s = m + UTF8SKIP(m);
4794 /* this one uses 's' and is a positive test */
4796 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4798 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4799 while (s < strend && isSPACE_LC(*s))
4802 while (s < strend && isSPACE(*s))
4807 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4809 for (m = s; m < strend && *m != '\n'; m++)
4814 dstr = newSVpvn_flags(s, m-s,
4815 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4820 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4822 Pre-extend the stack, either the number of bytes or
4823 characters in the string or a limited amount, triggered by:
4825 my ($x, $y) = split //, $str;
4829 const U32 items = limit - 1;
4837 /* keep track of how many bytes we skip over */
4840 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
4849 dstr = newSVpvn(s, 1);
4863 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4864 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4865 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4866 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4867 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4868 SV * const csv = CALLREG_INTUIT_STRING(rx);
4870 len = RX_MINLENRET(rx);
4871 if (len == 1 && !RX_UTF8(rx) && !tail) {
4872 const char c = *SvPV_nolen_const(csv);
4874 for (m = s; m < strend && *m != c; m++)
4878 dstr = newSVpvn_flags(s, m-s,
4879 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4881 /* The rx->minlen is in characters but we want to step
4882 * s ahead by bytes. */
4884 s = (char*)utf8_hop((U8*)m, len);
4886 s = m + len; /* Fake \n at the end */
4890 while (s < strend && --limit &&
4891 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4892 csv, multiline ? FBMrf_MULTILINE : 0)) )
4894 dstr = newSVpvn_flags(s, m-s,
4895 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4897 /* The rx->minlen is in characters but we want to step
4898 * s ahead by bytes. */
4900 s = (char*)utf8_hop((U8*)m, len);
4902 s = m + len; /* Fake \n at the end */
4907 maxiters += slen * RX_NPARENS(rx);
4908 while (s < strend && --limit)
4912 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4915 if (rex_return == 0)
4917 TAINT_IF(RX_MATCH_TAINTED(rx));
4918 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4921 orig = RX_SUBBEG(rx);
4923 strend = s + (strend - m);
4925 m = RX_OFFS(rx)[0].start + orig;
4926 dstr = newSVpvn_flags(s, m-s,
4927 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4929 if (RX_NPARENS(rx)) {
4931 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4932 s = RX_OFFS(rx)[i].start + orig;
4933 m = RX_OFFS(rx)[i].end + orig;
4935 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4936 parens that didn't match -- they should be set to
4937 undef, not the empty string */
4938 if (m >= orig && s >= orig) {
4939 dstr = newSVpvn_flags(s, m-s,
4940 (do_utf8 ? SVf_UTF8 : 0)
4944 dstr = &PL_sv_undef; /* undef, not "" */
4948 s = RX_OFFS(rx)[0].end + orig;
4952 iters = (SP - PL_stack_base) - base;
4953 if (iters > maxiters)
4954 DIE(aTHX_ "Split loop");
4956 /* keep field after final delim? */
4957 if (s < strend || (iters && origlimit)) {
4958 const STRLEN l = strend - s;
4959 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4963 else if (!origlimit) {
4964 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4965 if (TOPs && !make_mortal)
4968 *SP-- = &PL_sv_undef;
4973 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4977 if (SvSMAGICAL(ary)) {
4982 if (gimme == G_ARRAY) {
4984 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4992 call_method("PUSH",G_SCALAR|G_DISCARD);
4995 if (gimme == G_ARRAY) {
4997 /* EXTEND should not be needed - we just popped them */
4999 for (i=0; i < iters; i++) {
5000 SV **svp = av_fetch(ary, i, FALSE);
5001 PUSHs((svp) ? *svp : &PL_sv_undef);
5008 if (gimme == G_ARRAY)
5020 SV *const sv = PAD_SVl(PL_op->op_targ);
5022 if (SvPADSTALE(sv)) {
5025 RETURNOP(cLOGOP->op_other);
5027 RETURNOP(cLOGOP->op_next);
5037 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5038 || SvTYPE(retsv) == SVt_PVCV) {
5039 retsv = refto(retsv);
5046 PP(unimplemented_op)
5049 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5055 * c-indentation-style: bsd
5057 * indent-tabs-mode: t
5060 * ex: set ts=8 sts=4 sw=4 noet: