3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
66 if (PL_op->op_flags & OPf_REF) {
70 if (GIMME == G_SCALAR)
71 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
76 if (gimme == G_ARRAY) {
77 const I32 maxarg = AvFILL((AV*)TARG) + 1;
79 if (SvMAGICAL(TARG)) {
81 for (i=0; i < (U32)maxarg; i++) {
82 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
83 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
87 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
91 else if (gimme == G_SCALAR) {
92 SV* const sv = sv_newmortal();
93 const I32 maxarg = AvFILL((AV*)TARG) + 1;
106 if (PL_op->op_private & OPpLVAL_INTRO)
107 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
108 if (PL_op->op_flags & OPf_REF)
111 if (GIMME == G_SCALAR)
112 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
116 if (gimme == G_ARRAY) {
119 else if (gimme == G_SCALAR) {
120 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
134 tryAMAGICunDEREF(to_gv);
137 if (SvTYPE(sv) == SVt_PVIO) {
138 GV * const gv = (GV*) sv_newmortal();
139 gv_init(gv, 0, "", 0, 0);
140 GvIOp(gv) = (IO *)sv;
141 SvREFCNT_inc_void_NN(sv);
144 else if (SvTYPE(sv) != SVt_PVGV)
145 DIE(aTHX_ "Not a GLOB reference");
148 if (SvTYPE(sv) != SVt_PVGV) {
149 if (SvGMAGICAL(sv)) {
154 if (!SvOK(sv) && sv != &PL_sv_undef) {
155 /* If this is a 'my' scalar and flag is set then vivify
159 Perl_croak(aTHX_ PL_no_modify);
160 if (PL_op->op_private & OPpDEREF) {
162 if (cUNOP->op_targ) {
164 SV * const namesv = PAD_SV(cUNOP->op_targ);
165 const char * const name = SvPV(namesv, len);
167 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
170 const char * const name = CopSTASHPV(PL_curcop);
173 if (SvTYPE(sv) < SVt_RV)
174 sv_upgrade(sv, SVt_RV);
175 else if (SvPVX_const(sv)) {
180 SvRV_set(sv, (SV*)gv);
185 if (PL_op->op_flags & OPf_REF ||
186 PL_op->op_private & HINT_STRICT_REFS)
187 DIE(aTHX_ PL_no_usym, "a symbol");
188 if (ckWARN(WARN_UNINITIALIZED))
192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
195 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
197 && (!is_gv_magical_sv(sv,0)
198 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
204 if (PL_op->op_private & HINT_STRICT_REFS)
205 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
206 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
207 == OPpDONT_INIT_GV) {
208 /* We are the target of a coderef assignment. Return
209 the scalar unchanged, and let pp_sasssign deal with
213 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
217 if (PL_op->op_private & OPpLVAL_INTRO)
218 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
230 tryAMAGICunDEREF(to_sv);
233 switch (SvTYPE(sv)) {
239 DIE(aTHX_ "Not a SCALAR reference");
245 if (SvTYPE(gv) != SVt_PVGV) {
246 if (SvGMAGICAL(sv)) {
251 if (PL_op->op_private & HINT_STRICT_REFS) {
253 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
255 DIE(aTHX_ PL_no_usym, "a SCALAR");
258 if (PL_op->op_flags & OPf_REF)
259 DIE(aTHX_ PL_no_usym, "a SCALAR");
260 if (ckWARN(WARN_UNINITIALIZED))
264 if ((PL_op->op_flags & OPf_SPECIAL) &&
265 !(PL_op->op_flags & OPf_MOD))
267 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
269 && (!is_gv_magical_sv(sv, 0)
270 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
276 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
281 if (PL_op->op_flags & OPf_MOD) {
282 if (PL_op->op_private & OPpLVAL_INTRO) {
283 if (cUNOP->op_first->op_type == OP_NULL)
284 sv = save_scalar((GV*)TOPs);
286 sv = save_scalar(gv);
288 Perl_croak(aTHX_ PL_no_localize_ref);
290 else if (PL_op->op_private & OPpDEREF)
291 vivify_ref(sv, PL_op->op_private & OPpDEREF);
300 AV * const av = (AV*)TOPs;
301 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
304 sv_upgrade(*sv, SVt_PVMG);
305 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
313 dVAR; dSP; dTARGET; dPOPss;
315 if (PL_op->op_flags & OPf_MOD || LVRET) {
316 if (SvTYPE(TARG) < SVt_PVLV) {
317 sv_upgrade(TARG, SVt_PVLV);
318 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
322 if (LvTARG(TARG) != sv) {
324 SvREFCNT_dec(LvTARG(TARG));
325 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
327 PUSHs(TARG); /* no SvSETMAGIC */
331 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
332 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
333 if (mg && mg->mg_len >= 0) {
337 PUSHi(i + CopARYBASE_get(PL_curcop));
350 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
352 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
355 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
356 /* (But not in defined().) */
358 CV *cv = sv_2cv(TOPs, &stash, &gv, flags);
361 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
362 if ((PL_op->op_private & OPpLVAL_INTRO)) {
363 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
366 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
369 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
373 cv = (CV*)&PL_sv_undef;
384 SV *ret = &PL_sv_undef;
386 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
387 const char * const s = SvPVX_const(TOPs);
388 if (strnEQ(s, "CORE::", 6)) {
389 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
390 if (code < 0) { /* Overridable. */
391 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
392 int i = 0, n = 0, seen_question = 0;
394 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
396 if (code == -KEY_chop || code == -KEY_chomp
397 || code == -KEY_exec || code == -KEY_system)
399 while (i < MAXO) { /* The slow way. */
400 if (strEQ(s + 6, PL_op_name[i])
401 || strEQ(s + 6, PL_op_desc[i]))
407 goto nonesuch; /* Should not happen... */
409 oa = PL_opargs[i] >> OASHIFT;
411 if (oa & OA_OPTIONAL && !seen_question) {
415 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
416 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
417 /* But globs are already references (kinda) */
418 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
422 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
426 ret = sv_2mortal(newSVpvn(str, n - 1));
428 else if (code) /* Non-Overridable */
430 else { /* None such */
432 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
436 cv = sv_2cv(TOPs, &stash, &gv, 0);
438 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
447 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
449 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
465 if (GIMME != G_ARRAY) {
469 *MARK = &PL_sv_undef;
470 *MARK = refto(*MARK);
474 EXTEND_MORTAL(SP - MARK);
476 *MARK = refto(*MARK);
481 S_refto(pTHX_ SV *sv)
486 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
489 if (!(sv = LvTARG(sv)))
492 SvREFCNT_inc_void_NN(sv);
494 else if (SvTYPE(sv) == SVt_PVAV) {
495 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
498 SvREFCNT_inc_void_NN(sv);
500 else if (SvPADTMP(sv) && !IS_PADGV(sv))
504 SvREFCNT_inc_void_NN(sv);
507 sv_upgrade(rv, SVt_RV);
517 SV * const sv = POPs;
522 if (!sv || !SvROK(sv))
525 pv = sv_reftype(SvRV(sv),TRUE);
526 PUSHp(pv, strlen(pv));
536 stash = CopSTASH(PL_curcop);
538 SV * const ssv = POPs;
542 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
543 Perl_croak(aTHX_ "Attempt to bless into a reference");
544 ptr = SvPV_const(ssv,len);
545 if (len == 0 && ckWARN(WARN_MISC))
546 Perl_warner(aTHX_ packWARN(WARN_MISC),
547 "Explicit blessing to '' (assuming package main)");
548 stash = gv_stashpvn(ptr, len, TRUE);
551 (void)sv_bless(TOPs, stash);
560 const char * const elem = SvPV_nolen_const(sv);
561 GV * const gv = (GV*)POPs;
566 /* elem will always be NUL terminated. */
567 const char * const second_letter = elem + 1;
570 if (strEQ(second_letter, "RRAY"))
571 tmpRef = (SV*)GvAV(gv);
574 if (strEQ(second_letter, "ODE"))
575 tmpRef = (SV*)GvCVu(gv);
578 if (strEQ(second_letter, "ILEHANDLE")) {
579 /* finally deprecated in 5.8.0 */
580 deprecate("*glob{FILEHANDLE}");
581 tmpRef = (SV*)GvIOp(gv);
584 if (strEQ(second_letter, "ORMAT"))
585 tmpRef = (SV*)GvFORM(gv);
588 if (strEQ(second_letter, "LOB"))
592 if (strEQ(second_letter, "ASH"))
593 tmpRef = (SV*)GvHV(gv);
596 if (*second_letter == 'O' && !elem[2])
597 tmpRef = (SV*)GvIOp(gv);
600 if (strEQ(second_letter, "AME"))
601 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
604 if (strEQ(second_letter, "ACKAGE")) {
605 const HV * const stash = GvSTASH(gv);
606 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
607 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
611 if (strEQ(second_letter, "CALAR"))
626 /* Pattern matching */
631 register unsigned char *s;
634 register I32 *sfirst;
638 if (sv == PL_lastscream) {
642 s = (unsigned char*)(SvPV(sv, len));
644 if (pos <= 0 || !SvPOK(sv)) {
645 /* No point in studying a zero length string, and not safe to study
646 anything that doesn't appear to be a simple scalar (and hence might
647 change between now and when the regexp engine runs without our set
648 magic ever running) such as a reference to an object with overloaded
654 SvSCREAM_off(PL_lastscream);
655 SvREFCNT_dec(PL_lastscream);
657 PL_lastscream = SvREFCNT_inc_simple(sv);
659 s = (unsigned char*)(SvPV(sv, len));
663 if (pos > PL_maxscream) {
664 if (PL_maxscream < 0) {
665 PL_maxscream = pos + 80;
666 Newx(PL_screamfirst, 256, I32);
667 Newx(PL_screamnext, PL_maxscream, I32);
670 PL_maxscream = pos + pos / 4;
671 Renew(PL_screamnext, PL_maxscream, I32);
675 sfirst = PL_screamfirst;
676 snext = PL_screamnext;
678 if (!sfirst || !snext)
679 DIE(aTHX_ "do_study: out of memory");
681 for (ch = 256; ch; --ch)
686 register const I32 ch = s[pos];
688 snext[pos] = sfirst[ch] - pos;
695 /* piggyback on m//g magic */
696 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
705 if (PL_op->op_flags & OPf_STACKED)
707 else if (PL_op->op_private & OPpTARGET_MY)
713 TARG = sv_newmortal();
718 /* Lvalue operators. */
730 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
732 do_chop(TARG, *++MARK);
741 SETi(do_chomp(TOPs));
747 dVAR; dSP; dMARK; dTARGET;
748 register I32 count = 0;
751 count += do_chomp(POPs);
761 if (!PL_op->op_private) {
770 SV_CHECK_THINKFIRST_COW_DROP(sv);
772 switch (SvTYPE(sv)) {
782 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
783 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
784 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
788 /* let user-undef'd sub keep its identity */
789 GV* const gv = CvGV((CV*)sv);
796 SvSetMagicSV(sv, &PL_sv_undef);
801 GvGP(sv) = gp_ref(gp);
803 GvLINE(sv) = CopLINE(PL_curcop);
809 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
824 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
825 DIE(aTHX_ PL_no_modify);
826 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
827 && SvIVX(TOPs) != IV_MIN)
829 SvIV_set(TOPs, SvIVX(TOPs) - 1);
830 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
842 DIE(aTHX_ PL_no_modify);
843 sv_setsv(TARG, TOPs);
844 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
845 && SvIVX(TOPs) != IV_MAX)
847 SvIV_set(TOPs, SvIVX(TOPs) + 1);
848 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
853 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
863 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 sv_setsv(TARG, TOPs);
866 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
867 && SvIVX(TOPs) != IV_MIN)
869 SvIV_set(TOPs, SvIVX(TOPs) - 1);
870 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
879 /* Ordinary operators. */
884 #ifdef PERL_PRESERVE_IVUV
887 tryAMAGICbin(pow,opASSIGN);
888 #ifdef PERL_PRESERVE_IVUV
889 /* For integer to integer power, we do the calculation by hand wherever
890 we're sure it is safe; otherwise we call pow() and try to convert to
891 integer afterwards. */
904 const IV iv = SvIVX(TOPs);
908 goto float_it; /* Can't do negative powers this way. */
912 baseuok = SvUOK(TOPm1s);
914 baseuv = SvUVX(TOPm1s);
916 const IV iv = SvIVX(TOPm1s);
919 baseuok = TRUE; /* effectively it's a UV now */
921 baseuv = -iv; /* abs, baseuok == false records sign */
924 /* now we have integer ** positive integer. */
927 /* foo & (foo - 1) is zero only for a power of 2. */
928 if (!(baseuv & (baseuv - 1))) {
929 /* We are raising power-of-2 to a positive integer.
930 The logic here will work for any base (even non-integer
931 bases) but it can be less accurate than
932 pow (base,power) or exp (power * log (base)) when the
933 intermediate values start to spill out of the mantissa.
934 With powers of 2 we know this can't happen.
935 And powers of 2 are the favourite thing for perl
936 programmers to notice ** not doing what they mean. */
938 NV base = baseuok ? baseuv : -(NV)baseuv;
943 while (power >>= 1) {
954 register unsigned int highbit = 8 * sizeof(UV);
955 register unsigned int diff = 8 * sizeof(UV);
958 if (baseuv >> highbit) {
962 /* we now have baseuv < 2 ** highbit */
963 if (power * highbit <= 8 * sizeof(UV)) {
964 /* result will definitely fit in UV, so use UV math
965 on same algorithm as above */
966 register UV result = 1;
967 register UV base = baseuv;
968 const bool odd_power = (bool)(power & 1);
972 while (power >>= 1) {
979 if (baseuok || !odd_power)
980 /* answer is positive */
982 else if (result <= (UV)IV_MAX)
983 /* answer negative, fits in IV */
985 else if (result == (UV)IV_MIN)
986 /* 2's complement assumption: special case IV_MIN */
989 /* answer negative, doesn't fit */
1002 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1004 We are building perl with long double support and are on an AIX OS
1005 afflicted with a powl() function that wrongly returns NaNQ for any
1006 negative base. This was reported to IBM as PMR #23047-379 on
1007 03/06/2006. The problem exists in at least the following versions
1008 of AIX and the libm fileset, and no doubt others as well:
1010 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1011 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1012 AIX 5.2.0 bos.adt.libm 5.2.0.85
1014 So, until IBM fixes powl(), we provide the following workaround to
1015 handle the problem ourselves. Our logic is as follows: for
1016 negative bases (left), we use fmod(right, 2) to check if the
1017 exponent is an odd or even integer:
1019 - if odd, powl(left, right) == -powl(-left, right)
1020 - if even, powl(left, right) == powl(-left, right)
1022 If the exponent is not an integer, the result is rightly NaNQ, so
1023 we just return that (as NV_NAN).
1027 NV mod2 = Perl_fmod( right, 2.0 );
1028 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1029 SETn( -Perl_pow( -left, right) );
1030 } else if (mod2 == 0.0) { /* even integer */
1031 SETn( Perl_pow( -left, right) );
1032 } else { /* fractional power */
1036 SETn( Perl_pow( left, right) );
1039 SETn( Perl_pow( left, right) );
1040 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1042 #ifdef PERL_PRESERVE_IVUV
1052 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1053 #ifdef PERL_PRESERVE_IVUV
1056 /* Unless the left argument is integer in range we are going to have to
1057 use NV maths. Hence only attempt to coerce the right argument if
1058 we know the left is integer. */
1059 /* Left operand is defined, so is it IV? */
1060 SvIV_please(TOPm1s);
1061 if (SvIOK(TOPm1s)) {
1062 bool auvok = SvUOK(TOPm1s);
1063 bool buvok = SvUOK(TOPs);
1064 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1065 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1072 alow = SvUVX(TOPm1s);
1074 const IV aiv = SvIVX(TOPm1s);
1077 auvok = TRUE; /* effectively it's a UV now */
1079 alow = -aiv; /* abs, auvok == false records sign */
1085 const IV biv = SvIVX(TOPs);
1088 buvok = TRUE; /* effectively it's a UV now */
1090 blow = -biv; /* abs, buvok == false records sign */
1094 /* If this does sign extension on unsigned it's time for plan B */
1095 ahigh = alow >> (4 * sizeof (UV));
1097 bhigh = blow >> (4 * sizeof (UV));
1099 if (ahigh && bhigh) {
1101 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1102 which is overflow. Drop to NVs below. */
1103 } else if (!ahigh && !bhigh) {
1104 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1105 so the unsigned multiply cannot overflow. */
1106 const UV product = alow * blow;
1107 if (auvok == buvok) {
1108 /* -ve * -ve or +ve * +ve gives a +ve result. */
1112 } else if (product <= (UV)IV_MIN) {
1113 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1114 /* -ve result, which could overflow an IV */
1116 SETi( -(IV)product );
1118 } /* else drop to NVs below. */
1120 /* One operand is large, 1 small */
1123 /* swap the operands */
1125 bhigh = blow; /* bhigh now the temp var for the swap */
1129 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1130 multiplies can't overflow. shift can, add can, -ve can. */
1131 product_middle = ahigh * blow;
1132 if (!(product_middle & topmask)) {
1133 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1135 product_middle <<= (4 * sizeof (UV));
1136 product_low = alow * blow;
1138 /* as for pp_add, UV + something mustn't get smaller.
1139 IIRC ANSI mandates this wrapping *behaviour* for
1140 unsigned whatever the actual representation*/
1141 product_low += product_middle;
1142 if (product_low >= product_middle) {
1143 /* didn't overflow */
1144 if (auvok == buvok) {
1145 /* -ve * -ve or +ve * +ve gives a +ve result. */
1147 SETu( product_low );
1149 } else if (product_low <= (UV)IV_MIN) {
1150 /* 2s complement assumption again */
1151 /* -ve result, which could overflow an IV */
1153 SETi( -(IV)product_low );
1155 } /* else drop to NVs below. */
1157 } /* product_middle too large */
1158 } /* ahigh && bhigh */
1159 } /* SvIOK(TOPm1s) */
1164 SETn( left * right );
1171 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1172 /* Only try to do UV divide first
1173 if ((SLOPPYDIVIDE is true) or
1174 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1176 The assumption is that it is better to use floating point divide
1177 whenever possible, only doing integer divide first if we can't be sure.
1178 If NV_PRESERVES_UV is true then we know at compile time that no UV
1179 can be too large to preserve, so don't need to compile the code to
1180 test the size of UVs. */
1183 # define PERL_TRY_UV_DIVIDE
1184 /* ensure that 20./5. == 4. */
1186 # ifdef PERL_PRESERVE_IVUV
1187 # ifndef NV_PRESERVES_UV
1188 # define PERL_TRY_UV_DIVIDE
1193 #ifdef PERL_TRY_UV_DIVIDE
1196 SvIV_please(TOPm1s);
1197 if (SvIOK(TOPm1s)) {
1198 bool left_non_neg = SvUOK(TOPm1s);
1199 bool right_non_neg = SvUOK(TOPs);
1203 if (right_non_neg) {
1204 right = SvUVX(TOPs);
1207 const IV biv = SvIVX(TOPs);
1210 right_non_neg = TRUE; /* effectively it's a UV now */
1216 /* historically undef()/0 gives a "Use of uninitialized value"
1217 warning before dieing, hence this test goes here.
1218 If it were immediately before the second SvIV_please, then
1219 DIE() would be invoked before left was even inspected, so
1220 no inpsection would give no warning. */
1222 DIE(aTHX_ "Illegal division by zero");
1225 left = SvUVX(TOPm1s);
1228 const IV aiv = SvIVX(TOPm1s);
1231 left_non_neg = TRUE; /* effectively it's a UV now */
1240 /* For sloppy divide we always attempt integer division. */
1242 /* Otherwise we only attempt it if either or both operands
1243 would not be preserved by an NV. If both fit in NVs
1244 we fall through to the NV divide code below. However,
1245 as left >= right to ensure integer result here, we know that
1246 we can skip the test on the right operand - right big
1247 enough not to be preserved can't get here unless left is
1250 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1253 /* Integer division can't overflow, but it can be imprecise. */
1254 const UV result = left / right;
1255 if (result * right == left) {
1256 SP--; /* result is valid */
1257 if (left_non_neg == right_non_neg) {
1258 /* signs identical, result is positive. */
1262 /* 2s complement assumption */
1263 if (result <= (UV)IV_MIN)
1264 SETi( -(IV)result );
1266 /* It's exact but too negative for IV. */
1267 SETn( -(NV)result );
1270 } /* tried integer divide but it was not an integer result */
1271 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1272 } /* left wasn't SvIOK */
1273 } /* right wasn't SvIOK */
1274 #endif /* PERL_TRY_UV_DIVIDE */
1278 DIE(aTHX_ "Illegal division by zero");
1279 PUSHn( left / right );
1286 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1290 bool left_neg = FALSE;
1291 bool right_neg = FALSE;
1292 bool use_double = FALSE;
1293 bool dright_valid = FALSE;
1299 right_neg = !SvUOK(TOPs);
1301 right = SvUVX(POPs);
1303 const IV biv = SvIVX(POPs);
1306 right_neg = FALSE; /* effectively it's a UV now */
1314 right_neg = dright < 0;
1317 if (dright < UV_MAX_P1) {
1318 right = U_V(dright);
1319 dright_valid = TRUE; /* In case we need to use double below. */
1325 /* At this point use_double is only true if right is out of range for
1326 a UV. In range NV has been rounded down to nearest UV and
1327 use_double false. */
1329 if (!use_double && SvIOK(TOPs)) {
1331 left_neg = !SvUOK(TOPs);
1335 const IV aiv = SvIVX(POPs);
1338 left_neg = FALSE; /* effectively it's a UV now */
1347 left_neg = dleft < 0;
1351 /* This should be exactly the 5.6 behaviour - if left and right are
1352 both in range for UV then use U_V() rather than floor. */
1354 if (dleft < UV_MAX_P1) {
1355 /* right was in range, so is dleft, so use UVs not double.
1359 /* left is out of range for UV, right was in range, so promote
1360 right (back) to double. */
1362 /* The +0.5 is used in 5.6 even though it is not strictly
1363 consistent with the implicit +0 floor in the U_V()
1364 inside the #if 1. */
1365 dleft = Perl_floor(dleft + 0.5);
1368 dright = Perl_floor(dright + 0.5);
1378 DIE(aTHX_ "Illegal modulus zero");
1380 dans = Perl_fmod(dleft, dright);
1381 if ((left_neg != right_neg) && dans)
1382 dans = dright - dans;
1385 sv_setnv(TARG, dans);
1391 DIE(aTHX_ "Illegal modulus zero");
1394 if ((left_neg != right_neg) && ans)
1397 /* XXX may warn: unary minus operator applied to unsigned type */
1398 /* could change -foo to be (~foo)+1 instead */
1399 if (ans <= ~((UV)IV_MAX)+1)
1400 sv_setiv(TARG, ~ans+1);
1402 sv_setnv(TARG, -(NV)ans);
1405 sv_setuv(TARG, ans);
1414 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1421 const UV uv = SvUV(sv);
1423 count = IV_MAX; /* The best we can do? */
1427 const IV iv = SvIV(sv);
1434 else if (SvNOKp(sv)) {
1435 const NV nv = SvNV(sv);
1443 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1445 static const char oom_list_extend[] = "Out of memory during list extend";
1446 const I32 items = SP - MARK;
1447 const I32 max = items * count;
1449 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1450 /* Did the max computation overflow? */
1451 if (items > 0 && max > 0 && (max < items || max < count))
1452 Perl_croak(aTHX_ oom_list_extend);
1457 /* This code was intended to fix 20010809.028:
1460 for (($x =~ /./g) x 2) {
1461 print chop; # "abcdabcd" expected as output.
1464 * but that change (#11635) broke this code:
1466 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1468 * I can't think of a better fix that doesn't introduce
1469 * an efficiency hit by copying the SVs. The stack isn't
1470 * refcounted, and mortalisation obviously doesn't
1471 * Do The Right Thing when the stack has more than
1472 * one pointer to the same mortal value.
1476 *SP = sv_2mortal(newSVsv(*SP));
1486 repeatcpy((char*)(MARK + items), (char*)MARK,
1487 items * sizeof(SV*), count - 1);
1490 else if (count <= 0)
1493 else { /* Note: mark already snarfed by pp_list */
1494 SV * const tmpstr = POPs;
1497 static const char oom_string_extend[] =
1498 "Out of memory during string extend";
1500 SvSetSV(TARG, tmpstr);
1501 SvPV_force(TARG, len);
1502 isutf = DO_UTF8(TARG);
1507 const STRLEN max = (UV)count * len;
1508 if (len > ((MEM_SIZE)~0)/count)
1509 Perl_croak(aTHX_ oom_string_extend);
1510 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1511 SvGROW(TARG, max + 1);
1512 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1513 SvCUR_set(TARG, SvCUR(TARG) * count);
1515 *SvEND(TARG) = '\0';
1518 (void)SvPOK_only_UTF8(TARG);
1520 (void)SvPOK_only(TARG);
1522 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1523 /* The parser saw this as a list repeat, and there
1524 are probably several items on the stack. But we're
1525 in scalar context, and there's no pp_list to save us
1526 now. So drop the rest of the items -- robin@kitsite.com
1539 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1540 useleft = USE_LEFT(TOPm1s);
1541 #ifdef PERL_PRESERVE_IVUV
1542 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1543 "bad things" happen if you rely on signed integers wrapping. */
1546 /* Unless the left argument is integer in range we are going to have to
1547 use NV maths. Hence only attempt to coerce the right argument if
1548 we know the left is integer. */
1549 register UV auv = 0;
1555 a_valid = auvok = 1;
1556 /* left operand is undef, treat as zero. */
1558 /* Left operand is defined, so is it IV? */
1559 SvIV_please(TOPm1s);
1560 if (SvIOK(TOPm1s)) {
1561 if ((auvok = SvUOK(TOPm1s)))
1562 auv = SvUVX(TOPm1s);
1564 register const IV aiv = SvIVX(TOPm1s);
1567 auvok = 1; /* Now acting as a sign flag. */
1568 } else { /* 2s complement assumption for IV_MIN */
1576 bool result_good = 0;
1579 bool buvok = SvUOK(TOPs);
1584 register const IV biv = SvIVX(TOPs);
1591 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1592 else "IV" now, independent of how it came in.
1593 if a, b represents positive, A, B negative, a maps to -A etc
1598 all UV maths. negate result if A negative.
1599 subtract if signs same, add if signs differ. */
1601 if (auvok ^ buvok) {
1610 /* Must get smaller */
1615 if (result <= buv) {
1616 /* result really should be -(auv-buv). as its negation
1617 of true value, need to swap our result flag */
1629 if (result <= (UV)IV_MIN)
1630 SETi( -(IV)result );
1632 /* result valid, but out of range for IV. */
1633 SETn( -(NV)result );
1637 } /* Overflow, drop through to NVs. */
1641 useleft = USE_LEFT(TOPm1s);
1645 /* left operand is undef, treat as zero - value */
1649 SETn( TOPn - value );
1656 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1658 const IV shift = POPi;
1659 if (PL_op->op_private & HINT_INTEGER) {
1673 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1675 const IV shift = POPi;
1676 if (PL_op->op_private & HINT_INTEGER) {
1690 dVAR; dSP; tryAMAGICbinSET(lt,0);
1691 #ifdef PERL_PRESERVE_IVUV
1694 SvIV_please(TOPm1s);
1695 if (SvIOK(TOPm1s)) {
1696 bool auvok = SvUOK(TOPm1s);
1697 bool buvok = SvUOK(TOPs);
1699 if (!auvok && !buvok) { /* ## IV < IV ## */
1700 const IV aiv = SvIVX(TOPm1s);
1701 const IV biv = SvIVX(TOPs);
1704 SETs(boolSV(aiv < biv));
1707 if (auvok && buvok) { /* ## UV < UV ## */
1708 const UV auv = SvUVX(TOPm1s);
1709 const UV buv = SvUVX(TOPs);
1712 SETs(boolSV(auv < buv));
1715 if (auvok) { /* ## UV < IV ## */
1717 const IV biv = SvIVX(TOPs);
1720 /* As (a) is a UV, it's >=0, so it cannot be < */
1725 SETs(boolSV(auv < (UV)biv));
1728 { /* ## IV < UV ## */
1729 const IV aiv = SvIVX(TOPm1s);
1733 /* As (b) is a UV, it's >=0, so it must be < */
1740 SETs(boolSV((UV)aiv < buv));
1746 #ifndef NV_PRESERVES_UV
1747 #ifdef PERL_PRESERVE_IVUV
1750 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1752 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1757 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1759 if (Perl_isnan(left) || Perl_isnan(right))
1761 SETs(boolSV(left < right));
1764 SETs(boolSV(TOPn < value));
1772 dVAR; dSP; tryAMAGICbinSET(gt,0);
1773 #ifdef PERL_PRESERVE_IVUV
1776 SvIV_please(TOPm1s);
1777 if (SvIOK(TOPm1s)) {
1778 bool auvok = SvUOK(TOPm1s);
1779 bool buvok = SvUOK(TOPs);
1781 if (!auvok && !buvok) { /* ## IV > IV ## */
1782 const IV aiv = SvIVX(TOPm1s);
1783 const IV biv = SvIVX(TOPs);
1786 SETs(boolSV(aiv > biv));
1789 if (auvok && buvok) { /* ## UV > UV ## */
1790 const UV auv = SvUVX(TOPm1s);
1791 const UV buv = SvUVX(TOPs);
1794 SETs(boolSV(auv > buv));
1797 if (auvok) { /* ## UV > IV ## */
1799 const IV biv = SvIVX(TOPs);
1803 /* As (a) is a UV, it's >=0, so it must be > */
1808 SETs(boolSV(auv > (UV)biv));
1811 { /* ## IV > UV ## */
1812 const IV aiv = SvIVX(TOPm1s);
1816 /* As (b) is a UV, it's >=0, so it cannot be > */
1823 SETs(boolSV((UV)aiv > buv));
1829 #ifndef NV_PRESERVES_UV
1830 #ifdef PERL_PRESERVE_IVUV
1833 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1835 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1840 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1842 if (Perl_isnan(left) || Perl_isnan(right))
1844 SETs(boolSV(left > right));
1847 SETs(boolSV(TOPn > value));
1855 dVAR; dSP; tryAMAGICbinSET(le,0);
1856 #ifdef PERL_PRESERVE_IVUV
1859 SvIV_please(TOPm1s);
1860 if (SvIOK(TOPm1s)) {
1861 bool auvok = SvUOK(TOPm1s);
1862 bool buvok = SvUOK(TOPs);
1864 if (!auvok && !buvok) { /* ## IV <= IV ## */
1865 const IV aiv = SvIVX(TOPm1s);
1866 const IV biv = SvIVX(TOPs);
1869 SETs(boolSV(aiv <= biv));
1872 if (auvok && buvok) { /* ## UV <= UV ## */
1873 UV auv = SvUVX(TOPm1s);
1874 UV buv = SvUVX(TOPs);
1877 SETs(boolSV(auv <= buv));
1880 if (auvok) { /* ## UV <= IV ## */
1882 const IV biv = SvIVX(TOPs);
1886 /* As (a) is a UV, it's >=0, so a cannot be <= */
1891 SETs(boolSV(auv <= (UV)biv));
1894 { /* ## IV <= UV ## */
1895 const IV aiv = SvIVX(TOPm1s);
1899 /* As (b) is a UV, it's >=0, so a must be <= */
1906 SETs(boolSV((UV)aiv <= buv));
1912 #ifndef NV_PRESERVES_UV
1913 #ifdef PERL_PRESERVE_IVUV
1916 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1918 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1923 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1925 if (Perl_isnan(left) || Perl_isnan(right))
1927 SETs(boolSV(left <= right));
1930 SETs(boolSV(TOPn <= value));
1938 dVAR; dSP; tryAMAGICbinSET(ge,0);
1939 #ifdef PERL_PRESERVE_IVUV
1942 SvIV_please(TOPm1s);
1943 if (SvIOK(TOPm1s)) {
1944 bool auvok = SvUOK(TOPm1s);
1945 bool buvok = SvUOK(TOPs);
1947 if (!auvok && !buvok) { /* ## IV >= IV ## */
1948 const IV aiv = SvIVX(TOPm1s);
1949 const IV biv = SvIVX(TOPs);
1952 SETs(boolSV(aiv >= biv));
1955 if (auvok && buvok) { /* ## UV >= UV ## */
1956 const UV auv = SvUVX(TOPm1s);
1957 const UV buv = SvUVX(TOPs);
1960 SETs(boolSV(auv >= buv));
1963 if (auvok) { /* ## UV >= IV ## */
1965 const IV biv = SvIVX(TOPs);
1969 /* As (a) is a UV, it's >=0, so it must be >= */
1974 SETs(boolSV(auv >= (UV)biv));
1977 { /* ## IV >= UV ## */
1978 const IV aiv = SvIVX(TOPm1s);
1982 /* As (b) is a UV, it's >=0, so a cannot be >= */
1989 SETs(boolSV((UV)aiv >= buv));
1995 #ifndef NV_PRESERVES_UV
1996 #ifdef PERL_PRESERVE_IVUV
1999 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2001 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2006 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2008 if (Perl_isnan(left) || Perl_isnan(right))
2010 SETs(boolSV(left >= right));
2013 SETs(boolSV(TOPn >= value));
2021 dVAR; dSP; tryAMAGICbinSET(ne,0);
2022 #ifndef NV_PRESERVES_UV
2023 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2025 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2029 #ifdef PERL_PRESERVE_IVUV
2032 SvIV_please(TOPm1s);
2033 if (SvIOK(TOPm1s)) {
2034 const bool auvok = SvUOK(TOPm1s);
2035 const bool buvok = SvUOK(TOPs);
2037 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2038 /* Casting IV to UV before comparison isn't going to matter
2039 on 2s complement. On 1s complement or sign&magnitude
2040 (if we have any of them) it could make negative zero
2041 differ from normal zero. As I understand it. (Need to
2042 check - is negative zero implementation defined behaviour
2044 const UV buv = SvUVX(POPs);
2045 const UV auv = SvUVX(TOPs);
2047 SETs(boolSV(auv != buv));
2050 { /* ## Mixed IV,UV ## */
2054 /* != is commutative so swap if needed (save code) */
2056 /* swap. top of stack (b) is the iv */
2060 /* As (a) is a UV, it's >0, so it cannot be == */
2069 /* As (b) is a UV, it's >0, so it cannot be == */
2073 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2075 SETs(boolSV((UV)iv != uv));
2082 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2084 if (Perl_isnan(left) || Perl_isnan(right))
2086 SETs(boolSV(left != right));
2089 SETs(boolSV(TOPn != value));
2097 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2098 #ifndef NV_PRESERVES_UV
2099 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2100 const UV right = PTR2UV(SvRV(POPs));
2101 const UV left = PTR2UV(SvRV(TOPs));
2102 SETi((left > right) - (left < right));
2106 #ifdef PERL_PRESERVE_IVUV
2107 /* Fortunately it seems NaN isn't IOK */
2110 SvIV_please(TOPm1s);
2111 if (SvIOK(TOPm1s)) {
2112 const bool leftuvok = SvUOK(TOPm1s);
2113 const bool rightuvok = SvUOK(TOPs);
2115 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2116 const IV leftiv = SvIVX(TOPm1s);
2117 const IV rightiv = SvIVX(TOPs);
2119 if (leftiv > rightiv)
2121 else if (leftiv < rightiv)
2125 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2126 const UV leftuv = SvUVX(TOPm1s);
2127 const UV rightuv = SvUVX(TOPs);
2129 if (leftuv > rightuv)
2131 else if (leftuv < rightuv)
2135 } else if (leftuvok) { /* ## UV <=> IV ## */
2136 const IV rightiv = SvIVX(TOPs);
2138 /* As (a) is a UV, it's >=0, so it cannot be < */
2141 const UV leftuv = SvUVX(TOPm1s);
2142 if (leftuv > (UV)rightiv) {
2144 } else if (leftuv < (UV)rightiv) {
2150 } else { /* ## IV <=> UV ## */
2151 const IV leftiv = SvIVX(TOPm1s);
2153 /* As (b) is a UV, it's >=0, so it must be < */
2156 const UV rightuv = SvUVX(TOPs);
2157 if ((UV)leftiv > rightuv) {
2159 } else if ((UV)leftiv < rightuv) {
2177 if (Perl_isnan(left) || Perl_isnan(right)) {
2181 value = (left > right) - (left < right);
2185 else if (left < right)
2187 else if (left > right)
2203 int amg_type = sle_amg;
2207 switch (PL_op->op_type) {
2226 tryAMAGICbinSET_var(amg_type,0);
2229 const int cmp = (IN_LOCALE_RUNTIME
2230 ? sv_cmp_locale(left, right)
2231 : sv_cmp(left, right));
2232 SETs(boolSV(cmp * multiplier < rhs));
2239 dVAR; dSP; tryAMAGICbinSET(seq,0);
2242 SETs(boolSV(sv_eq(left, right)));
2249 dVAR; dSP; tryAMAGICbinSET(sne,0);
2252 SETs(boolSV(!sv_eq(left, right)));
2259 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2262 const int cmp = (IN_LOCALE_RUNTIME
2263 ? sv_cmp_locale(left, right)
2264 : sv_cmp(left, right));
2272 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2277 if (SvNIOKp(left) || SvNIOKp(right)) {
2278 if (PL_op->op_private & HINT_INTEGER) {
2279 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2283 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2288 do_vop(PL_op->op_type, TARG, left, right);
2297 dVAR; dSP; dATARGET;
2298 const int op_type = PL_op->op_type;
2300 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2305 if (SvNIOKp(left) || SvNIOKp(right)) {
2306 if (PL_op->op_private & HINT_INTEGER) {
2307 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2308 const IV r = SvIV_nomg(right);
2309 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2313 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2314 const UV r = SvUV_nomg(right);
2315 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2320 do_vop(op_type, TARG, left, right);
2329 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2332 const int flags = SvFLAGS(sv);
2334 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2335 /* It's publicly an integer, or privately an integer-not-float */
2338 if (SvIVX(sv) == IV_MIN) {
2339 /* 2s complement assumption. */
2340 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2343 else if (SvUVX(sv) <= IV_MAX) {
2348 else if (SvIVX(sv) != IV_MIN) {
2352 #ifdef PERL_PRESERVE_IVUV
2361 else if (SvPOKp(sv)) {
2363 const char * const s = SvPV_const(sv, len);
2364 if (isIDFIRST(*s)) {
2365 sv_setpvn(TARG, "-", 1);
2368 else if (*s == '+' || *s == '-') {
2370 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2372 else if (DO_UTF8(sv)) {
2375 goto oops_its_an_int;
2377 sv_setnv(TARG, -SvNV(sv));
2379 sv_setpvn(TARG, "-", 1);
2386 goto oops_its_an_int;
2387 sv_setnv(TARG, -SvNV(sv));
2399 dVAR; dSP; tryAMAGICunSET(not);
2400 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2406 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2411 if (PL_op->op_private & HINT_INTEGER) {
2412 const IV i = ~SvIV_nomg(sv);
2416 const UV u = ~SvUV_nomg(sv);
2425 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2426 sv_setsv_nomg(TARG, sv);
2427 tmps = (U8*)SvPV_force(TARG, len);
2430 /* Calculate exact length, let's not estimate. */
2435 U8 * const send = tmps + len;
2436 U8 * const origtmps = tmps;
2437 const UV utf8flags = UTF8_ALLOW_ANYUV;
2439 while (tmps < send) {
2440 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2442 targlen += UNISKIP(~c);
2448 /* Now rewind strings and write them. */
2455 Newx(result, targlen + 1, U8);
2457 while (tmps < send) {
2458 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2460 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2463 sv_usepvn_flags(TARG, (char*)result, targlen,
2464 SV_HAS_TRAILING_NUL);
2471 Newx(result, nchar + 1, U8);
2473 while (tmps < send) {
2474 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2479 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2487 register long *tmpl;
2488 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2491 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2496 for ( ; anum > 0; anum--, tmps++)
2505 /* integer versions of some of the above */
2509 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2512 SETi( left * right );
2520 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2524 DIE(aTHX_ "Illegal division by zero");
2527 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2531 value = num / value;
2540 /* This is the vanilla old i_modulo. */
2541 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2545 DIE(aTHX_ "Illegal modulus zero");
2546 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2550 SETi( left % right );
2555 #if defined(__GLIBC__) && IVSIZE == 8
2559 /* This is the i_modulo with the workaround for the _moddi3 bug
2560 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2561 * See below for pp_i_modulo. */
2562 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2566 DIE(aTHX_ "Illegal modulus zero");
2567 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2571 SETi( left % PERL_ABS(right) );
2579 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2583 DIE(aTHX_ "Illegal modulus zero");
2584 /* The assumption is to use hereafter the old vanilla version... */
2586 PL_ppaddr[OP_I_MODULO] =
2588 /* .. but if we have glibc, we might have a buggy _moddi3
2589 * (at least glicb 2.2.5 is known to have this bug), in other
2590 * words our integer modulus with negative quad as the second
2591 * argument might be broken. Test for this and re-patch the
2592 * opcode dispatch table if that is the case, remembering to
2593 * also apply the workaround so that this first round works
2594 * right, too. See [perl #9402] for more information. */
2595 #if defined(__GLIBC__) && IVSIZE == 8
2599 /* Cannot do this check with inlined IV constants since
2600 * that seems to work correctly even with the buggy glibc. */
2602 /* Yikes, we have the bug.
2603 * Patch in the workaround version. */
2605 PL_ppaddr[OP_I_MODULO] =
2606 &Perl_pp_i_modulo_1;
2607 /* Make certain we work right this time, too. */
2608 right = PERL_ABS(right);
2612 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2616 SETi( left % right );
2623 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2626 SETi( left + right );
2633 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2636 SETi( left - right );
2643 dVAR; dSP; tryAMAGICbinSET(lt,0);
2646 SETs(boolSV(left < right));
2653 dVAR; dSP; tryAMAGICbinSET(gt,0);
2656 SETs(boolSV(left > right));
2663 dVAR; dSP; tryAMAGICbinSET(le,0);
2666 SETs(boolSV(left <= right));
2673 dVAR; dSP; tryAMAGICbinSET(ge,0);
2676 SETs(boolSV(left >= right));
2683 dVAR; dSP; tryAMAGICbinSET(eq,0);
2686 SETs(boolSV(left == right));
2693 dVAR; dSP; tryAMAGICbinSET(ne,0);
2696 SETs(boolSV(left != right));
2703 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2710 else if (left < right)
2721 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2726 /* High falutin' math. */
2730 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2733 SETn(Perl_atan2(left, right));
2741 int amg_type = sin_amg;
2742 const char *neg_report = NULL;
2743 NV (*func)(NV) = Perl_sin;
2744 const int op_type = PL_op->op_type;
2761 amg_type = sqrt_amg;
2763 neg_report = "sqrt";
2767 tryAMAGICun_var(amg_type);
2769 const NV value = POPn;
2771 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2772 SET_NUMERIC_STANDARD();
2773 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2776 XPUSHn(func(value));
2781 /* Support Configure command-line overrides for rand() functions.
2782 After 5.005, perhaps we should replace this by Configure support
2783 for drand48(), random(), or rand(). For 5.005, though, maintain
2784 compatibility by calling rand() but allow the user to override it.
2785 See INSTALL for details. --Andy Dougherty 15 July 1998
2787 /* Now it's after 5.005, and Configure supports drand48() and random(),
2788 in addition to rand(). So the overrides should not be needed any more.
2789 --Jarkko Hietaniemi 27 September 1998
2792 #ifndef HAS_DRAND48_PROTO
2793 extern double drand48 (void);
2806 if (!PL_srand_called) {
2807 (void)seedDrand01((Rand_seed_t)seed());
2808 PL_srand_called = TRUE;
2818 const UV anum = (MAXARG < 1) ? seed() : POPu;
2819 (void)seedDrand01((Rand_seed_t)anum);
2820 PL_srand_called = TRUE;
2827 dVAR; dSP; dTARGET; tryAMAGICun(int);
2829 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2830 /* XXX it's arguable that compiler casting to IV might be subtly
2831 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2832 else preferring IV has introduced a subtle behaviour change bug. OTOH
2833 relying on floating point to be accurate is a bug. */
2837 else if (SvIOK(TOPs)) {
2844 const NV value = TOPn;
2846 if (value < (NV)UV_MAX + 0.5) {
2849 SETn(Perl_floor(value));
2853 if (value > (NV)IV_MIN - 0.5) {
2856 SETn(Perl_ceil(value));
2866 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2868 /* This will cache the NV value if string isn't actually integer */
2873 else if (SvIOK(TOPs)) {
2874 /* IVX is precise */
2876 SETu(TOPu); /* force it to be numeric only */
2884 /* 2s complement assumption. Also, not really needed as
2885 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2891 const NV value = TOPn;
2905 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2909 SV* const sv = POPs;
2911 tmps = (SvPV_const(sv, len));
2913 /* If Unicode, try to downgrade
2914 * If not possible, croak. */
2915 SV* const tsv = sv_2mortal(newSVsv(sv));
2918 sv_utf8_downgrade(tsv, FALSE);
2919 tmps = SvPV_const(tsv, len);
2921 if (PL_op->op_type == OP_HEX)
2924 while (*tmps && len && isSPACE(*tmps))
2930 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2932 else if (*tmps == 'b')
2933 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2935 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2937 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2951 SV * const sv = TOPs;
2954 /* For an overloaded scalar, we can't know in advance if it's going to
2955 be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to
2956 cache the length. Maybe that should be a documented feature of it.
2959 const char *const p = SvPV_const(sv, len);
2962 SETi(utf8_length((U8*)p, (U8*)p + len));
2968 else if (DO_UTF8(sv))
2969 SETi(sv_len_utf8(sv));
2985 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2987 const I32 arybase = CopARYBASE_get(PL_curcop);
2989 const char *repl = NULL;
2991 const int num_args = PL_op->op_private & 7;
2992 bool repl_need_utf8_upgrade = FALSE;
2993 bool repl_is_utf8 = FALSE;
2995 SvTAINTED_off(TARG); /* decontaminate */
2996 SvUTF8_off(TARG); /* decontaminate */
3000 repl = SvPV_const(repl_sv, repl_len);
3001 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3011 sv_utf8_upgrade(sv);
3013 else if (DO_UTF8(sv))
3014 repl_need_utf8_upgrade = TRUE;
3016 tmps = SvPV_const(sv, curlen);
3018 utf8_curlen = sv_len_utf8(sv);
3019 if (utf8_curlen == curlen)
3022 curlen = utf8_curlen;
3027 if (pos >= arybase) {
3045 else if (len >= 0) {
3047 if (rem > (I32)curlen)
3062 Perl_croak(aTHX_ "substr outside of string");
3063 if (ckWARN(WARN_SUBSTR))
3064 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3068 const I32 upos = pos;
3069 const I32 urem = rem;
3071 sv_pos_u2b(sv, &pos, &rem);
3073 /* we either return a PV or an LV. If the TARG hasn't been used
3074 * before, or is of that type, reuse it; otherwise use a mortal
3075 * instead. Note that LVs can have an extended lifetime, so also
3076 * dont reuse if refcount > 1 (bug #20933) */
3077 if (SvTYPE(TARG) > SVt_NULL) {
3078 if ( (SvTYPE(TARG) == SVt_PVLV)
3079 ? (!lvalue || SvREFCNT(TARG) > 1)
3082 TARG = sv_newmortal();
3086 sv_setpvn(TARG, tmps, rem);
3087 #ifdef USE_LOCALE_COLLATE
3088 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3093 SV* repl_sv_copy = NULL;
3095 if (repl_need_utf8_upgrade) {
3096 repl_sv_copy = newSVsv(repl_sv);
3097 sv_utf8_upgrade(repl_sv_copy);
3098 repl = SvPV_const(repl_sv_copy, repl_len);
3099 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3101 sv_insert(sv, pos, rem, repl, repl_len);
3105 SvREFCNT_dec(repl_sv_copy);
3107 else if (lvalue) { /* it's an lvalue! */
3108 if (!SvGMAGICAL(sv)) {
3110 SvPV_force_nolen(sv);
3111 if (ckWARN(WARN_SUBSTR))
3112 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3113 "Attempt to use reference as lvalue in substr");
3115 if (isGV_with_GP(sv))
3116 SvPV_force_nolen(sv);
3117 else if (SvOK(sv)) /* is it defined ? */
3118 (void)SvPOK_only_UTF8(sv);
3120 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3123 if (SvTYPE(TARG) < SVt_PVLV) {
3124 sv_upgrade(TARG, SVt_PVLV);
3125 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3131 if (LvTARG(TARG) != sv) {
3133 SvREFCNT_dec(LvTARG(TARG));
3134 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3136 LvTARGOFF(TARG) = upos;
3137 LvTARGLEN(TARG) = urem;
3141 PUSHs(TARG); /* avoid SvSETMAGIC here */
3148 register const IV size = POPi;
3149 register const IV offset = POPi;
3150 register SV * const src = POPs;
3151 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3153 SvTAINTED_off(TARG); /* decontaminate */
3154 if (lvalue) { /* it's an lvalue! */
3155 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3156 TARG = sv_newmortal();
3157 if (SvTYPE(TARG) < SVt_PVLV) {
3158 sv_upgrade(TARG, SVt_PVLV);
3159 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3162 if (LvTARG(TARG) != src) {
3164 SvREFCNT_dec(LvTARG(TARG));
3165 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3167 LvTARGOFF(TARG) = offset;
3168 LvTARGLEN(TARG) = size;
3171 sv_setuv(TARG, do_vecget(src, offset, size));
3188 const I32 arybase = CopARYBASE_get(PL_curcop);
3191 const bool is_index = PL_op->op_type == OP_INDEX;
3194 /* arybase is in characters, like offset, so combine prior to the
3195 UTF-8 to bytes calculation. */
3196 offset = POPi - arybase;
3200 big_utf8 = DO_UTF8(big);
3201 little_utf8 = DO_UTF8(little);
3202 if (big_utf8 ^ little_utf8) {
3203 /* One needs to be upgraded. */
3204 if (little_utf8 && !PL_encoding) {
3205 /* Well, maybe instead we might be able to downgrade the small
3208 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3209 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3212 /* If the large string is ISO-8859-1, and it's not possible to
3213 convert the small string to ISO-8859-1, then there is no
3214 way that it could be found anywhere by index. */
3219 /* At this point, pv is a malloc()ed string. So donate it to temp
3220 to ensure it will get free()d */
3221 little = temp = newSV(0);
3222 sv_usepvn(temp, pv, little_len);
3224 SV * const bytes = little_utf8 ? big : little;
3226 const char * const p = SvPV_const(bytes, len);
3228 temp = newSVpvn(p, len);
3231 sv_recode_to_utf8(temp, PL_encoding);
3233 sv_utf8_upgrade(temp);
3243 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3244 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3245 tmps = SvPV_const(big, biglen);
3248 offset = is_index ? 0 : biglen;
3250 if (big_utf8 && offset > 0)
3251 sv_pos_u2b(big, &offset, 0);
3256 else if (offset > (I32)biglen)
3258 if (!(tmps2 = is_index
3259 ? fbm_instr((unsigned char*)tmps + offset,
3260 (unsigned char*)tmps + biglen, little, 0)
3261 : rninstr(tmps, tmps + offset,
3262 tmps2, tmps2 + llen)))
3265 retval = tmps2 - tmps;
3266 if (retval > 0 && big_utf8)
3267 sv_pos_b2u(big, &retval);
3272 PUSHi(retval + arybase);
3278 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3279 do_sprintf(TARG, SP-MARK, MARK+1);
3280 TAINT_IF(SvTAINTED(TARG));
3291 const U8 *s = (U8*)SvPV_const(argsv, len);
3294 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3295 tmpsv = sv_2mortal(newSVsv(argsv));
3296 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3300 XPUSHu(DO_UTF8(argsv) ?
3301 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3313 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3315 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3317 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3319 (void) POPs; /* Ignore the argument value. */
3320 value = UNICODE_REPLACEMENT;
3326 SvUPGRADE(TARG,SVt_PV);
3328 if (value > 255 && !IN_BYTES) {
3329 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3330 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3331 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3333 (void)SvPOK_only(TARG);
3342 *tmps++ = (char)value;
3344 (void)SvPOK_only(TARG);
3345 if (PL_encoding && !IN_BYTES) {
3346 sv_recode_to_utf8(TARG, PL_encoding);
3348 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3349 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3353 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3354 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3369 const char *tmps = SvPV_const(left, len);
3371 if (DO_UTF8(left)) {
3372 /* If Unicode, try to downgrade.
3373 * If not possible, croak.
3374 * Yes, we made this up. */
3375 SV* const tsv = sv_2mortal(newSVsv(left));
3378 sv_utf8_downgrade(tsv, FALSE);
3379 tmps = SvPV_const(tsv, len);
3381 # ifdef USE_ITHREADS
3383 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3384 /* This should be threadsafe because in ithreads there is only
3385 * one thread per interpreter. If this would not be true,
3386 * we would need a mutex to protect this malloc. */
3387 PL_reentrant_buffer->_crypt_struct_buffer =
3388 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3389 #if defined(__GLIBC__) || defined(__EMX__)
3390 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3391 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3392 /* work around glibc-2.2.5 bug */
3393 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3397 # endif /* HAS_CRYPT_R */
3398 # endif /* USE_ITHREADS */
3400 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3402 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3408 "The crypt() function is unimplemented due to excessive paranoia.");
3419 const int op_type = PL_op->op_type;
3423 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3424 UTF8_IS_START(*s)) {
3425 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3429 utf8_to_uvchr(s, &ulen);
3430 if (op_type == OP_UCFIRST) {
3431 toTITLE_utf8(s, tmpbuf, &tculen);
3433 toLOWER_utf8(s, tmpbuf, &tculen);
3436 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3438 /* slen is the byte length of the whole SV.
3439 * ulen is the byte length of the original Unicode character
3440 * stored as UTF-8 at s.
3441 * tculen is the byte length of the freshly titlecased (or
3442 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3443 * We first set the result to be the titlecased (/lowercased)
3444 * character, and then append the rest of the SV data. */
3445 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3447 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3453 s = (U8*)SvPV_force_nomg(sv, slen);
3454 Copy(tmpbuf, s, tculen, U8);
3459 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3461 SvUTF8_off(TARG); /* decontaminate */
3462 sv_setsv_nomg(TARG, sv);
3466 s1 = (U8*)SvPV_force_nomg(sv, slen);
3468 if (IN_LOCALE_RUNTIME) {
3471 *s1 = (op_type == OP_UCFIRST)
3472 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3475 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3482 /* There's so much setup/teardown code common between uc and lc, I wonder if
3483 it would be worth merging the two, and just having a switch outside each
3484 of the three tight loops. */
3498 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3499 && !DO_UTF8(source)) {
3500 /* We can convert in place. */
3503 s = d = (U8*)SvPV_force_nomg(source, len);
3510 /* The old implementation would copy source into TARG at this point.
3511 This had the side effect that if source was undef, TARG was now
3512 an undefined SV with PADTMP set, and they don't warn inside
3513 sv_2pv_flags(). However, we're now getting the PV direct from
3514 source, which doesn't have PADTMP set, so it would warn. Hence the
3518 s = (const U8*)SvPV_nomg_const(source, len);
3525 SvUPGRADE(dest, SVt_PV);
3526 d = SvGROW(dest, min);
3527 (void)SvPOK_only(dest);
3532 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3533 to check DO_UTF8 again here. */
3535 if (DO_UTF8(source)) {
3536 const U8 *const send = s + len;
3537 U8 tmpbuf[UTF8_MAXBYTES+1];
3540 const STRLEN u = UTF8SKIP(s);
3543 toUPPER_utf8(s, tmpbuf, &ulen);
3544 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3545 /* If the eventually required minimum size outgrows
3546 * the available space, we need to grow. */
3547 const UV o = d - (U8*)SvPVX_const(dest);
3549 /* If someone uppercases one million U+03B0s we SvGROW() one
3550 * million times. Or we could try guessing how much to
3551 allocate without allocating too much. Such is life. */
3553 d = (U8*)SvPVX(dest) + o;
3555 Copy(tmpbuf, d, ulen, U8);
3561 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3564 const U8 *const send = s + len;
3565 if (IN_LOCALE_RUNTIME) {
3568 for (; s < send; d++, s++)
3569 *d = toUPPER_LC(*s);
3572 for (; s < send; d++, s++)
3576 if (source != dest) {
3578 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
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 = 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_CASE+1];
3640 const STRLEN u = UTF8SKIP(s);
3642 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3644 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3645 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3648 * Now if the sigma is NOT followed by
3649 * /$ignorable_sequence$cased_letter/;
3650 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3651 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3652 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3653 * then it should be mapped to 0x03C2,
3654 * (GREEK SMALL LETTER FINAL SIGMA),
3655 * instead of staying 0x03A3.
3656 * "should be": in other words, this is not implemented yet.
3657 * See lib/unicore/SpecialCasing.txt.
3660 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3661 /* If the eventually required minimum size outgrows
3662 * the available space, we need to grow. */
3663 const UV o = d - (U8*)SvPVX_const(dest);
3665 /* If someone lowercases one million U+0130s we SvGROW() one
3666 * million times. Or we could try guessing how much to
3667 allocate without allocating too much. Such is life. */
3669 d = (U8*)SvPVX(dest) + o;
3671 Copy(tmpbuf, d, ulen, U8);
3677 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3680 const U8 *const send = s + len;
3681 if (IN_LOCALE_RUNTIME) {
3684 for (; s < send; d++, s++)
3685 *d = toLOWER_LC(*s);
3688 for (; s < send; d++, s++)
3692 if (source != dest) {
3694 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3704 SV * const sv = TOPs;
3706 register const char *s = SvPV_const(sv,len);
3708 SvUTF8_off(TARG); /* decontaminate */
3711 SvUPGRADE(TARG, SVt_PV);
3712 SvGROW(TARG, (len * 2) + 1);
3716 if (UTF8_IS_CONTINUED(*s)) {
3717 STRLEN ulen = UTF8SKIP(s);
3741 SvCUR_set(TARG, d - SvPVX_const(TARG));
3742 (void)SvPOK_only_UTF8(TARG);
3745 sv_setpvn(TARG, s, len);
3747 if (SvSMAGICAL(TARG))
3756 dVAR; dSP; dMARK; dORIGMARK;
3757 register AV* const av = (AV*)POPs;
3758 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3760 if (SvTYPE(av) == SVt_PVAV) {
3761 const I32 arybase = CopARYBASE_get(PL_curcop);
3762 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3765 for (svp = MARK + 1; svp <= SP; svp++) {
3766 const I32 elem = SvIVx(*svp);
3770 if (max > AvMAX(av))
3773 while (++MARK <= SP) {
3775 I32 elem = SvIVx(*MARK);
3779 svp = av_fetch(av, elem, lval);
3781 if (!svp || *svp == &PL_sv_undef)
3782 DIE(aTHX_ PL_no_aelem, elem);
3783 if (PL_op->op_private & OPpLVAL_INTRO)
3784 save_aelem(av, elem, svp);
3786 *MARK = svp ? *svp : &PL_sv_undef;
3789 if (GIMME != G_ARRAY) {
3791 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3797 /* Associative arrays. */
3803 HV * const hash = (HV*)POPs;
3805 const I32 gimme = GIMME_V;
3808 /* might clobber stack_sp */
3809 entry = hv_iternext(hash);
3814 SV* const sv = hv_iterkeysv(entry);
3815 PUSHs(sv); /* won't clobber stack_sp */
3816 if (gimme == G_ARRAY) {
3819 /* might clobber stack_sp */
3820 val = hv_iterval(hash, entry);
3825 else if (gimme == G_SCALAR)
3835 const I32 gimme = GIMME_V;
3836 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3838 if (PL_op->op_private & OPpSLICE) {
3840 HV * const hv = (HV*)POPs;
3841 const U32 hvtype = SvTYPE(hv);
3842 if (hvtype == SVt_PVHV) { /* hash element */
3843 while (++MARK <= SP) {
3844 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3845 *MARK = sv ? sv : &PL_sv_undef;
3848 else if (hvtype == SVt_PVAV) { /* array element */
3849 if (PL_op->op_flags & OPf_SPECIAL) {
3850 while (++MARK <= SP) {
3851 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3852 *MARK = sv ? sv : &PL_sv_undef;
3857 DIE(aTHX_ "Not a HASH reference");
3860 else if (gimme == G_SCALAR) {
3865 *++MARK = &PL_sv_undef;
3871 HV * const hv = (HV*)POPs;
3873 if (SvTYPE(hv) == SVt_PVHV)
3874 sv = hv_delete_ent(hv, keysv, discard, 0);
3875 else if (SvTYPE(hv) == SVt_PVAV) {
3876 if (PL_op->op_flags & OPf_SPECIAL)
3877 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3879 DIE(aTHX_ "panic: avhv_delete no longer supported");
3882 DIE(aTHX_ "Not a HASH reference");
3898 if (PL_op->op_private & OPpEXISTS_SUB) {
3900 SV * const sv = POPs;
3901 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3904 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3910 if (SvTYPE(hv) == SVt_PVHV) {
3911 if (hv_exists_ent(hv, tmpsv, 0))
3914 else if (SvTYPE(hv) == SVt_PVAV) {
3915 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3916 if (av_exists((AV*)hv, SvIV(tmpsv)))
3921 DIE(aTHX_ "Not a HASH reference");
3928 dVAR; dSP; dMARK; dORIGMARK;
3929 register HV * const hv = (HV*)POPs;
3930 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3931 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3932 bool other_magic = FALSE;
3938 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3939 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3940 /* Try to preserve the existenceness of a tied hash
3941 * element by using EXISTS and DELETE if possible.
3942 * Fallback to FETCH and STORE otherwise */
3943 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3944 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3945 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3948 while (++MARK <= SP) {
3949 SV * const keysv = *MARK;
3952 bool preeminent = FALSE;
3955 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3956 hv_exists_ent(hv, keysv, 0);
3959 he = hv_fetch_ent(hv, keysv, lval, 0);
3960 svp = he ? &HeVAL(he) : 0;
3963 if (!svp || *svp == &PL_sv_undef) {
3964 DIE(aTHX_ PL_no_helem_sv, keysv);
3967 if (HvNAME_get(hv) && isGV(*svp))
3968 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
3971 save_helem(hv, keysv, svp);
3974 const char * const key = SvPV_const(keysv, keylen);
3975 SAVEDELETE(hv, savepvn(key,keylen),
3976 SvUTF8(keysv) ? -keylen : keylen);
3981 *MARK = svp ? *svp : &PL_sv_undef;
3983 if (GIMME != G_ARRAY) {
3985 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3991 /* List operators. */
3996 if (GIMME != G_ARRAY) {
3998 *MARK = *SP; /* unwanted list, return last item */
4000 *MARK = &PL_sv_undef;
4010 SV ** const lastrelem = PL_stack_sp;
4011 SV ** const lastlelem = PL_stack_base + POPMARK;
4012 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4013 register SV ** const firstrelem = lastlelem + 1;
4014 const I32 arybase = CopARYBASE_get(PL_curcop);
4015 I32 is_something_there = PL_op->op_flags & OPf_MOD;
4017 register const I32 max = lastrelem - lastlelem;
4018 register SV **lelem;
4020 if (GIMME != G_ARRAY) {
4021 I32 ix = SvIVx(*lastlelem);
4026 if (ix < 0 || ix >= max)
4027 *firstlelem = &PL_sv_undef;
4029 *firstlelem = firstrelem[ix];
4035 SP = firstlelem - 1;
4039 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4040 I32 ix = SvIVx(*lelem);
4045 if (ix < 0 || ix >= max)
4046 *lelem = &PL_sv_undef;
4048 is_something_there = TRUE;
4049 if (!(*lelem = firstrelem[ix]))
4050 *lelem = &PL_sv_undef;
4053 if (is_something_there)
4056 SP = firstlelem - 1;
4062 dVAR; dSP; dMARK; dORIGMARK;
4063 const I32 items = SP - MARK;
4064 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4065 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4072 dVAR; dSP; dMARK; dORIGMARK;
4073 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4076 SV * const key = *++MARK;
4077 SV * const val = newSV(0);
4079 sv_setsv(val, *++MARK);
4080 else if (ckWARN(WARN_MISC))
4081 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4082 (void)hv_store_ent(hv,key,val,0);
4091 dVAR; dSP; dMARK; dORIGMARK;
4092 register AV *ary = (AV*)*++MARK;
4096 register I32 offset;
4097 register I32 length;
4101 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4104 *MARK-- = SvTIED_obj((SV*)ary, mg);
4108 call_method("SPLICE",GIMME_V);
4117 offset = i = SvIVx(*MARK);
4119 offset += AvFILLp(ary) + 1;
4121 offset -= CopARYBASE_get(PL_curcop);
4123 DIE(aTHX_ PL_no_aelem, i);
4125 length = SvIVx(*MARK++);
4127 length += AvFILLp(ary) - offset + 1;
4133 length = AvMAX(ary) + 1; /* close enough to infinity */
4137 length = AvMAX(ary) + 1;
4139 if (offset > AvFILLp(ary) + 1) {
4140 if (ckWARN(WARN_MISC))
4141 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4142 offset = AvFILLp(ary) + 1;
4144 after = AvFILLp(ary) + 1 - (offset + length);
4145 if (after < 0) { /* not that much array */
4146 length += after; /* offset+length now in array */
4152 /* At this point, MARK .. SP-1 is our new LIST */
4155 diff = newlen - length;
4156 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4159 /* make new elements SVs now: avoid problems if they're from the array */
4160 for (dst = MARK, i = newlen; i; i--) {
4161 SV * const h = *dst;
4162 *dst++ = newSVsv(h);
4165 if (diff < 0) { /* shrinking the area */
4166 SV **tmparyval = NULL;
4168 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4169 Copy(MARK, tmparyval, newlen, SV*);
4172 MARK = ORIGMARK + 1;
4173 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4174 MEXTEND(MARK, length);
4175 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4177 EXTEND_MORTAL(length);
4178 for (i = length, dst = MARK; i; i--) {
4179 sv_2mortal(*dst); /* free them eventualy */
4186 *MARK = AvARRAY(ary)[offset+length-1];
4189 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4190 SvREFCNT_dec(*dst++); /* free them now */
4193 AvFILLp(ary) += diff;
4195 /* pull up or down? */
4197 if (offset < after) { /* easier to pull up */
4198 if (offset) { /* esp. if nothing to pull */
4199 src = &AvARRAY(ary)[offset-1];
4200 dst = src - diff; /* diff is negative */
4201 for (i = offset; i > 0; i--) /* can't trust Copy */
4205 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4209 if (after) { /* anything to pull down? */
4210 src = AvARRAY(ary) + offset + length;
4211 dst = src + diff; /* diff is negative */
4212 Move(src, dst, after, SV*);
4214 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4215 /* avoid later double free */
4219 dst[--i] = &PL_sv_undef;
4222 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4223 Safefree(tmparyval);
4226 else { /* no, expanding (or same) */
4227 SV** tmparyval = NULL;
4229 Newx(tmparyval, length, SV*); /* so remember deletion */
4230 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4233 if (diff > 0) { /* expanding */
4234 /* push up or down? */
4235 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4239 Move(src, dst, offset, SV*);
4241 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4243 AvFILLp(ary) += diff;
4246 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4247 av_extend(ary, AvFILLp(ary) + diff);
4248 AvFILLp(ary) += diff;
4251 dst = AvARRAY(ary) + AvFILLp(ary);
4253 for (i = after; i; i--) {
4261 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4264 MARK = ORIGMARK + 1;
4265 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4267 Copy(tmparyval, MARK, length, SV*);
4269 EXTEND_MORTAL(length);
4270 for (i = length, dst = MARK; i; i--) {
4271 sv_2mortal(*dst); /* free them eventualy */
4278 else if (length--) {
4279 *MARK = tmparyval[length];
4282 while (length-- > 0)
4283 SvREFCNT_dec(tmparyval[length]);
4287 *MARK = &PL_sv_undef;
4288 Safefree(tmparyval);
4296 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4297 register AV *ary = (AV*)*++MARK;
4298 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4301 *MARK-- = SvTIED_obj((SV*)ary, mg);
4305 call_method("PUSH",G_SCALAR|G_DISCARD);
4309 PUSHi( AvFILL(ary) + 1 );
4312 for (++MARK; MARK <= SP; MARK++) {
4313 SV * const sv = newSV(0);
4315 sv_setsv(sv, *MARK);
4316 av_store(ary, AvFILLp(ary)+1, sv);
4319 PUSHi( AvFILLp(ary) + 1 );
4328 AV * const av = (AV*)POPs;
4329 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4333 (void)sv_2mortal(sv);
4340 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4341 register AV *ary = (AV*)*++MARK;
4342 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4345 *MARK-- = SvTIED_obj((SV*)ary, mg);
4349 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4355 av_unshift(ary, SP - MARK);
4357 SV * const sv = newSVsv(*++MARK);
4358 (void)av_store(ary, i++, sv);
4362 PUSHi( AvFILL(ary) + 1 );
4369 SV ** const oldsp = SP;
4371 if (GIMME == G_ARRAY) {
4374 register SV * const tmp = *MARK;
4378 /* safe as long as stack cannot get extended in the above */
4383 register char *down;
4387 PADOFFSET padoff_du;
4389 SvUTF8_off(TARG); /* decontaminate */
4391 do_join(TARG, &PL_sv_no, MARK, SP);
4393 sv_setsv(TARG, (SP > MARK)
4395 : (padoff_du = find_rundefsvoffset(),
4396 (padoff_du == NOT_IN_PAD
4397 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4398 ? DEFSV : PAD_SVl(padoff_du)));
4399 up = SvPV_force(TARG, len);
4401 if (DO_UTF8(TARG)) { /* first reverse each character */
4402 U8* s = (U8*)SvPVX(TARG);
4403 const U8* send = (U8*)(s + len);
4405 if (UTF8_IS_INVARIANT(*s)) {
4410 if (!utf8_to_uvchr(s, 0))
4414 down = (char*)(s - 1);
4415 /* reverse this character */
4419 *down-- = (char)tmp;
4425 down = SvPVX(TARG) + len - 1;
4429 *down-- = (char)tmp;
4431 (void)SvPOK_only_UTF8(TARG);
4443 register IV limit = POPi; /* note, negative is forever */
4444 SV * const sv = POPs;
4446 register const char *s = SvPV_const(sv, len);
4447 const bool do_utf8 = DO_UTF8(sv);
4448 const char *strend = s + len;
4450 register REGEXP *rx;
4452 register const char *m;
4454 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4455 I32 maxiters = slen + 10;
4457 const I32 origlimit = limit;
4460 const I32 gimme = GIMME_V;
4461 const I32 oldsave = PL_savestack_ix;
4462 I32 make_mortal = 1;
4467 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4472 DIE(aTHX_ "panic: pp_split");
4475 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4476 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4478 RX_MATCH_UTF8_set(rx, do_utf8);
4480 if (pm->op_pmreplroot) {
4482 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4484 ary = GvAVn((GV*)pm->op_pmreplroot);
4487 else if (gimme != G_ARRAY)
4488 ary = GvAVn(PL_defgv);
4491 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4497 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4499 XPUSHs(SvTIED_obj((SV*)ary, mg));
4506 for (i = AvFILLp(ary); i >= 0; i--)
4507 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4509 /* temporarily switch stacks */
4510 SAVESWITCHSTACK(PL_curstack, ary);
4514 base = SP - PL_stack_base;
4516 if (pm->op_pmflags & PMf_SKIPWHITE) {
4517 if (pm->op_pmflags & PMf_LOCALE) {
4518 while (isSPACE_LC(*s))
4526 if (pm->op_pmflags & PMf_MULTILINE) {
4531 limit = maxiters + 2;
4532 if (pm->op_pmflags & PMf_WHITE) {
4535 while (m < strend &&
4536 !((pm->op_pmflags & PMf_LOCALE)
4537 ? isSPACE_LC(*m) : isSPACE(*m)))
4542 dstr = newSVpvn(s, m-s);
4546 (void)SvUTF8_on(dstr);
4550 while (s < strend &&
4551 ((pm->op_pmflags & PMf_LOCALE)
4552 ? isSPACE_LC(*s) : isSPACE(*s)))
4556 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4558 for (m = s; m < strend && *m != '\n'; m++)
4563 dstr = newSVpvn(s, m-s);
4567 (void)SvUTF8_on(dstr);
4572 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4573 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4574 && (rx->reganch & ROPT_CHECK_ALL)
4575 && !(rx->reganch & ROPT_ANCH)) {
4576 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4577 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4580 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4581 const char c = *SvPV_nolen_const(csv);
4583 for (m = s; m < strend && *m != c; m++)
4587 dstr = newSVpvn(s, m-s);
4591 (void)SvUTF8_on(dstr);
4593 /* The rx->minlen is in characters but we want to step
4594 * s ahead by bytes. */
4596 s = (char*)utf8_hop((U8*)m, len);
4598 s = m + len; /* Fake \n at the end */
4602 while (s < strend && --limit &&
4603 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4604 csv, multiline ? FBMrf_MULTILINE : 0)) )
4606 dstr = newSVpvn(s, m-s);
4610 (void)SvUTF8_on(dstr);
4612 /* The rx->minlen is in characters but we want to step
4613 * s ahead by bytes. */
4615 s = (char*)utf8_hop((U8*)m, len);
4617 s = m + len; /* Fake \n at the end */
4622 maxiters += slen * rx->nparens;
4623 while (s < strend && --limit)
4627 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4630 if (rex_return == 0)
4632 TAINT_IF(RX_MATCH_TAINTED(rx));
4633 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4638 strend = s + (strend - m);
4640 m = rx->startp[0] + orig;
4641 dstr = newSVpvn(s, m-s);
4645 (void)SvUTF8_on(dstr);
4649 for (i = 1; i <= (I32)rx->nparens; i++) {
4650 s = rx->startp[i] + orig;
4651 m = rx->endp[i] + orig;
4653 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4654 parens that didn't match -- they should be set to
4655 undef, not the empty string */
4656 if (m >= orig && s >= orig) {
4657 dstr = newSVpvn(s, m-s);
4660 dstr = &PL_sv_undef; /* undef, not "" */
4664 (void)SvUTF8_on(dstr);
4668 s = rx->endp[0] + orig;
4672 iters = (SP - PL_stack_base) - base;
4673 if (iters > maxiters)
4674 DIE(aTHX_ "Split loop");
4676 /* keep field after final delim? */
4677 if (s < strend || (iters && origlimit)) {
4678 const STRLEN l = strend - s;
4679 dstr = newSVpvn(s, l);
4683 (void)SvUTF8_on(dstr);
4687 else if (!origlimit) {
4688 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4689 if (TOPs && !make_mortal)
4692 *SP-- = &PL_sv_undef;
4697 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4701 if (SvSMAGICAL(ary)) {
4706 if (gimme == G_ARRAY) {
4708 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4716 call_method("PUSH",G_SCALAR|G_DISCARD);
4719 if (gimme == G_ARRAY) {
4721 /* EXTEND should not be needed - we just popped them */
4723 for (i=0; i < iters; i++) {
4724 SV **svp = av_fetch(ary, i, FALSE);
4725 PUSHs((svp) ? *svp : &PL_sv_undef);
4732 if (gimme == G_ARRAY)
4748 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4749 || SvTYPE(retsv) == SVt_PVCV) {
4750 retsv = refto(retsv);
4757 PP(unimplemented_op)
4760 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4766 * c-indentation-style: bsd
4768 * indent-tabs-mode: t
4771 * ex: set ts=8 sts=4 sw=4 noet: