3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
52 if (GIMME_V == G_SCALAR)
63 if (PL_op->op_private & OPpLVAL_INTRO)
64 if (!(PL_op->op_private & OPpPAD_STATE))
65 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
67 if (PL_op->op_flags & OPf_REF) {
71 if (GIMME == G_SCALAR)
72 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
77 if (gimme == G_ARRAY) {
78 const I32 maxarg = AvFILL((AV*)TARG) + 1;
80 if (SvMAGICAL(TARG)) {
82 for (i=0; i < (U32)maxarg; i++) {
83 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
84 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
88 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
92 else if (gimme == G_SCALAR) {
93 SV* const sv = sv_newmortal();
94 const I32 maxarg = AvFILL((AV*)TARG) + 1;
107 if (PL_op->op_private & OPpLVAL_INTRO)
108 if (!(PL_op->op_private & OPpPAD_STATE))
109 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
110 if (PL_op->op_flags & OPf_REF)
113 if (GIMME == G_SCALAR)
114 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
118 if (gimme == G_ARRAY) {
121 else if (gimme == G_SCALAR) {
122 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
136 tryAMAGICunDEREF(to_gv);
139 if (SvTYPE(sv) == SVt_PVIO) {
140 GV * const gv = (GV*) sv_newmortal();
141 gv_init(gv, 0, "", 0, 0);
142 GvIOp(gv) = (IO *)sv;
143 SvREFCNT_inc_void_NN(sv);
146 else if (SvTYPE(sv) != SVt_PVGV)
147 DIE(aTHX_ "Not a GLOB reference");
150 if (SvTYPE(sv) != SVt_PVGV) {
151 if (SvGMAGICAL(sv)) {
156 if (!SvOK(sv) && sv != &PL_sv_undef) {
157 /* If this is a 'my' scalar and flag is set then vivify
161 Perl_croak(aTHX_ PL_no_modify);
162 if (PL_op->op_private & OPpDEREF) {
164 if (cUNOP->op_targ) {
166 SV * const namesv = PAD_SV(cUNOP->op_targ);
167 const char * const name = SvPV(namesv, len);
169 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
172 const char * const name = CopSTASHPV(PL_curcop);
175 if (SvTYPE(sv) < SVt_RV)
176 sv_upgrade(sv, SVt_RV);
177 else if (SvPVX_const(sv)) {
182 SvRV_set(sv, (SV*)gv);
187 if (PL_op->op_flags & OPf_REF ||
188 PL_op->op_private & HINT_STRICT_REFS)
189 DIE(aTHX_ PL_no_usym, "a symbol");
190 if (ckWARN(WARN_UNINITIALIZED))
194 if ((PL_op->op_flags & OPf_SPECIAL) &&
195 !(PL_op->op_flags & OPf_MOD))
197 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
199 && (!is_gv_magical_sv(sv,0)
200 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
206 if (PL_op->op_private & HINT_STRICT_REFS)
207 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
208 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
209 == OPpDONT_INIT_GV) {
210 /* We are the target of a coderef assignment. Return
211 the scalar unchanged, and let pp_sasssign deal with
215 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
219 if (PL_op->op_private & OPpLVAL_INTRO)
220 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
225 /* Helper function for pp_rv2sv and pp_rv2av */
227 Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type,
233 if (PL_op->op_private & HINT_STRICT_REFS) {
235 Perl_die(aTHX_ PL_no_symref_sv, sv, what);
237 Perl_die(aTHX_ PL_no_usym, what);
240 if (PL_op->op_flags & OPf_REF)
241 Perl_die(aTHX_ PL_no_usym, what);
242 if (ckWARN(WARN_UNINITIALIZED))
244 if (type != SVt_PV && GIMME_V == G_ARRAY) {
248 **spp = &PL_sv_undef;
251 if ((PL_op->op_flags & OPf_SPECIAL) &&
252 !(PL_op->op_flags & OPf_MOD))
254 gv = gv_fetchsv(sv, 0, type);
256 && (!is_gv_magical_sv(sv,0)
257 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
259 **spp = &PL_sv_undef;
264 gv = gv_fetchsv(sv, GV_ADD, type);
276 tryAMAGICunDEREF(to_sv);
279 switch (SvTYPE(sv)) {
285 DIE(aTHX_ "Not a SCALAR reference");
292 if (SvTYPE(gv) != SVt_PVGV) {
293 if (SvGMAGICAL(sv)) {
298 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
304 if (PL_op->op_flags & OPf_MOD) {
305 if (PL_op->op_private & OPpLVAL_INTRO) {
306 if (cUNOP->op_first->op_type == OP_NULL)
307 sv = save_scalar((GV*)TOPs);
309 sv = save_scalar(gv);
311 Perl_croak(aTHX_ PL_no_localize_ref);
313 else if (PL_op->op_private & OPpDEREF)
314 vivify_ref(sv, PL_op->op_private & OPpDEREF);
323 AV * const av = (AV*)TOPs;
324 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
326 *sv = newSV_type(SVt_PVMG);
327 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
335 dVAR; dSP; dTARGET; dPOPss;
337 if (PL_op->op_flags & OPf_MOD || LVRET) {
338 if (SvTYPE(TARG) < SVt_PVLV) {
339 sv_upgrade(TARG, SVt_PVLV);
340 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
344 if (LvTARG(TARG) != sv) {
346 SvREFCNT_dec(LvTARG(TARG));
347 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
349 PUSHs(TARG); /* no SvSETMAGIC */
353 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
354 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
355 if (mg && mg->mg_len >= 0) {
359 PUSHi(i + CopARYBASE_get(PL_curcop));
372 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
374 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
377 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
378 /* (But not in defined().) */
380 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
383 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
384 if ((PL_op->op_private & OPpLVAL_INTRO)) {
385 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
388 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
391 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
395 cv = (CV*)&PL_sv_undef;
406 SV *ret = &PL_sv_undef;
408 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
409 const char * s = SvPVX_const(TOPs);
410 if (strnEQ(s, "CORE::", 6)) {
411 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
412 if (code < 0) { /* Overridable. */
413 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
414 int i = 0, n = 0, seen_question = 0, defgv = 0;
416 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
418 if (code == -KEY_chop || code == -KEY_chomp
419 || code == -KEY_exec || code == -KEY_system || code == -KEY_err)
421 if (code == -KEY_mkdir) {
422 ret = sv_2mortal(newSVpvs("_;$"));
425 if (code == -KEY_readpipe) {
426 s = "CORE::backtick";
428 while (i < MAXO) { /* The slow way. */
429 if (strEQ(s + 6, PL_op_name[i])
430 || strEQ(s + 6, PL_op_desc[i]))
436 goto nonesuch; /* Should not happen... */
438 defgv = PL_opargs[i] & OA_DEFGV;
439 oa = PL_opargs[i] >> OASHIFT;
441 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
445 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
446 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
447 /* But globs are already references (kinda) */
448 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
452 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
455 if (defgv && str[n - 1] == '$')
458 ret = sv_2mortal(newSVpvn(str, n - 1));
460 else if (code) /* Non-Overridable */
462 else { /* None such */
464 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
468 cv = sv_2cv(TOPs, &stash, &gv, 0);
470 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
479 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
481 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
497 if (GIMME != G_ARRAY) {
501 *MARK = &PL_sv_undef;
502 *MARK = refto(*MARK);
506 EXTEND_MORTAL(SP - MARK);
508 *MARK = refto(*MARK);
513 S_refto(pTHX_ SV *sv)
518 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
521 if (!(sv = LvTARG(sv)))
524 SvREFCNT_inc_void_NN(sv);
526 else if (SvTYPE(sv) == SVt_PVAV) {
527 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
530 SvREFCNT_inc_void_NN(sv);
532 else if (SvPADTMP(sv) && !IS_PADGV(sv))
536 SvREFCNT_inc_void_NN(sv);
539 sv_upgrade(rv, SVt_RV);
549 SV * const sv = POPs;
554 if (!sv || !SvROK(sv))
557 pv = sv_reftype(SvRV(sv),TRUE);
558 PUSHp(pv, strlen(pv));
568 stash = CopSTASH(PL_curcop);
570 SV * const ssv = POPs;
574 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
575 Perl_croak(aTHX_ "Attempt to bless into a reference");
576 ptr = SvPV_const(ssv,len);
577 if (len == 0 && ckWARN(WARN_MISC))
578 Perl_warner(aTHX_ packWARN(WARN_MISC),
579 "Explicit blessing to '' (assuming package main)");
580 stash = gv_stashpvn(ptr, len, GV_ADD);
583 (void)sv_bless(TOPs, stash);
592 const char * const elem = SvPV_nolen_const(sv);
593 GV * const gv = (GV*)POPs;
598 /* elem will always be NUL terminated. */
599 const char * const second_letter = elem + 1;
602 if (strEQ(second_letter, "RRAY"))
603 tmpRef = (SV*)GvAV(gv);
606 if (strEQ(second_letter, "ODE"))
607 tmpRef = (SV*)GvCVu(gv);
610 if (strEQ(second_letter, "ILEHANDLE")) {
611 /* finally deprecated in 5.8.0 */
612 deprecate("*glob{FILEHANDLE}");
613 tmpRef = (SV*)GvIOp(gv);
616 if (strEQ(second_letter, "ORMAT"))
617 tmpRef = (SV*)GvFORM(gv);
620 if (strEQ(second_letter, "LOB"))
624 if (strEQ(second_letter, "ASH"))
625 tmpRef = (SV*)GvHV(gv);
628 if (*second_letter == 'O' && !elem[2])
629 tmpRef = (SV*)GvIOp(gv);
632 if (strEQ(second_letter, "AME"))
633 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
636 if (strEQ(second_letter, "ACKAGE")) {
637 const HV * const stash = GvSTASH(gv);
638 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
639 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
643 if (strEQ(second_letter, "CALAR"))
658 /* Pattern matching */
663 register unsigned char *s;
666 register I32 *sfirst;
670 if (sv == PL_lastscream) {
674 s = (unsigned char*)(SvPV(sv, len));
676 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
677 /* No point in studying a zero length string, and not safe to study
678 anything that doesn't appear to be a simple scalar (and hence might
679 change between now and when the regexp engine runs without our set
680 magic ever running) such as a reference to an object with overloaded
686 SvSCREAM_off(PL_lastscream);
687 SvREFCNT_dec(PL_lastscream);
689 PL_lastscream = SvREFCNT_inc_simple(sv);
691 s = (unsigned char*)(SvPV(sv, len));
695 if (pos > PL_maxscream) {
696 if (PL_maxscream < 0) {
697 PL_maxscream = pos + 80;
698 Newx(PL_screamfirst, 256, I32);
699 Newx(PL_screamnext, PL_maxscream, I32);
702 PL_maxscream = pos + pos / 4;
703 Renew(PL_screamnext, PL_maxscream, I32);
707 sfirst = PL_screamfirst;
708 snext = PL_screamnext;
710 if (!sfirst || !snext)
711 DIE(aTHX_ "do_study: out of memory");
713 for (ch = 256; ch; --ch)
718 register const I32 ch = s[pos];
720 snext[pos] = sfirst[ch] - pos;
727 /* piggyback on m//g magic */
728 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
737 if (PL_op->op_flags & OPf_STACKED)
739 else if (PL_op->op_private & OPpTARGET_MY)
745 TARG = sv_newmortal();
750 /* Lvalue operators. */
762 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
764 do_chop(TARG, *++MARK);
773 SETi(do_chomp(TOPs));
779 dVAR; dSP; dMARK; dTARGET;
780 register I32 count = 0;
783 count += do_chomp(POPs);
793 if (!PL_op->op_private) {
802 SV_CHECK_THINKFIRST_COW_DROP(sv);
804 switch (SvTYPE(sv)) {
814 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
815 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
816 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
820 /* let user-undef'd sub keep its identity */
821 GV* const gv = CvGV((CV*)sv);
828 SvSetMagicSV(sv, &PL_sv_undef);
833 GvGP(sv) = gp_ref(gp);
835 GvLINE(sv) = CopLINE(PL_curcop);
841 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
856 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
857 DIE(aTHX_ PL_no_modify);
858 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
859 && SvIVX(TOPs) != IV_MIN)
861 SvIV_set(TOPs, SvIVX(TOPs) - 1);
862 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
873 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 sv_setsv(TARG, TOPs);
876 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
877 && SvIVX(TOPs) != IV_MAX)
879 SvIV_set(TOPs, SvIVX(TOPs) + 1);
880 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
885 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
895 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
896 DIE(aTHX_ PL_no_modify);
897 sv_setsv(TARG, TOPs);
898 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
899 && SvIVX(TOPs) != IV_MIN)
901 SvIV_set(TOPs, SvIVX(TOPs) - 1);
902 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
911 /* Ordinary operators. */
916 #ifdef PERL_PRESERVE_IVUV
919 tryAMAGICbin(pow,opASSIGN);
920 #ifdef PERL_PRESERVE_IVUV
921 /* For integer to integer power, we do the calculation by hand wherever
922 we're sure it is safe; otherwise we call pow() and try to convert to
923 integer afterwards. */
936 const IV iv = SvIVX(TOPs);
940 goto float_it; /* Can't do negative powers this way. */
944 baseuok = SvUOK(TOPm1s);
946 baseuv = SvUVX(TOPm1s);
948 const IV iv = SvIVX(TOPm1s);
951 baseuok = TRUE; /* effectively it's a UV now */
953 baseuv = -iv; /* abs, baseuok == false records sign */
956 /* now we have integer ** positive integer. */
959 /* foo & (foo - 1) is zero only for a power of 2. */
960 if (!(baseuv & (baseuv - 1))) {
961 /* We are raising power-of-2 to a positive integer.
962 The logic here will work for any base (even non-integer
963 bases) but it can be less accurate than
964 pow (base,power) or exp (power * log (base)) when the
965 intermediate values start to spill out of the mantissa.
966 With powers of 2 we know this can't happen.
967 And powers of 2 are the favourite thing for perl
968 programmers to notice ** not doing what they mean. */
970 NV base = baseuok ? baseuv : -(NV)baseuv;
975 while (power >>= 1) {
986 register unsigned int highbit = 8 * sizeof(UV);
987 register unsigned int diff = 8 * sizeof(UV);
990 if (baseuv >> highbit) {
994 /* we now have baseuv < 2 ** highbit */
995 if (power * highbit <= 8 * sizeof(UV)) {
996 /* result will definitely fit in UV, so use UV math
997 on same algorithm as above */
998 register UV result = 1;
999 register UV base = baseuv;
1000 const bool odd_power = (bool)(power & 1);
1004 while (power >>= 1) {
1011 if (baseuok || !odd_power)
1012 /* answer is positive */
1014 else if (result <= (UV)IV_MAX)
1015 /* answer negative, fits in IV */
1016 SETi( -(IV)result );
1017 else if (result == (UV)IV_MIN)
1018 /* 2's complement assumption: special case IV_MIN */
1021 /* answer negative, doesn't fit */
1022 SETn( -(NV)result );
1034 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1036 We are building perl with long double support and are on an AIX OS
1037 afflicted with a powl() function that wrongly returns NaNQ for any
1038 negative base. This was reported to IBM as PMR #23047-379 on
1039 03/06/2006. The problem exists in at least the following versions
1040 of AIX and the libm fileset, and no doubt others as well:
1042 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1043 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1044 AIX 5.2.0 bos.adt.libm 5.2.0.85
1046 So, until IBM fixes powl(), we provide the following workaround to
1047 handle the problem ourselves. Our logic is as follows: for
1048 negative bases (left), we use fmod(right, 2) to check if the
1049 exponent is an odd or even integer:
1051 - if odd, powl(left, right) == -powl(-left, right)
1052 - if even, powl(left, right) == powl(-left, right)
1054 If the exponent is not an integer, the result is rightly NaNQ, so
1055 we just return that (as NV_NAN).
1059 NV mod2 = Perl_fmod( right, 2.0 );
1060 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1061 SETn( -Perl_pow( -left, right) );
1062 } else if (mod2 == 0.0) { /* even integer */
1063 SETn( Perl_pow( -left, right) );
1064 } else { /* fractional power */
1068 SETn( Perl_pow( left, right) );
1071 SETn( Perl_pow( left, right) );
1072 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1074 #ifdef PERL_PRESERVE_IVUV
1084 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1085 #ifdef PERL_PRESERVE_IVUV
1088 /* Unless the left argument is integer in range we are going to have to
1089 use NV maths. Hence only attempt to coerce the right argument if
1090 we know the left is integer. */
1091 /* Left operand is defined, so is it IV? */
1092 SvIV_please(TOPm1s);
1093 if (SvIOK(TOPm1s)) {
1094 bool auvok = SvUOK(TOPm1s);
1095 bool buvok = SvUOK(TOPs);
1096 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1097 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1104 alow = SvUVX(TOPm1s);
1106 const IV aiv = SvIVX(TOPm1s);
1109 auvok = TRUE; /* effectively it's a UV now */
1111 alow = -aiv; /* abs, auvok == false records sign */
1117 const IV biv = SvIVX(TOPs);
1120 buvok = TRUE; /* effectively it's a UV now */
1122 blow = -biv; /* abs, buvok == false records sign */
1126 /* If this does sign extension on unsigned it's time for plan B */
1127 ahigh = alow >> (4 * sizeof (UV));
1129 bhigh = blow >> (4 * sizeof (UV));
1131 if (ahigh && bhigh) {
1133 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1134 which is overflow. Drop to NVs below. */
1135 } else if (!ahigh && !bhigh) {
1136 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1137 so the unsigned multiply cannot overflow. */
1138 const UV product = alow * blow;
1139 if (auvok == buvok) {
1140 /* -ve * -ve or +ve * +ve gives a +ve result. */
1144 } else if (product <= (UV)IV_MIN) {
1145 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1146 /* -ve result, which could overflow an IV */
1148 SETi( -(IV)product );
1150 } /* else drop to NVs below. */
1152 /* One operand is large, 1 small */
1155 /* swap the operands */
1157 bhigh = blow; /* bhigh now the temp var for the swap */
1161 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1162 multiplies can't overflow. shift can, add can, -ve can. */
1163 product_middle = ahigh * blow;
1164 if (!(product_middle & topmask)) {
1165 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1167 product_middle <<= (4 * sizeof (UV));
1168 product_low = alow * blow;
1170 /* as for pp_add, UV + something mustn't get smaller.
1171 IIRC ANSI mandates this wrapping *behaviour* for
1172 unsigned whatever the actual representation*/
1173 product_low += product_middle;
1174 if (product_low >= product_middle) {
1175 /* didn't overflow */
1176 if (auvok == buvok) {
1177 /* -ve * -ve or +ve * +ve gives a +ve result. */
1179 SETu( product_low );
1181 } else if (product_low <= (UV)IV_MIN) {
1182 /* 2s complement assumption again */
1183 /* -ve result, which could overflow an IV */
1185 SETi( -(IV)product_low );
1187 } /* else drop to NVs below. */
1189 } /* product_middle too large */
1190 } /* ahigh && bhigh */
1191 } /* SvIOK(TOPm1s) */
1196 SETn( left * right );
1203 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1204 /* Only try to do UV divide first
1205 if ((SLOPPYDIVIDE is true) or
1206 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1208 The assumption is that it is better to use floating point divide
1209 whenever possible, only doing integer divide first if we can't be sure.
1210 If NV_PRESERVES_UV is true then we know at compile time that no UV
1211 can be too large to preserve, so don't need to compile the code to
1212 test the size of UVs. */
1215 # define PERL_TRY_UV_DIVIDE
1216 /* ensure that 20./5. == 4. */
1218 # ifdef PERL_PRESERVE_IVUV
1219 # ifndef NV_PRESERVES_UV
1220 # define PERL_TRY_UV_DIVIDE
1225 #ifdef PERL_TRY_UV_DIVIDE
1228 SvIV_please(TOPm1s);
1229 if (SvIOK(TOPm1s)) {
1230 bool left_non_neg = SvUOK(TOPm1s);
1231 bool right_non_neg = SvUOK(TOPs);
1235 if (right_non_neg) {
1236 right = SvUVX(TOPs);
1239 const IV biv = SvIVX(TOPs);
1242 right_non_neg = TRUE; /* effectively it's a UV now */
1248 /* historically undef()/0 gives a "Use of uninitialized value"
1249 warning before dieing, hence this test goes here.
1250 If it were immediately before the second SvIV_please, then
1251 DIE() would be invoked before left was even inspected, so
1252 no inpsection would give no warning. */
1254 DIE(aTHX_ "Illegal division by zero");
1257 left = SvUVX(TOPm1s);
1260 const IV aiv = SvIVX(TOPm1s);
1263 left_non_neg = TRUE; /* effectively it's a UV now */
1272 /* For sloppy divide we always attempt integer division. */
1274 /* Otherwise we only attempt it if either or both operands
1275 would not be preserved by an NV. If both fit in NVs
1276 we fall through to the NV divide code below. However,
1277 as left >= right to ensure integer result here, we know that
1278 we can skip the test on the right operand - right big
1279 enough not to be preserved can't get here unless left is
1282 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1285 /* Integer division can't overflow, but it can be imprecise. */
1286 const UV result = left / right;
1287 if (result * right == left) {
1288 SP--; /* result is valid */
1289 if (left_non_neg == right_non_neg) {
1290 /* signs identical, result is positive. */
1294 /* 2s complement assumption */
1295 if (result <= (UV)IV_MIN)
1296 SETi( -(IV)result );
1298 /* It's exact but too negative for IV. */
1299 SETn( -(NV)result );
1302 } /* tried integer divide but it was not an integer result */
1303 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1304 } /* left wasn't SvIOK */
1305 } /* right wasn't SvIOK */
1306 #endif /* PERL_TRY_UV_DIVIDE */
1309 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1310 if (! Perl_isnan(right) && right == 0.0)
1314 DIE(aTHX_ "Illegal division by zero");
1315 PUSHn( left / right );
1322 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1326 bool left_neg = FALSE;
1327 bool right_neg = FALSE;
1328 bool use_double = FALSE;
1329 bool dright_valid = FALSE;
1335 right_neg = !SvUOK(TOPs);
1337 right = SvUVX(POPs);
1339 const IV biv = SvIVX(POPs);
1342 right_neg = FALSE; /* effectively it's a UV now */
1350 right_neg = dright < 0;
1353 if (dright < UV_MAX_P1) {
1354 right = U_V(dright);
1355 dright_valid = TRUE; /* In case we need to use double below. */
1361 /* At this point use_double is only true if right is out of range for
1362 a UV. In range NV has been rounded down to nearest UV and
1363 use_double false. */
1365 if (!use_double && SvIOK(TOPs)) {
1367 left_neg = !SvUOK(TOPs);
1371 const IV aiv = SvIVX(POPs);
1374 left_neg = FALSE; /* effectively it's a UV now */
1383 left_neg = dleft < 0;
1387 /* This should be exactly the 5.6 behaviour - if left and right are
1388 both in range for UV then use U_V() rather than floor. */
1390 if (dleft < UV_MAX_P1) {
1391 /* right was in range, so is dleft, so use UVs not double.
1395 /* left is out of range for UV, right was in range, so promote
1396 right (back) to double. */
1398 /* The +0.5 is used in 5.6 even though it is not strictly
1399 consistent with the implicit +0 floor in the U_V()
1400 inside the #if 1. */
1401 dleft = Perl_floor(dleft + 0.5);
1404 dright = Perl_floor(dright + 0.5);
1414 DIE(aTHX_ "Illegal modulus zero");
1416 dans = Perl_fmod(dleft, dright);
1417 if ((left_neg != right_neg) && dans)
1418 dans = dright - dans;
1421 sv_setnv(TARG, dans);
1427 DIE(aTHX_ "Illegal modulus zero");
1430 if ((left_neg != right_neg) && ans)
1433 /* XXX may warn: unary minus operator applied to unsigned type */
1434 /* could change -foo to be (~foo)+1 instead */
1435 if (ans <= ~((UV)IV_MAX)+1)
1436 sv_setiv(TARG, ~ans+1);
1438 sv_setnv(TARG, -(NV)ans);
1441 sv_setuv(TARG, ans);
1450 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1457 const UV uv = SvUV(sv);
1459 count = IV_MAX; /* The best we can do? */
1463 const IV iv = SvIV(sv);
1470 else if (SvNOKp(sv)) {
1471 const NV nv = SvNV(sv);
1479 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1481 static const char oom_list_extend[] = "Out of memory during list extend";
1482 const I32 items = SP - MARK;
1483 const I32 max = items * count;
1485 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1486 /* Did the max computation overflow? */
1487 if (items > 0 && max > 0 && (max < items || max < count))
1488 Perl_croak(aTHX_ oom_list_extend);
1493 /* This code was intended to fix 20010809.028:
1496 for (($x =~ /./g) x 2) {
1497 print chop; # "abcdabcd" expected as output.
1500 * but that change (#11635) broke this code:
1502 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1504 * I can't think of a better fix that doesn't introduce
1505 * an efficiency hit by copying the SVs. The stack isn't
1506 * refcounted, and mortalisation obviously doesn't
1507 * Do The Right Thing when the stack has more than
1508 * one pointer to the same mortal value.
1512 *SP = sv_2mortal(newSVsv(*SP));
1522 repeatcpy((char*)(MARK + items), (char*)MARK,
1523 items * sizeof(SV*), count - 1);
1526 else if (count <= 0)
1529 else { /* Note: mark already snarfed by pp_list */
1530 SV * const tmpstr = POPs;
1533 static const char oom_string_extend[] =
1534 "Out of memory during string extend";
1536 SvSetSV(TARG, tmpstr);
1537 SvPV_force(TARG, len);
1538 isutf = DO_UTF8(TARG);
1543 const STRLEN max = (UV)count * len;
1544 if (len > MEM_SIZE_MAX / count)
1545 Perl_croak(aTHX_ oom_string_extend);
1546 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1547 SvGROW(TARG, max + 1);
1548 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1549 SvCUR_set(TARG, SvCUR(TARG) * count);
1551 *SvEND(TARG) = '\0';
1554 (void)SvPOK_only_UTF8(TARG);
1556 (void)SvPOK_only(TARG);
1558 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1559 /* The parser saw this as a list repeat, and there
1560 are probably several items on the stack. But we're
1561 in scalar context, and there's no pp_list to save us
1562 now. So drop the rest of the items -- robin@kitsite.com
1575 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1576 useleft = USE_LEFT(TOPm1s);
1577 #ifdef PERL_PRESERVE_IVUV
1578 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1579 "bad things" happen if you rely on signed integers wrapping. */
1582 /* Unless the left argument is integer in range we are going to have to
1583 use NV maths. Hence only attempt to coerce the right argument if
1584 we know the left is integer. */
1585 register UV auv = 0;
1591 a_valid = auvok = 1;
1592 /* left operand is undef, treat as zero. */
1594 /* Left operand is defined, so is it IV? */
1595 SvIV_please(TOPm1s);
1596 if (SvIOK(TOPm1s)) {
1597 if ((auvok = SvUOK(TOPm1s)))
1598 auv = SvUVX(TOPm1s);
1600 register const IV aiv = SvIVX(TOPm1s);
1603 auvok = 1; /* Now acting as a sign flag. */
1604 } else { /* 2s complement assumption for IV_MIN */
1612 bool result_good = 0;
1615 bool buvok = SvUOK(TOPs);
1620 register const IV biv = SvIVX(TOPs);
1627 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1628 else "IV" now, independent of how it came in.
1629 if a, b represents positive, A, B negative, a maps to -A etc
1634 all UV maths. negate result if A negative.
1635 subtract if signs same, add if signs differ. */
1637 if (auvok ^ buvok) {
1646 /* Must get smaller */
1651 if (result <= buv) {
1652 /* result really should be -(auv-buv). as its negation
1653 of true value, need to swap our result flag */
1665 if (result <= (UV)IV_MIN)
1666 SETi( -(IV)result );
1668 /* result valid, but out of range for IV. */
1669 SETn( -(NV)result );
1673 } /* Overflow, drop through to NVs. */
1677 useleft = USE_LEFT(TOPm1s);
1681 /* left operand is undef, treat as zero - value */
1685 SETn( TOPn - value );
1692 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1694 const IV shift = POPi;
1695 if (PL_op->op_private & HINT_INTEGER) {
1709 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1711 const IV shift = POPi;
1712 if (PL_op->op_private & HINT_INTEGER) {
1726 dVAR; dSP; tryAMAGICbinSET(lt,0);
1727 #ifdef PERL_PRESERVE_IVUV
1730 SvIV_please(TOPm1s);
1731 if (SvIOK(TOPm1s)) {
1732 bool auvok = SvUOK(TOPm1s);
1733 bool buvok = SvUOK(TOPs);
1735 if (!auvok && !buvok) { /* ## IV < IV ## */
1736 const IV aiv = SvIVX(TOPm1s);
1737 const IV biv = SvIVX(TOPs);
1740 SETs(boolSV(aiv < biv));
1743 if (auvok && buvok) { /* ## UV < UV ## */
1744 const UV auv = SvUVX(TOPm1s);
1745 const UV buv = SvUVX(TOPs);
1748 SETs(boolSV(auv < buv));
1751 if (auvok) { /* ## UV < IV ## */
1753 const IV biv = SvIVX(TOPs);
1756 /* As (a) is a UV, it's >=0, so it cannot be < */
1761 SETs(boolSV(auv < (UV)biv));
1764 { /* ## IV < UV ## */
1765 const IV aiv = SvIVX(TOPm1s);
1769 /* As (b) is a UV, it's >=0, so it must be < */
1776 SETs(boolSV((UV)aiv < buv));
1782 #ifndef NV_PRESERVES_UV
1783 #ifdef PERL_PRESERVE_IVUV
1786 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1788 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1793 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1795 if (Perl_isnan(left) || Perl_isnan(right))
1797 SETs(boolSV(left < right));
1800 SETs(boolSV(TOPn < value));
1808 dVAR; dSP; tryAMAGICbinSET(gt,0);
1809 #ifdef PERL_PRESERVE_IVUV
1812 SvIV_please(TOPm1s);
1813 if (SvIOK(TOPm1s)) {
1814 bool auvok = SvUOK(TOPm1s);
1815 bool buvok = SvUOK(TOPs);
1817 if (!auvok && !buvok) { /* ## IV > IV ## */
1818 const IV aiv = SvIVX(TOPm1s);
1819 const IV biv = SvIVX(TOPs);
1822 SETs(boolSV(aiv > biv));
1825 if (auvok && buvok) { /* ## UV > UV ## */
1826 const UV auv = SvUVX(TOPm1s);
1827 const UV buv = SvUVX(TOPs);
1830 SETs(boolSV(auv > buv));
1833 if (auvok) { /* ## UV > IV ## */
1835 const IV biv = SvIVX(TOPs);
1839 /* As (a) is a UV, it's >=0, so it must be > */
1844 SETs(boolSV(auv > (UV)biv));
1847 { /* ## IV > UV ## */
1848 const IV aiv = SvIVX(TOPm1s);
1852 /* As (b) is a UV, it's >=0, so it cannot be > */
1859 SETs(boolSV((UV)aiv > buv));
1865 #ifndef NV_PRESERVES_UV
1866 #ifdef PERL_PRESERVE_IVUV
1869 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1871 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1876 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1878 if (Perl_isnan(left) || Perl_isnan(right))
1880 SETs(boolSV(left > right));
1883 SETs(boolSV(TOPn > value));
1891 dVAR; dSP; tryAMAGICbinSET(le,0);
1892 #ifdef PERL_PRESERVE_IVUV
1895 SvIV_please(TOPm1s);
1896 if (SvIOK(TOPm1s)) {
1897 bool auvok = SvUOK(TOPm1s);
1898 bool buvok = SvUOK(TOPs);
1900 if (!auvok && !buvok) { /* ## IV <= IV ## */
1901 const IV aiv = SvIVX(TOPm1s);
1902 const IV biv = SvIVX(TOPs);
1905 SETs(boolSV(aiv <= biv));
1908 if (auvok && buvok) { /* ## UV <= UV ## */
1909 UV auv = SvUVX(TOPm1s);
1910 UV buv = SvUVX(TOPs);
1913 SETs(boolSV(auv <= buv));
1916 if (auvok) { /* ## UV <= IV ## */
1918 const IV biv = SvIVX(TOPs);
1922 /* As (a) is a UV, it's >=0, so a cannot be <= */
1927 SETs(boolSV(auv <= (UV)biv));
1930 { /* ## IV <= UV ## */
1931 const IV aiv = SvIVX(TOPm1s);
1935 /* As (b) is a UV, it's >=0, so a must be <= */
1942 SETs(boolSV((UV)aiv <= buv));
1948 #ifndef NV_PRESERVES_UV
1949 #ifdef PERL_PRESERVE_IVUV
1952 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1954 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1959 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1961 if (Perl_isnan(left) || Perl_isnan(right))
1963 SETs(boolSV(left <= right));
1966 SETs(boolSV(TOPn <= value));
1974 dVAR; dSP; tryAMAGICbinSET(ge,0);
1975 #ifdef PERL_PRESERVE_IVUV
1978 SvIV_please(TOPm1s);
1979 if (SvIOK(TOPm1s)) {
1980 bool auvok = SvUOK(TOPm1s);
1981 bool buvok = SvUOK(TOPs);
1983 if (!auvok && !buvok) { /* ## IV >= IV ## */
1984 const IV aiv = SvIVX(TOPm1s);
1985 const IV biv = SvIVX(TOPs);
1988 SETs(boolSV(aiv >= biv));
1991 if (auvok && buvok) { /* ## UV >= UV ## */
1992 const UV auv = SvUVX(TOPm1s);
1993 const UV buv = SvUVX(TOPs);
1996 SETs(boolSV(auv >= buv));
1999 if (auvok) { /* ## UV >= IV ## */
2001 const IV biv = SvIVX(TOPs);
2005 /* As (a) is a UV, it's >=0, so it must be >= */
2010 SETs(boolSV(auv >= (UV)biv));
2013 { /* ## IV >= UV ## */
2014 const IV aiv = SvIVX(TOPm1s);
2018 /* As (b) is a UV, it's >=0, so a cannot be >= */
2025 SETs(boolSV((UV)aiv >= buv));
2031 #ifndef NV_PRESERVES_UV
2032 #ifdef PERL_PRESERVE_IVUV
2035 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2037 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2042 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2044 if (Perl_isnan(left) || Perl_isnan(right))
2046 SETs(boolSV(left >= right));
2049 SETs(boolSV(TOPn >= value));
2057 dVAR; dSP; tryAMAGICbinSET(ne,0);
2058 #ifndef NV_PRESERVES_UV
2059 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2061 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2065 #ifdef PERL_PRESERVE_IVUV
2068 SvIV_please(TOPm1s);
2069 if (SvIOK(TOPm1s)) {
2070 const bool auvok = SvUOK(TOPm1s);
2071 const bool buvok = SvUOK(TOPs);
2073 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2074 /* Casting IV to UV before comparison isn't going to matter
2075 on 2s complement. On 1s complement or sign&magnitude
2076 (if we have any of them) it could make negative zero
2077 differ from normal zero. As I understand it. (Need to
2078 check - is negative zero implementation defined behaviour
2080 const UV buv = SvUVX(POPs);
2081 const UV auv = SvUVX(TOPs);
2083 SETs(boolSV(auv != buv));
2086 { /* ## Mixed IV,UV ## */
2090 /* != is commutative so swap if needed (save code) */
2092 /* swap. top of stack (b) is the iv */
2096 /* As (a) is a UV, it's >0, so it cannot be == */
2105 /* As (b) is a UV, it's >0, so it cannot be == */
2109 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2111 SETs(boolSV((UV)iv != uv));
2118 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2120 if (Perl_isnan(left) || Perl_isnan(right))
2122 SETs(boolSV(left != right));
2125 SETs(boolSV(TOPn != value));
2133 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2134 #ifndef NV_PRESERVES_UV
2135 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2136 const UV right = PTR2UV(SvRV(POPs));
2137 const UV left = PTR2UV(SvRV(TOPs));
2138 SETi((left > right) - (left < right));
2142 #ifdef PERL_PRESERVE_IVUV
2143 /* Fortunately it seems NaN isn't IOK */
2146 SvIV_please(TOPm1s);
2147 if (SvIOK(TOPm1s)) {
2148 const bool leftuvok = SvUOK(TOPm1s);
2149 const bool rightuvok = SvUOK(TOPs);
2151 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2152 const IV leftiv = SvIVX(TOPm1s);
2153 const IV rightiv = SvIVX(TOPs);
2155 if (leftiv > rightiv)
2157 else if (leftiv < rightiv)
2161 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2162 const UV leftuv = SvUVX(TOPm1s);
2163 const UV rightuv = SvUVX(TOPs);
2165 if (leftuv > rightuv)
2167 else if (leftuv < rightuv)
2171 } else if (leftuvok) { /* ## UV <=> IV ## */
2172 const IV rightiv = SvIVX(TOPs);
2174 /* As (a) is a UV, it's >=0, so it cannot be < */
2177 const UV leftuv = SvUVX(TOPm1s);
2178 if (leftuv > (UV)rightiv) {
2180 } else if (leftuv < (UV)rightiv) {
2186 } else { /* ## IV <=> UV ## */
2187 const IV leftiv = SvIVX(TOPm1s);
2189 /* As (b) is a UV, it's >=0, so it must be < */
2192 const UV rightuv = SvUVX(TOPs);
2193 if ((UV)leftiv > rightuv) {
2195 } else if ((UV)leftiv < rightuv) {
2213 if (Perl_isnan(left) || Perl_isnan(right)) {
2217 value = (left > right) - (left < right);
2221 else if (left < right)
2223 else if (left > right)
2239 int amg_type = sle_amg;
2243 switch (PL_op->op_type) {
2262 tryAMAGICbinSET_var(amg_type,0);
2265 const int cmp = (IN_LOCALE_RUNTIME
2266 ? sv_cmp_locale(left, right)
2267 : sv_cmp(left, right));
2268 SETs(boolSV(cmp * multiplier < rhs));
2275 dVAR; dSP; tryAMAGICbinSET(seq,0);
2278 SETs(boolSV(sv_eq(left, right)));
2285 dVAR; dSP; tryAMAGICbinSET(sne,0);
2288 SETs(boolSV(!sv_eq(left, right)));
2295 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2298 const int cmp = (IN_LOCALE_RUNTIME
2299 ? sv_cmp_locale(left, right)
2300 : sv_cmp(left, right));
2308 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2313 if (SvNIOKp(left) || SvNIOKp(right)) {
2314 if (PL_op->op_private & HINT_INTEGER) {
2315 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2319 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2324 do_vop(PL_op->op_type, TARG, left, right);
2333 dVAR; dSP; dATARGET;
2334 const int op_type = PL_op->op_type;
2336 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2341 if (SvNIOKp(left) || SvNIOKp(right)) {
2342 if (PL_op->op_private & HINT_INTEGER) {
2343 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2344 const IV r = SvIV_nomg(right);
2345 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2349 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2350 const UV r = SvUV_nomg(right);
2351 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2356 do_vop(op_type, TARG, left, right);
2365 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2368 const int flags = SvFLAGS(sv);
2370 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2371 /* It's publicly an integer, or privately an integer-not-float */
2374 if (SvIVX(sv) == IV_MIN) {
2375 /* 2s complement assumption. */
2376 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2379 else if (SvUVX(sv) <= IV_MAX) {
2384 else if (SvIVX(sv) != IV_MIN) {
2388 #ifdef PERL_PRESERVE_IVUV
2397 else if (SvPOKp(sv)) {
2399 const char * const s = SvPV_const(sv, len);
2400 if (isIDFIRST(*s)) {
2401 sv_setpvn(TARG, "-", 1);
2404 else if (*s == '+' || *s == '-') {
2406 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2408 else if (DO_UTF8(sv)) {
2411 goto oops_its_an_int;
2413 sv_setnv(TARG, -SvNV(sv));
2415 sv_setpvn(TARG, "-", 1);
2422 goto oops_its_an_int;
2423 sv_setnv(TARG, -SvNV(sv));
2435 dVAR; dSP; tryAMAGICunSET(not);
2436 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2442 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2447 if (PL_op->op_private & HINT_INTEGER) {
2448 const IV i = ~SvIV_nomg(sv);
2452 const UV u = ~SvUV_nomg(sv);
2461 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2462 sv_setsv_nomg(TARG, sv);
2463 tmps = (U8*)SvPV_force(TARG, len);
2466 /* Calculate exact length, let's not estimate. */
2471 U8 * const send = tmps + len;
2472 U8 * const origtmps = tmps;
2473 const UV utf8flags = UTF8_ALLOW_ANYUV;
2475 while (tmps < send) {
2476 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2478 targlen += UNISKIP(~c);
2484 /* Now rewind strings and write them. */
2491 Newx(result, targlen + 1, U8);
2493 while (tmps < send) {
2494 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2496 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2499 sv_usepvn_flags(TARG, (char*)result, targlen,
2500 SV_HAS_TRAILING_NUL);
2507 Newx(result, nchar + 1, U8);
2509 while (tmps < send) {
2510 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2515 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2523 register long *tmpl;
2524 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2527 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2532 for ( ; anum > 0; anum--, tmps++)
2541 /* integer versions of some of the above */
2545 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2548 SETi( left * right );
2556 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2560 DIE(aTHX_ "Illegal division by zero");
2563 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2567 value = num / value;
2573 #if defined(__GLIBC__) && IVSIZE == 8
2580 /* This is the vanilla old i_modulo. */
2581 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2585 DIE(aTHX_ "Illegal modulus zero");
2586 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2590 SETi( left % right );
2595 #if defined(__GLIBC__) && IVSIZE == 8
2600 /* This is the i_modulo with the workaround for the _moddi3 bug
2601 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2602 * See below for pp_i_modulo. */
2603 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2607 DIE(aTHX_ "Illegal modulus zero");
2608 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2612 SETi( left % PERL_ABS(right) );
2619 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2623 DIE(aTHX_ "Illegal modulus zero");
2624 /* The assumption is to use hereafter the old vanilla version... */
2626 PL_ppaddr[OP_I_MODULO] =
2628 /* .. but if we have glibc, we might have a buggy _moddi3
2629 * (at least glicb 2.2.5 is known to have this bug), in other
2630 * words our integer modulus with negative quad as the second
2631 * argument might be broken. Test for this and re-patch the
2632 * opcode dispatch table if that is the case, remembering to
2633 * also apply the workaround so that this first round works
2634 * right, too. See [perl #9402] for more information. */
2638 /* Cannot do this check with inlined IV constants since
2639 * that seems to work correctly even with the buggy glibc. */
2641 /* Yikes, we have the bug.
2642 * Patch in the workaround version. */
2644 PL_ppaddr[OP_I_MODULO] =
2645 &Perl_pp_i_modulo_1;
2646 /* Make certain we work right this time, too. */
2647 right = PERL_ABS(right);
2650 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2654 SETi( left % right );
2662 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2665 SETi( left + right );
2672 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2675 SETi( left - right );
2682 dVAR; dSP; tryAMAGICbinSET(lt,0);
2685 SETs(boolSV(left < right));
2692 dVAR; dSP; tryAMAGICbinSET(gt,0);
2695 SETs(boolSV(left > right));
2702 dVAR; dSP; tryAMAGICbinSET(le,0);
2705 SETs(boolSV(left <= right));
2712 dVAR; dSP; tryAMAGICbinSET(ge,0);
2715 SETs(boolSV(left >= right));
2722 dVAR; dSP; tryAMAGICbinSET(eq,0);
2725 SETs(boolSV(left == right));
2732 dVAR; dSP; tryAMAGICbinSET(ne,0);
2735 SETs(boolSV(left != right));
2742 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2749 else if (left < right)
2760 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2765 /* High falutin' math. */
2769 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2772 SETn(Perl_atan2(left, right));
2780 int amg_type = sin_amg;
2781 const char *neg_report = NULL;
2782 NV (*func)(NV) = Perl_sin;
2783 const int op_type = PL_op->op_type;
2800 amg_type = sqrt_amg;
2802 neg_report = "sqrt";
2806 tryAMAGICun_var(amg_type);
2808 const NV value = POPn;
2810 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2811 SET_NUMERIC_STANDARD();
2812 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2815 XPUSHn(func(value));
2820 /* Support Configure command-line overrides for rand() functions.
2821 After 5.005, perhaps we should replace this by Configure support
2822 for drand48(), random(), or rand(). For 5.005, though, maintain
2823 compatibility by calling rand() but allow the user to override it.
2824 See INSTALL for details. --Andy Dougherty 15 July 1998
2826 /* Now it's after 5.005, and Configure supports drand48() and random(),
2827 in addition to rand(). So the overrides should not be needed any more.
2828 --Jarkko Hietaniemi 27 September 1998
2831 #ifndef HAS_DRAND48_PROTO
2832 extern double drand48 (void);
2845 if (!PL_srand_called) {
2846 (void)seedDrand01((Rand_seed_t)seed());
2847 PL_srand_called = TRUE;
2857 const UV anum = (MAXARG < 1) ? seed() : POPu;
2858 (void)seedDrand01((Rand_seed_t)anum);
2859 PL_srand_called = TRUE;
2866 dVAR; dSP; dTARGET; tryAMAGICun(int);
2868 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2869 /* XXX it's arguable that compiler casting to IV might be subtly
2870 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2871 else preferring IV has introduced a subtle behaviour change bug. OTOH
2872 relying on floating point to be accurate is a bug. */
2876 else if (SvIOK(TOPs)) {
2883 const NV value = TOPn;
2885 if (value < (NV)UV_MAX + 0.5) {
2888 SETn(Perl_floor(value));
2892 if (value > (NV)IV_MIN - 0.5) {
2895 SETn(Perl_ceil(value));
2905 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2907 /* This will cache the NV value if string isn't actually integer */
2912 else if (SvIOK(TOPs)) {
2913 /* IVX is precise */
2915 SETu(TOPu); /* force it to be numeric only */
2923 /* 2s complement assumption. Also, not really needed as
2924 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2930 const NV value = TOPn;
2944 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2948 SV* const sv = POPs;
2950 tmps = (SvPV_const(sv, len));
2952 /* If Unicode, try to downgrade
2953 * If not possible, croak. */
2954 SV* const tsv = sv_2mortal(newSVsv(sv));
2957 sv_utf8_downgrade(tsv, FALSE);
2958 tmps = SvPV_const(tsv, len);
2960 if (PL_op->op_type == OP_HEX)
2963 while (*tmps && len && isSPACE(*tmps))
2969 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2971 else if (*tmps == 'b')
2972 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2974 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2976 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2990 SV * const sv = TOPs;
2993 /* For an overloaded scalar, we can't know in advance if it's going to
2994 be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2995 cache the length. Maybe that should be a documented feature of it.
2998 const char *const p = SvPV_const(sv, len);
3001 SETi(utf8_length((U8*)p, (U8*)p + len));
3007 else if (DO_UTF8(sv))
3008 SETi(sv_len_utf8(sv));
3024 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3026 const I32 arybase = CopARYBASE_get(PL_curcop);
3028 const char *repl = NULL;
3030 const int num_args = PL_op->op_private & 7;
3031 bool repl_need_utf8_upgrade = FALSE;
3032 bool repl_is_utf8 = FALSE;
3034 SvTAINTED_off(TARG); /* decontaminate */
3035 SvUTF8_off(TARG); /* decontaminate */
3039 repl = SvPV_const(repl_sv, repl_len);
3040 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3050 sv_utf8_upgrade(sv);
3052 else if (DO_UTF8(sv))
3053 repl_need_utf8_upgrade = TRUE;
3055 tmps = SvPV_const(sv, curlen);
3057 utf8_curlen = sv_len_utf8(sv);
3058 if (utf8_curlen == curlen)
3061 curlen = utf8_curlen;
3066 if (pos >= arybase) {
3084 else if (len >= 0) {
3086 if (rem > (I32)curlen)
3101 Perl_croak(aTHX_ "substr outside of string");
3102 if (ckWARN(WARN_SUBSTR))
3103 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3107 const I32 upos = pos;
3108 const I32 urem = rem;
3110 sv_pos_u2b(sv, &pos, &rem);
3112 /* we either return a PV or an LV. If the TARG hasn't been used
3113 * before, or is of that type, reuse it; otherwise use a mortal
3114 * instead. Note that LVs can have an extended lifetime, so also
3115 * dont reuse if refcount > 1 (bug #20933) */
3116 if (SvTYPE(TARG) > SVt_NULL) {
3117 if ( (SvTYPE(TARG) == SVt_PVLV)
3118 ? (!lvalue || SvREFCNT(TARG) > 1)
3121 TARG = sv_newmortal();
3125 sv_setpvn(TARG, tmps, rem);
3126 #ifdef USE_LOCALE_COLLATE
3127 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3132 SV* repl_sv_copy = NULL;
3134 if (repl_need_utf8_upgrade) {
3135 repl_sv_copy = newSVsv(repl_sv);
3136 sv_utf8_upgrade(repl_sv_copy);
3137 repl = SvPV_const(repl_sv_copy, repl_len);
3138 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3140 sv_insert(sv, pos, rem, repl, repl_len);
3144 SvREFCNT_dec(repl_sv_copy);
3146 else if (lvalue) { /* it's an lvalue! */
3147 if (!SvGMAGICAL(sv)) {
3149 SvPV_force_nolen(sv);
3150 if (ckWARN(WARN_SUBSTR))
3151 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3152 "Attempt to use reference as lvalue in substr");
3154 if (isGV_with_GP(sv))
3155 SvPV_force_nolen(sv);
3156 else if (SvOK(sv)) /* is it defined ? */
3157 (void)SvPOK_only_UTF8(sv);
3159 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3162 if (SvTYPE(TARG) < SVt_PVLV) {
3163 sv_upgrade(TARG, SVt_PVLV);
3164 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3168 if (LvTARG(TARG) != sv) {
3170 SvREFCNT_dec(LvTARG(TARG));
3171 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3173 LvTARGOFF(TARG) = upos;
3174 LvTARGLEN(TARG) = urem;
3178 PUSHs(TARG); /* avoid SvSETMAGIC here */
3185 register const IV size = POPi;
3186 register const IV offset = POPi;
3187 register SV * const src = POPs;
3188 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3190 SvTAINTED_off(TARG); /* decontaminate */
3191 if (lvalue) { /* it's an lvalue! */
3192 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3193 TARG = sv_newmortal();
3194 if (SvTYPE(TARG) < SVt_PVLV) {
3195 sv_upgrade(TARG, SVt_PVLV);
3196 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3199 if (LvTARG(TARG) != src) {
3201 SvREFCNT_dec(LvTARG(TARG));
3202 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3204 LvTARGOFF(TARG) = offset;
3205 LvTARGLEN(TARG) = size;
3208 sv_setuv(TARG, do_vecget(src, offset, size));
3224 const char *little_p;
3225 const I32 arybase = CopARYBASE_get(PL_curcop);
3228 const bool is_index = PL_op->op_type == OP_INDEX;
3231 /* arybase is in characters, like offset, so combine prior to the
3232 UTF-8 to bytes calculation. */
3233 offset = POPi - arybase;
3237 big_p = SvPV_const(big, biglen);
3238 little_p = SvPV_const(little, llen);
3240 big_utf8 = DO_UTF8(big);
3241 little_utf8 = DO_UTF8(little);
3242 if (big_utf8 ^ little_utf8) {
3243 /* One needs to be upgraded. */
3244 if (little_utf8 && !PL_encoding) {
3245 /* Well, maybe instead we might be able to downgrade the small
3247 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3250 /* If the large string is ISO-8859-1, and it's not possible to
3251 convert the small string to ISO-8859-1, then there is no
3252 way that it could be found anywhere by index. */
3257 /* At this point, pv is a malloc()ed string. So donate it to temp
3258 to ensure it will get free()d */
3259 little = temp = newSV(0);
3260 sv_usepvn(temp, pv, llen);
3261 little_p = SvPVX(little);
3264 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3267 sv_recode_to_utf8(temp, PL_encoding);
3269 sv_utf8_upgrade(temp);
3274 big_p = SvPV_const(big, biglen);
3277 little_p = SvPV_const(little, llen);
3281 if (SvGAMAGIC(big)) {
3282 /* Life just becomes a lot easier if I use a temporary here.
3283 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3284 will trigger magic and overloading again, as will fbm_instr()
3286 big = sv_2mortal(newSVpvn(big_p, biglen));
3291 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3292 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3293 warn on undef, and we've already triggered a warning with the
3294 SvPV_const some lines above. We can't remove that, as we need to
3295 call some SvPV to trigger overloading early and find out if the
3297 This is all getting to messy. The API isn't quite clean enough,
3298 because data access has side effects.
3300 little = sv_2mortal(newSVpvn(little_p, llen));
3303 little_p = SvPVX(little);
3307 offset = is_index ? 0 : biglen;
3309 if (big_utf8 && offset > 0)
3310 sv_pos_u2b(big, &offset, 0);
3316 else if (offset > (I32)biglen)
3318 if (!(little_p = is_index
3319 ? fbm_instr((unsigned char*)big_p + offset,
3320 (unsigned char*)big_p + biglen, little, 0)
3321 : rninstr(big_p, big_p + offset,
3322 little_p, little_p + llen)))
3325 retval = little_p - big_p;
3326 if (retval > 0 && big_utf8)
3327 sv_pos_b2u(big, &retval);
3332 PUSHi(retval + arybase);
3338 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3339 if (SvTAINTED(MARK[1]))
3340 TAINT_PROPER("sprintf");
3341 do_sprintf(TARG, SP-MARK, MARK+1);
3342 TAINT_IF(SvTAINTED(TARG));
3354 const U8 *s = (U8*)SvPV_const(argsv, len);
3356 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3357 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3358 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3362 XPUSHu(DO_UTF8(argsv) ?
3363 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3375 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3377 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3379 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3381 (void) POPs; /* Ignore the argument value. */
3382 value = UNICODE_REPLACEMENT;
3388 SvUPGRADE(TARG,SVt_PV);
3390 if (value > 255 && !IN_BYTES) {
3391 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3392 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3393 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3395 (void)SvPOK_only(TARG);
3404 *tmps++ = (char)value;
3406 (void)SvPOK_only(TARG);
3408 if (PL_encoding && !IN_BYTES) {
3409 sv_recode_to_utf8(TARG, PL_encoding);
3411 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3412 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3416 *tmps++ = (char)value;
3432 const char *tmps = SvPV_const(left, len);
3434 if (DO_UTF8(left)) {
3435 /* If Unicode, try to downgrade.
3436 * If not possible, croak.
3437 * Yes, we made this up. */
3438 SV* const tsv = sv_2mortal(newSVsv(left));
3441 sv_utf8_downgrade(tsv, FALSE);
3442 tmps = SvPV_const(tsv, len);
3444 # ifdef USE_ITHREADS
3446 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3447 /* This should be threadsafe because in ithreads there is only
3448 * one thread per interpreter. If this would not be true,
3449 * we would need a mutex to protect this malloc. */
3450 PL_reentrant_buffer->_crypt_struct_buffer =
3451 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3452 #if defined(__GLIBC__) || defined(__EMX__)
3453 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3454 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3455 /* work around glibc-2.2.5 bug */
3456 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3460 # endif /* HAS_CRYPT_R */
3461 # endif /* USE_ITHREADS */
3463 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3465 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3471 "The crypt() function is unimplemented due to excessive paranoia.");
3483 bool inplace = TRUE;
3485 const int op_type = PL_op->op_type;
3488 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3494 s = (const U8*)SvPV_nomg_const(source, slen);
3500 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3502 utf8_to_uvchr(s, &ulen);
3503 if (op_type == OP_UCFIRST) {
3504 toTITLE_utf8(s, tmpbuf, &tculen);
3506 toLOWER_utf8(s, tmpbuf, &tculen);
3508 /* If the two differ, we definately cannot do inplace. */
3509 inplace = (ulen == tculen);
3510 need = slen + 1 - ulen + tculen;
3516 if (SvPADTMP(source) && !SvREADONLY(source) && inplace) {
3517 /* We can convert in place. */
3520 s = d = (U8*)SvPV_force_nomg(source, slen);
3526 SvUPGRADE(dest, SVt_PV);
3527 d = (U8*)SvGROW(dest, need);
3528 (void)SvPOK_only(dest);
3537 /* slen is the byte length of the whole SV.
3538 * ulen is the byte length of the original Unicode character
3539 * stored as UTF-8 at s.
3540 * tculen is the byte length of the freshly titlecased (or
3541 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3542 * We first set the result to be the titlecased (/lowercased)
3543 * character, and then append the rest of the SV data. */
3544 sv_setpvn(dest, (char*)tmpbuf, tculen);
3546 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3550 Copy(tmpbuf, d, tculen, U8);
3551 SvCUR_set(dest, need - 1);
3556 if (IN_LOCALE_RUNTIME) {
3559 *d = (op_type == OP_UCFIRST)
3560 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3563 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3565 /* See bug #39028 */
3573 /* This will copy the trailing NUL */
3574 Copy(s + 1, d + 1, slen, U8);
3575 SvCUR_set(dest, need - 1);
3582 /* There's so much setup/teardown code common between uc and lc, I wonder if
3583 it would be worth merging the two, and just having a switch outside each
3584 of the three tight loops. */
3598 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3599 && !DO_UTF8(source)) {
3600 /* We can convert in place. */
3603 s = d = (U8*)SvPV_force_nomg(source, len);
3610 /* The old implementation would copy source into TARG at this point.
3611 This had the side effect that if source was undef, TARG was now
3612 an undefined SV with PADTMP set, and they don't warn inside
3613 sv_2pv_flags(). However, we're now getting the PV direct from
3614 source, which doesn't have PADTMP set, so it would warn. Hence the
3618 s = (const U8*)SvPV_nomg_const(source, len);
3625 SvUPGRADE(dest, SVt_PV);
3626 d = (U8*)SvGROW(dest, min);
3627 (void)SvPOK_only(dest);
3632 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3633 to check DO_UTF8 again here. */
3635 if (DO_UTF8(source)) {
3636 const U8 *const send = s + len;
3637 U8 tmpbuf[UTF8_MAXBYTES+1];
3640 const STRLEN u = UTF8SKIP(s);
3643 toUPPER_utf8(s, tmpbuf, &ulen);
3644 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3645 /* If the eventually required minimum size outgrows
3646 * the available space, we need to grow. */
3647 const UV o = d - (U8*)SvPVX_const(dest);
3649 /* If someone uppercases one million U+03B0s we SvGROW() one
3650 * million times. Or we could try guessing how much to
3651 allocate without allocating too much. Such is life. */
3653 d = (U8*)SvPVX(dest) + o;
3655 Copy(tmpbuf, d, ulen, U8);
3661 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3664 const U8 *const send = s + len;
3665 if (IN_LOCALE_RUNTIME) {
3668 for (; s < send; d++, s++)
3669 *d = toUPPER_LC(*s);
3672 for (; s < send; d++, s++)
3676 if (source != dest) {
3678 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3698 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3699 && !DO_UTF8(source)) {
3700 /* We can convert in place. */
3703 s = d = (U8*)SvPV_force_nomg(source, len);
3710 /* The old implementation would copy source into TARG at this point.
3711 This had the side effect that if source was undef, TARG was now
3712 an undefined SV with PADTMP set, and they don't warn inside
3713 sv_2pv_flags(). However, we're now getting the PV direct from
3714 source, which doesn't have PADTMP set, so it would warn. Hence the
3718 s = (const U8*)SvPV_nomg_const(source, len);
3725 SvUPGRADE(dest, SVt_PV);
3726 d = (U8*)SvGROW(dest, min);
3727 (void)SvPOK_only(dest);
3732 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3733 to check DO_UTF8 again here. */
3735 if (DO_UTF8(source)) {
3736 const U8 *const send = s + len;
3737 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3740 const STRLEN u = UTF8SKIP(s);
3742 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3744 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3745 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3748 * Now if the sigma is NOT followed by
3749 * /$ignorable_sequence$cased_letter/;
3750 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3751 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3752 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3753 * then it should be mapped to 0x03C2,
3754 * (GREEK SMALL LETTER FINAL SIGMA),
3755 * instead of staying 0x03A3.
3756 * "should be": in other words, this is not implemented yet.
3757 * See lib/unicore/SpecialCasing.txt.
3760 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3761 /* If the eventually required minimum size outgrows
3762 * the available space, we need to grow. */
3763 const UV o = d - (U8*)SvPVX_const(dest);
3765 /* If someone lowercases one million U+0130s we SvGROW() one
3766 * million times. Or we could try guessing how much to
3767 allocate without allocating too much. Such is life. */
3769 d = (U8*)SvPVX(dest) + o;
3771 Copy(tmpbuf, d, ulen, U8);
3777 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3780 const U8 *const send = s + len;
3781 if (IN_LOCALE_RUNTIME) {
3784 for (; s < send; d++, s++)
3785 *d = toLOWER_LC(*s);
3788 for (; s < send; d++, s++)
3792 if (source != dest) {
3794 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3804 SV * const sv = TOPs;
3806 register const char *s = SvPV_const(sv,len);
3808 SvUTF8_off(TARG); /* decontaminate */
3811 SvUPGRADE(TARG, SVt_PV);
3812 SvGROW(TARG, (len * 2) + 1);
3816 if (UTF8_IS_CONTINUED(*s)) {
3817 STRLEN ulen = UTF8SKIP(s);
3841 SvCUR_set(TARG, d - SvPVX_const(TARG));
3842 (void)SvPOK_only_UTF8(TARG);
3845 sv_setpvn(TARG, s, len);
3847 if (SvSMAGICAL(TARG))
3856 dVAR; dSP; dMARK; dORIGMARK;
3857 register AV* const av = (AV*)POPs;
3858 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3860 if (SvTYPE(av) == SVt_PVAV) {
3861 const I32 arybase = CopARYBASE_get(PL_curcop);
3862 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3865 for (svp = MARK + 1; svp <= SP; svp++) {
3866 const I32 elem = SvIV(*svp);
3870 if (max > AvMAX(av))
3873 while (++MARK <= SP) {
3875 I32 elem = SvIV(*MARK);
3879 svp = av_fetch(av, elem, lval);
3881 if (!svp || *svp == &PL_sv_undef)
3882 DIE(aTHX_ PL_no_aelem, elem);
3883 if (PL_op->op_private & OPpLVAL_INTRO)
3884 save_aelem(av, elem, svp);
3886 *MARK = svp ? *svp : &PL_sv_undef;
3889 if (GIMME != G_ARRAY) {
3891 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3897 /* Associative arrays. */
3903 HV * hash = (HV*)POPs;
3905 const I32 gimme = GIMME_V;
3908 /* might clobber stack_sp */
3909 entry = hv_iternext(hash);
3914 SV* const sv = hv_iterkeysv(entry);
3915 PUSHs(sv); /* won't clobber stack_sp */
3916 if (gimme == G_ARRAY) {
3919 /* might clobber stack_sp */
3920 val = hv_iterval(hash, entry);
3925 else if (gimme == G_SCALAR)
3935 const I32 gimme = GIMME_V;
3936 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3938 if (PL_op->op_private & OPpSLICE) {
3940 HV * const hv = (HV*)POPs;
3941 const U32 hvtype = SvTYPE(hv);
3942 if (hvtype == SVt_PVHV) { /* hash element */
3943 while (++MARK <= SP) {
3944 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3945 *MARK = sv ? sv : &PL_sv_undef;
3948 else if (hvtype == SVt_PVAV) { /* array element */
3949 if (PL_op->op_flags & OPf_SPECIAL) {
3950 while (++MARK <= SP) {
3951 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3952 *MARK = sv ? sv : &PL_sv_undef;
3957 DIE(aTHX_ "Not a HASH reference");
3960 else if (gimme == G_SCALAR) {
3965 *++MARK = &PL_sv_undef;
3971 HV * const hv = (HV*)POPs;
3973 if (SvTYPE(hv) == SVt_PVHV)
3974 sv = hv_delete_ent(hv, keysv, discard, 0);
3975 else if (SvTYPE(hv) == SVt_PVAV) {
3976 if (PL_op->op_flags & OPf_SPECIAL)
3977 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3979 DIE(aTHX_ "panic: avhv_delete no longer supported");
3982 DIE(aTHX_ "Not a HASH reference");
3998 if (PL_op->op_private & OPpEXISTS_SUB) {
4000 SV * const sv = POPs;
4001 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4004 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4010 if (SvTYPE(hv) == SVt_PVHV) {
4011 if (hv_exists_ent(hv, tmpsv, 0))
4014 else if (SvTYPE(hv) == SVt_PVAV) {
4015 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4016 if (av_exists((AV*)hv, SvIV(tmpsv)))
4021 DIE(aTHX_ "Not a HASH reference");
4028 dVAR; dSP; dMARK; dORIGMARK;
4029 register HV * const hv = (HV*)POPs;
4030 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4031 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4032 bool other_magic = FALSE;
4038 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4039 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4040 /* Try to preserve the existenceness of a tied hash
4041 * element by using EXISTS and DELETE if possible.
4042 * Fallback to FETCH and STORE otherwise */
4043 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4044 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4045 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4048 while (++MARK <= SP) {
4049 SV * const keysv = *MARK;
4052 bool preeminent = FALSE;
4055 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4056 hv_exists_ent(hv, keysv, 0);
4059 he = hv_fetch_ent(hv, keysv, lval, 0);
4060 svp = he ? &HeVAL(he) : 0;
4063 if (!svp || *svp == &PL_sv_undef) {
4064 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4067 if (HvNAME_get(hv) && isGV(*svp))
4068 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4071 save_helem(hv, keysv, svp);
4074 const char * const key = SvPV_const(keysv, keylen);
4075 SAVEDELETE(hv, savepvn(key,keylen),
4076 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4081 *MARK = svp ? *svp : &PL_sv_undef;
4083 if (GIMME != G_ARRAY) {
4085 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4091 /* List operators. */
4096 if (GIMME != G_ARRAY) {
4098 *MARK = *SP; /* unwanted list, return last item */
4100 *MARK = &PL_sv_undef;
4110 SV ** const lastrelem = PL_stack_sp;
4111 SV ** const lastlelem = PL_stack_base + POPMARK;
4112 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4113 register SV ** const firstrelem = lastlelem + 1;
4114 const I32 arybase = CopARYBASE_get(PL_curcop);
4115 I32 is_something_there = FALSE;
4117 register const I32 max = lastrelem - lastlelem;
4118 register SV **lelem;
4120 if (GIMME != G_ARRAY) {
4121 I32 ix = SvIV(*lastlelem);
4126 if (ix < 0 || ix >= max)
4127 *firstlelem = &PL_sv_undef;
4129 *firstlelem = firstrelem[ix];
4135 SP = firstlelem - 1;
4139 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4140 I32 ix = SvIV(*lelem);
4145 if (ix < 0 || ix >= max)
4146 *lelem = &PL_sv_undef;
4148 is_something_there = TRUE;
4149 if (!(*lelem = firstrelem[ix]))
4150 *lelem = &PL_sv_undef;
4153 if (is_something_there)
4156 SP = firstlelem - 1;
4162 dVAR; dSP; dMARK; dORIGMARK;
4163 const I32 items = SP - MARK;
4164 SV * const av = (SV *) av_make(items, MARK+1);
4165 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4166 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4167 ? newRV_noinc(av) : av));
4173 dVAR; dSP; dMARK; dORIGMARK;
4174 HV* const hv = newHV();
4177 SV * const key = *++MARK;
4178 SV * const val = newSV(0);
4180 sv_setsv(val, *++MARK);
4181 else if (ckWARN(WARN_MISC))
4182 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4183 (void)hv_store_ent(hv,key,val,0);
4186 XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
4187 ? newRV_noinc((SV*) hv) : (SV*)hv));
4193 dVAR; dSP; dMARK; dORIGMARK;
4194 register AV *ary = (AV*)*++MARK;
4198 register I32 offset;
4199 register I32 length;
4203 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4206 *MARK-- = SvTIED_obj((SV*)ary, mg);
4210 call_method("SPLICE",GIMME_V);
4219 offset = i = SvIV(*MARK);
4221 offset += AvFILLp(ary) + 1;
4223 offset -= CopARYBASE_get(PL_curcop);
4225 DIE(aTHX_ PL_no_aelem, i);
4227 length = SvIVx(*MARK++);
4229 length += AvFILLp(ary) - offset + 1;
4235 length = AvMAX(ary) + 1; /* close enough to infinity */
4239 length = AvMAX(ary) + 1;
4241 if (offset > AvFILLp(ary) + 1) {
4242 if (ckWARN(WARN_MISC))
4243 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4244 offset = AvFILLp(ary) + 1;
4246 after = AvFILLp(ary) + 1 - (offset + length);
4247 if (after < 0) { /* not that much array */
4248 length += after; /* offset+length now in array */
4254 /* At this point, MARK .. SP-1 is our new LIST */
4257 diff = newlen - length;
4258 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4261 /* make new elements SVs now: avoid problems if they're from the array */
4262 for (dst = MARK, i = newlen; i; i--) {
4263 SV * const h = *dst;
4264 *dst++ = newSVsv(h);
4267 if (diff < 0) { /* shrinking the area */
4268 SV **tmparyval = NULL;
4270 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4271 Copy(MARK, tmparyval, newlen, SV*);
4274 MARK = ORIGMARK + 1;
4275 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4276 MEXTEND(MARK, length);
4277 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4279 EXTEND_MORTAL(length);
4280 for (i = length, dst = MARK; i; i--) {
4281 sv_2mortal(*dst); /* free them eventualy */
4288 *MARK = AvARRAY(ary)[offset+length-1];
4291 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4292 SvREFCNT_dec(*dst++); /* free them now */
4295 AvFILLp(ary) += diff;
4297 /* pull up or down? */
4299 if (offset < after) { /* easier to pull up */
4300 if (offset) { /* esp. if nothing to pull */
4301 src = &AvARRAY(ary)[offset-1];
4302 dst = src - diff; /* diff is negative */
4303 for (i = offset; i > 0; i--) /* can't trust Copy */
4307 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4311 if (after) { /* anything to pull down? */
4312 src = AvARRAY(ary) + offset + length;
4313 dst = src + diff; /* diff is negative */
4314 Move(src, dst, after, SV*);
4316 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4317 /* avoid later double free */
4321 dst[--i] = &PL_sv_undef;
4324 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4325 Safefree(tmparyval);
4328 else { /* no, expanding (or same) */
4329 SV** tmparyval = NULL;
4331 Newx(tmparyval, length, SV*); /* so remember deletion */
4332 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4335 if (diff > 0) { /* expanding */
4336 /* push up or down? */
4337 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4341 Move(src, dst, offset, SV*);
4343 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4345 AvFILLp(ary) += diff;
4348 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4349 av_extend(ary, AvFILLp(ary) + diff);
4350 AvFILLp(ary) += diff;
4353 dst = AvARRAY(ary) + AvFILLp(ary);
4355 for (i = after; i; i--) {
4363 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4366 MARK = ORIGMARK + 1;
4367 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4369 Copy(tmparyval, MARK, length, SV*);
4371 EXTEND_MORTAL(length);
4372 for (i = length, dst = MARK; i; i--) {
4373 sv_2mortal(*dst); /* free them eventualy */
4380 else if (length--) {
4381 *MARK = tmparyval[length];
4384 while (length-- > 0)
4385 SvREFCNT_dec(tmparyval[length]);
4389 *MARK = &PL_sv_undef;
4390 Safefree(tmparyval);
4398 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4399 register AV * const ary = (AV*)*++MARK;
4400 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4403 *MARK-- = SvTIED_obj((SV*)ary, mg);
4407 call_method("PUSH",G_SCALAR|G_DISCARD);
4411 PUSHi( AvFILL(ary) + 1 );
4414 for (++MARK; MARK <= SP; MARK++) {
4415 SV * const sv = newSV(0);
4417 sv_setsv(sv, *MARK);
4418 av_store(ary, AvFILLp(ary)+1, sv);
4421 PUSHi( AvFILLp(ary) + 1 );
4430 AV * const av = (AV*)POPs;
4431 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4435 (void)sv_2mortal(sv);
4442 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4443 register AV *ary = (AV*)*++MARK;
4444 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4447 *MARK-- = SvTIED_obj((SV*)ary, mg);
4451 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4457 av_unshift(ary, SP - MARK);
4459 SV * const sv = newSVsv(*++MARK);
4460 (void)av_store(ary, i++, sv);
4464 PUSHi( AvFILL(ary) + 1 );
4471 SV ** const oldsp = SP;
4473 if (GIMME == G_ARRAY) {
4476 register SV * const tmp = *MARK;
4480 /* safe as long as stack cannot get extended in the above */
4485 register char *down;
4489 PADOFFSET padoff_du;
4491 SvUTF8_off(TARG); /* decontaminate */
4493 do_join(TARG, &PL_sv_no, MARK, SP);
4495 sv_setsv(TARG, (SP > MARK)
4497 : (padoff_du = find_rundefsvoffset(),
4498 (padoff_du == NOT_IN_PAD
4499 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4500 ? DEFSV : PAD_SVl(padoff_du)));
4501 up = SvPV_force(TARG, len);
4503 if (DO_UTF8(TARG)) { /* first reverse each character */
4504 U8* s = (U8*)SvPVX(TARG);
4505 const U8* send = (U8*)(s + len);
4507 if (UTF8_IS_INVARIANT(*s)) {
4512 if (!utf8_to_uvchr(s, 0))
4516 down = (char*)(s - 1);
4517 /* reverse this character */
4521 *down-- = (char)tmp;
4527 down = SvPVX(TARG) + len - 1;
4531 *down-- = (char)tmp;
4533 (void)SvPOK_only_UTF8(TARG);
4545 register IV limit = POPi; /* note, negative is forever */
4546 SV * const sv = POPs;
4548 register const char *s = SvPV_const(sv, len);
4549 const bool do_utf8 = DO_UTF8(sv);
4550 const char *strend = s + len;
4552 register REGEXP *rx;
4554 register const char *m;
4556 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4557 I32 maxiters = slen + 10;
4559 const I32 origlimit = limit;
4562 const I32 gimme = GIMME_V;
4563 const I32 oldsave = PL_savestack_ix;
4564 I32 make_mortal = 1;
4569 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4574 DIE(aTHX_ "panic: pp_split");
4577 TAINT_IF((rx->extflags & RXf_PMf_LOCALE) &&
4578 (rx->extflags & (RXf_WHITE | RXf_SKIPWHITE)));
4580 RX_MATCH_UTF8_set(rx, do_utf8);
4583 if (pm->op_pmreplrootu.op_pmtargetoff) {
4584 ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4587 if (pm->op_pmreplrootu.op_pmtargetgv) {
4588 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4591 else if (gimme != G_ARRAY)
4592 ary = GvAVn(PL_defgv);
4595 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4601 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4603 XPUSHs(SvTIED_obj((SV*)ary, mg));
4610 for (i = AvFILLp(ary); i >= 0; i--)
4611 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4613 /* temporarily switch stacks */
4614 SAVESWITCHSTACK(PL_curstack, ary);
4618 base = SP - PL_stack_base;
4620 if (rx->extflags & RXf_SKIPWHITE) {
4622 while (*s == ' ' || is_utf8_space((U8*)s))
4625 else if (rx->extflags & RXf_PMf_LOCALE) {
4626 while (isSPACE_LC(*s))
4634 if (rx->extflags & PMf_MULTILINE) {
4639 limit = maxiters + 2;
4640 if (rx->extflags & RXf_WHITE) {
4643 /* this one uses 'm' and is a negative test */
4645 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4646 const int t = UTF8SKIP(m);
4647 /* is_utf8_space returns FALSE for malform utf8 */
4653 } else if (rx->extflags & RXf_PMf_LOCALE) {
4654 while (m < strend && !isSPACE_LC(*m))
4657 while (m < strend && !isSPACE(*m))
4663 dstr = newSVpvn(s, m-s);
4667 (void)SvUTF8_on(dstr);
4670 /* skip the whitespace found last */
4672 s = m + UTF8SKIP(m);
4676 /* this one uses 's' and is a positive test */
4678 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4680 } else if (rx->extflags & RXf_PMf_LOCALE) {
4681 while (s < strend && isSPACE_LC(*s))
4684 while (s < strend && isSPACE(*s))
4689 else if (rx->extflags & RXf_START_ONLY) {
4691 for (m = s; m < strend && *m != '\n'; m++)
4696 dstr = newSVpvn(s, m-s);
4700 (void)SvUTF8_on(dstr);
4705 else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
4706 (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
4707 && (rx->extflags & RXf_CHECK_ALL)
4708 && !(rx->extflags & RXf_ANCH)) {
4709 const int tail = (rx->extflags & RXf_INTUIT_TAIL);
4710 SV * const csv = CALLREG_INTUIT_STRING(rx);
4712 len = rx->minlenret;
4713 if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
4714 const char c = *SvPV_nolen_const(csv);
4716 for (m = s; m < strend && *m != c; m++)
4720 dstr = newSVpvn(s, m-s);
4724 (void)SvUTF8_on(dstr);
4726 /* The rx->minlen is in characters but we want to step
4727 * s ahead by bytes. */
4729 s = (char*)utf8_hop((U8*)m, len);
4731 s = m + len; /* Fake \n at the end */
4735 while (s < strend && --limit &&
4736 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4737 csv, multiline ? FBMrf_MULTILINE : 0)) )
4739 dstr = newSVpvn(s, m-s);
4743 (void)SvUTF8_on(dstr);
4745 /* The rx->minlen is in characters but we want to step
4746 * s ahead by bytes. */
4748 s = (char*)utf8_hop((U8*)m, len);
4750 s = m + len; /* Fake \n at the end */
4755 maxiters += slen * rx->nparens;
4756 while (s < strend && --limit)
4760 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4763 if (rex_return == 0)
4765 TAINT_IF(RX_MATCH_TAINTED(rx));
4766 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4771 strend = s + (strend - m);
4773 m = rx->offs[0].start + orig;
4774 dstr = newSVpvn(s, m-s);
4778 (void)SvUTF8_on(dstr);
4782 for (i = 1; i <= (I32)rx->nparens; i++) {
4783 s = rx->offs[i].start + orig;
4784 m = rx->offs[i].end + orig;
4786 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4787 parens that didn't match -- they should be set to
4788 undef, not the empty string */
4789 if (m >= orig && s >= orig) {
4790 dstr = newSVpvn(s, m-s);
4793 dstr = &PL_sv_undef; /* undef, not "" */
4797 (void)SvUTF8_on(dstr);
4801 s = rx->offs[0].end + orig;
4805 iters = (SP - PL_stack_base) - base;
4806 if (iters > maxiters)
4807 DIE(aTHX_ "Split loop");
4809 /* keep field after final delim? */
4810 if (s < strend || (iters && origlimit)) {
4811 const STRLEN l = strend - s;
4812 dstr = newSVpvn(s, l);
4816 (void)SvUTF8_on(dstr);
4820 else if (!origlimit) {
4821 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4822 if (TOPs && !make_mortal)
4825 *SP-- = &PL_sv_undef;
4830 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4834 if (SvSMAGICAL(ary)) {
4839 if (gimme == G_ARRAY) {
4841 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4849 call_method("PUSH",G_SCALAR|G_DISCARD);
4852 if (gimme == G_ARRAY) {
4854 /* EXTEND should not be needed - we just popped them */
4856 for (i=0; i < iters; i++) {
4857 SV **svp = av_fetch(ary, i, FALSE);
4858 PUSHs((svp) ? *svp : &PL_sv_undef);
4865 if (gimme == G_ARRAY)
4881 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4882 || SvTYPE(retsv) == SVt_PVCV) {
4883 retsv = refto(retsv);
4890 PP(unimplemented_op)
4893 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4899 * c-indentation-style: bsd
4901 * indent-tabs-mode: t
4904 * ex: set ts=8 sts=4 sw=4 noet: