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");
2436 if (num == IV_MIN && value == -1)
2437 DIE(aTHX_ "Integer overflow in division");
2438 value = num / value;
2447 /* This is the vanilla old i_modulo. */
2448 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2452 DIE(aTHX_ "Illegal modulus zero");
2453 SETi( left % right );
2458 #if defined(__GLIBC__) && IVSIZE == 8
2462 /* This is the i_modulo with the workaround for the _moddi3 bug
2463 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2464 * See below for pp_i_modulo. */
2465 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2469 DIE(aTHX_ "Illegal modulus zero");
2470 SETi( left % PERL_ABS(right) );
2478 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2482 DIE(aTHX_ "Illegal modulus zero");
2483 /* The assumption is to use hereafter the old vanilla version... */
2485 PL_ppaddr[OP_I_MODULO] =
2487 /* .. but if we have glibc, we might have a buggy _moddi3
2488 * (at least glicb 2.2.5 is known to have this bug), in other
2489 * words our integer modulus with negative quad as the second
2490 * argument might be broken. Test for this and re-patch the
2491 * opcode dispatch table if that is the case, remembering to
2492 * also apply the workaround so that this first round works
2493 * right, too. See [perl #9402] for more information. */
2494 #if defined(__GLIBC__) && IVSIZE == 8
2498 /* Cannot do this check with inlined IV constants since
2499 * that seems to work correctly even with the buggy glibc. */
2501 /* Yikes, we have the bug.
2502 * Patch in the workaround version. */
2504 PL_ppaddr[OP_I_MODULO] =
2505 &Perl_pp_i_modulo_1;
2506 /* Make certain we work right this time, too. */
2507 right = PERL_ABS(right);
2511 SETi( left % right );
2518 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2521 SETi( left + right );
2528 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2531 SETi( left - right );
2538 dVAR; dSP; tryAMAGICbinSET(lt,0);
2541 SETs(boolSV(left < right));
2548 dVAR; dSP; tryAMAGICbinSET(gt,0);
2551 SETs(boolSV(left > right));
2558 dVAR; dSP; tryAMAGICbinSET(le,0);
2561 SETs(boolSV(left <= right));
2568 dVAR; dSP; tryAMAGICbinSET(ge,0);
2571 SETs(boolSV(left >= right));
2578 dVAR; dSP; tryAMAGICbinSET(eq,0);
2581 SETs(boolSV(left == right));
2588 dVAR; dSP; tryAMAGICbinSET(ne,0);
2591 SETs(boolSV(left != right));
2598 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2605 else if (left < right)
2616 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2621 /* High falutin' math. */
2625 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2628 SETn(Perl_atan2(left, right));
2636 int amg_type = sin_amg;
2637 const char *neg_report = NULL;
2638 NV (*func)(NV) = Perl_sin;
2639 const int op_type = PL_op->op_type;
2656 amg_type = sqrt_amg;
2658 neg_report = "sqrt";
2662 tryAMAGICun_var(amg_type);
2664 const NV value = POPn;
2666 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2667 SET_NUMERIC_STANDARD();
2668 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2671 XPUSHn(func(value));
2676 /* Support Configure command-line overrides for rand() functions.
2677 After 5.005, perhaps we should replace this by Configure support
2678 for drand48(), random(), or rand(). For 5.005, though, maintain
2679 compatibility by calling rand() but allow the user to override it.
2680 See INSTALL for details. --Andy Dougherty 15 July 1998
2682 /* Now it's after 5.005, and Configure supports drand48() and random(),
2683 in addition to rand(). So the overrides should not be needed any more.
2684 --Jarkko Hietaniemi 27 September 1998
2687 #ifndef HAS_DRAND48_PROTO
2688 extern double drand48 (void);
2701 if (!PL_srand_called) {
2702 (void)seedDrand01((Rand_seed_t)seed());
2703 PL_srand_called = TRUE;
2713 const UV anum = (MAXARG < 1) ? seed() : POPu;
2714 (void)seedDrand01((Rand_seed_t)anum);
2715 PL_srand_called = TRUE;
2722 dVAR; dSP; dTARGET; tryAMAGICun(int);
2724 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2725 /* XXX it's arguable that compiler casting to IV might be subtly
2726 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2727 else preferring IV has introduced a subtle behaviour change bug. OTOH
2728 relying on floating point to be accurate is a bug. */
2732 else if (SvIOK(TOPs)) {
2739 const NV value = TOPn;
2741 if (value < (NV)UV_MAX + 0.5) {
2744 SETn(Perl_floor(value));
2748 if (value > (NV)IV_MIN - 0.5) {
2751 SETn(Perl_ceil(value));
2761 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2763 /* This will cache the NV value if string isn't actually integer */
2768 else if (SvIOK(TOPs)) {
2769 /* IVX is precise */
2771 SETu(TOPu); /* force it to be numeric only */
2779 /* 2s complement assumption. Also, not really needed as
2780 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2786 const NV value = TOPn;
2800 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2804 SV* const sv = POPs;
2806 tmps = (SvPV_const(sv, len));
2808 /* If Unicode, try to downgrade
2809 * If not possible, croak. */
2810 SV* const tsv = sv_2mortal(newSVsv(sv));
2813 sv_utf8_downgrade(tsv, FALSE);
2814 tmps = SvPV_const(tsv, len);
2816 if (PL_op->op_type == OP_HEX)
2819 while (*tmps && len && isSPACE(*tmps))
2825 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2827 else if (*tmps == 'b')
2828 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2830 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2832 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2846 SV * const sv = TOPs;
2849 SETi(sv_len_utf8(sv));
2865 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2867 const I32 arybase = PL_curcop->cop_arybase;
2869 const char *repl = NULL;
2871 const int num_args = PL_op->op_private & 7;
2872 bool repl_need_utf8_upgrade = FALSE;
2873 bool repl_is_utf8 = FALSE;
2875 SvTAINTED_off(TARG); /* decontaminate */
2876 SvUTF8_off(TARG); /* decontaminate */
2880 repl = SvPV_const(repl_sv, repl_len);
2881 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2891 sv_utf8_upgrade(sv);
2893 else if (DO_UTF8(sv))
2894 repl_need_utf8_upgrade = TRUE;
2896 tmps = SvPV_const(sv, curlen);
2898 utf8_curlen = sv_len_utf8(sv);
2899 if (utf8_curlen == curlen)
2902 curlen = utf8_curlen;
2907 if (pos >= arybase) {
2925 else if (len >= 0) {
2927 if (rem > (I32)curlen)
2942 Perl_croak(aTHX_ "substr outside of string");
2943 if (ckWARN(WARN_SUBSTR))
2944 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2948 const I32 upos = pos;
2949 const I32 urem = rem;
2951 sv_pos_u2b(sv, &pos, &rem);
2953 /* we either return a PV or an LV. If the TARG hasn't been used
2954 * before, or is of that type, reuse it; otherwise use a mortal
2955 * instead. Note that LVs can have an extended lifetime, so also
2956 * dont reuse if refcount > 1 (bug #20933) */
2957 if (SvTYPE(TARG) > SVt_NULL) {
2958 if ( (SvTYPE(TARG) == SVt_PVLV)
2959 ? (!lvalue || SvREFCNT(TARG) > 1)
2962 TARG = sv_newmortal();
2966 sv_setpvn(TARG, tmps, rem);
2967 #ifdef USE_LOCALE_COLLATE
2968 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2973 SV* repl_sv_copy = NULL;
2975 if (repl_need_utf8_upgrade) {
2976 repl_sv_copy = newSVsv(repl_sv);
2977 sv_utf8_upgrade(repl_sv_copy);
2978 repl = SvPV_const(repl_sv_copy, repl_len);
2979 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2981 sv_insert(sv, pos, rem, repl, repl_len);
2985 SvREFCNT_dec(repl_sv_copy);
2987 else if (lvalue) { /* it's an lvalue! */
2988 if (!SvGMAGICAL(sv)) {
2990 SvPV_force_nolen(sv);
2991 if (ckWARN(WARN_SUBSTR))
2992 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
2993 "Attempt to use reference as lvalue in substr");
2995 if (SvOK(sv)) /* is it defined ? */
2996 (void)SvPOK_only_UTF8(sv);
2998 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3001 if (SvTYPE(TARG) < SVt_PVLV) {
3002 sv_upgrade(TARG, SVt_PVLV);
3003 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3009 if (LvTARG(TARG) != sv) {
3011 SvREFCNT_dec(LvTARG(TARG));
3012 LvTARG(TARG) = SvREFCNT_inc(sv);
3014 LvTARGOFF(TARG) = upos;
3015 LvTARGLEN(TARG) = urem;
3019 PUSHs(TARG); /* avoid SvSETMAGIC here */
3026 register const IV size = POPi;
3027 register const IV offset = POPi;
3028 register SV * const src = POPs;
3029 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3031 SvTAINTED_off(TARG); /* decontaminate */
3032 if (lvalue) { /* it's an lvalue! */
3033 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3034 TARG = sv_newmortal();
3035 if (SvTYPE(TARG) < SVt_PVLV) {
3036 sv_upgrade(TARG, SVt_PVLV);
3037 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3040 if (LvTARG(TARG) != src) {
3042 SvREFCNT_dec(LvTARG(TARG));
3043 LvTARG(TARG) = SvREFCNT_inc(src);
3045 LvTARGOFF(TARG) = offset;
3046 LvTARGLEN(TARG) = size;
3049 sv_setuv(TARG, do_vecget(src, offset, size));
3066 const I32 arybase = PL_curcop->cop_arybase;
3069 const bool is_index = PL_op->op_type == OP_INDEX;
3072 /* arybase is in characters, like offset, so combine prior to the
3073 UTF-8 to bytes calculation. */
3074 offset = POPi - arybase;
3078 big_utf8 = DO_UTF8(big);
3079 little_utf8 = DO_UTF8(little);
3080 if (big_utf8 ^ little_utf8) {
3081 /* One needs to be upgraded. */
3082 if (little_utf8 && !PL_encoding) {
3083 /* Well, maybe instead we might be able to downgrade the small
3086 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3087 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3090 /* If the large string is ISO-8859-1, and it's not possible to
3091 convert the small string to ISO-8859-1, then there is no
3092 way that it could be found anywhere by index. */
3097 /* At this point, pv is a malloc()ed string. So donate it to temp
3098 to ensure it will get free()d */
3099 little = temp = newSV(0);
3100 sv_usepvn(temp, pv, little_len);
3102 SV * const bytes = little_utf8 ? big : little;
3104 const char * const p = SvPV_const(bytes, len);
3106 temp = newSVpvn(p, len);
3109 sv_recode_to_utf8(temp, PL_encoding);
3111 sv_utf8_upgrade(temp);
3121 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3122 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3123 tmps = SvPV_const(big, biglen);
3126 offset = is_index ? 0 : biglen;
3128 if (big_utf8 && offset > 0)
3129 sv_pos_u2b(big, &offset, 0);
3134 else if (offset > (I32)biglen)
3136 if (!(tmps2 = is_index
3137 ? fbm_instr((unsigned char*)tmps + offset,
3138 (unsigned char*)tmps + biglen, little, 0)
3139 : rninstr(tmps, tmps + offset,
3140 tmps2, tmps2 + llen)))
3143 retval = tmps2 - tmps;
3144 if (retval > 0 && big_utf8)
3145 sv_pos_b2u(big, &retval);
3150 PUSHi(retval + arybase);
3156 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3157 do_sprintf(TARG, SP-MARK, MARK+1);
3158 TAINT_IF(SvTAINTED(TARG));
3169 const U8 *s = (U8*)SvPV_const(argsv, len);
3172 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3173 tmpsv = sv_2mortal(newSVsv(argsv));
3174 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3178 XPUSHu(DO_UTF8(argsv) ?
3179 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3191 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3193 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3195 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3197 (void) POPs; /* Ignore the argument value. */
3198 value = UNICODE_REPLACEMENT;
3204 SvUPGRADE(TARG,SVt_PV);
3206 if (value > 255 && !IN_BYTES) {
3207 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3208 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3209 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3211 (void)SvPOK_only(TARG);
3220 *tmps++ = (char)value;
3222 (void)SvPOK_only(TARG);
3223 if (PL_encoding && !IN_BYTES) {
3224 sv_recode_to_utf8(TARG, PL_encoding);
3226 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3227 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3231 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3232 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3247 const char *tmps = SvPV_const(left, len);
3249 if (DO_UTF8(left)) {
3250 /* If Unicode, try to downgrade.
3251 * If not possible, croak.
3252 * Yes, we made this up. */
3253 SV* const tsv = sv_2mortal(newSVsv(left));
3256 sv_utf8_downgrade(tsv, FALSE);
3257 tmps = SvPV_const(tsv, len);
3259 # ifdef USE_ITHREADS
3261 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3262 /* This should be threadsafe because in ithreads there is only
3263 * one thread per interpreter. If this would not be true,
3264 * we would need a mutex to protect this malloc. */
3265 PL_reentrant_buffer->_crypt_struct_buffer =
3266 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3267 #if defined(__GLIBC__) || defined(__EMX__)
3268 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3269 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3270 /* work around glibc-2.2.5 bug */
3271 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3275 # endif /* HAS_CRYPT_R */
3276 # endif /* USE_ITHREADS */
3278 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3280 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3286 "The crypt() function is unimplemented due to excessive paranoia.");
3297 const int op_type = PL_op->op_type;
3301 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3302 UTF8_IS_START(*s)) {
3303 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3307 utf8_to_uvchr(s, &ulen);
3308 if (op_type == OP_UCFIRST) {
3309 toTITLE_utf8(s, tmpbuf, &tculen);
3311 toLOWER_utf8(s, tmpbuf, &tculen);
3314 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3316 /* slen is the byte length of the whole SV.
3317 * ulen is the byte length of the original Unicode character
3318 * stored as UTF-8 at s.
3319 * tculen is the byte length of the freshly titlecased (or
3320 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3321 * We first set the result to be the titlecased (/lowercased)
3322 * character, and then append the rest of the SV data. */
3323 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3325 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3330 s = (U8*)SvPV_force_nomg(sv, slen);
3331 Copy(tmpbuf, s, tculen, U8);
3336 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3338 SvUTF8_off(TARG); /* decontaminate */
3339 sv_setsv_nomg(TARG, sv);
3343 s1 = (U8*)SvPV_force_nomg(sv, slen);
3345 if (IN_LOCALE_RUNTIME) {
3348 *s1 = (op_type == OP_UCFIRST)
3349 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3352 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3373 U8 tmpbuf[UTF8_MAXBYTES+1];
3375 s = (const U8*)SvPV_nomg_const(sv,len);
3377 SvUTF8_off(TARG); /* decontaminate */
3378 sv_setpvn(TARG, "", 0);
3382 STRLEN min = len + 1;
3384 SvUPGRADE(TARG, SVt_PV);
3386 (void)SvPOK_only(TARG);
3387 d = (U8*)SvPVX(TARG);
3390 STRLEN u = UTF8SKIP(s);
3392 toUPPER_utf8(s, tmpbuf, &ulen);
3393 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3394 /* If the eventually required minimum size outgrows
3395 * the available space, we need to grow. */
3396 const UV o = d - (U8*)SvPVX_const(TARG);
3398 /* If someone uppercases one million U+03B0s we
3399 * SvGROW() one million times. Or we could try
3400 * guessing how much to allocate without allocating
3401 * too much. Such is life. */
3403 d = (U8*)SvPVX(TARG) + o;
3405 Copy(tmpbuf, d, ulen, U8);
3411 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3417 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3419 SvUTF8_off(TARG); /* decontaminate */
3420 sv_setsv_nomg(TARG, sv);
3424 s = (U8*)SvPV_force_nomg(sv, len);
3426 register const U8 *send = s + len;
3428 if (IN_LOCALE_RUNTIME) {
3431 for (; s < send; s++)
3432 *s = toUPPER_LC(*s);
3435 for (; s < send; s++)
3458 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3460 s = (const U8*)SvPV_nomg_const(sv,len);
3462 SvUTF8_off(TARG); /* decontaminate */
3463 sv_setpvn(TARG, "", 0);
3467 STRLEN min = len + 1;
3469 SvUPGRADE(TARG, SVt_PV);
3471 (void)SvPOK_only(TARG);
3472 d = (U8*)SvPVX(TARG);
3475 const STRLEN u = UTF8SKIP(s);
3476 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3478 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3479 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3482 * Now if the sigma is NOT followed by
3483 * /$ignorable_sequence$cased_letter/;
3484 * and it IS preceded by
3485 * /$cased_letter$ignorable_sequence/;
3486 * where $ignorable_sequence is
3487 * [\x{2010}\x{AD}\p{Mn}]*
3488 * and $cased_letter is
3489 * [\p{Ll}\p{Lo}\p{Lt}]
3490 * then it should be mapped to 0x03C2,
3491 * (GREEK SMALL LETTER FINAL SIGMA),
3492 * instead of staying 0x03A3.
3493 * "should be": in other words,
3494 * this is not implemented yet.
3495 * See lib/unicore/SpecialCasing.txt.
3498 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3499 /* If the eventually required minimum size outgrows
3500 * the available space, we need to grow. */
3501 const UV o = d - (U8*)SvPVX_const(TARG);
3503 /* If someone lowercases one million U+0130s we
3504 * SvGROW() one million times. Or we could try
3505 * guessing how much to allocate without allocating.
3506 * too much. Such is life. */
3508 d = (U8*)SvPVX(TARG) + o;
3510 Copy(tmpbuf, d, ulen, U8);
3516 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3522 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3524 SvUTF8_off(TARG); /* decontaminate */
3525 sv_setsv_nomg(TARG, sv);
3530 s = (U8*)SvPV_force_nomg(sv, len);
3532 register const U8 * const send = s + len;
3534 if (IN_LOCALE_RUNTIME) {
3537 for (; s < send; s++)
3538 *s = toLOWER_LC(*s);
3541 for (; s < send; s++)
3553 SV * const sv = TOPs;
3555 register const char *s = SvPV_const(sv,len);
3557 SvUTF8_off(TARG); /* decontaminate */
3560 SvUPGRADE(TARG, SVt_PV);
3561 SvGROW(TARG, (len * 2) + 1);
3565 if (UTF8_IS_CONTINUED(*s)) {
3566 STRLEN ulen = UTF8SKIP(s);
3590 SvCUR_set(TARG, d - SvPVX_const(TARG));
3591 (void)SvPOK_only_UTF8(TARG);
3594 sv_setpvn(TARG, s, len);
3596 if (SvSMAGICAL(TARG))
3605 dVAR; dSP; dMARK; dORIGMARK;
3606 register AV* const av = (AV*)POPs;
3607 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3609 if (SvTYPE(av) == SVt_PVAV) {
3610 const I32 arybase = PL_curcop->cop_arybase;
3611 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3614 for (svp = MARK + 1; svp <= SP; svp++) {
3615 const I32 elem = SvIVx(*svp);
3619 if (max > AvMAX(av))
3622 while (++MARK <= SP) {
3624 I32 elem = SvIVx(*MARK);
3628 svp = av_fetch(av, elem, lval);
3630 if (!svp || *svp == &PL_sv_undef)
3631 DIE(aTHX_ PL_no_aelem, elem);
3632 if (PL_op->op_private & OPpLVAL_INTRO)
3633 save_aelem(av, elem, svp);
3635 *MARK = svp ? *svp : &PL_sv_undef;
3638 if (GIMME != G_ARRAY) {
3640 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3646 /* Associative arrays. */
3652 HV * const hash = (HV*)POPs;
3654 const I32 gimme = GIMME_V;
3657 /* might clobber stack_sp */
3658 entry = hv_iternext(hash);
3663 SV* const sv = hv_iterkeysv(entry);
3664 PUSHs(sv); /* won't clobber stack_sp */
3665 if (gimme == G_ARRAY) {
3668 /* might clobber stack_sp */
3669 val = hv_iterval(hash, entry);
3674 else if (gimme == G_SCALAR)
3684 const I32 gimme = GIMME_V;
3685 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3687 if (PL_op->op_private & OPpSLICE) {
3689 HV * const hv = (HV*)POPs;
3690 const U32 hvtype = SvTYPE(hv);
3691 if (hvtype == SVt_PVHV) { /* hash element */
3692 while (++MARK <= SP) {
3693 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3694 *MARK = sv ? sv : &PL_sv_undef;
3697 else if (hvtype == SVt_PVAV) { /* array element */
3698 if (PL_op->op_flags & OPf_SPECIAL) {
3699 while (++MARK <= SP) {
3700 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3701 *MARK = sv ? sv : &PL_sv_undef;
3706 DIE(aTHX_ "Not a HASH reference");
3709 else if (gimme == G_SCALAR) {
3714 *++MARK = &PL_sv_undef;
3720 HV * const hv = (HV*)POPs;
3722 if (SvTYPE(hv) == SVt_PVHV)
3723 sv = hv_delete_ent(hv, keysv, discard, 0);
3724 else if (SvTYPE(hv) == SVt_PVAV) {
3725 if (PL_op->op_flags & OPf_SPECIAL)
3726 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3728 DIE(aTHX_ "panic: avhv_delete no longer supported");
3731 DIE(aTHX_ "Not a HASH reference");
3747 if (PL_op->op_private & OPpEXISTS_SUB) {
3749 SV * const sv = POPs;
3750 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3753 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3759 if (SvTYPE(hv) == SVt_PVHV) {
3760 if (hv_exists_ent(hv, tmpsv, 0))
3763 else if (SvTYPE(hv) == SVt_PVAV) {
3764 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3765 if (av_exists((AV*)hv, SvIV(tmpsv)))
3770 DIE(aTHX_ "Not a HASH reference");
3777 dVAR; dSP; dMARK; dORIGMARK;
3778 register HV * const hv = (HV*)POPs;
3779 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3780 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3781 bool other_magic = FALSE;
3787 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3788 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3789 /* Try to preserve the existenceness of a tied hash
3790 * element by using EXISTS and DELETE if possible.
3791 * Fallback to FETCH and STORE otherwise */
3792 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3793 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3794 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3797 while (++MARK <= SP) {
3798 SV * const keysv = *MARK;
3801 bool preeminent = FALSE;
3804 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3805 hv_exists_ent(hv, keysv, 0);
3808 he = hv_fetch_ent(hv, keysv, lval, 0);
3809 svp = he ? &HeVAL(he) : 0;
3812 if (!svp || *svp == &PL_sv_undef) {
3813 DIE(aTHX_ PL_no_helem_sv, keysv);
3817 save_helem(hv, keysv, svp);
3820 const char *key = SvPV_const(keysv, keylen);
3821 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3825 *MARK = svp ? *svp : &PL_sv_undef;
3827 if (GIMME != G_ARRAY) {
3829 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3835 /* List operators. */
3840 if (GIMME != G_ARRAY) {
3842 *MARK = *SP; /* unwanted list, return last item */
3844 *MARK = &PL_sv_undef;
3854 SV ** const lastrelem = PL_stack_sp;
3855 SV ** const lastlelem = PL_stack_base + POPMARK;
3856 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3857 register SV ** const firstrelem = lastlelem + 1;
3858 const I32 arybase = PL_curcop->cop_arybase;
3859 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3861 register const I32 max = lastrelem - lastlelem;
3862 register SV **lelem;
3864 if (GIMME != G_ARRAY) {
3865 I32 ix = SvIVx(*lastlelem);
3870 if (ix < 0 || ix >= max)
3871 *firstlelem = &PL_sv_undef;
3873 *firstlelem = firstrelem[ix];
3879 SP = firstlelem - 1;
3883 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3884 I32 ix = SvIVx(*lelem);
3889 if (ix < 0 || ix >= max)
3890 *lelem = &PL_sv_undef;
3892 is_something_there = TRUE;
3893 if (!(*lelem = firstrelem[ix]))
3894 *lelem = &PL_sv_undef;
3897 if (is_something_there)
3900 SP = firstlelem - 1;
3906 dVAR; dSP; dMARK; dORIGMARK;
3907 const I32 items = SP - MARK;
3908 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3909 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3916 dVAR; dSP; dMARK; dORIGMARK;
3917 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3920 SV * const key = *++MARK;
3921 SV * const val = newSV(0);
3923 sv_setsv(val, *++MARK);
3924 else if (ckWARN(WARN_MISC))
3925 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3926 (void)hv_store_ent(hv,key,val,0);
3935 dVAR; dSP; dMARK; dORIGMARK;
3936 register AV *ary = (AV*)*++MARK;
3940 register I32 offset;
3941 register I32 length;
3945 SV **tmparyval = NULL;
3946 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
3949 *MARK-- = SvTIED_obj((SV*)ary, mg);
3953 call_method("SPLICE",GIMME_V);
3962 offset = i = SvIVx(*MARK);
3964 offset += AvFILLp(ary) + 1;
3966 offset -= PL_curcop->cop_arybase;
3968 DIE(aTHX_ PL_no_aelem, i);
3970 length = SvIVx(*MARK++);
3972 length += AvFILLp(ary) - offset + 1;
3978 length = AvMAX(ary) + 1; /* close enough to infinity */
3982 length = AvMAX(ary) + 1;
3984 if (offset > AvFILLp(ary) + 1) {
3985 if (ckWARN(WARN_MISC))
3986 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
3987 offset = AvFILLp(ary) + 1;
3989 after = AvFILLp(ary) + 1 - (offset + length);
3990 if (after < 0) { /* not that much array */
3991 length += after; /* offset+length now in array */
3997 /* At this point, MARK .. SP-1 is our new LIST */
4000 diff = newlen - length;
4001 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4004 /* make new elements SVs now: avoid problems if they're from the array */
4005 for (dst = MARK, i = newlen; i; i--) {
4006 SV * const h = *dst;
4007 *dst++ = newSVsv(h);
4010 if (diff < 0) { /* shrinking the area */
4012 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4013 Copy(MARK, tmparyval, newlen, SV*);
4016 MARK = ORIGMARK + 1;
4017 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4018 MEXTEND(MARK, length);
4019 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4021 EXTEND_MORTAL(length);
4022 for (i = length, dst = MARK; i; i--) {
4023 sv_2mortal(*dst); /* free them eventualy */
4030 *MARK = AvARRAY(ary)[offset+length-1];
4033 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4034 SvREFCNT_dec(*dst++); /* free them now */
4037 AvFILLp(ary) += diff;
4039 /* pull up or down? */
4041 if (offset < after) { /* easier to pull up */
4042 if (offset) { /* esp. if nothing to pull */
4043 src = &AvARRAY(ary)[offset-1];
4044 dst = src - diff; /* diff is negative */
4045 for (i = offset; i > 0; i--) /* can't trust Copy */
4049 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4053 if (after) { /* anything to pull down? */
4054 src = AvARRAY(ary) + offset + length;
4055 dst = src + diff; /* diff is negative */
4056 Move(src, dst, after, SV*);
4058 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4059 /* avoid later double free */
4063 dst[--i] = &PL_sv_undef;
4066 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4067 Safefree(tmparyval);
4070 else { /* no, expanding (or same) */
4072 Newx(tmparyval, length, SV*); /* so remember deletion */
4073 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4076 if (diff > 0) { /* expanding */
4078 /* push up or down? */
4080 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4084 Move(src, dst, offset, SV*);
4086 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4088 AvFILLp(ary) += diff;
4091 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4092 av_extend(ary, AvFILLp(ary) + diff);
4093 AvFILLp(ary) += diff;
4096 dst = AvARRAY(ary) + AvFILLp(ary);
4098 for (i = after; i; i--) {
4106 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4109 MARK = ORIGMARK + 1;
4110 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4112 Copy(tmparyval, MARK, length, SV*);
4114 EXTEND_MORTAL(length);
4115 for (i = length, dst = MARK; i; i--) {
4116 sv_2mortal(*dst); /* free them eventualy */
4120 Safefree(tmparyval);
4124 else if (length--) {
4125 *MARK = tmparyval[length];
4128 while (length-- > 0)
4129 SvREFCNT_dec(tmparyval[length]);
4131 Safefree(tmparyval);
4134 *MARK = &PL_sv_undef;
4142 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4143 register AV *ary = (AV*)*++MARK;
4144 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4147 *MARK-- = SvTIED_obj((SV*)ary, mg);
4151 call_method("PUSH",G_SCALAR|G_DISCARD);
4155 PUSHi( AvFILL(ary) + 1 );
4158 for (++MARK; MARK <= SP; MARK++) {
4159 SV * const sv = newSV(0);
4161 sv_setsv(sv, *MARK);
4162 av_store(ary, AvFILLp(ary)+1, sv);
4165 PUSHi( AvFILLp(ary) + 1 );
4174 AV * const av = (AV*)POPs;
4175 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4179 (void)sv_2mortal(sv);
4186 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4187 register AV *ary = (AV*)*++MARK;
4188 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4191 *MARK-- = SvTIED_obj((SV*)ary, mg);
4195 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4201 av_unshift(ary, SP - MARK);
4203 SV * const sv = newSVsv(*++MARK);
4204 (void)av_store(ary, i++, sv);
4208 PUSHi( AvFILL(ary) + 1 );
4215 SV ** const oldsp = SP;
4217 if (GIMME == G_ARRAY) {
4220 register SV * const tmp = *MARK;
4224 /* safe as long as stack cannot get extended in the above */
4229 register char *down;
4235 SvUTF8_off(TARG); /* decontaminate */
4237 do_join(TARG, &PL_sv_no, MARK, SP);
4239 sv_setsv(TARG, (SP > MARK)
4241 : (padoff_du = find_rundefsvoffset(),
4242 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4243 ? DEFSV : PAD_SVl(padoff_du)));
4244 up = SvPV_force(TARG, len);
4246 if (DO_UTF8(TARG)) { /* first reverse each character */
4247 U8* s = (U8*)SvPVX(TARG);
4248 const U8* send = (U8*)(s + len);
4250 if (UTF8_IS_INVARIANT(*s)) {
4255 if (!utf8_to_uvchr(s, 0))
4259 down = (char*)(s - 1);
4260 /* reverse this character */
4264 *down-- = (char)tmp;
4270 down = SvPVX(TARG) + len - 1;
4274 *down-- = (char)tmp;
4276 (void)SvPOK_only_UTF8(TARG);
4288 register IV limit = POPi; /* note, negative is forever */
4289 SV * const sv = POPs;
4291 register const char *s = SvPV_const(sv, len);
4292 const bool do_utf8 = DO_UTF8(sv);
4293 const char *strend = s + len;
4295 register REGEXP *rx;
4297 register const char *m;
4299 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4300 I32 maxiters = slen + 10;
4302 const I32 origlimit = limit;
4305 const I32 gimme = GIMME_V;
4306 const I32 oldsave = PL_savestack_ix;
4307 I32 make_mortal = 1;
4309 MAGIC *mg = (MAGIC *) NULL;
4312 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4317 DIE(aTHX_ "panic: pp_split");
4320 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4321 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4323 RX_MATCH_UTF8_set(rx, do_utf8);
4325 if (pm->op_pmreplroot) {
4327 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4329 ary = GvAVn((GV*)pm->op_pmreplroot);
4332 else if (gimme != G_ARRAY)
4333 ary = GvAVn(PL_defgv);
4336 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4342 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4344 XPUSHs(SvTIED_obj((SV*)ary, mg));
4351 for (i = AvFILLp(ary); i >= 0; i--)
4352 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4354 /* temporarily switch stacks */
4355 SAVESWITCHSTACK(PL_curstack, ary);
4359 base = SP - PL_stack_base;
4361 if (pm->op_pmflags & PMf_SKIPWHITE) {
4362 if (pm->op_pmflags & PMf_LOCALE) {
4363 while (isSPACE_LC(*s))
4371 if (pm->op_pmflags & PMf_MULTILINE) {
4376 limit = maxiters + 2;
4377 if (pm->op_pmflags & PMf_WHITE) {
4380 while (m < strend &&
4381 !((pm->op_pmflags & PMf_LOCALE)
4382 ? isSPACE_LC(*m) : isSPACE(*m)))
4387 dstr = newSVpvn(s, m-s);
4391 (void)SvUTF8_on(dstr);
4395 while (s < strend &&
4396 ((pm->op_pmflags & PMf_LOCALE)
4397 ? isSPACE_LC(*s) : isSPACE(*s)))
4401 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4403 for (m = s; m < strend && *m != '\n'; m++)
4408 dstr = newSVpvn(s, m-s);
4412 (void)SvUTF8_on(dstr);
4417 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4418 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4419 && (rx->reganch & ROPT_CHECK_ALL)
4420 && !(rx->reganch & ROPT_ANCH)) {
4421 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4422 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4425 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4426 const char c = *SvPV_nolen_const(csv);
4428 for (m = s; m < strend && *m != c; m++)
4432 dstr = newSVpvn(s, m-s);
4436 (void)SvUTF8_on(dstr);
4438 /* The rx->minlen is in characters but we want to step
4439 * s ahead by bytes. */
4441 s = (char*)utf8_hop((U8*)m, len);
4443 s = m + len; /* Fake \n at the end */
4447 while (s < strend && --limit &&
4448 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4449 csv, multiline ? FBMrf_MULTILINE : 0)) )
4451 dstr = newSVpvn(s, m-s);
4455 (void)SvUTF8_on(dstr);
4457 /* The rx->minlen is in characters but we want to step
4458 * s ahead by bytes. */
4460 s = (char*)utf8_hop((U8*)m, len);
4462 s = m + len; /* Fake \n at the end */
4467 maxiters += slen * rx->nparens;
4468 while (s < strend && --limit)
4472 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4475 if (rex_return == 0)
4477 TAINT_IF(RX_MATCH_TAINTED(rx));
4478 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4483 strend = s + (strend - m);
4485 m = rx->startp[0] + orig;
4486 dstr = newSVpvn(s, m-s);
4490 (void)SvUTF8_on(dstr);
4494 for (i = 1; i <= (I32)rx->nparens; i++) {
4495 s = rx->startp[i] + orig;
4496 m = rx->endp[i] + orig;
4498 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4499 parens that didn't match -- they should be set to
4500 undef, not the empty string */
4501 if (m >= orig && s >= orig) {
4502 dstr = newSVpvn(s, m-s);
4505 dstr = &PL_sv_undef; /* undef, not "" */
4509 (void)SvUTF8_on(dstr);
4513 s = rx->endp[0] + orig;
4517 iters = (SP - PL_stack_base) - base;
4518 if (iters > maxiters)
4519 DIE(aTHX_ "Split loop");
4521 /* keep field after final delim? */
4522 if (s < strend || (iters && origlimit)) {
4523 const STRLEN l = strend - s;
4524 dstr = newSVpvn(s, l);
4528 (void)SvUTF8_on(dstr);
4532 else if (!origlimit) {
4533 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4534 if (TOPs && !make_mortal)
4537 *SP-- = &PL_sv_undef;
4542 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4546 if (SvSMAGICAL(ary)) {
4551 if (gimme == G_ARRAY) {
4553 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4561 call_method("PUSH",G_SCALAR|G_DISCARD);
4564 if (gimme == G_ARRAY) {
4566 /* EXTEND should not be needed - we just popped them */
4568 for (i=0; i < iters; i++) {
4569 SV **svp = av_fetch(ary, i, FALSE);
4570 PUSHs((svp) ? *svp : &PL_sv_undef);
4577 if (gimme == G_ARRAY)
4593 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4594 || SvTYPE(retsv) == SVt_PVCV) {
4595 retsv = refto(retsv);
4602 PP(unimplemented_op)
4605 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4611 * c-indentation-style: bsd
4613 * indent-tabs-mode: t
4616 * ex: set ts=8 sts=4 sw=4 noet: