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 (void)SvREFCNT_inc(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 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(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 + PL_curcop->cop_arybase);
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 (void)SvREFCNT_inc(sv);
494 else if (SvTYPE(sv) == SVt_PVAV) {
495 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
498 (void)SvREFCNT_inc(sv);
500 else if (SvPADTMP(sv) && !IS_PADGV(sv))
504 (void)SvREFCNT_inc(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) {
644 SvSCREAM_off(PL_lastscream);
645 SvREFCNT_dec(PL_lastscream);
647 PL_lastscream = SvREFCNT_inc(sv);
650 s = (unsigned char*)(SvPV(sv, len));
654 if (pos > PL_maxscream) {
655 if (PL_maxscream < 0) {
656 PL_maxscream = pos + 80;
657 Newx(PL_screamfirst, 256, I32);
658 Newx(PL_screamnext, PL_maxscream, I32);
661 PL_maxscream = pos + pos / 4;
662 Renew(PL_screamnext, PL_maxscream, I32);
666 sfirst = PL_screamfirst;
667 snext = PL_screamnext;
669 if (!sfirst || !snext)
670 DIE(aTHX_ "do_study: out of memory");
672 for (ch = 256; ch; --ch)
677 register const I32 ch = s[pos];
679 snext[pos] = sfirst[ch] - pos;
686 /* piggyback on m//g magic */
687 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
696 if (PL_op->op_flags & OPf_STACKED)
698 else if (PL_op->op_private & OPpTARGET_MY)
704 TARG = sv_newmortal();
709 /* Lvalue operators. */
721 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
723 do_chop(TARG, *++MARK);
732 SETi(do_chomp(TOPs));
738 dVAR; dSP; dMARK; dTARGET;
739 register I32 count = 0;
742 count += do_chomp(POPs);
752 if (!PL_op->op_private) {
761 SV_CHECK_THINKFIRST_COW_DROP(sv);
763 switch (SvTYPE(sv)) {
773 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
774 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
775 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
779 /* let user-undef'd sub keep its identity */
780 GV* const gv = CvGV((CV*)sv);
787 SvSetMagicSV(sv, &PL_sv_undef);
792 GvGP(sv) = gp_ref(gp);
794 GvLINE(sv) = CopLINE(PL_curcop);
800 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
815 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
816 DIE(aTHX_ PL_no_modify);
817 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
818 && SvIVX(TOPs) != IV_MIN)
820 SvIV_set(TOPs, SvIVX(TOPs) - 1);
821 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
832 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
833 DIE(aTHX_ PL_no_modify);
834 sv_setsv(TARG, TOPs);
835 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
836 && SvIVX(TOPs) != IV_MAX)
838 SvIV_set(TOPs, SvIVX(TOPs) + 1);
839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
844 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
854 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
855 DIE(aTHX_ PL_no_modify);
856 sv_setsv(TARG, TOPs);
857 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
858 && SvIVX(TOPs) != IV_MIN)
860 SvIV_set(TOPs, SvIVX(TOPs) - 1);
861 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
870 /* Ordinary operators. */
875 #ifdef PERL_PRESERVE_IVUV
878 tryAMAGICbin(pow,opASSIGN);
879 #ifdef PERL_PRESERVE_IVUV
880 /* For integer to integer power, we do the calculation by hand wherever
881 we're sure it is safe; otherwise we call pow() and try to convert to
882 integer afterwards. */
895 const IV iv = SvIVX(TOPs);
899 goto float_it; /* Can't do negative powers this way. */
903 baseuok = SvUOK(TOPm1s);
905 baseuv = SvUVX(TOPm1s);
907 const IV iv = SvIVX(TOPm1s);
910 baseuok = TRUE; /* effectively it's a UV now */
912 baseuv = -iv; /* abs, baseuok == false records sign */
915 /* now we have integer ** positive integer. */
918 /* foo & (foo - 1) is zero only for a power of 2. */
919 if (!(baseuv & (baseuv - 1))) {
920 /* We are raising power-of-2 to a positive integer.
921 The logic here will work for any base (even non-integer
922 bases) but it can be less accurate than
923 pow (base,power) or exp (power * log (base)) when the
924 intermediate values start to spill out of the mantissa.
925 With powers of 2 we know this can't happen.
926 And powers of 2 are the favourite thing for perl
927 programmers to notice ** not doing what they mean. */
929 NV base = baseuok ? baseuv : -(NV)baseuv;
934 while (power >>= 1) {
945 register unsigned int highbit = 8 * sizeof(UV);
946 register unsigned int diff = 8 * sizeof(UV);
949 if (baseuv >> highbit) {
953 /* we now have baseuv < 2 ** highbit */
954 if (power * highbit <= 8 * sizeof(UV)) {
955 /* result will definitely fit in UV, so use UV math
956 on same algorithm as above */
957 register UV result = 1;
958 register UV base = baseuv;
959 const bool odd_power = (bool)(power & 1);
963 while (power >>= 1) {
970 if (baseuok || !odd_power)
971 /* answer is positive */
973 else if (result <= (UV)IV_MAX)
974 /* answer negative, fits in IV */
976 else if (result == (UV)IV_MIN)
977 /* 2's complement assumption: special case IV_MIN */
980 /* answer negative, doesn't fit */
992 SETn( Perl_pow( left, right) );
993 #ifdef PERL_PRESERVE_IVUV
1003 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1004 #ifdef PERL_PRESERVE_IVUV
1007 /* Unless the left argument is integer in range we are going to have to
1008 use NV maths. Hence only attempt to coerce the right argument if
1009 we know the left is integer. */
1010 /* Left operand is defined, so is it IV? */
1011 SvIV_please(TOPm1s);
1012 if (SvIOK(TOPm1s)) {
1013 bool auvok = SvUOK(TOPm1s);
1014 bool buvok = SvUOK(TOPs);
1015 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1016 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1023 alow = SvUVX(TOPm1s);
1025 const IV aiv = SvIVX(TOPm1s);
1028 auvok = TRUE; /* effectively it's a UV now */
1030 alow = -aiv; /* abs, auvok == false records sign */
1036 const IV biv = SvIVX(TOPs);
1039 buvok = TRUE; /* effectively it's a UV now */
1041 blow = -biv; /* abs, buvok == false records sign */
1045 /* If this does sign extension on unsigned it's time for plan B */
1046 ahigh = alow >> (4 * sizeof (UV));
1048 bhigh = blow >> (4 * sizeof (UV));
1050 if (ahigh && bhigh) {
1052 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1053 which is overflow. Drop to NVs below. */
1054 } else if (!ahigh && !bhigh) {
1055 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1056 so the unsigned multiply cannot overflow. */
1057 const UV product = alow * blow;
1058 if (auvok == buvok) {
1059 /* -ve * -ve or +ve * +ve gives a +ve result. */
1063 } else if (product <= (UV)IV_MIN) {
1064 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1065 /* -ve result, which could overflow an IV */
1067 SETi( -(IV)product );
1069 } /* else drop to NVs below. */
1071 /* One operand is large, 1 small */
1074 /* swap the operands */
1076 bhigh = blow; /* bhigh now the temp var for the swap */
1080 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1081 multiplies can't overflow. shift can, add can, -ve can. */
1082 product_middle = ahigh * blow;
1083 if (!(product_middle & topmask)) {
1084 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1086 product_middle <<= (4 * sizeof (UV));
1087 product_low = alow * blow;
1089 /* as for pp_add, UV + something mustn't get smaller.
1090 IIRC ANSI mandates this wrapping *behaviour* for
1091 unsigned whatever the actual representation*/
1092 product_low += product_middle;
1093 if (product_low >= product_middle) {
1094 /* didn't overflow */
1095 if (auvok == buvok) {
1096 /* -ve * -ve or +ve * +ve gives a +ve result. */
1098 SETu( product_low );
1100 } else if (product_low <= (UV)IV_MIN) {
1101 /* 2s complement assumption again */
1102 /* -ve result, which could overflow an IV */
1104 SETi( -(IV)product_low );
1106 } /* else drop to NVs below. */
1108 } /* product_middle too large */
1109 } /* ahigh && bhigh */
1110 } /* SvIOK(TOPm1s) */
1115 SETn( left * right );
1122 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1123 /* Only try to do UV divide first
1124 if ((SLOPPYDIVIDE is true) or
1125 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1127 The assumption is that it is better to use floating point divide
1128 whenever possible, only doing integer divide first if we can't be sure.
1129 If NV_PRESERVES_UV is true then we know at compile time that no UV
1130 can be too large to preserve, so don't need to compile the code to
1131 test the size of UVs. */
1134 # define PERL_TRY_UV_DIVIDE
1135 /* ensure that 20./5. == 4. */
1137 # ifdef PERL_PRESERVE_IVUV
1138 # ifndef NV_PRESERVES_UV
1139 # define PERL_TRY_UV_DIVIDE
1144 #ifdef PERL_TRY_UV_DIVIDE
1147 SvIV_please(TOPm1s);
1148 if (SvIOK(TOPm1s)) {
1149 bool left_non_neg = SvUOK(TOPm1s);
1150 bool right_non_neg = SvUOK(TOPs);
1154 if (right_non_neg) {
1155 right = SvUVX(TOPs);
1158 const IV biv = SvIVX(TOPs);
1161 right_non_neg = TRUE; /* effectively it's a UV now */
1167 /* historically undef()/0 gives a "Use of uninitialized value"
1168 warning before dieing, hence this test goes here.
1169 If it were immediately before the second SvIV_please, then
1170 DIE() would be invoked before left was even inspected, so
1171 no inpsection would give no warning. */
1173 DIE(aTHX_ "Illegal division by zero");
1176 left = SvUVX(TOPm1s);
1179 const IV aiv = SvIVX(TOPm1s);
1182 left_non_neg = TRUE; /* effectively it's a UV now */
1191 /* For sloppy divide we always attempt integer division. */
1193 /* Otherwise we only attempt it if either or both operands
1194 would not be preserved by an NV. If both fit in NVs
1195 we fall through to the NV divide code below. However,
1196 as left >= right to ensure integer result here, we know that
1197 we can skip the test on the right operand - right big
1198 enough not to be preserved can't get here unless left is
1201 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1204 /* Integer division can't overflow, but it can be imprecise. */
1205 const UV result = left / right;
1206 if (result * right == left) {
1207 SP--; /* result is valid */
1208 if (left_non_neg == right_non_neg) {
1209 /* signs identical, result is positive. */
1213 /* 2s complement assumption */
1214 if (result <= (UV)IV_MIN)
1215 SETi( -(IV)result );
1217 /* It's exact but too negative for IV. */
1218 SETn( -(NV)result );
1221 } /* tried integer divide but it was not an integer result */
1222 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1223 } /* left wasn't SvIOK */
1224 } /* right wasn't SvIOK */
1225 #endif /* PERL_TRY_UV_DIVIDE */
1229 DIE(aTHX_ "Illegal division by zero");
1230 PUSHn( left / right );
1237 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1241 bool left_neg = FALSE;
1242 bool right_neg = FALSE;
1243 bool use_double = FALSE;
1244 bool dright_valid = FALSE;
1250 right_neg = !SvUOK(TOPs);
1252 right = SvUVX(POPs);
1254 const IV biv = SvIVX(POPs);
1257 right_neg = FALSE; /* effectively it's a UV now */
1265 right_neg = dright < 0;
1268 if (dright < UV_MAX_P1) {
1269 right = U_V(dright);
1270 dright_valid = TRUE; /* In case we need to use double below. */
1276 /* At this point use_double is only true if right is out of range for
1277 a UV. In range NV has been rounded down to nearest UV and
1278 use_double false. */
1280 if (!use_double && SvIOK(TOPs)) {
1282 left_neg = !SvUOK(TOPs);
1286 const IV aiv = SvIVX(POPs);
1289 left_neg = FALSE; /* effectively it's a UV now */
1298 left_neg = dleft < 0;
1302 /* This should be exactly the 5.6 behaviour - if left and right are
1303 both in range for UV then use U_V() rather than floor. */
1305 if (dleft < UV_MAX_P1) {
1306 /* right was in range, so is dleft, so use UVs not double.
1310 /* left is out of range for UV, right was in range, so promote
1311 right (back) to double. */
1313 /* The +0.5 is used in 5.6 even though it is not strictly
1314 consistent with the implicit +0 floor in the U_V()
1315 inside the #if 1. */
1316 dleft = Perl_floor(dleft + 0.5);
1319 dright = Perl_floor(dright + 0.5);
1329 DIE(aTHX_ "Illegal modulus zero");
1331 dans = Perl_fmod(dleft, dright);
1332 if ((left_neg != right_neg) && dans)
1333 dans = dright - dans;
1336 sv_setnv(TARG, dans);
1342 DIE(aTHX_ "Illegal modulus zero");
1345 if ((left_neg != right_neg) && ans)
1348 /* XXX may warn: unary minus operator applied to unsigned type */
1349 /* could change -foo to be (~foo)+1 instead */
1350 if (ans <= ~((UV)IV_MAX)+1)
1351 sv_setiv(TARG, ~ans+1);
1353 sv_setnv(TARG, -(NV)ans);
1356 sv_setuv(TARG, ans);
1365 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1372 const UV uv = SvUV(sv);
1374 count = IV_MAX; /* The best we can do? */
1378 const IV iv = SvIV(sv);
1385 else if (SvNOKp(sv)) {
1386 const NV nv = SvNV(sv);
1394 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1396 static const char oom_list_extend[] = "Out of memory during list extend";
1397 const I32 items = SP - MARK;
1398 const I32 max = items * count;
1400 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1401 /* Did the max computation overflow? */
1402 if (items > 0 && max > 0 && (max < items || max < count))
1403 Perl_croak(aTHX_ oom_list_extend);
1408 /* This code was intended to fix 20010809.028:
1411 for (($x =~ /./g) x 2) {
1412 print chop; # "abcdabcd" expected as output.
1415 * but that change (#11635) broke this code:
1417 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1419 * I can't think of a better fix that doesn't introduce
1420 * an efficiency hit by copying the SVs. The stack isn't
1421 * refcounted, and mortalisation obviously doesn't
1422 * Do The Right Thing when the stack has more than
1423 * one pointer to the same mortal value.
1427 *SP = sv_2mortal(newSVsv(*SP));
1437 repeatcpy((char*)(MARK + items), (char*)MARK,
1438 items * sizeof(SV*), count - 1);
1441 else if (count <= 0)
1444 else { /* Note: mark already snarfed by pp_list */
1445 SV * const tmpstr = POPs;
1448 static const char oom_string_extend[] =
1449 "Out of memory during string extend";
1451 SvSetSV(TARG, tmpstr);
1452 SvPV_force(TARG, len);
1453 isutf = DO_UTF8(TARG);
1458 const STRLEN max = (UV)count * len;
1459 if (len > ((MEM_SIZE)~0)/count)
1460 Perl_croak(aTHX_ oom_string_extend);
1461 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1462 SvGROW(TARG, max + 1);
1463 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1464 SvCUR_set(TARG, SvCUR(TARG) * count);
1466 *SvEND(TARG) = '\0';
1469 (void)SvPOK_only_UTF8(TARG);
1471 (void)SvPOK_only(TARG);
1473 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1474 /* The parser saw this as a list repeat, and there
1475 are probably several items on the stack. But we're
1476 in scalar context, and there's no pp_list to save us
1477 now. So drop the rest of the items -- robin@kitsite.com
1490 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1491 useleft = USE_LEFT(TOPm1s);
1492 #ifdef PERL_PRESERVE_IVUV
1493 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1494 "bad things" happen if you rely on signed integers wrapping. */
1497 /* Unless the left argument is integer in range we are going to have to
1498 use NV maths. Hence only attempt to coerce the right argument if
1499 we know the left is integer. */
1500 register UV auv = 0;
1506 a_valid = auvok = 1;
1507 /* left operand is undef, treat as zero. */
1509 /* Left operand is defined, so is it IV? */
1510 SvIV_please(TOPm1s);
1511 if (SvIOK(TOPm1s)) {
1512 if ((auvok = SvUOK(TOPm1s)))
1513 auv = SvUVX(TOPm1s);
1515 register const IV aiv = SvIVX(TOPm1s);
1518 auvok = 1; /* Now acting as a sign flag. */
1519 } else { /* 2s complement assumption for IV_MIN */
1527 bool result_good = 0;
1530 bool buvok = SvUOK(TOPs);
1535 register const IV biv = SvIVX(TOPs);
1542 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1543 else "IV" now, independent of how it came in.
1544 if a, b represents positive, A, B negative, a maps to -A etc
1549 all UV maths. negate result if A negative.
1550 subtract if signs same, add if signs differ. */
1552 if (auvok ^ buvok) {
1561 /* Must get smaller */
1566 if (result <= buv) {
1567 /* result really should be -(auv-buv). as its negation
1568 of true value, need to swap our result flag */
1580 if (result <= (UV)IV_MIN)
1581 SETi( -(IV)result );
1583 /* result valid, but out of range for IV. */
1584 SETn( -(NV)result );
1588 } /* Overflow, drop through to NVs. */
1592 useleft = USE_LEFT(TOPm1s);
1596 /* left operand is undef, treat as zero - value */
1600 SETn( TOPn - value );
1607 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1609 const IV shift = POPi;
1610 if (PL_op->op_private & HINT_INTEGER) {
1624 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1626 const IV shift = POPi;
1627 if (PL_op->op_private & HINT_INTEGER) {
1641 dVAR; dSP; tryAMAGICbinSET(lt,0);
1642 #ifdef PERL_PRESERVE_IVUV
1645 SvIV_please(TOPm1s);
1646 if (SvIOK(TOPm1s)) {
1647 bool auvok = SvUOK(TOPm1s);
1648 bool buvok = SvUOK(TOPs);
1650 if (!auvok && !buvok) { /* ## IV < IV ## */
1651 const IV aiv = SvIVX(TOPm1s);
1652 const IV biv = SvIVX(TOPs);
1655 SETs(boolSV(aiv < biv));
1658 if (auvok && buvok) { /* ## UV < UV ## */
1659 const UV auv = SvUVX(TOPm1s);
1660 const UV buv = SvUVX(TOPs);
1663 SETs(boolSV(auv < buv));
1666 if (auvok) { /* ## UV < IV ## */
1668 const IV biv = SvIVX(TOPs);
1671 /* As (a) is a UV, it's >=0, so it cannot be < */
1676 SETs(boolSV(auv < (UV)biv));
1679 { /* ## IV < UV ## */
1680 const IV aiv = SvIVX(TOPm1s);
1684 /* As (b) is a UV, it's >=0, so it must be < */
1691 SETs(boolSV((UV)aiv < buv));
1697 #ifndef NV_PRESERVES_UV
1698 #ifdef PERL_PRESERVE_IVUV
1701 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1703 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1709 SETs(boolSV(TOPn < value));
1716 dVAR; dSP; tryAMAGICbinSET(gt,0);
1717 #ifdef PERL_PRESERVE_IVUV
1720 SvIV_please(TOPm1s);
1721 if (SvIOK(TOPm1s)) {
1722 bool auvok = SvUOK(TOPm1s);
1723 bool buvok = SvUOK(TOPs);
1725 if (!auvok && !buvok) { /* ## IV > IV ## */
1726 const IV aiv = SvIVX(TOPm1s);
1727 const IV biv = SvIVX(TOPs);
1730 SETs(boolSV(aiv > biv));
1733 if (auvok && buvok) { /* ## UV > UV ## */
1734 const UV auv = SvUVX(TOPm1s);
1735 const UV buv = SvUVX(TOPs);
1738 SETs(boolSV(auv > buv));
1741 if (auvok) { /* ## UV > IV ## */
1743 const IV biv = SvIVX(TOPs);
1747 /* As (a) is a UV, it's >=0, so it must be > */
1752 SETs(boolSV(auv > (UV)biv));
1755 { /* ## IV > UV ## */
1756 const IV aiv = SvIVX(TOPm1s);
1760 /* As (b) is a UV, it's >=0, so it cannot be > */
1767 SETs(boolSV((UV)aiv > buv));
1773 #ifndef NV_PRESERVES_UV
1774 #ifdef PERL_PRESERVE_IVUV
1777 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1779 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1785 SETs(boolSV(TOPn > value));
1792 dVAR; dSP; tryAMAGICbinSET(le,0);
1793 #ifdef PERL_PRESERVE_IVUV
1796 SvIV_please(TOPm1s);
1797 if (SvIOK(TOPm1s)) {
1798 bool auvok = SvUOK(TOPm1s);
1799 bool buvok = SvUOK(TOPs);
1801 if (!auvok && !buvok) { /* ## IV <= IV ## */
1802 const IV aiv = SvIVX(TOPm1s);
1803 const IV biv = SvIVX(TOPs);
1806 SETs(boolSV(aiv <= biv));
1809 if (auvok && buvok) { /* ## UV <= UV ## */
1810 UV auv = SvUVX(TOPm1s);
1811 UV buv = SvUVX(TOPs);
1814 SETs(boolSV(auv <= buv));
1817 if (auvok) { /* ## UV <= IV ## */
1819 const IV biv = SvIVX(TOPs);
1823 /* As (a) is a UV, it's >=0, so a cannot be <= */
1828 SETs(boolSV(auv <= (UV)biv));
1831 { /* ## IV <= UV ## */
1832 const IV aiv = SvIVX(TOPm1s);
1836 /* As (b) is a UV, it's >=0, so a must be <= */
1843 SETs(boolSV((UV)aiv <= buv));
1849 #ifndef NV_PRESERVES_UV
1850 #ifdef PERL_PRESERVE_IVUV
1853 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1855 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1861 SETs(boolSV(TOPn <= value));
1868 dVAR; dSP; tryAMAGICbinSET(ge,0);
1869 #ifdef PERL_PRESERVE_IVUV
1872 SvIV_please(TOPm1s);
1873 if (SvIOK(TOPm1s)) {
1874 bool auvok = SvUOK(TOPm1s);
1875 bool buvok = SvUOK(TOPs);
1877 if (!auvok && !buvok) { /* ## IV >= IV ## */
1878 const IV aiv = SvIVX(TOPm1s);
1879 const IV biv = SvIVX(TOPs);
1882 SETs(boolSV(aiv >= biv));
1885 if (auvok && buvok) { /* ## UV >= UV ## */
1886 const UV auv = SvUVX(TOPm1s);
1887 const UV buv = SvUVX(TOPs);
1890 SETs(boolSV(auv >= buv));
1893 if (auvok) { /* ## UV >= IV ## */
1895 const IV biv = SvIVX(TOPs);
1899 /* As (a) is a UV, it's >=0, so it must be >= */
1904 SETs(boolSV(auv >= (UV)biv));
1907 { /* ## IV >= UV ## */
1908 const IV aiv = SvIVX(TOPm1s);
1912 /* As (b) is a UV, it's >=0, so a cannot be >= */
1919 SETs(boolSV((UV)aiv >= buv));
1925 #ifndef NV_PRESERVES_UV
1926 #ifdef PERL_PRESERVE_IVUV
1929 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1931 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1937 SETs(boolSV(TOPn >= value));
1944 dVAR; dSP; tryAMAGICbinSET(ne,0);
1945 #ifndef NV_PRESERVES_UV
1946 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1948 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1952 #ifdef PERL_PRESERVE_IVUV
1955 SvIV_please(TOPm1s);
1956 if (SvIOK(TOPm1s)) {
1957 const bool auvok = SvUOK(TOPm1s);
1958 const bool buvok = SvUOK(TOPs);
1960 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1961 /* Casting IV to UV before comparison isn't going to matter
1962 on 2s complement. On 1s complement or sign&magnitude
1963 (if we have any of them) it could make negative zero
1964 differ from normal zero. As I understand it. (Need to
1965 check - is negative zero implementation defined behaviour
1967 const UV buv = SvUVX(POPs);
1968 const UV auv = SvUVX(TOPs);
1970 SETs(boolSV(auv != buv));
1973 { /* ## Mixed IV,UV ## */
1977 /* != is commutative so swap if needed (save code) */
1979 /* swap. top of stack (b) is the iv */
1983 /* As (a) is a UV, it's >0, so it cannot be == */
1992 /* As (b) is a UV, it's >0, so it cannot be == */
1996 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1998 SETs(boolSV((UV)iv != uv));
2006 SETs(boolSV(TOPn != value));
2013 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2014 #ifndef NV_PRESERVES_UV
2015 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2016 const UV right = PTR2UV(SvRV(POPs));
2017 const UV left = PTR2UV(SvRV(TOPs));
2018 SETi((left > right) - (left < right));
2022 #ifdef PERL_PRESERVE_IVUV
2023 /* Fortunately it seems NaN isn't IOK */
2026 SvIV_please(TOPm1s);
2027 if (SvIOK(TOPm1s)) {
2028 const bool leftuvok = SvUOK(TOPm1s);
2029 const bool rightuvok = SvUOK(TOPs);
2031 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2032 const IV leftiv = SvIVX(TOPm1s);
2033 const IV rightiv = SvIVX(TOPs);
2035 if (leftiv > rightiv)
2037 else if (leftiv < rightiv)
2041 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2042 const UV leftuv = SvUVX(TOPm1s);
2043 const UV rightuv = SvUVX(TOPs);
2045 if (leftuv > rightuv)
2047 else if (leftuv < rightuv)
2051 } else if (leftuvok) { /* ## UV <=> IV ## */
2052 const IV rightiv = SvIVX(TOPs);
2054 /* As (a) is a UV, it's >=0, so it cannot be < */
2057 const UV leftuv = SvUVX(TOPm1s);
2058 if (leftuv > (UV)rightiv) {
2060 } else if (leftuv < (UV)rightiv) {
2066 } else { /* ## IV <=> UV ## */
2067 const IV leftiv = SvIVX(TOPm1s);
2069 /* As (b) is a UV, it's >=0, so it must be < */
2072 const UV rightuv = SvUVX(TOPs);
2073 if ((UV)leftiv > rightuv) {
2075 } else if ((UV)leftiv < rightuv) {
2093 if (Perl_isnan(left) || Perl_isnan(right)) {
2097 value = (left > right) - (left < right);
2101 else if (left < right)
2103 else if (left > right)
2119 int amg_type = sle_amg;
2123 switch (PL_op->op_type) {
2142 tryAMAGICbinSET_var(amg_type,0);
2145 const int cmp = (IN_LOCALE_RUNTIME
2146 ? sv_cmp_locale(left, right)
2147 : sv_cmp(left, right));
2148 SETs(boolSV(cmp * multiplier < rhs));
2155 dVAR; dSP; tryAMAGICbinSET(seq,0);
2158 SETs(boolSV(sv_eq(left, right)));
2165 dVAR; dSP; tryAMAGICbinSET(sne,0);
2168 SETs(boolSV(!sv_eq(left, right)));
2175 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2178 const int cmp = (IN_LOCALE_RUNTIME
2179 ? sv_cmp_locale(left, right)
2180 : sv_cmp(left, right));
2188 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2193 if (SvNIOKp(left) || SvNIOKp(right)) {
2194 if (PL_op->op_private & HINT_INTEGER) {
2195 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2199 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2204 do_vop(PL_op->op_type, TARG, left, right);
2213 dVAR; dSP; dATARGET;
2214 const int op_type = PL_op->op_type;
2216 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2221 if (SvNIOKp(left) || SvNIOKp(right)) {
2222 if (PL_op->op_private & HINT_INTEGER) {
2223 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2224 const IV r = SvIV_nomg(right);
2225 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2229 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2230 const UV r = SvUV_nomg(right);
2231 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2236 do_vop(op_type, TARG, left, right);
2245 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2248 const int flags = SvFLAGS(sv);
2250 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2251 /* It's publicly an integer, or privately an integer-not-float */
2254 if (SvIVX(sv) == IV_MIN) {
2255 /* 2s complement assumption. */
2256 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2259 else if (SvUVX(sv) <= IV_MAX) {
2264 else if (SvIVX(sv) != IV_MIN) {
2268 #ifdef PERL_PRESERVE_IVUV
2277 else if (SvPOKp(sv)) {
2279 const char * const s = SvPV_const(sv, len);
2280 if (isIDFIRST(*s)) {
2281 sv_setpvn(TARG, "-", 1);
2284 else if (*s == '+' || *s == '-') {
2286 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2288 else if (DO_UTF8(sv)) {
2291 goto oops_its_an_int;
2293 sv_setnv(TARG, -SvNV(sv));
2295 sv_setpvn(TARG, "-", 1);
2302 goto oops_its_an_int;
2303 sv_setnv(TARG, -SvNV(sv));
2315 dVAR; dSP; tryAMAGICunSET(not);
2316 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2322 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2327 if (PL_op->op_private & HINT_INTEGER) {
2328 const IV i = ~SvIV_nomg(sv);
2332 const UV u = ~SvUV_nomg(sv);
2341 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2342 sv_setsv_nomg(TARG, sv);
2343 tmps = (U8*)SvPV_force(TARG, len);
2346 /* Calculate exact length, let's not estimate. */
2355 while (tmps < send) {
2356 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2357 tmps += UTF8SKIP(tmps);
2358 targlen += UNISKIP(~c);
2364 /* Now rewind strings and write them. */
2368 Newxz(result, targlen + 1, U8);
2369 while (tmps < send) {
2370 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2371 tmps += UTF8SKIP(tmps);
2372 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2376 sv_setpvn(TARG, (char*)result, targlen);
2380 Newxz(result, nchar + 1, U8);
2381 while (tmps < send) {
2382 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2383 tmps += UTF8SKIP(tmps);
2388 sv_setpvn(TARG, (char*)result, nchar);
2397 register long *tmpl;
2398 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2401 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2406 for ( ; anum > 0; anum--, tmps++)
2415 /* integer versions of some of the above */
2419 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2422 SETi( left * right );
2430 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2434 DIE(aTHX_ "Illegal division by zero");
2437 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2441 value = num / value;
2450 /* This is the vanilla old i_modulo. */
2451 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2455 DIE(aTHX_ "Illegal modulus zero");
2456 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2460 SETi( left % right );
2465 #if defined(__GLIBC__) && IVSIZE == 8
2469 /* This is the i_modulo with the workaround for the _moddi3 bug
2470 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2471 * See below for pp_i_modulo. */
2472 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2476 DIE(aTHX_ "Illegal modulus zero");
2477 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2481 SETi( left % PERL_ABS(right) );
2489 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2493 DIE(aTHX_ "Illegal modulus zero");
2494 /* The assumption is to use hereafter the old vanilla version... */
2496 PL_ppaddr[OP_I_MODULO] =
2498 /* .. but if we have glibc, we might have a buggy _moddi3
2499 * (at least glicb 2.2.5 is known to have this bug), in other
2500 * words our integer modulus with negative quad as the second
2501 * argument might be broken. Test for this and re-patch the
2502 * opcode dispatch table if that is the case, remembering to
2503 * also apply the workaround so that this first round works
2504 * right, too. See [perl #9402] for more information. */
2505 #if defined(__GLIBC__) && IVSIZE == 8
2509 /* Cannot do this check with inlined IV constants since
2510 * that seems to work correctly even with the buggy glibc. */
2512 /* Yikes, we have the bug.
2513 * Patch in the workaround version. */
2515 PL_ppaddr[OP_I_MODULO] =
2516 &Perl_pp_i_modulo_1;
2517 /* Make certain we work right this time, too. */
2518 right = PERL_ABS(right);
2522 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2526 SETi( left % right );
2533 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2536 SETi( left + right );
2543 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2546 SETi( left - right );
2553 dVAR; dSP; tryAMAGICbinSET(lt,0);
2556 SETs(boolSV(left < right));
2563 dVAR; dSP; tryAMAGICbinSET(gt,0);
2566 SETs(boolSV(left > right));
2573 dVAR; dSP; tryAMAGICbinSET(le,0);
2576 SETs(boolSV(left <= right));
2583 dVAR; dSP; tryAMAGICbinSET(ge,0);
2586 SETs(boolSV(left >= right));
2593 dVAR; dSP; tryAMAGICbinSET(eq,0);
2596 SETs(boolSV(left == right));
2603 dVAR; dSP; tryAMAGICbinSET(ne,0);
2606 SETs(boolSV(left != right));
2613 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2620 else if (left < right)
2631 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2636 /* High falutin' math. */
2640 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2643 SETn(Perl_atan2(left, right));
2651 int amg_type = sin_amg;
2652 const char *neg_report = NULL;
2653 NV (*func)(NV) = Perl_sin;
2654 const int op_type = PL_op->op_type;
2671 amg_type = sqrt_amg;
2673 neg_report = "sqrt";
2677 tryAMAGICun_var(amg_type);
2679 const NV value = POPn;
2681 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2682 SET_NUMERIC_STANDARD();
2683 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2686 XPUSHn(func(value));
2691 /* Support Configure command-line overrides for rand() functions.
2692 After 5.005, perhaps we should replace this by Configure support
2693 for drand48(), random(), or rand(). For 5.005, though, maintain
2694 compatibility by calling rand() but allow the user to override it.
2695 See INSTALL for details. --Andy Dougherty 15 July 1998
2697 /* Now it's after 5.005, and Configure supports drand48() and random(),
2698 in addition to rand(). So the overrides should not be needed any more.
2699 --Jarkko Hietaniemi 27 September 1998
2702 #ifndef HAS_DRAND48_PROTO
2703 extern double drand48 (void);
2716 if (!PL_srand_called) {
2717 (void)seedDrand01((Rand_seed_t)seed());
2718 PL_srand_called = TRUE;
2728 const UV anum = (MAXARG < 1) ? seed() : POPu;
2729 (void)seedDrand01((Rand_seed_t)anum);
2730 PL_srand_called = TRUE;
2737 dVAR; dSP; dTARGET; tryAMAGICun(int);
2739 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2740 /* XXX it's arguable that compiler casting to IV might be subtly
2741 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2742 else preferring IV has introduced a subtle behaviour change bug. OTOH
2743 relying on floating point to be accurate is a bug. */
2747 else if (SvIOK(TOPs)) {
2754 const NV value = TOPn;
2756 if (value < (NV)UV_MAX + 0.5) {
2759 SETn(Perl_floor(value));
2763 if (value > (NV)IV_MIN - 0.5) {
2766 SETn(Perl_ceil(value));
2776 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2778 /* This will cache the NV value if string isn't actually integer */
2783 else if (SvIOK(TOPs)) {
2784 /* IVX is precise */
2786 SETu(TOPu); /* force it to be numeric only */
2794 /* 2s complement assumption. Also, not really needed as
2795 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2801 const NV value = TOPn;
2815 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2819 SV* const sv = POPs;
2821 tmps = (SvPV_const(sv, len));
2823 /* If Unicode, try to downgrade
2824 * If not possible, croak. */
2825 SV* const tsv = sv_2mortal(newSVsv(sv));
2828 sv_utf8_downgrade(tsv, FALSE);
2829 tmps = SvPV_const(tsv, len);
2831 if (PL_op->op_type == OP_HEX)
2834 while (*tmps && len && isSPACE(*tmps))
2840 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2842 else if (*tmps == 'b')
2843 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2845 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2847 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2861 SV * const sv = TOPs;
2864 SETi(sv_len_utf8(sv));
2880 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2882 const I32 arybase = PL_curcop->cop_arybase;
2884 const char *repl = NULL;
2886 const int num_args = PL_op->op_private & 7;
2887 bool repl_need_utf8_upgrade = FALSE;
2888 bool repl_is_utf8 = FALSE;
2890 SvTAINTED_off(TARG); /* decontaminate */
2891 SvUTF8_off(TARG); /* decontaminate */
2895 repl = SvPV_const(repl_sv, repl_len);
2896 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2906 sv_utf8_upgrade(sv);
2908 else if (DO_UTF8(sv))
2909 repl_need_utf8_upgrade = TRUE;
2911 tmps = SvPV_const(sv, curlen);
2913 utf8_curlen = sv_len_utf8(sv);
2914 if (utf8_curlen == curlen)
2917 curlen = utf8_curlen;
2922 if (pos >= arybase) {
2940 else if (len >= 0) {
2942 if (rem > (I32)curlen)
2957 Perl_croak(aTHX_ "substr outside of string");
2958 if (ckWARN(WARN_SUBSTR))
2959 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2963 const I32 upos = pos;
2964 const I32 urem = rem;
2966 sv_pos_u2b(sv, &pos, &rem);
2968 /* we either return a PV or an LV. If the TARG hasn't been used
2969 * before, or is of that type, reuse it; otherwise use a mortal
2970 * instead. Note that LVs can have an extended lifetime, so also
2971 * dont reuse if refcount > 1 (bug #20933) */
2972 if (SvTYPE(TARG) > SVt_NULL) {
2973 if ( (SvTYPE(TARG) == SVt_PVLV)
2974 ? (!lvalue || SvREFCNT(TARG) > 1)
2977 TARG = sv_newmortal();
2981 sv_setpvn(TARG, tmps, rem);
2982 #ifdef USE_LOCALE_COLLATE
2983 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2988 SV* repl_sv_copy = NULL;
2990 if (repl_need_utf8_upgrade) {
2991 repl_sv_copy = newSVsv(repl_sv);
2992 sv_utf8_upgrade(repl_sv_copy);
2993 repl = SvPV_const(repl_sv_copy, repl_len);
2994 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2996 sv_insert(sv, pos, rem, repl, repl_len);
3000 SvREFCNT_dec(repl_sv_copy);
3002 else if (lvalue) { /* it's an lvalue! */
3003 if (!SvGMAGICAL(sv)) {
3005 SvPV_force_nolen(sv);
3006 if (ckWARN(WARN_SUBSTR))
3007 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3008 "Attempt to use reference as lvalue in substr");
3010 if (SvOK(sv)) /* is it defined ? */
3011 (void)SvPOK_only_UTF8(sv);
3013 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3016 if (SvTYPE(TARG) < SVt_PVLV) {
3017 sv_upgrade(TARG, SVt_PVLV);
3018 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3024 if (LvTARG(TARG) != sv) {
3026 SvREFCNT_dec(LvTARG(TARG));
3027 LvTARG(TARG) = SvREFCNT_inc(sv);
3029 LvTARGOFF(TARG) = upos;
3030 LvTARGLEN(TARG) = urem;
3034 PUSHs(TARG); /* avoid SvSETMAGIC here */
3041 register const IV size = POPi;
3042 register const IV offset = POPi;
3043 register SV * const src = POPs;
3044 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3046 SvTAINTED_off(TARG); /* decontaminate */
3047 if (lvalue) { /* it's an lvalue! */
3048 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3049 TARG = sv_newmortal();
3050 if (SvTYPE(TARG) < SVt_PVLV) {
3051 sv_upgrade(TARG, SVt_PVLV);
3052 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3055 if (LvTARG(TARG) != src) {
3057 SvREFCNT_dec(LvTARG(TARG));
3058 LvTARG(TARG) = SvREFCNT_inc(src);
3060 LvTARGOFF(TARG) = offset;
3061 LvTARGLEN(TARG) = size;
3064 sv_setuv(TARG, do_vecget(src, offset, size));
3081 const I32 arybase = PL_curcop->cop_arybase;
3084 const bool is_index = PL_op->op_type == OP_INDEX;
3087 /* arybase is in characters, like offset, so combine prior to the
3088 UTF-8 to bytes calculation. */
3089 offset = POPi - arybase;
3093 big_utf8 = DO_UTF8(big);
3094 little_utf8 = DO_UTF8(little);
3095 if (big_utf8 ^ little_utf8) {
3096 /* One needs to be upgraded. */
3097 if (little_utf8 && !PL_encoding) {
3098 /* Well, maybe instead we might be able to downgrade the small
3101 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3102 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3105 /* If the large string is ISO-8859-1, and it's not possible to
3106 convert the small string to ISO-8859-1, then there is no
3107 way that it could be found anywhere by index. */
3112 /* At this point, pv is a malloc()ed string. So donate it to temp
3113 to ensure it will get free()d */
3114 little = temp = newSV(0);
3115 sv_usepvn(temp, pv, little_len);
3117 SV * const bytes = little_utf8 ? big : little;
3119 const char * const p = SvPV_const(bytes, len);
3121 temp = newSVpvn(p, len);
3124 sv_recode_to_utf8(temp, PL_encoding);
3126 sv_utf8_upgrade(temp);
3136 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3137 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3138 tmps = SvPV_const(big, biglen);
3141 offset = is_index ? 0 : biglen;
3143 if (big_utf8 && offset > 0)
3144 sv_pos_u2b(big, &offset, 0);
3149 else if (offset > (I32)biglen)
3151 if (!(tmps2 = is_index
3152 ? fbm_instr((unsigned char*)tmps + offset,
3153 (unsigned char*)tmps + biglen, little, 0)
3154 : rninstr(tmps, tmps + offset,
3155 tmps2, tmps2 + llen)))
3158 retval = tmps2 - tmps;
3159 if (retval > 0 && big_utf8)
3160 sv_pos_b2u(big, &retval);
3165 PUSHi(retval + arybase);
3171 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3172 do_sprintf(TARG, SP-MARK, MARK+1);
3173 TAINT_IF(SvTAINTED(TARG));
3184 const U8 *s = (U8*)SvPV_const(argsv, len);
3187 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3188 tmpsv = sv_2mortal(newSVsv(argsv));
3189 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3193 XPUSHu(DO_UTF8(argsv) ?
3194 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3206 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3208 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3210 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3212 (void) POPs; /* Ignore the argument value. */
3213 value = UNICODE_REPLACEMENT;
3219 SvUPGRADE(TARG,SVt_PV);
3221 if (value > 255 && !IN_BYTES) {
3222 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3223 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3224 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3226 (void)SvPOK_only(TARG);
3235 *tmps++ = (char)value;
3237 (void)SvPOK_only(TARG);
3238 if (PL_encoding && !IN_BYTES) {
3239 sv_recode_to_utf8(TARG, PL_encoding);
3241 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3242 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3246 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3247 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3262 const char *tmps = SvPV_const(left, len);
3264 if (DO_UTF8(left)) {
3265 /* If Unicode, try to downgrade.
3266 * If not possible, croak.
3267 * Yes, we made this up. */
3268 SV* const tsv = sv_2mortal(newSVsv(left));
3271 sv_utf8_downgrade(tsv, FALSE);
3272 tmps = SvPV_const(tsv, len);
3274 # ifdef USE_ITHREADS
3276 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3277 /* This should be threadsafe because in ithreads there is only
3278 * one thread per interpreter. If this would not be true,
3279 * we would need a mutex to protect this malloc. */
3280 PL_reentrant_buffer->_crypt_struct_buffer =
3281 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3282 #if defined(__GLIBC__) || defined(__EMX__)
3283 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3284 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3285 /* work around glibc-2.2.5 bug */
3286 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3290 # endif /* HAS_CRYPT_R */
3291 # endif /* USE_ITHREADS */
3293 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3295 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3301 "The crypt() function is unimplemented due to excessive paranoia.");
3312 const int op_type = PL_op->op_type;
3316 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3317 UTF8_IS_START(*s)) {
3318 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3322 utf8_to_uvchr(s, &ulen);
3323 if (op_type == OP_UCFIRST) {
3324 toTITLE_utf8(s, tmpbuf, &tculen);
3326 toLOWER_utf8(s, tmpbuf, &tculen);
3329 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3331 /* slen is the byte length of the whole SV.
3332 * ulen is the byte length of the original Unicode character
3333 * stored as UTF-8 at s.
3334 * tculen is the byte length of the freshly titlecased (or
3335 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3336 * We first set the result to be the titlecased (/lowercased)
3337 * character, and then append the rest of the SV data. */
3338 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3340 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3345 s = (U8*)SvPV_force_nomg(sv, slen);
3346 Copy(tmpbuf, s, tculen, U8);
3351 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3353 SvUTF8_off(TARG); /* decontaminate */
3354 sv_setsv_nomg(TARG, sv);
3358 s1 = (U8*)SvPV_force_nomg(sv, slen);
3360 if (IN_LOCALE_RUNTIME) {
3363 *s1 = (op_type == OP_UCFIRST)
3364 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3367 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3388 U8 tmpbuf[UTF8_MAXBYTES+1];
3390 s = (const U8*)SvPV_nomg_const(sv,len);
3392 SvUTF8_off(TARG); /* decontaminate */
3393 sv_setpvn(TARG, "", 0);
3397 STRLEN min = len + 1;
3399 SvUPGRADE(TARG, SVt_PV);
3401 (void)SvPOK_only(TARG);
3402 d = (U8*)SvPVX(TARG);
3405 STRLEN u = UTF8SKIP(s);
3407 toUPPER_utf8(s, tmpbuf, &ulen);
3408 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3409 /* If the eventually required minimum size outgrows
3410 * the available space, we need to grow. */
3411 const UV o = d - (U8*)SvPVX_const(TARG);
3413 /* If someone uppercases one million U+03B0s we
3414 * SvGROW() one million times. Or we could try
3415 * guessing how much to allocate without allocating
3416 * too much. Such is life. */
3418 d = (U8*)SvPVX(TARG) + o;
3420 Copy(tmpbuf, d, ulen, U8);
3426 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3432 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3434 SvUTF8_off(TARG); /* decontaminate */
3435 sv_setsv_nomg(TARG, sv);
3439 s = (U8*)SvPV_force_nomg(sv, len);
3441 register const U8 *send = s + len;
3443 if (IN_LOCALE_RUNTIME) {
3446 for (; s < send; s++)
3447 *s = toUPPER_LC(*s);
3450 for (; s < send; s++)
3473 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3475 s = (const U8*)SvPV_nomg_const(sv,len);
3477 SvUTF8_off(TARG); /* decontaminate */
3478 sv_setpvn(TARG, "", 0);
3482 STRLEN min = len + 1;
3484 SvUPGRADE(TARG, SVt_PV);
3486 (void)SvPOK_only(TARG);
3487 d = (U8*)SvPVX(TARG);
3490 const STRLEN u = UTF8SKIP(s);
3491 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3493 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3494 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3497 * Now if the sigma is NOT followed by
3498 * /$ignorable_sequence$cased_letter/;
3499 * and it IS preceded by
3500 * /$cased_letter$ignorable_sequence/;
3501 * where $ignorable_sequence is
3502 * [\x{2010}\x{AD}\p{Mn}]*
3503 * and $cased_letter is
3504 * [\p{Ll}\p{Lo}\p{Lt}]
3505 * then it should be mapped to 0x03C2,
3506 * (GREEK SMALL LETTER FINAL SIGMA),
3507 * instead of staying 0x03A3.
3508 * "should be": in other words,
3509 * this is not implemented yet.
3510 * See lib/unicore/SpecialCasing.txt.
3513 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3514 /* If the eventually required minimum size outgrows
3515 * the available space, we need to grow. */
3516 const UV o = d - (U8*)SvPVX_const(TARG);
3518 /* If someone lowercases one million U+0130s we
3519 * SvGROW() one million times. Or we could try
3520 * guessing how much to allocate without allocating.
3521 * too much. Such is life. */
3523 d = (U8*)SvPVX(TARG) + o;
3525 Copy(tmpbuf, d, ulen, U8);
3531 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3537 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3539 SvUTF8_off(TARG); /* decontaminate */
3540 sv_setsv_nomg(TARG, sv);
3545 s = (U8*)SvPV_force_nomg(sv, len);
3547 register const U8 * const send = s + len;
3549 if (IN_LOCALE_RUNTIME) {
3552 for (; s < send; s++)
3553 *s = toLOWER_LC(*s);
3556 for (; s < send; s++)
3568 SV * const sv = TOPs;
3570 register const char *s = SvPV_const(sv,len);
3572 SvUTF8_off(TARG); /* decontaminate */
3575 SvUPGRADE(TARG, SVt_PV);
3576 SvGROW(TARG, (len * 2) + 1);
3580 if (UTF8_IS_CONTINUED(*s)) {
3581 STRLEN ulen = UTF8SKIP(s);
3605 SvCUR_set(TARG, d - SvPVX_const(TARG));
3606 (void)SvPOK_only_UTF8(TARG);
3609 sv_setpvn(TARG, s, len);
3611 if (SvSMAGICAL(TARG))
3620 dVAR; dSP; dMARK; dORIGMARK;
3621 register AV* const av = (AV*)POPs;
3622 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3624 if (SvTYPE(av) == SVt_PVAV) {
3625 const I32 arybase = PL_curcop->cop_arybase;
3626 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3629 for (svp = MARK + 1; svp <= SP; svp++) {
3630 const I32 elem = SvIVx(*svp);
3634 if (max > AvMAX(av))
3637 while (++MARK <= SP) {
3639 I32 elem = SvIVx(*MARK);
3643 svp = av_fetch(av, elem, lval);
3645 if (!svp || *svp == &PL_sv_undef)
3646 DIE(aTHX_ PL_no_aelem, elem);
3647 if (PL_op->op_private & OPpLVAL_INTRO)
3648 save_aelem(av, elem, svp);
3650 *MARK = svp ? *svp : &PL_sv_undef;
3653 if (GIMME != G_ARRAY) {
3655 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3661 /* Associative arrays. */
3667 HV * const hash = (HV*)POPs;
3669 const I32 gimme = GIMME_V;
3672 /* might clobber stack_sp */
3673 entry = hv_iternext(hash);
3678 SV* const sv = hv_iterkeysv(entry);
3679 PUSHs(sv); /* won't clobber stack_sp */
3680 if (gimme == G_ARRAY) {
3683 /* might clobber stack_sp */
3684 val = hv_iterval(hash, entry);
3689 else if (gimme == G_SCALAR)
3699 const I32 gimme = GIMME_V;
3700 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3702 if (PL_op->op_private & OPpSLICE) {
3704 HV * const hv = (HV*)POPs;
3705 const U32 hvtype = SvTYPE(hv);
3706 if (hvtype == SVt_PVHV) { /* hash element */
3707 while (++MARK <= SP) {
3708 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3709 *MARK = sv ? sv : &PL_sv_undef;
3712 else if (hvtype == SVt_PVAV) { /* array element */
3713 if (PL_op->op_flags & OPf_SPECIAL) {
3714 while (++MARK <= SP) {
3715 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3716 *MARK = sv ? sv : &PL_sv_undef;
3721 DIE(aTHX_ "Not a HASH reference");
3724 else if (gimme == G_SCALAR) {
3729 *++MARK = &PL_sv_undef;
3735 HV * const hv = (HV*)POPs;
3737 if (SvTYPE(hv) == SVt_PVHV)
3738 sv = hv_delete_ent(hv, keysv, discard, 0);
3739 else if (SvTYPE(hv) == SVt_PVAV) {
3740 if (PL_op->op_flags & OPf_SPECIAL)
3741 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3743 DIE(aTHX_ "panic: avhv_delete no longer supported");
3746 DIE(aTHX_ "Not a HASH reference");
3762 if (PL_op->op_private & OPpEXISTS_SUB) {
3764 SV * const sv = POPs;
3765 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3768 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3774 if (SvTYPE(hv) == SVt_PVHV) {
3775 if (hv_exists_ent(hv, tmpsv, 0))
3778 else if (SvTYPE(hv) == SVt_PVAV) {
3779 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3780 if (av_exists((AV*)hv, SvIV(tmpsv)))
3785 DIE(aTHX_ "Not a HASH reference");
3792 dVAR; dSP; dMARK; dORIGMARK;
3793 register HV * const hv = (HV*)POPs;
3794 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3795 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3796 bool other_magic = FALSE;
3802 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3803 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3804 /* Try to preserve the existenceness of a tied hash
3805 * element by using EXISTS and DELETE if possible.
3806 * Fallback to FETCH and STORE otherwise */
3807 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3808 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3809 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3812 while (++MARK <= SP) {
3813 SV * const keysv = *MARK;
3816 bool preeminent = FALSE;
3819 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3820 hv_exists_ent(hv, keysv, 0);
3823 he = hv_fetch_ent(hv, keysv, lval, 0);
3824 svp = he ? &HeVAL(he) : 0;
3827 if (!svp || *svp == &PL_sv_undef) {
3828 DIE(aTHX_ PL_no_helem_sv, keysv);
3832 save_helem(hv, keysv, svp);
3835 const char *key = SvPV_const(keysv, keylen);
3836 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3840 *MARK = svp ? *svp : &PL_sv_undef;
3842 if (GIMME != G_ARRAY) {
3844 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3850 /* List operators. */
3855 if (GIMME != G_ARRAY) {
3857 *MARK = *SP; /* unwanted list, return last item */
3859 *MARK = &PL_sv_undef;
3869 SV ** const lastrelem = PL_stack_sp;
3870 SV ** const lastlelem = PL_stack_base + POPMARK;
3871 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3872 register SV ** const firstrelem = lastlelem + 1;
3873 const I32 arybase = PL_curcop->cop_arybase;
3874 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3876 register const I32 max = lastrelem - lastlelem;
3877 register SV **lelem;
3879 if (GIMME != G_ARRAY) {
3880 I32 ix = SvIVx(*lastlelem);
3885 if (ix < 0 || ix >= max)
3886 *firstlelem = &PL_sv_undef;
3888 *firstlelem = firstrelem[ix];
3894 SP = firstlelem - 1;
3898 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3899 I32 ix = SvIVx(*lelem);
3904 if (ix < 0 || ix >= max)
3905 *lelem = &PL_sv_undef;
3907 is_something_there = TRUE;
3908 if (!(*lelem = firstrelem[ix]))
3909 *lelem = &PL_sv_undef;
3912 if (is_something_there)
3915 SP = firstlelem - 1;
3921 dVAR; dSP; dMARK; dORIGMARK;
3922 const I32 items = SP - MARK;
3923 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3924 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3931 dVAR; dSP; dMARK; dORIGMARK;
3932 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3935 SV * const key = *++MARK;
3936 SV * const val = newSV(0);
3938 sv_setsv(val, *++MARK);
3939 else if (ckWARN(WARN_MISC))
3940 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3941 (void)hv_store_ent(hv,key,val,0);
3950 dVAR; dSP; dMARK; dORIGMARK;
3951 register AV *ary = (AV*)*++MARK;
3955 register I32 offset;
3956 register I32 length;
3960 SV **tmparyval = NULL;
3961 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
3964 *MARK-- = SvTIED_obj((SV*)ary, mg);
3968 call_method("SPLICE",GIMME_V);
3977 offset = i = SvIVx(*MARK);
3979 offset += AvFILLp(ary) + 1;
3981 offset -= PL_curcop->cop_arybase;
3983 DIE(aTHX_ PL_no_aelem, i);
3985 length = SvIVx(*MARK++);
3987 length += AvFILLp(ary) - offset + 1;
3993 length = AvMAX(ary) + 1; /* close enough to infinity */
3997 length = AvMAX(ary) + 1;
3999 if (offset > AvFILLp(ary) + 1) {
4000 if (ckWARN(WARN_MISC))
4001 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4002 offset = AvFILLp(ary) + 1;
4004 after = AvFILLp(ary) + 1 - (offset + length);
4005 if (after < 0) { /* not that much array */
4006 length += after; /* offset+length now in array */
4012 /* At this point, MARK .. SP-1 is our new LIST */
4015 diff = newlen - length;
4016 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4019 /* make new elements SVs now: avoid problems if they're from the array */
4020 for (dst = MARK, i = newlen; i; i--) {
4021 SV * const h = *dst;
4022 *dst++ = newSVsv(h);
4025 if (diff < 0) { /* shrinking the area */
4027 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4028 Copy(MARK, tmparyval, newlen, SV*);
4031 MARK = ORIGMARK + 1;
4032 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4033 MEXTEND(MARK, length);
4034 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4036 EXTEND_MORTAL(length);
4037 for (i = length, dst = MARK; i; i--) {
4038 sv_2mortal(*dst); /* free them eventualy */
4045 *MARK = AvARRAY(ary)[offset+length-1];
4048 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4049 SvREFCNT_dec(*dst++); /* free them now */
4052 AvFILLp(ary) += diff;
4054 /* pull up or down? */
4056 if (offset < after) { /* easier to pull up */
4057 if (offset) { /* esp. if nothing to pull */
4058 src = &AvARRAY(ary)[offset-1];
4059 dst = src - diff; /* diff is negative */
4060 for (i = offset; i > 0; i--) /* can't trust Copy */
4064 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4068 if (after) { /* anything to pull down? */
4069 src = AvARRAY(ary) + offset + length;
4070 dst = src + diff; /* diff is negative */
4071 Move(src, dst, after, SV*);
4073 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4074 /* avoid later double free */
4078 dst[--i] = &PL_sv_undef;
4081 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4082 Safefree(tmparyval);
4085 else { /* no, expanding (or same) */
4087 Newx(tmparyval, length, SV*); /* so remember deletion */
4088 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4091 if (diff > 0) { /* expanding */
4093 /* push up or down? */
4095 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4099 Move(src, dst, offset, SV*);
4101 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4103 AvFILLp(ary) += diff;
4106 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4107 av_extend(ary, AvFILLp(ary) + diff);
4108 AvFILLp(ary) += diff;
4111 dst = AvARRAY(ary) + AvFILLp(ary);
4113 for (i = after; i; i--) {
4121 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4124 MARK = ORIGMARK + 1;
4125 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4127 Copy(tmparyval, MARK, length, SV*);
4129 EXTEND_MORTAL(length);
4130 for (i = length, dst = MARK; i; i--) {
4131 sv_2mortal(*dst); /* free them eventualy */
4135 Safefree(tmparyval);
4139 else if (length--) {
4140 *MARK = tmparyval[length];
4143 while (length-- > 0)
4144 SvREFCNT_dec(tmparyval[length]);
4146 Safefree(tmparyval);
4149 *MARK = &PL_sv_undef;
4157 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4158 register AV *ary = (AV*)*++MARK;
4159 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4162 *MARK-- = SvTIED_obj((SV*)ary, mg);
4166 call_method("PUSH",G_SCALAR|G_DISCARD);
4170 PUSHi( AvFILL(ary) + 1 );
4173 for (++MARK; MARK <= SP; MARK++) {
4174 SV * const sv = newSV(0);
4176 sv_setsv(sv, *MARK);
4177 av_store(ary, AvFILLp(ary)+1, sv);
4180 PUSHi( AvFILLp(ary) + 1 );
4189 AV * const av = (AV*)POPs;
4190 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4194 (void)sv_2mortal(sv);
4201 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4202 register AV *ary = (AV*)*++MARK;
4203 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4206 *MARK-- = SvTIED_obj((SV*)ary, mg);
4210 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4216 av_unshift(ary, SP - MARK);
4218 SV * const sv = newSVsv(*++MARK);
4219 (void)av_store(ary, i++, sv);
4223 PUSHi( AvFILL(ary) + 1 );
4230 SV ** const oldsp = SP;
4232 if (GIMME == G_ARRAY) {
4235 register SV * const tmp = *MARK;
4239 /* safe as long as stack cannot get extended in the above */
4244 register char *down;
4250 SvUTF8_off(TARG); /* decontaminate */
4252 do_join(TARG, &PL_sv_no, MARK, SP);
4254 sv_setsv(TARG, (SP > MARK)
4256 : (padoff_du = find_rundefsvoffset(),
4257 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4258 ? DEFSV : PAD_SVl(padoff_du)));
4259 up = SvPV_force(TARG, len);
4261 if (DO_UTF8(TARG)) { /* first reverse each character */
4262 U8* s = (U8*)SvPVX(TARG);
4263 const U8* send = (U8*)(s + len);
4265 if (UTF8_IS_INVARIANT(*s)) {
4270 if (!utf8_to_uvchr(s, 0))
4274 down = (char*)(s - 1);
4275 /* reverse this character */
4279 *down-- = (char)tmp;
4285 down = SvPVX(TARG) + len - 1;
4289 *down-- = (char)tmp;
4291 (void)SvPOK_only_UTF8(TARG);
4303 register IV limit = POPi; /* note, negative is forever */
4304 SV * const sv = POPs;
4306 register const char *s = SvPV_const(sv, len);
4307 const bool do_utf8 = DO_UTF8(sv);
4308 const char *strend = s + len;
4310 register REGEXP *rx;
4312 register const char *m;
4314 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4315 I32 maxiters = slen + 10;
4317 const I32 origlimit = limit;
4320 const I32 gimme = GIMME_V;
4321 const I32 oldsave = PL_savestack_ix;
4322 I32 make_mortal = 1;
4324 MAGIC *mg = (MAGIC *) NULL;
4327 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4332 DIE(aTHX_ "panic: pp_split");
4335 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4336 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4338 RX_MATCH_UTF8_set(rx, do_utf8);
4340 if (pm->op_pmreplroot) {
4342 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4344 ary = GvAVn((GV*)pm->op_pmreplroot);
4347 else if (gimme != G_ARRAY)
4348 ary = GvAVn(PL_defgv);
4351 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4357 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4359 XPUSHs(SvTIED_obj((SV*)ary, mg));
4366 for (i = AvFILLp(ary); i >= 0; i--)
4367 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4369 /* temporarily switch stacks */
4370 SAVESWITCHSTACK(PL_curstack, ary);
4374 base = SP - PL_stack_base;
4376 if (pm->op_pmflags & PMf_SKIPWHITE) {
4377 if (pm->op_pmflags & PMf_LOCALE) {
4378 while (isSPACE_LC(*s))
4386 if (pm->op_pmflags & PMf_MULTILINE) {
4391 limit = maxiters + 2;
4392 if (pm->op_pmflags & PMf_WHITE) {
4395 while (m < strend &&
4396 !((pm->op_pmflags & PMf_LOCALE)
4397 ? isSPACE_LC(*m) : isSPACE(*m)))
4402 dstr = newSVpvn(s, m-s);
4406 (void)SvUTF8_on(dstr);
4410 while (s < strend &&
4411 ((pm->op_pmflags & PMf_LOCALE)
4412 ? isSPACE_LC(*s) : isSPACE(*s)))
4416 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4418 for (m = s; m < strend && *m != '\n'; m++)
4423 dstr = newSVpvn(s, m-s);
4427 (void)SvUTF8_on(dstr);
4432 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4433 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4434 && (rx->reganch & ROPT_CHECK_ALL)
4435 && !(rx->reganch & ROPT_ANCH)) {
4436 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4437 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4440 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4441 const char c = *SvPV_nolen_const(csv);
4443 for (m = s; m < strend && *m != c; m++)
4447 dstr = newSVpvn(s, m-s);
4451 (void)SvUTF8_on(dstr);
4453 /* The rx->minlen is in characters but we want to step
4454 * s ahead by bytes. */
4456 s = (char*)utf8_hop((U8*)m, len);
4458 s = m + len; /* Fake \n at the end */
4462 while (s < strend && --limit &&
4463 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4464 csv, multiline ? FBMrf_MULTILINE : 0)) )
4466 dstr = newSVpvn(s, m-s);
4470 (void)SvUTF8_on(dstr);
4472 /* The rx->minlen is in characters but we want to step
4473 * s ahead by bytes. */
4475 s = (char*)utf8_hop((U8*)m, len);
4477 s = m + len; /* Fake \n at the end */
4482 maxiters += slen * rx->nparens;
4483 while (s < strend && --limit)
4487 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4490 if (rex_return == 0)
4492 TAINT_IF(RX_MATCH_TAINTED(rx));
4493 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4498 strend = s + (strend - m);
4500 m = rx->startp[0] + orig;
4501 dstr = newSVpvn(s, m-s);
4505 (void)SvUTF8_on(dstr);
4509 for (i = 1; i <= (I32)rx->nparens; i++) {
4510 s = rx->startp[i] + orig;
4511 m = rx->endp[i] + orig;
4513 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4514 parens that didn't match -- they should be set to
4515 undef, not the empty string */
4516 if (m >= orig && s >= orig) {
4517 dstr = newSVpvn(s, m-s);
4520 dstr = &PL_sv_undef; /* undef, not "" */
4524 (void)SvUTF8_on(dstr);
4528 s = rx->endp[0] + orig;
4532 iters = (SP - PL_stack_base) - base;
4533 if (iters > maxiters)
4534 DIE(aTHX_ "Split loop");
4536 /* keep field after final delim? */
4537 if (s < strend || (iters && origlimit)) {
4538 const STRLEN l = strend - s;
4539 dstr = newSVpvn(s, l);
4543 (void)SvUTF8_on(dstr);
4547 else if (!origlimit) {
4548 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4549 if (TOPs && !make_mortal)
4552 *SP-- = &PL_sv_undef;
4557 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4561 if (SvSMAGICAL(ary)) {
4566 if (gimme == G_ARRAY) {
4568 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4576 call_method("PUSH",G_SCALAR|G_DISCARD);
4579 if (gimme == G_ARRAY) {
4581 /* EXTEND should not be needed - we just popped them */
4583 for (i=0; i < iters; i++) {
4584 SV **svp = av_fetch(ary, i, FALSE);
4585 PUSHs((svp) ? *svp : &PL_sv_undef);
4592 if (gimme == G_ARRAY)
4608 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4609 || SvTYPE(retsv) == SVt_PVCV) {
4610 retsv = refto(retsv);
4617 PP(unimplemented_op)
4620 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4626 * c-indentation-style: bsd
4628 * indent-tabs-mode: t
4631 * ex: set ts=8 sts=4 sw=4 noet: