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;
2437 while (tmps < send) {
2438 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2439 tmps += UTF8SKIP(tmps);
2440 targlen += UNISKIP(~c);
2446 /* Now rewind strings and write them. */
2453 Newxz(result, targlen + 1, U8);
2455 while (tmps < send) {
2456 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2457 tmps += UTF8SKIP(tmps);
2458 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2461 sv_usepvn_flags(TARG, (char*)result, targlen,
2462 SV_HAS_TRAILING_NUL);
2469 Newxz(result, nchar + 1, U8);
2471 while (tmps < send) {
2472 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2473 tmps += UTF8SKIP(tmps);
2477 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2485 register long *tmpl;
2486 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2489 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2494 for ( ; anum > 0; anum--, tmps++)
2503 /* integer versions of some of the above */
2507 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2510 SETi( left * right );
2518 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2522 DIE(aTHX_ "Illegal division by zero");
2525 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2529 value = num / value;
2538 /* This is the vanilla old i_modulo. */
2539 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2543 DIE(aTHX_ "Illegal modulus zero");
2544 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2548 SETi( left % right );
2553 #if defined(__GLIBC__) && IVSIZE == 8
2557 /* This is the i_modulo with the workaround for the _moddi3 bug
2558 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2559 * See below for pp_i_modulo. */
2560 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2564 DIE(aTHX_ "Illegal modulus zero");
2565 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2569 SETi( left % PERL_ABS(right) );
2577 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2581 DIE(aTHX_ "Illegal modulus zero");
2582 /* The assumption is to use hereafter the old vanilla version... */
2584 PL_ppaddr[OP_I_MODULO] =
2586 /* .. but if we have glibc, we might have a buggy _moddi3
2587 * (at least glicb 2.2.5 is known to have this bug), in other
2588 * words our integer modulus with negative quad as the second
2589 * argument might be broken. Test for this and re-patch the
2590 * opcode dispatch table if that is the case, remembering to
2591 * also apply the workaround so that this first round works
2592 * right, too. See [perl #9402] for more information. */
2593 #if defined(__GLIBC__) && IVSIZE == 8
2597 /* Cannot do this check with inlined IV constants since
2598 * that seems to work correctly even with the buggy glibc. */
2600 /* Yikes, we have the bug.
2601 * Patch in the workaround version. */
2603 PL_ppaddr[OP_I_MODULO] =
2604 &Perl_pp_i_modulo_1;
2605 /* Make certain we work right this time, too. */
2606 right = PERL_ABS(right);
2610 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2614 SETi( left % right );
2621 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2624 SETi( left + right );
2631 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2634 SETi( left - right );
2641 dVAR; dSP; tryAMAGICbinSET(lt,0);
2644 SETs(boolSV(left < right));
2651 dVAR; dSP; tryAMAGICbinSET(gt,0);
2654 SETs(boolSV(left > right));
2661 dVAR; dSP; tryAMAGICbinSET(le,0);
2664 SETs(boolSV(left <= right));
2671 dVAR; dSP; tryAMAGICbinSET(ge,0);
2674 SETs(boolSV(left >= right));
2681 dVAR; dSP; tryAMAGICbinSET(eq,0);
2684 SETs(boolSV(left == right));
2691 dVAR; dSP; tryAMAGICbinSET(ne,0);
2694 SETs(boolSV(left != right));
2701 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2708 else if (left < right)
2719 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2724 /* High falutin' math. */
2728 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2731 SETn(Perl_atan2(left, right));
2739 int amg_type = sin_amg;
2740 const char *neg_report = NULL;
2741 NV (*func)(NV) = Perl_sin;
2742 const int op_type = PL_op->op_type;
2759 amg_type = sqrt_amg;
2761 neg_report = "sqrt";
2765 tryAMAGICun_var(amg_type);
2767 const NV value = POPn;
2769 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2770 SET_NUMERIC_STANDARD();
2771 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2774 XPUSHn(func(value));
2779 /* Support Configure command-line overrides for rand() functions.
2780 After 5.005, perhaps we should replace this by Configure support
2781 for drand48(), random(), or rand(). For 5.005, though, maintain
2782 compatibility by calling rand() but allow the user to override it.
2783 See INSTALL for details. --Andy Dougherty 15 July 1998
2785 /* Now it's after 5.005, and Configure supports drand48() and random(),
2786 in addition to rand(). So the overrides should not be needed any more.
2787 --Jarkko Hietaniemi 27 September 1998
2790 #ifndef HAS_DRAND48_PROTO
2791 extern double drand48 (void);
2804 if (!PL_srand_called) {
2805 (void)seedDrand01((Rand_seed_t)seed());
2806 PL_srand_called = TRUE;
2816 const UV anum = (MAXARG < 1) ? seed() : POPu;
2817 (void)seedDrand01((Rand_seed_t)anum);
2818 PL_srand_called = TRUE;
2825 dVAR; dSP; dTARGET; tryAMAGICun(int);
2827 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2828 /* XXX it's arguable that compiler casting to IV might be subtly
2829 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2830 else preferring IV has introduced a subtle behaviour change bug. OTOH
2831 relying on floating point to be accurate is a bug. */
2835 else if (SvIOK(TOPs)) {
2842 const NV value = TOPn;
2844 if (value < (NV)UV_MAX + 0.5) {
2847 SETn(Perl_floor(value));
2851 if (value > (NV)IV_MIN - 0.5) {
2854 SETn(Perl_ceil(value));
2864 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2866 /* This will cache the NV value if string isn't actually integer */
2871 else if (SvIOK(TOPs)) {
2872 /* IVX is precise */
2874 SETu(TOPu); /* force it to be numeric only */
2882 /* 2s complement assumption. Also, not really needed as
2883 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2889 const NV value = TOPn;
2903 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2907 SV* const sv = POPs;
2909 tmps = (SvPV_const(sv, len));
2911 /* If Unicode, try to downgrade
2912 * If not possible, croak. */
2913 SV* const tsv = sv_2mortal(newSVsv(sv));
2916 sv_utf8_downgrade(tsv, FALSE);
2917 tmps = SvPV_const(tsv, len);
2919 if (PL_op->op_type == OP_HEX)
2922 while (*tmps && len && isSPACE(*tmps))
2928 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2930 else if (*tmps == 'b')
2931 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2933 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2935 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2949 SV * const sv = TOPs;
2952 SETi(sv_len_utf8(sv));
2968 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2970 const I32 arybase = CopARYBASE_get(PL_curcop);
2972 const char *repl = NULL;
2974 const int num_args = PL_op->op_private & 7;
2975 bool repl_need_utf8_upgrade = FALSE;
2976 bool repl_is_utf8 = FALSE;
2978 SvTAINTED_off(TARG); /* decontaminate */
2979 SvUTF8_off(TARG); /* decontaminate */
2983 repl = SvPV_const(repl_sv, repl_len);
2984 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2994 sv_utf8_upgrade(sv);
2996 else if (DO_UTF8(sv))
2997 repl_need_utf8_upgrade = TRUE;
2999 tmps = SvPV_const(sv, curlen);
3001 utf8_curlen = sv_len_utf8(sv);
3002 if (utf8_curlen == curlen)
3005 curlen = utf8_curlen;
3010 if (pos >= arybase) {
3028 else if (len >= 0) {
3030 if (rem > (I32)curlen)
3045 Perl_croak(aTHX_ "substr outside of string");
3046 if (ckWARN(WARN_SUBSTR))
3047 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3051 const I32 upos = pos;
3052 const I32 urem = rem;
3054 sv_pos_u2b(sv, &pos, &rem);
3056 /* we either return a PV or an LV. If the TARG hasn't been used
3057 * before, or is of that type, reuse it; otherwise use a mortal
3058 * instead. Note that LVs can have an extended lifetime, so also
3059 * dont reuse if refcount > 1 (bug #20933) */
3060 if (SvTYPE(TARG) > SVt_NULL) {
3061 if ( (SvTYPE(TARG) == SVt_PVLV)
3062 ? (!lvalue || SvREFCNT(TARG) > 1)
3065 TARG = sv_newmortal();
3069 sv_setpvn(TARG, tmps, rem);
3070 #ifdef USE_LOCALE_COLLATE
3071 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3076 SV* repl_sv_copy = NULL;
3078 if (repl_need_utf8_upgrade) {
3079 repl_sv_copy = newSVsv(repl_sv);
3080 sv_utf8_upgrade(repl_sv_copy);
3081 repl = SvPV_const(repl_sv_copy, repl_len);
3082 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3084 sv_insert(sv, pos, rem, repl, repl_len);
3088 SvREFCNT_dec(repl_sv_copy);
3090 else if (lvalue) { /* it's an lvalue! */
3091 if (!SvGMAGICAL(sv)) {
3093 SvPV_force_nolen(sv);
3094 if (ckWARN(WARN_SUBSTR))
3095 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3096 "Attempt to use reference as lvalue in substr");
3098 if (isGV_with_GP(sv))
3099 SvPV_force_nolen(sv);
3100 else if (SvOK(sv)) /* is it defined ? */
3101 (void)SvPOK_only_UTF8(sv);
3103 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3106 if (SvTYPE(TARG) < SVt_PVLV) {
3107 sv_upgrade(TARG, SVt_PVLV);
3108 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3114 if (LvTARG(TARG) != sv) {
3116 SvREFCNT_dec(LvTARG(TARG));
3117 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3119 LvTARGOFF(TARG) = upos;
3120 LvTARGLEN(TARG) = urem;
3124 PUSHs(TARG); /* avoid SvSETMAGIC here */
3131 register const IV size = POPi;
3132 register const IV offset = POPi;
3133 register SV * const src = POPs;
3134 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3136 SvTAINTED_off(TARG); /* decontaminate */
3137 if (lvalue) { /* it's an lvalue! */
3138 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3139 TARG = sv_newmortal();
3140 if (SvTYPE(TARG) < SVt_PVLV) {
3141 sv_upgrade(TARG, SVt_PVLV);
3142 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3145 if (LvTARG(TARG) != src) {
3147 SvREFCNT_dec(LvTARG(TARG));
3148 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3150 LvTARGOFF(TARG) = offset;
3151 LvTARGLEN(TARG) = size;
3154 sv_setuv(TARG, do_vecget(src, offset, size));
3171 const I32 arybase = CopARYBASE_get(PL_curcop);
3174 const bool is_index = PL_op->op_type == OP_INDEX;
3177 /* arybase is in characters, like offset, so combine prior to the
3178 UTF-8 to bytes calculation. */
3179 offset = POPi - arybase;
3183 big_utf8 = DO_UTF8(big);
3184 little_utf8 = DO_UTF8(little);
3185 if (big_utf8 ^ little_utf8) {
3186 /* One needs to be upgraded. */
3187 if (little_utf8 && !PL_encoding) {
3188 /* Well, maybe instead we might be able to downgrade the small
3191 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3192 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3195 /* If the large string is ISO-8859-1, and it's not possible to
3196 convert the small string to ISO-8859-1, then there is no
3197 way that it could be found anywhere by index. */
3202 /* At this point, pv is a malloc()ed string. So donate it to temp
3203 to ensure it will get free()d */
3204 little = temp = newSV(0);
3205 sv_usepvn(temp, pv, little_len);
3207 SV * const bytes = little_utf8 ? big : little;
3209 const char * const p = SvPV_const(bytes, len);
3211 temp = newSVpvn(p, len);
3214 sv_recode_to_utf8(temp, PL_encoding);
3216 sv_utf8_upgrade(temp);
3226 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3227 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3228 tmps = SvPV_const(big, biglen);
3231 offset = is_index ? 0 : biglen;
3233 if (big_utf8 && offset > 0)
3234 sv_pos_u2b(big, &offset, 0);
3239 else if (offset > (I32)biglen)
3241 if (!(tmps2 = is_index
3242 ? fbm_instr((unsigned char*)tmps + offset,
3243 (unsigned char*)tmps + biglen, little, 0)
3244 : rninstr(tmps, tmps + offset,
3245 tmps2, tmps2 + llen)))
3248 retval = tmps2 - tmps;
3249 if (retval > 0 && big_utf8)
3250 sv_pos_b2u(big, &retval);
3255 PUSHi(retval + arybase);
3261 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3262 do_sprintf(TARG, SP-MARK, MARK+1);
3263 TAINT_IF(SvTAINTED(TARG));
3274 const U8 *s = (U8*)SvPV_const(argsv, len);
3277 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3278 tmpsv = sv_2mortal(newSVsv(argsv));
3279 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3283 XPUSHu(DO_UTF8(argsv) ?
3284 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3296 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3298 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3300 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3302 (void) POPs; /* Ignore the argument value. */
3303 value = UNICODE_REPLACEMENT;
3309 SvUPGRADE(TARG,SVt_PV);
3311 if (value > 255 && !IN_BYTES) {
3312 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3313 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3314 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3316 (void)SvPOK_only(TARG);
3325 *tmps++ = (char)value;
3327 (void)SvPOK_only(TARG);
3328 if (PL_encoding && !IN_BYTES) {
3329 sv_recode_to_utf8(TARG, PL_encoding);
3331 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3332 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3336 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3337 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3352 const char *tmps = SvPV_const(left, len);
3354 if (DO_UTF8(left)) {
3355 /* If Unicode, try to downgrade.
3356 * If not possible, croak.
3357 * Yes, we made this up. */
3358 SV* const tsv = sv_2mortal(newSVsv(left));
3361 sv_utf8_downgrade(tsv, FALSE);
3362 tmps = SvPV_const(tsv, len);
3364 # ifdef USE_ITHREADS
3366 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3367 /* This should be threadsafe because in ithreads there is only
3368 * one thread per interpreter. If this would not be true,
3369 * we would need a mutex to protect this malloc. */
3370 PL_reentrant_buffer->_crypt_struct_buffer =
3371 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3372 #if defined(__GLIBC__) || defined(__EMX__)
3373 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3374 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3375 /* work around glibc-2.2.5 bug */
3376 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3380 # endif /* HAS_CRYPT_R */
3381 # endif /* USE_ITHREADS */
3383 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3385 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3391 "The crypt() function is unimplemented due to excessive paranoia.");
3402 const int op_type = PL_op->op_type;
3406 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3407 UTF8_IS_START(*s)) {
3408 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3412 utf8_to_uvchr(s, &ulen);
3413 if (op_type == OP_UCFIRST) {
3414 toTITLE_utf8(s, tmpbuf, &tculen);
3416 toLOWER_utf8(s, tmpbuf, &tculen);
3419 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3421 /* slen is the byte length of the whole SV.
3422 * ulen is the byte length of the original Unicode character
3423 * stored as UTF-8 at s.
3424 * tculen is the byte length of the freshly titlecased (or
3425 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3426 * We first set the result to be the titlecased (/lowercased)
3427 * character, and then append the rest of the SV data. */
3428 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3430 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3436 s = (U8*)SvPV_force_nomg(sv, slen);
3437 Copy(tmpbuf, s, tculen, U8);
3442 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3444 SvUTF8_off(TARG); /* decontaminate */
3445 sv_setsv_nomg(TARG, sv);
3449 s1 = (U8*)SvPV_force_nomg(sv, slen);
3451 if (IN_LOCALE_RUNTIME) {
3454 *s1 = (op_type == OP_UCFIRST)
3455 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3458 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3479 U8 tmpbuf[UTF8_MAXBYTES+1];
3481 s = (const U8*)SvPV_nomg_const(sv,len);
3483 SvUTF8_off(TARG); /* decontaminate */
3484 sv_setpvn(TARG, "", 0);
3489 STRLEN min = len + 1;
3491 SvUPGRADE(TARG, SVt_PV);
3493 (void)SvPOK_only(TARG);
3494 d = (U8*)SvPVX(TARG);
3497 STRLEN u = UTF8SKIP(s);
3499 toUPPER_utf8(s, tmpbuf, &ulen);
3500 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3501 /* If the eventually required minimum size outgrows
3502 * the available space, we need to grow. */
3503 const UV o = d - (U8*)SvPVX_const(TARG);
3505 /* If someone uppercases one million U+03B0s we
3506 * SvGROW() one million times. Or we could try
3507 * guessing how much to allocate without allocating
3508 * too much. Such is life. */
3510 d = (U8*)SvPVX(TARG) + o;
3512 Copy(tmpbuf, d, ulen, U8);
3518 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3525 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3527 SvUTF8_off(TARG); /* decontaminate */
3528 sv_setsv_nomg(TARG, sv);
3532 s = (U8*)SvPV_force_nomg(sv, len);
3534 register const U8 *send = s + len;
3536 if (IN_LOCALE_RUNTIME) {
3539 for (; s < send; s++)
3540 *s = toUPPER_LC(*s);
3543 for (; s < send; s++)
3566 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3568 s = (const U8*)SvPV_nomg_const(sv,len);
3570 SvUTF8_off(TARG); /* decontaminate */
3571 sv_setpvn(TARG, "", 0);
3576 STRLEN min = len + 1;
3578 SvUPGRADE(TARG, SVt_PV);
3580 (void)SvPOK_only(TARG);
3581 d = (U8*)SvPVX(TARG);
3584 const STRLEN u = UTF8SKIP(s);
3585 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3587 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3588 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3591 * Now if the sigma is NOT followed by
3592 * /$ignorable_sequence$cased_letter/;
3593 * and it IS preceded by
3594 * /$cased_letter$ignorable_sequence/;
3595 * where $ignorable_sequence is
3596 * [\x{2010}\x{AD}\p{Mn}]*
3597 * and $cased_letter is
3598 * [\p{Ll}\p{Lo}\p{Lt}]
3599 * then it should be mapped to 0x03C2,
3600 * (GREEK SMALL LETTER FINAL SIGMA),
3601 * instead of staying 0x03A3.
3602 * "should be": in other words,
3603 * this is not implemented yet.
3604 * See lib/unicore/SpecialCasing.txt.
3607 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3608 /* If the eventually required minimum size outgrows
3609 * the available space, we need to grow. */
3610 const UV o = d - (U8*)SvPVX_const(TARG);
3612 /* If someone lowercases one million U+0130s we
3613 * SvGROW() one million times. Or we could try
3614 * guessing how much to allocate without allocating.
3615 * too much. Such is life. */
3617 d = (U8*)SvPVX(TARG) + o;
3619 Copy(tmpbuf, d, ulen, U8);
3625 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3632 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3634 SvUTF8_off(TARG); /* decontaminate */
3635 sv_setsv_nomg(TARG, sv);
3640 s = (U8*)SvPV_force_nomg(sv, len);
3642 register const U8 * const send = s + len;
3644 if (IN_LOCALE_RUNTIME) {
3647 for (; s < send; s++)
3648 *s = toLOWER_LC(*s);
3651 for (; s < send; s++)
3663 SV * const sv = TOPs;
3665 register const char *s = SvPV_const(sv,len);
3667 SvUTF8_off(TARG); /* decontaminate */
3670 SvUPGRADE(TARG, SVt_PV);
3671 SvGROW(TARG, (len * 2) + 1);
3675 if (UTF8_IS_CONTINUED(*s)) {
3676 STRLEN ulen = UTF8SKIP(s);
3700 SvCUR_set(TARG, d - SvPVX_const(TARG));
3701 (void)SvPOK_only_UTF8(TARG);
3704 sv_setpvn(TARG, s, len);
3706 if (SvSMAGICAL(TARG))
3715 dVAR; dSP; dMARK; dORIGMARK;
3716 register AV* const av = (AV*)POPs;
3717 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3719 if (SvTYPE(av) == SVt_PVAV) {
3720 const I32 arybase = CopARYBASE_get(PL_curcop);
3721 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3724 for (svp = MARK + 1; svp <= SP; svp++) {
3725 const I32 elem = SvIVx(*svp);
3729 if (max > AvMAX(av))
3732 while (++MARK <= SP) {
3734 I32 elem = SvIVx(*MARK);
3738 svp = av_fetch(av, elem, lval);
3740 if (!svp || *svp == &PL_sv_undef)
3741 DIE(aTHX_ PL_no_aelem, elem);
3742 if (PL_op->op_private & OPpLVAL_INTRO)
3743 save_aelem(av, elem, svp);
3745 *MARK = svp ? *svp : &PL_sv_undef;
3748 if (GIMME != G_ARRAY) {
3750 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3756 /* Associative arrays. */
3762 HV * const hash = (HV*)POPs;
3764 const I32 gimme = GIMME_V;
3767 /* might clobber stack_sp */
3768 entry = hv_iternext(hash);
3773 SV* const sv = hv_iterkeysv(entry);
3774 PUSHs(sv); /* won't clobber stack_sp */
3775 if (gimme == G_ARRAY) {
3778 /* might clobber stack_sp */
3779 val = hv_iterval(hash, entry);
3784 else if (gimme == G_SCALAR)
3794 const I32 gimme = GIMME_V;
3795 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3797 if (PL_op->op_private & OPpSLICE) {
3799 HV * const hv = (HV*)POPs;
3800 const U32 hvtype = SvTYPE(hv);
3801 if (hvtype == SVt_PVHV) { /* hash element */
3802 while (++MARK <= SP) {
3803 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3804 *MARK = sv ? sv : &PL_sv_undef;
3807 else if (hvtype == SVt_PVAV) { /* array element */
3808 if (PL_op->op_flags & OPf_SPECIAL) {
3809 while (++MARK <= SP) {
3810 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3811 *MARK = sv ? sv : &PL_sv_undef;
3816 DIE(aTHX_ "Not a HASH reference");
3819 else if (gimme == G_SCALAR) {
3824 *++MARK = &PL_sv_undef;
3830 HV * const hv = (HV*)POPs;
3832 if (SvTYPE(hv) == SVt_PVHV)
3833 sv = hv_delete_ent(hv, keysv, discard, 0);
3834 else if (SvTYPE(hv) == SVt_PVAV) {
3835 if (PL_op->op_flags & OPf_SPECIAL)
3836 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3838 DIE(aTHX_ "panic: avhv_delete no longer supported");
3841 DIE(aTHX_ "Not a HASH reference");
3857 if (PL_op->op_private & OPpEXISTS_SUB) {
3859 SV * const sv = POPs;
3860 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3863 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3869 if (SvTYPE(hv) == SVt_PVHV) {
3870 if (hv_exists_ent(hv, tmpsv, 0))
3873 else if (SvTYPE(hv) == SVt_PVAV) {
3874 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3875 if (av_exists((AV*)hv, SvIV(tmpsv)))
3880 DIE(aTHX_ "Not a HASH reference");
3887 dVAR; dSP; dMARK; dORIGMARK;
3888 register HV * const hv = (HV*)POPs;
3889 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3890 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3891 bool other_magic = FALSE;
3897 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3898 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3899 /* Try to preserve the existenceness of a tied hash
3900 * element by using EXISTS and DELETE if possible.
3901 * Fallback to FETCH and STORE otherwise */
3902 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3903 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3904 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3907 while (++MARK <= SP) {
3908 SV * const keysv = *MARK;
3911 bool preeminent = FALSE;
3914 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3915 hv_exists_ent(hv, keysv, 0);
3918 he = hv_fetch_ent(hv, keysv, lval, 0);
3919 svp = he ? &HeVAL(he) : 0;
3922 if (!svp || *svp == &PL_sv_undef) {
3923 DIE(aTHX_ PL_no_helem_sv, keysv);
3926 if (HvNAME_get(hv) && isGV(*svp))
3927 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
3930 save_helem(hv, keysv, svp);
3933 const char * const key = SvPV_const(keysv, keylen);
3934 SAVEDELETE(hv, savepvn(key,keylen),
3935 SvUTF8(keysv) ? -keylen : keylen);
3940 *MARK = svp ? *svp : &PL_sv_undef;
3942 if (GIMME != G_ARRAY) {
3944 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3950 /* List operators. */
3955 if (GIMME != G_ARRAY) {
3957 *MARK = *SP; /* unwanted list, return last item */
3959 *MARK = &PL_sv_undef;
3969 SV ** const lastrelem = PL_stack_sp;
3970 SV ** const lastlelem = PL_stack_base + POPMARK;
3971 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3972 register SV ** const firstrelem = lastlelem + 1;
3973 const I32 arybase = CopARYBASE_get(PL_curcop);
3974 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3976 register const I32 max = lastrelem - lastlelem;
3977 register SV **lelem;
3979 if (GIMME != G_ARRAY) {
3980 I32 ix = SvIVx(*lastlelem);
3985 if (ix < 0 || ix >= max)
3986 *firstlelem = &PL_sv_undef;
3988 *firstlelem = firstrelem[ix];
3994 SP = firstlelem - 1;
3998 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3999 I32 ix = SvIVx(*lelem);
4004 if (ix < 0 || ix >= max)
4005 *lelem = &PL_sv_undef;
4007 is_something_there = TRUE;
4008 if (!(*lelem = firstrelem[ix]))
4009 *lelem = &PL_sv_undef;
4012 if (is_something_there)
4015 SP = firstlelem - 1;
4021 dVAR; dSP; dMARK; dORIGMARK;
4022 const I32 items = SP - MARK;
4023 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4024 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4031 dVAR; dSP; dMARK; dORIGMARK;
4032 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4035 SV * const key = *++MARK;
4036 SV * const val = newSV(0);
4038 sv_setsv(val, *++MARK);
4039 else if (ckWARN(WARN_MISC))
4040 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4041 (void)hv_store_ent(hv,key,val,0);
4050 dVAR; dSP; dMARK; dORIGMARK;
4051 register AV *ary = (AV*)*++MARK;
4055 register I32 offset;
4056 register I32 length;
4060 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4063 *MARK-- = SvTIED_obj((SV*)ary, mg);
4067 call_method("SPLICE",GIMME_V);
4076 offset = i = SvIVx(*MARK);
4078 offset += AvFILLp(ary) + 1;
4080 offset -= CopARYBASE_get(PL_curcop);
4082 DIE(aTHX_ PL_no_aelem, i);
4084 length = SvIVx(*MARK++);
4086 length += AvFILLp(ary) - offset + 1;
4092 length = AvMAX(ary) + 1; /* close enough to infinity */
4096 length = AvMAX(ary) + 1;
4098 if (offset > AvFILLp(ary) + 1) {
4099 if (ckWARN(WARN_MISC))
4100 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4101 offset = AvFILLp(ary) + 1;
4103 after = AvFILLp(ary) + 1 - (offset + length);
4104 if (after < 0) { /* not that much array */
4105 length += after; /* offset+length now in array */
4111 /* At this point, MARK .. SP-1 is our new LIST */
4114 diff = newlen - length;
4115 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4118 /* make new elements SVs now: avoid problems if they're from the array */
4119 for (dst = MARK, i = newlen; i; i--) {
4120 SV * const h = *dst;
4121 *dst++ = newSVsv(h);
4124 if (diff < 0) { /* shrinking the area */
4127 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4128 Copy(MARK, tmparyval, newlen, SV*);
4131 MARK = ORIGMARK + 1;
4132 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4133 MEXTEND(MARK, length);
4134 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4136 EXTEND_MORTAL(length);
4137 for (i = length, dst = MARK; i; i--) {
4138 sv_2mortal(*dst); /* free them eventualy */
4145 *MARK = AvARRAY(ary)[offset+length-1];
4148 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4149 SvREFCNT_dec(*dst++); /* free them now */
4152 AvFILLp(ary) += diff;
4154 /* pull up or down? */
4156 if (offset < after) { /* easier to pull up */
4157 if (offset) { /* esp. if nothing to pull */
4158 src = &AvARRAY(ary)[offset-1];
4159 dst = src - diff; /* diff is negative */
4160 for (i = offset; i > 0; i--) /* can't trust Copy */
4164 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4168 if (after) { /* anything to pull down? */
4169 src = AvARRAY(ary) + offset + length;
4170 dst = src + diff; /* diff is negative */
4171 Move(src, dst, after, SV*);
4173 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4174 /* avoid later double free */
4178 dst[--i] = &PL_sv_undef;
4181 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4182 Safefree(tmparyval);
4185 else { /* no, expanding (or same) */
4186 SV** tmparyval = NULL;
4188 Newx(tmparyval, length, SV*); /* so remember deletion */
4189 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4192 if (diff > 0) { /* expanding */
4193 /* push up or down? */
4194 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4198 Move(src, dst, offset, SV*);
4200 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4202 AvFILLp(ary) += diff;
4205 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4206 av_extend(ary, AvFILLp(ary) + diff);
4207 AvFILLp(ary) += diff;
4210 dst = AvARRAY(ary) + AvFILLp(ary);
4212 for (i = after; i; i--) {
4220 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4223 MARK = ORIGMARK + 1;
4224 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4226 Copy(tmparyval, MARK, length, SV*);
4228 EXTEND_MORTAL(length);
4229 for (i = length, dst = MARK; i; i--) {
4230 sv_2mortal(*dst); /* free them eventualy */
4237 else if (length--) {
4238 *MARK = tmparyval[length];
4241 while (length-- > 0)
4242 SvREFCNT_dec(tmparyval[length]);
4246 *MARK = &PL_sv_undef;
4247 Safefree(tmparyval);
4255 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4256 register AV *ary = (AV*)*++MARK;
4257 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4260 *MARK-- = SvTIED_obj((SV*)ary, mg);
4264 call_method("PUSH",G_SCALAR|G_DISCARD);
4268 PUSHi( AvFILL(ary) + 1 );
4271 for (++MARK; MARK <= SP; MARK++) {
4272 SV * const sv = newSV(0);
4274 sv_setsv(sv, *MARK);
4275 av_store(ary, AvFILLp(ary)+1, sv);
4278 PUSHi( AvFILLp(ary) + 1 );
4287 AV * const av = (AV*)POPs;
4288 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4292 (void)sv_2mortal(sv);
4299 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4300 register AV *ary = (AV*)*++MARK;
4301 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4304 *MARK-- = SvTIED_obj((SV*)ary, mg);
4308 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4314 av_unshift(ary, SP - MARK);
4316 SV * const sv = newSVsv(*++MARK);
4317 (void)av_store(ary, i++, sv);
4321 PUSHi( AvFILL(ary) + 1 );
4328 SV ** const oldsp = SP;
4330 if (GIMME == G_ARRAY) {
4333 register SV * const tmp = *MARK;
4337 /* safe as long as stack cannot get extended in the above */
4342 register char *down;
4348 SvUTF8_off(TARG); /* decontaminate */
4350 do_join(TARG, &PL_sv_no, MARK, SP);
4352 sv_setsv(TARG, (SP > MARK)
4354 : (padoff_du = find_rundefsvoffset(),
4355 (padoff_du == NOT_IN_PAD
4356 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4357 ? DEFSV : PAD_SVl(padoff_du)));
4358 up = SvPV_force(TARG, len);
4360 if (DO_UTF8(TARG)) { /* first reverse each character */
4361 U8* s = (U8*)SvPVX(TARG);
4362 const U8* send = (U8*)(s + len);
4364 if (UTF8_IS_INVARIANT(*s)) {
4369 if (!utf8_to_uvchr(s, 0))
4373 down = (char*)(s - 1);
4374 /* reverse this character */
4378 *down-- = (char)tmp;
4384 down = SvPVX(TARG) + len - 1;
4388 *down-- = (char)tmp;
4390 (void)SvPOK_only_UTF8(TARG);
4402 register IV limit = POPi; /* note, negative is forever */
4403 SV * const sv = POPs;
4405 register const char *s = SvPV_const(sv, len);
4406 const bool do_utf8 = DO_UTF8(sv);
4407 const char *strend = s + len;
4409 register REGEXP *rx;
4411 register const char *m;
4413 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4414 I32 maxiters = slen + 10;
4416 const I32 origlimit = limit;
4419 const I32 gimme = GIMME_V;
4420 const I32 oldsave = PL_savestack_ix;
4421 I32 make_mortal = 1;
4426 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4431 DIE(aTHX_ "panic: pp_split");
4434 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4435 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4437 RX_MATCH_UTF8_set(rx, do_utf8);
4439 if (pm->op_pmreplroot) {
4441 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4443 ary = GvAVn((GV*)pm->op_pmreplroot);
4446 else if (gimme != G_ARRAY)
4447 ary = GvAVn(PL_defgv);
4450 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4456 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4458 XPUSHs(SvTIED_obj((SV*)ary, mg));
4465 for (i = AvFILLp(ary); i >= 0; i--)
4466 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4468 /* temporarily switch stacks */
4469 SAVESWITCHSTACK(PL_curstack, ary);
4473 base = SP - PL_stack_base;
4475 if (pm->op_pmflags & PMf_SKIPWHITE) {
4476 if (pm->op_pmflags & PMf_LOCALE) {
4477 while (isSPACE_LC(*s))
4485 if (pm->op_pmflags & PMf_MULTILINE) {
4490 limit = maxiters + 2;
4491 if (pm->op_pmflags & PMf_WHITE) {
4494 while (m < strend &&
4495 !((pm->op_pmflags & PMf_LOCALE)
4496 ? isSPACE_LC(*m) : isSPACE(*m)))
4501 dstr = newSVpvn(s, m-s);
4505 (void)SvUTF8_on(dstr);
4509 while (s < strend &&
4510 ((pm->op_pmflags & PMf_LOCALE)
4511 ? isSPACE_LC(*s) : isSPACE(*s)))
4515 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4517 for (m = s; m < strend && *m != '\n'; m++)
4522 dstr = newSVpvn(s, m-s);
4526 (void)SvUTF8_on(dstr);
4531 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4532 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4533 && (rx->reganch & ROPT_CHECK_ALL)
4534 && !(rx->reganch & ROPT_ANCH)) {
4535 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4536 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4539 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4540 const char c = *SvPV_nolen_const(csv);
4542 for (m = s; m < strend && *m != c; m++)
4546 dstr = newSVpvn(s, m-s);
4550 (void)SvUTF8_on(dstr);
4552 /* The rx->minlen is in characters but we want to step
4553 * s ahead by bytes. */
4555 s = (char*)utf8_hop((U8*)m, len);
4557 s = m + len; /* Fake \n at the end */
4561 while (s < strend && --limit &&
4562 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4563 csv, multiline ? FBMrf_MULTILINE : 0)) )
4565 dstr = newSVpvn(s, m-s);
4569 (void)SvUTF8_on(dstr);
4571 /* The rx->minlen is in characters but we want to step
4572 * s ahead by bytes. */
4574 s = (char*)utf8_hop((U8*)m, len);
4576 s = m + len; /* Fake \n at the end */
4581 maxiters += slen * rx->nparens;
4582 while (s < strend && --limit)
4586 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4589 if (rex_return == 0)
4591 TAINT_IF(RX_MATCH_TAINTED(rx));
4592 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4597 strend = s + (strend - m);
4599 m = rx->startp[0] + orig;
4600 dstr = newSVpvn(s, m-s);
4604 (void)SvUTF8_on(dstr);
4608 for (i = 1; i <= (I32)rx->nparens; i++) {
4609 s = rx->startp[i] + orig;
4610 m = rx->endp[i] + orig;
4612 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4613 parens that didn't match -- they should be set to
4614 undef, not the empty string */
4615 if (m >= orig && s >= orig) {
4616 dstr = newSVpvn(s, m-s);
4619 dstr = &PL_sv_undef; /* undef, not "" */
4623 (void)SvUTF8_on(dstr);
4627 s = rx->endp[0] + orig;
4631 iters = (SP - PL_stack_base) - base;
4632 if (iters > maxiters)
4633 DIE(aTHX_ "Split loop");
4635 /* keep field after final delim? */
4636 if (s < strend || (iters && origlimit)) {
4637 const STRLEN l = strend - s;
4638 dstr = newSVpvn(s, l);
4642 (void)SvUTF8_on(dstr);
4646 else if (!origlimit) {
4647 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4648 if (TOPs && !make_mortal)
4651 *SP-- = &PL_sv_undef;
4656 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4660 if (SvSMAGICAL(ary)) {
4665 if (gimme == G_ARRAY) {
4667 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4675 call_method("PUSH",G_SCALAR|G_DISCARD);
4678 if (gimme == G_ARRAY) {
4680 /* EXTEND should not be needed - we just popped them */
4682 for (i=0; i < iters; i++) {
4683 SV **svp = av_fetch(ary, i, FALSE);
4684 PUSHs((svp) ? *svp : &PL_sv_undef);
4691 if (gimme == G_ARRAY)
4707 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4708 || SvTYPE(retsv) == SVt_PVCV) {
4709 retsv = refto(retsv);
4716 PP(unimplemented_op)
4719 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4725 * c-indentation-style: bsd
4727 * indent-tabs-mode: t
4730 * ex: set ts=8 sts=4 sw=4 noet: