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 SETi(sv_len_utf8(sv));
2970 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2972 const I32 arybase = CopARYBASE_get(PL_curcop);
2974 const char *repl = NULL;
2976 const int num_args = PL_op->op_private & 7;
2977 bool repl_need_utf8_upgrade = FALSE;
2978 bool repl_is_utf8 = FALSE;
2980 SvTAINTED_off(TARG); /* decontaminate */
2981 SvUTF8_off(TARG); /* decontaminate */
2985 repl = SvPV_const(repl_sv, repl_len);
2986 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2996 sv_utf8_upgrade(sv);
2998 else if (DO_UTF8(sv))
2999 repl_need_utf8_upgrade = TRUE;
3001 tmps = SvPV_const(sv, curlen);
3003 utf8_curlen = sv_len_utf8(sv);
3004 if (utf8_curlen == curlen)
3007 curlen = utf8_curlen;
3012 if (pos >= arybase) {
3030 else if (len >= 0) {
3032 if (rem > (I32)curlen)
3047 Perl_croak(aTHX_ "substr outside of string");
3048 if (ckWARN(WARN_SUBSTR))
3049 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3053 const I32 upos = pos;
3054 const I32 urem = rem;
3056 sv_pos_u2b(sv, &pos, &rem);
3058 /* we either return a PV or an LV. If the TARG hasn't been used
3059 * before, or is of that type, reuse it; otherwise use a mortal
3060 * instead. Note that LVs can have an extended lifetime, so also
3061 * dont reuse if refcount > 1 (bug #20933) */
3062 if (SvTYPE(TARG) > SVt_NULL) {
3063 if ( (SvTYPE(TARG) == SVt_PVLV)
3064 ? (!lvalue || SvREFCNT(TARG) > 1)
3067 TARG = sv_newmortal();
3071 sv_setpvn(TARG, tmps, rem);
3072 #ifdef USE_LOCALE_COLLATE
3073 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3078 SV* repl_sv_copy = NULL;
3080 if (repl_need_utf8_upgrade) {
3081 repl_sv_copy = newSVsv(repl_sv);
3082 sv_utf8_upgrade(repl_sv_copy);
3083 repl = SvPV_const(repl_sv_copy, repl_len);
3084 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3086 sv_insert(sv, pos, rem, repl, repl_len);
3090 SvREFCNT_dec(repl_sv_copy);
3092 else if (lvalue) { /* it's an lvalue! */
3093 if (!SvGMAGICAL(sv)) {
3095 SvPV_force_nolen(sv);
3096 if (ckWARN(WARN_SUBSTR))
3097 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3098 "Attempt to use reference as lvalue in substr");
3100 if (isGV_with_GP(sv))
3101 SvPV_force_nolen(sv);
3102 else if (SvOK(sv)) /* is it defined ? */
3103 (void)SvPOK_only_UTF8(sv);
3105 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3108 if (SvTYPE(TARG) < SVt_PVLV) {
3109 sv_upgrade(TARG, SVt_PVLV);
3110 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3116 if (LvTARG(TARG) != sv) {
3118 SvREFCNT_dec(LvTARG(TARG));
3119 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3121 LvTARGOFF(TARG) = upos;
3122 LvTARGLEN(TARG) = urem;
3126 PUSHs(TARG); /* avoid SvSETMAGIC here */
3133 register const IV size = POPi;
3134 register const IV offset = POPi;
3135 register SV * const src = POPs;
3136 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3138 SvTAINTED_off(TARG); /* decontaminate */
3139 if (lvalue) { /* it's an lvalue! */
3140 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3141 TARG = sv_newmortal();
3142 if (SvTYPE(TARG) < SVt_PVLV) {
3143 sv_upgrade(TARG, SVt_PVLV);
3144 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3147 if (LvTARG(TARG) != src) {
3149 SvREFCNT_dec(LvTARG(TARG));
3150 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3152 LvTARGOFF(TARG) = offset;
3153 LvTARGLEN(TARG) = size;
3156 sv_setuv(TARG, do_vecget(src, offset, size));
3173 const I32 arybase = CopARYBASE_get(PL_curcop);
3176 const bool is_index = PL_op->op_type == OP_INDEX;
3179 /* arybase is in characters, like offset, so combine prior to the
3180 UTF-8 to bytes calculation. */
3181 offset = POPi - arybase;
3185 big_utf8 = DO_UTF8(big);
3186 little_utf8 = DO_UTF8(little);
3187 if (big_utf8 ^ little_utf8) {
3188 /* One needs to be upgraded. */
3189 if (little_utf8 && !PL_encoding) {
3190 /* Well, maybe instead we might be able to downgrade the small
3193 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3194 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3197 /* If the large string is ISO-8859-1, and it's not possible to
3198 convert the small string to ISO-8859-1, then there is no
3199 way that it could be found anywhere by index. */
3204 /* At this point, pv is a malloc()ed string. So donate it to temp
3205 to ensure it will get free()d */
3206 little = temp = newSV(0);
3207 sv_usepvn(temp, pv, little_len);
3209 SV * const bytes = little_utf8 ? big : little;
3211 const char * const p = SvPV_const(bytes, len);
3213 temp = newSVpvn(p, len);
3216 sv_recode_to_utf8(temp, PL_encoding);
3218 sv_utf8_upgrade(temp);
3228 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3229 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3230 tmps = SvPV_const(big, biglen);
3233 offset = is_index ? 0 : biglen;
3235 if (big_utf8 && offset > 0)
3236 sv_pos_u2b(big, &offset, 0);
3241 else if (offset > (I32)biglen)
3243 if (!(tmps2 = is_index
3244 ? fbm_instr((unsigned char*)tmps + offset,
3245 (unsigned char*)tmps + biglen, little, 0)
3246 : rninstr(tmps, tmps + offset,
3247 tmps2, tmps2 + llen)))
3250 retval = tmps2 - tmps;
3251 if (retval > 0 && big_utf8)
3252 sv_pos_b2u(big, &retval);
3257 PUSHi(retval + arybase);
3263 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3264 do_sprintf(TARG, SP-MARK, MARK+1);
3265 TAINT_IF(SvTAINTED(TARG));
3276 const U8 *s = (U8*)SvPV_const(argsv, len);
3279 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3280 tmpsv = sv_2mortal(newSVsv(argsv));
3281 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3285 XPUSHu(DO_UTF8(argsv) ?
3286 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3298 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3300 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3302 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3304 (void) POPs; /* Ignore the argument value. */
3305 value = UNICODE_REPLACEMENT;
3311 SvUPGRADE(TARG,SVt_PV);
3313 if (value > 255 && !IN_BYTES) {
3314 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3315 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3316 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3318 (void)SvPOK_only(TARG);
3327 *tmps++ = (char)value;
3329 (void)SvPOK_only(TARG);
3330 if (PL_encoding && !IN_BYTES) {
3331 sv_recode_to_utf8(TARG, PL_encoding);
3333 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3334 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3338 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3339 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3354 const char *tmps = SvPV_const(left, len);
3356 if (DO_UTF8(left)) {
3357 /* If Unicode, try to downgrade.
3358 * If not possible, croak.
3359 * Yes, we made this up. */
3360 SV* const tsv = sv_2mortal(newSVsv(left));
3363 sv_utf8_downgrade(tsv, FALSE);
3364 tmps = SvPV_const(tsv, len);
3366 # ifdef USE_ITHREADS
3368 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3369 /* This should be threadsafe because in ithreads there is only
3370 * one thread per interpreter. If this would not be true,
3371 * we would need a mutex to protect this malloc. */
3372 PL_reentrant_buffer->_crypt_struct_buffer =
3373 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3374 #if defined(__GLIBC__) || defined(__EMX__)
3375 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3376 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3377 /* work around glibc-2.2.5 bug */
3378 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3382 # endif /* HAS_CRYPT_R */
3383 # endif /* USE_ITHREADS */
3385 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3387 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3393 "The crypt() function is unimplemented due to excessive paranoia.");
3404 const int op_type = PL_op->op_type;
3408 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3409 UTF8_IS_START(*s)) {
3410 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3414 utf8_to_uvchr(s, &ulen);
3415 if (op_type == OP_UCFIRST) {
3416 toTITLE_utf8(s, tmpbuf, &tculen);
3418 toLOWER_utf8(s, tmpbuf, &tculen);
3421 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3423 /* slen is the byte length of the whole SV.
3424 * ulen is the byte length of the original Unicode character
3425 * stored as UTF-8 at s.
3426 * tculen is the byte length of the freshly titlecased (or
3427 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3428 * We first set the result to be the titlecased (/lowercased)
3429 * character, and then append the rest of the SV data. */
3430 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3432 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3438 s = (U8*)SvPV_force_nomg(sv, slen);
3439 Copy(tmpbuf, s, tculen, U8);
3444 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3446 SvUTF8_off(TARG); /* decontaminate */
3447 sv_setsv_nomg(TARG, sv);
3451 s1 = (U8*)SvPV_force_nomg(sv, slen);
3453 if (IN_LOCALE_RUNTIME) {
3456 *s1 = (op_type == OP_UCFIRST)
3457 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3460 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3481 U8 tmpbuf[UTF8_MAXBYTES+1];
3483 s = (const U8*)SvPV_nomg_const(sv,len);
3485 SvUTF8_off(TARG); /* decontaminate */
3486 sv_setpvn(TARG, "", 0);
3491 STRLEN min = len + 1;
3493 SvUPGRADE(TARG, SVt_PV);
3495 (void)SvPOK_only(TARG);
3496 d = (U8*)SvPVX(TARG);
3499 STRLEN u = UTF8SKIP(s);
3501 toUPPER_utf8(s, tmpbuf, &ulen);
3502 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3503 /* If the eventually required minimum size outgrows
3504 * the available space, we need to grow. */
3505 const UV o = d - (U8*)SvPVX_const(TARG);
3507 /* If someone uppercases one million U+03B0s we
3508 * SvGROW() one million times. Or we could try
3509 * guessing how much to allocate without allocating
3510 * too much. Such is life. */
3512 d = (U8*)SvPVX(TARG) + o;
3514 Copy(tmpbuf, d, ulen, U8);
3520 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3527 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3529 SvUTF8_off(TARG); /* decontaminate */
3530 sv_setsv_nomg(TARG, sv);
3534 s = (U8*)SvPV_force_nomg(sv, len);
3536 register const U8 *send = s + len;
3538 if (IN_LOCALE_RUNTIME) {
3541 for (; s < send; s++)
3542 *s = toUPPER_LC(*s);
3545 for (; s < send; s++)
3568 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3570 s = (const U8*)SvPV_nomg_const(sv,len);
3572 SvUTF8_off(TARG); /* decontaminate */
3573 sv_setpvn(TARG, "", 0);
3578 STRLEN min = len + 1;
3580 SvUPGRADE(TARG, SVt_PV);
3582 (void)SvPOK_only(TARG);
3583 d = (U8*)SvPVX(TARG);
3586 const STRLEN u = UTF8SKIP(s);
3587 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3589 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3590 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3593 * Now if the sigma is NOT followed by
3594 * /$ignorable_sequence$cased_letter/;
3595 * and it IS preceded by
3596 * /$cased_letter$ignorable_sequence/;
3597 * where $ignorable_sequence is
3598 * [\x{2010}\x{AD}\p{Mn}]*
3599 * and $cased_letter is
3600 * [\p{Ll}\p{Lo}\p{Lt}]
3601 * then it should be mapped to 0x03C2,
3602 * (GREEK SMALL LETTER FINAL SIGMA),
3603 * instead of staying 0x03A3.
3604 * "should be": in other words,
3605 * this is not implemented yet.
3606 * See lib/unicore/SpecialCasing.txt.
3609 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3610 /* If the eventually required minimum size outgrows
3611 * the available space, we need to grow. */
3612 const UV o = d - (U8*)SvPVX_const(TARG);
3614 /* If someone lowercases one million U+0130s we
3615 * SvGROW() one million times. Or we could try
3616 * guessing how much to allocate without allocating.
3617 * too much. Such is life. */
3619 d = (U8*)SvPVX(TARG) + o;
3621 Copy(tmpbuf, d, ulen, U8);
3627 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3634 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3636 SvUTF8_off(TARG); /* decontaminate */
3637 sv_setsv_nomg(TARG, sv);
3642 s = (U8*)SvPV_force_nomg(sv, len);
3644 register const U8 * const send = s + len;
3646 if (IN_LOCALE_RUNTIME) {
3649 for (; s < send; s++)
3650 *s = toLOWER_LC(*s);
3653 for (; s < send; s++)
3665 SV * const sv = TOPs;
3667 register const char *s = SvPV_const(sv,len);
3669 SvUTF8_off(TARG); /* decontaminate */
3672 SvUPGRADE(TARG, SVt_PV);
3673 SvGROW(TARG, (len * 2) + 1);
3677 if (UTF8_IS_CONTINUED(*s)) {
3678 STRLEN ulen = UTF8SKIP(s);
3702 SvCUR_set(TARG, d - SvPVX_const(TARG));
3703 (void)SvPOK_only_UTF8(TARG);
3706 sv_setpvn(TARG, s, len);
3708 if (SvSMAGICAL(TARG))
3717 dVAR; dSP; dMARK; dORIGMARK;
3718 register AV* const av = (AV*)POPs;
3719 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3721 if (SvTYPE(av) == SVt_PVAV) {
3722 const I32 arybase = CopARYBASE_get(PL_curcop);
3723 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3726 for (svp = MARK + 1; svp <= SP; svp++) {
3727 const I32 elem = SvIVx(*svp);
3731 if (max > AvMAX(av))
3734 while (++MARK <= SP) {
3736 I32 elem = SvIVx(*MARK);
3740 svp = av_fetch(av, elem, lval);
3742 if (!svp || *svp == &PL_sv_undef)
3743 DIE(aTHX_ PL_no_aelem, elem);
3744 if (PL_op->op_private & OPpLVAL_INTRO)
3745 save_aelem(av, elem, svp);
3747 *MARK = svp ? *svp : &PL_sv_undef;
3750 if (GIMME != G_ARRAY) {
3752 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3758 /* Associative arrays. */
3764 HV * const hash = (HV*)POPs;
3766 const I32 gimme = GIMME_V;
3769 /* might clobber stack_sp */
3770 entry = hv_iternext(hash);
3775 SV* const sv = hv_iterkeysv(entry);
3776 PUSHs(sv); /* won't clobber stack_sp */
3777 if (gimme == G_ARRAY) {
3780 /* might clobber stack_sp */
3781 val = hv_iterval(hash, entry);
3786 else if (gimme == G_SCALAR)
3796 const I32 gimme = GIMME_V;
3797 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3799 if (PL_op->op_private & OPpSLICE) {
3801 HV * const hv = (HV*)POPs;
3802 const U32 hvtype = SvTYPE(hv);
3803 if (hvtype == SVt_PVHV) { /* hash element */
3804 while (++MARK <= SP) {
3805 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3806 *MARK = sv ? sv : &PL_sv_undef;
3809 else if (hvtype == SVt_PVAV) { /* array element */
3810 if (PL_op->op_flags & OPf_SPECIAL) {
3811 while (++MARK <= SP) {
3812 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3813 *MARK = sv ? sv : &PL_sv_undef;
3818 DIE(aTHX_ "Not a HASH reference");
3821 else if (gimme == G_SCALAR) {
3826 *++MARK = &PL_sv_undef;
3832 HV * const hv = (HV*)POPs;
3834 if (SvTYPE(hv) == SVt_PVHV)
3835 sv = hv_delete_ent(hv, keysv, discard, 0);
3836 else if (SvTYPE(hv) == SVt_PVAV) {
3837 if (PL_op->op_flags & OPf_SPECIAL)
3838 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3840 DIE(aTHX_ "panic: avhv_delete no longer supported");
3843 DIE(aTHX_ "Not a HASH reference");
3859 if (PL_op->op_private & OPpEXISTS_SUB) {
3861 SV * const sv = POPs;
3862 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3865 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3871 if (SvTYPE(hv) == SVt_PVHV) {
3872 if (hv_exists_ent(hv, tmpsv, 0))
3875 else if (SvTYPE(hv) == SVt_PVAV) {
3876 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3877 if (av_exists((AV*)hv, SvIV(tmpsv)))
3882 DIE(aTHX_ "Not a HASH reference");
3889 dVAR; dSP; dMARK; dORIGMARK;
3890 register HV * const hv = (HV*)POPs;
3891 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3892 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3893 bool other_magic = FALSE;
3899 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3900 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3901 /* Try to preserve the existenceness of a tied hash
3902 * element by using EXISTS and DELETE if possible.
3903 * Fallback to FETCH and STORE otherwise */
3904 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3905 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3906 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3909 while (++MARK <= SP) {
3910 SV * const keysv = *MARK;
3913 bool preeminent = FALSE;
3916 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3917 hv_exists_ent(hv, keysv, 0);
3920 he = hv_fetch_ent(hv, keysv, lval, 0);
3921 svp = he ? &HeVAL(he) : 0;
3924 if (!svp || *svp == &PL_sv_undef) {
3925 DIE(aTHX_ PL_no_helem_sv, keysv);
3928 if (HvNAME_get(hv) && isGV(*svp))
3929 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
3932 save_helem(hv, keysv, svp);
3935 const char * const key = SvPV_const(keysv, keylen);
3936 SAVEDELETE(hv, savepvn(key,keylen),
3937 SvUTF8(keysv) ? -keylen : keylen);
3942 *MARK = svp ? *svp : &PL_sv_undef;
3944 if (GIMME != G_ARRAY) {
3946 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3952 /* List operators. */
3957 if (GIMME != G_ARRAY) {
3959 *MARK = *SP; /* unwanted list, return last item */
3961 *MARK = &PL_sv_undef;
3971 SV ** const lastrelem = PL_stack_sp;
3972 SV ** const lastlelem = PL_stack_base + POPMARK;
3973 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3974 register SV ** const firstrelem = lastlelem + 1;
3975 const I32 arybase = CopARYBASE_get(PL_curcop);
3976 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3978 register const I32 max = lastrelem - lastlelem;
3979 register SV **lelem;
3981 if (GIMME != G_ARRAY) {
3982 I32 ix = SvIVx(*lastlelem);
3987 if (ix < 0 || ix >= max)
3988 *firstlelem = &PL_sv_undef;
3990 *firstlelem = firstrelem[ix];
3996 SP = firstlelem - 1;
4000 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4001 I32 ix = SvIVx(*lelem);
4006 if (ix < 0 || ix >= max)
4007 *lelem = &PL_sv_undef;
4009 is_something_there = TRUE;
4010 if (!(*lelem = firstrelem[ix]))
4011 *lelem = &PL_sv_undef;
4014 if (is_something_there)
4017 SP = firstlelem - 1;
4023 dVAR; dSP; dMARK; dORIGMARK;
4024 const I32 items = SP - MARK;
4025 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4026 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4033 dVAR; dSP; dMARK; dORIGMARK;
4034 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4037 SV * const key = *++MARK;
4038 SV * const val = newSV(0);
4040 sv_setsv(val, *++MARK);
4041 else if (ckWARN(WARN_MISC))
4042 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4043 (void)hv_store_ent(hv,key,val,0);
4052 dVAR; dSP; dMARK; dORIGMARK;
4053 register AV *ary = (AV*)*++MARK;
4057 register I32 offset;
4058 register I32 length;
4062 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4065 *MARK-- = SvTIED_obj((SV*)ary, mg);
4069 call_method("SPLICE",GIMME_V);
4078 offset = i = SvIVx(*MARK);
4080 offset += AvFILLp(ary) + 1;
4082 offset -= CopARYBASE_get(PL_curcop);
4084 DIE(aTHX_ PL_no_aelem, i);
4086 length = SvIVx(*MARK++);
4088 length += AvFILLp(ary) - offset + 1;
4094 length = AvMAX(ary) + 1; /* close enough to infinity */
4098 length = AvMAX(ary) + 1;
4100 if (offset > AvFILLp(ary) + 1) {
4101 if (ckWARN(WARN_MISC))
4102 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4103 offset = AvFILLp(ary) + 1;
4105 after = AvFILLp(ary) + 1 - (offset + length);
4106 if (after < 0) { /* not that much array */
4107 length += after; /* offset+length now in array */
4113 /* At this point, MARK .. SP-1 is our new LIST */
4116 diff = newlen - length;
4117 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4120 /* make new elements SVs now: avoid problems if they're from the array */
4121 for (dst = MARK, i = newlen; i; i--) {
4122 SV * const h = *dst;
4123 *dst++ = newSVsv(h);
4126 if (diff < 0) { /* shrinking the area */
4129 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4130 Copy(MARK, tmparyval, newlen, SV*);
4133 MARK = ORIGMARK + 1;
4134 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4135 MEXTEND(MARK, length);
4136 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4138 EXTEND_MORTAL(length);
4139 for (i = length, dst = MARK; i; i--) {
4140 sv_2mortal(*dst); /* free them eventualy */
4147 *MARK = AvARRAY(ary)[offset+length-1];
4150 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4151 SvREFCNT_dec(*dst++); /* free them now */
4154 AvFILLp(ary) += diff;
4156 /* pull up or down? */
4158 if (offset < after) { /* easier to pull up */
4159 if (offset) { /* esp. if nothing to pull */
4160 src = &AvARRAY(ary)[offset-1];
4161 dst = src - diff; /* diff is negative */
4162 for (i = offset; i > 0; i--) /* can't trust Copy */
4166 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4170 if (after) { /* anything to pull down? */
4171 src = AvARRAY(ary) + offset + length;
4172 dst = src + diff; /* diff is negative */
4173 Move(src, dst, after, SV*);
4175 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4176 /* avoid later double free */
4180 dst[--i] = &PL_sv_undef;
4183 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4184 Safefree(tmparyval);
4187 else { /* no, expanding (or same) */
4188 SV** tmparyval = NULL;
4190 Newx(tmparyval, length, SV*); /* so remember deletion */
4191 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4194 if (diff > 0) { /* expanding */
4195 /* push up or down? */
4196 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4200 Move(src, dst, offset, SV*);
4202 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4204 AvFILLp(ary) += diff;
4207 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4208 av_extend(ary, AvFILLp(ary) + diff);
4209 AvFILLp(ary) += diff;
4212 dst = AvARRAY(ary) + AvFILLp(ary);
4214 for (i = after; i; i--) {
4222 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4225 MARK = ORIGMARK + 1;
4226 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4228 Copy(tmparyval, MARK, length, SV*);
4230 EXTEND_MORTAL(length);
4231 for (i = length, dst = MARK; i; i--) {
4232 sv_2mortal(*dst); /* free them eventualy */
4239 else if (length--) {
4240 *MARK = tmparyval[length];
4243 while (length-- > 0)
4244 SvREFCNT_dec(tmparyval[length]);
4248 *MARK = &PL_sv_undef;
4249 Safefree(tmparyval);
4257 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4258 register AV *ary = (AV*)*++MARK;
4259 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4262 *MARK-- = SvTIED_obj((SV*)ary, mg);
4266 call_method("PUSH",G_SCALAR|G_DISCARD);
4270 PUSHi( AvFILL(ary) + 1 );
4273 for (++MARK; MARK <= SP; MARK++) {
4274 SV * const sv = newSV(0);
4276 sv_setsv(sv, *MARK);
4277 av_store(ary, AvFILLp(ary)+1, sv);
4280 PUSHi( AvFILLp(ary) + 1 );
4289 AV * const av = (AV*)POPs;
4290 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4294 (void)sv_2mortal(sv);
4301 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4302 register AV *ary = (AV*)*++MARK;
4303 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4306 *MARK-- = SvTIED_obj((SV*)ary, mg);
4310 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4316 av_unshift(ary, SP - MARK);
4318 SV * const sv = newSVsv(*++MARK);
4319 (void)av_store(ary, i++, sv);
4323 PUSHi( AvFILL(ary) + 1 );
4330 SV ** const oldsp = SP;
4332 if (GIMME == G_ARRAY) {
4335 register SV * const tmp = *MARK;
4339 /* safe as long as stack cannot get extended in the above */
4344 register char *down;
4348 PADOFFSET padoff_du;
4350 SvUTF8_off(TARG); /* decontaminate */
4352 do_join(TARG, &PL_sv_no, MARK, SP);
4354 sv_setsv(TARG, (SP > MARK)
4356 : (padoff_du = find_rundefsvoffset(),
4357 (padoff_du == NOT_IN_PAD
4358 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4359 ? DEFSV : PAD_SVl(padoff_du)));
4360 up = SvPV_force(TARG, len);
4362 if (DO_UTF8(TARG)) { /* first reverse each character */
4363 U8* s = (U8*)SvPVX(TARG);
4364 const U8* send = (U8*)(s + len);
4366 if (UTF8_IS_INVARIANT(*s)) {
4371 if (!utf8_to_uvchr(s, 0))
4375 down = (char*)(s - 1);
4376 /* reverse this character */
4380 *down-- = (char)tmp;
4386 down = SvPVX(TARG) + len - 1;
4390 *down-- = (char)tmp;
4392 (void)SvPOK_only_UTF8(TARG);
4404 register IV limit = POPi; /* note, negative is forever */
4405 SV * const sv = POPs;
4407 register const char *s = SvPV_const(sv, len);
4408 const bool do_utf8 = DO_UTF8(sv);
4409 const char *strend = s + len;
4411 register REGEXP *rx;
4413 register const char *m;
4415 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4416 I32 maxiters = slen + 10;
4418 const I32 origlimit = limit;
4421 const I32 gimme = GIMME_V;
4422 const I32 oldsave = PL_savestack_ix;
4423 I32 make_mortal = 1;
4428 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4433 DIE(aTHX_ "panic: pp_split");
4436 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4437 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4439 RX_MATCH_UTF8_set(rx, do_utf8);
4441 if (pm->op_pmreplroot) {
4443 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4445 ary = GvAVn((GV*)pm->op_pmreplroot);
4448 else if (gimme != G_ARRAY)
4449 ary = GvAVn(PL_defgv);
4452 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4458 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4460 XPUSHs(SvTIED_obj((SV*)ary, mg));
4467 for (i = AvFILLp(ary); i >= 0; i--)
4468 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4470 /* temporarily switch stacks */
4471 SAVESWITCHSTACK(PL_curstack, ary);
4475 base = SP - PL_stack_base;
4477 if (pm->op_pmflags & PMf_SKIPWHITE) {
4478 if (pm->op_pmflags & PMf_LOCALE) {
4479 while (isSPACE_LC(*s))
4487 if (pm->op_pmflags & PMf_MULTILINE) {
4492 limit = maxiters + 2;
4493 if (pm->op_pmflags & PMf_WHITE) {
4496 while (m < strend &&
4497 !((pm->op_pmflags & PMf_LOCALE)
4498 ? isSPACE_LC(*m) : isSPACE(*m)))
4503 dstr = newSVpvn(s, m-s);
4507 (void)SvUTF8_on(dstr);
4511 while (s < strend &&
4512 ((pm->op_pmflags & PMf_LOCALE)
4513 ? isSPACE_LC(*s) : isSPACE(*s)))
4517 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4519 for (m = s; m < strend && *m != '\n'; m++)
4524 dstr = newSVpvn(s, m-s);
4528 (void)SvUTF8_on(dstr);
4533 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4534 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4535 && (rx->reganch & ROPT_CHECK_ALL)
4536 && !(rx->reganch & ROPT_ANCH)) {
4537 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4538 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4541 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4542 const char c = *SvPV_nolen_const(csv);
4544 for (m = s; m < strend && *m != c; m++)
4548 dstr = newSVpvn(s, m-s);
4552 (void)SvUTF8_on(dstr);
4554 /* The rx->minlen is in characters but we want to step
4555 * s ahead by bytes. */
4557 s = (char*)utf8_hop((U8*)m, len);
4559 s = m + len; /* Fake \n at the end */
4563 while (s < strend && --limit &&
4564 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4565 csv, multiline ? FBMrf_MULTILINE : 0)) )
4567 dstr = newSVpvn(s, m-s);
4571 (void)SvUTF8_on(dstr);
4573 /* The rx->minlen is in characters but we want to step
4574 * s ahead by bytes. */
4576 s = (char*)utf8_hop((U8*)m, len);
4578 s = m + len; /* Fake \n at the end */
4583 maxiters += slen * rx->nparens;
4584 while (s < strend && --limit)
4588 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4591 if (rex_return == 0)
4593 TAINT_IF(RX_MATCH_TAINTED(rx));
4594 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4599 strend = s + (strend - m);
4601 m = rx->startp[0] + orig;
4602 dstr = newSVpvn(s, m-s);
4606 (void)SvUTF8_on(dstr);
4610 for (i = 1; i <= (I32)rx->nparens; i++) {
4611 s = rx->startp[i] + orig;
4612 m = rx->endp[i] + orig;
4614 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4615 parens that didn't match -- they should be set to
4616 undef, not the empty string */
4617 if (m >= orig && s >= orig) {
4618 dstr = newSVpvn(s, m-s);
4621 dstr = &PL_sv_undef; /* undef, not "" */
4625 (void)SvUTF8_on(dstr);
4629 s = rx->endp[0] + orig;
4633 iters = (SP - PL_stack_base) - base;
4634 if (iters > maxiters)
4635 DIE(aTHX_ "Split loop");
4637 /* keep field after final delim? */
4638 if (s < strend || (iters && origlimit)) {
4639 const STRLEN l = strend - s;
4640 dstr = newSVpvn(s, l);
4644 (void)SvUTF8_on(dstr);
4648 else if (!origlimit) {
4649 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4650 if (TOPs && !make_mortal)
4653 *SP-- = &PL_sv_undef;
4658 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4662 if (SvSMAGICAL(ary)) {
4667 if (gimme == G_ARRAY) {
4669 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4677 call_method("PUSH",G_SCALAR|G_DISCARD);
4680 if (gimme == G_ARRAY) {
4682 /* EXTEND should not be needed - we just popped them */
4684 for (i=0; i < iters; i++) {
4685 SV **svp = av_fetch(ary, i, FALSE);
4686 PUSHs((svp) ? *svp : &PL_sv_undef);
4693 if (gimme == G_ARRAY)
4709 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4710 || SvTYPE(retsv) == SVt_PVCV) {
4711 retsv = refto(retsv);
4718 PP(unimplemented_op)
4721 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4727 * c-indentation-style: bsd
4729 * indent-tabs-mode: t
4732 * ex: set ts=8 sts=4 sw=4 noet: