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) {
642 s = (unsigned char*)(SvPV(sv, len));
644 if (pos <= 0 || !SvPOK(sv)) {
645 /* No point in studying a zero length string, and not safe to study
646 anything that doesn't appear to be a simple scalar (and hence might
647 change between now and when the regexp engine runs without our set
648 magic ever running, such as a reference to an object with overloaded
654 SvSCREAM_off(PL_lastscream);
655 SvREFCNT_dec(PL_lastscream);
657 PL_lastscream = SvREFCNT_inc(sv);
659 s = (unsigned char*)(SvPV(sv, len));
663 if (pos > PL_maxscream) {
664 if (PL_maxscream < 0) {
665 PL_maxscream = pos + 80;
666 Newx(PL_screamfirst, 256, I32);
667 Newx(PL_screamnext, PL_maxscream, I32);
670 PL_maxscream = pos + pos / 4;
671 Renew(PL_screamnext, PL_maxscream, I32);
675 sfirst = PL_screamfirst;
676 snext = PL_screamnext;
678 if (!sfirst || !snext)
679 DIE(aTHX_ "do_study: out of memory");
681 for (ch = 256; ch; --ch)
686 register const I32 ch = s[pos];
688 snext[pos] = sfirst[ch] - pos;
695 /* piggyback on m//g magic */
696 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
705 if (PL_op->op_flags & OPf_STACKED)
707 else if (PL_op->op_private & OPpTARGET_MY)
713 TARG = sv_newmortal();
718 /* Lvalue operators. */
730 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
732 do_chop(TARG, *++MARK);
741 SETi(do_chomp(TOPs));
747 dVAR; dSP; dMARK; dTARGET;
748 register I32 count = 0;
751 count += do_chomp(POPs);
761 if (!PL_op->op_private) {
770 SV_CHECK_THINKFIRST_COW_DROP(sv);
772 switch (SvTYPE(sv)) {
782 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
783 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
784 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
788 /* let user-undef'd sub keep its identity */
789 GV* const gv = CvGV((CV*)sv);
796 SvSetMagicSV(sv, &PL_sv_undef);
801 GvGP(sv) = gp_ref(gp);
803 GvLINE(sv) = CopLINE(PL_curcop);
809 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
824 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
825 DIE(aTHX_ PL_no_modify);
826 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
827 && SvIVX(TOPs) != IV_MIN)
829 SvIV_set(TOPs, SvIVX(TOPs) - 1);
830 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
842 DIE(aTHX_ PL_no_modify);
843 sv_setsv(TARG, TOPs);
844 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
845 && SvIVX(TOPs) != IV_MAX)
847 SvIV_set(TOPs, SvIVX(TOPs) + 1);
848 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
853 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
863 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 sv_setsv(TARG, TOPs);
866 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
867 && SvIVX(TOPs) != IV_MIN)
869 SvIV_set(TOPs, SvIVX(TOPs) - 1);
870 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
879 /* Ordinary operators. */
884 #ifdef PERL_PRESERVE_IVUV
887 tryAMAGICbin(pow,opASSIGN);
888 #ifdef PERL_PRESERVE_IVUV
889 /* For integer to integer power, we do the calculation by hand wherever
890 we're sure it is safe; otherwise we call pow() and try to convert to
891 integer afterwards. */
904 const IV iv = SvIVX(TOPs);
908 goto float_it; /* Can't do negative powers this way. */
912 baseuok = SvUOK(TOPm1s);
914 baseuv = SvUVX(TOPm1s);
916 const IV iv = SvIVX(TOPm1s);
919 baseuok = TRUE; /* effectively it's a UV now */
921 baseuv = -iv; /* abs, baseuok == false records sign */
924 /* now we have integer ** positive integer. */
927 /* foo & (foo - 1) is zero only for a power of 2. */
928 if (!(baseuv & (baseuv - 1))) {
929 /* We are raising power-of-2 to a positive integer.
930 The logic here will work for any base (even non-integer
931 bases) but it can be less accurate than
932 pow (base,power) or exp (power * log (base)) when the
933 intermediate values start to spill out of the mantissa.
934 With powers of 2 we know this can't happen.
935 And powers of 2 are the favourite thing for perl
936 programmers to notice ** not doing what they mean. */
938 NV base = baseuok ? baseuv : -(NV)baseuv;
943 while (power >>= 1) {
954 register unsigned int highbit = 8 * sizeof(UV);
955 register unsigned int diff = 8 * sizeof(UV);
958 if (baseuv >> highbit) {
962 /* we now have baseuv < 2 ** highbit */
963 if (power * highbit <= 8 * sizeof(UV)) {
964 /* result will definitely fit in UV, so use UV math
965 on same algorithm as above */
966 register UV result = 1;
967 register UV base = baseuv;
968 const bool odd_power = (bool)(power & 1);
972 while (power >>= 1) {
979 if (baseuok || !odd_power)
980 /* answer is positive */
982 else if (result <= (UV)IV_MAX)
983 /* answer negative, fits in IV */
985 else if (result == (UV)IV_MIN)
986 /* 2's complement assumption: special case IV_MIN */
989 /* answer negative, doesn't fit */
1001 SETn( Perl_pow( left, right) );
1002 #ifdef PERL_PRESERVE_IVUV
1012 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1013 #ifdef PERL_PRESERVE_IVUV
1016 /* Unless the left argument is integer in range we are going to have to
1017 use NV maths. Hence only attempt to coerce the right argument if
1018 we know the left is integer. */
1019 /* Left operand is defined, so is it IV? */
1020 SvIV_please(TOPm1s);
1021 if (SvIOK(TOPm1s)) {
1022 bool auvok = SvUOK(TOPm1s);
1023 bool buvok = SvUOK(TOPs);
1024 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1025 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1032 alow = SvUVX(TOPm1s);
1034 const IV aiv = SvIVX(TOPm1s);
1037 auvok = TRUE; /* effectively it's a UV now */
1039 alow = -aiv; /* abs, auvok == false records sign */
1045 const IV biv = SvIVX(TOPs);
1048 buvok = TRUE; /* effectively it's a UV now */
1050 blow = -biv; /* abs, buvok == false records sign */
1054 /* If this does sign extension on unsigned it's time for plan B */
1055 ahigh = alow >> (4 * sizeof (UV));
1057 bhigh = blow >> (4 * sizeof (UV));
1059 if (ahigh && bhigh) {
1061 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1062 which is overflow. Drop to NVs below. */
1063 } else if (!ahigh && !bhigh) {
1064 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1065 so the unsigned multiply cannot overflow. */
1066 const UV product = alow * blow;
1067 if (auvok == buvok) {
1068 /* -ve * -ve or +ve * +ve gives a +ve result. */
1072 } else if (product <= (UV)IV_MIN) {
1073 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1074 /* -ve result, which could overflow an IV */
1076 SETi( -(IV)product );
1078 } /* else drop to NVs below. */
1080 /* One operand is large, 1 small */
1083 /* swap the operands */
1085 bhigh = blow; /* bhigh now the temp var for the swap */
1089 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1090 multiplies can't overflow. shift can, add can, -ve can. */
1091 product_middle = ahigh * blow;
1092 if (!(product_middle & topmask)) {
1093 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1095 product_middle <<= (4 * sizeof (UV));
1096 product_low = alow * blow;
1098 /* as for pp_add, UV + something mustn't get smaller.
1099 IIRC ANSI mandates this wrapping *behaviour* for
1100 unsigned whatever the actual representation*/
1101 product_low += product_middle;
1102 if (product_low >= product_middle) {
1103 /* didn't overflow */
1104 if (auvok == buvok) {
1105 /* -ve * -ve or +ve * +ve gives a +ve result. */
1107 SETu( product_low );
1109 } else if (product_low <= (UV)IV_MIN) {
1110 /* 2s complement assumption again */
1111 /* -ve result, which could overflow an IV */
1113 SETi( -(IV)product_low );
1115 } /* else drop to NVs below. */
1117 } /* product_middle too large */
1118 } /* ahigh && bhigh */
1119 } /* SvIOK(TOPm1s) */
1124 SETn( left * right );
1131 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1132 /* Only try to do UV divide first
1133 if ((SLOPPYDIVIDE is true) or
1134 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1136 The assumption is that it is better to use floating point divide
1137 whenever possible, only doing integer divide first if we can't be sure.
1138 If NV_PRESERVES_UV is true then we know at compile time that no UV
1139 can be too large to preserve, so don't need to compile the code to
1140 test the size of UVs. */
1143 # define PERL_TRY_UV_DIVIDE
1144 /* ensure that 20./5. == 4. */
1146 # ifdef PERL_PRESERVE_IVUV
1147 # ifndef NV_PRESERVES_UV
1148 # define PERL_TRY_UV_DIVIDE
1153 #ifdef PERL_TRY_UV_DIVIDE
1156 SvIV_please(TOPm1s);
1157 if (SvIOK(TOPm1s)) {
1158 bool left_non_neg = SvUOK(TOPm1s);
1159 bool right_non_neg = SvUOK(TOPs);
1163 if (right_non_neg) {
1164 right = SvUVX(TOPs);
1167 const IV biv = SvIVX(TOPs);
1170 right_non_neg = TRUE; /* effectively it's a UV now */
1176 /* historically undef()/0 gives a "Use of uninitialized value"
1177 warning before dieing, hence this test goes here.
1178 If it were immediately before the second SvIV_please, then
1179 DIE() would be invoked before left was even inspected, so
1180 no inpsection would give no warning. */
1182 DIE(aTHX_ "Illegal division by zero");
1185 left = SvUVX(TOPm1s);
1188 const IV aiv = SvIVX(TOPm1s);
1191 left_non_neg = TRUE; /* effectively it's a UV now */
1200 /* For sloppy divide we always attempt integer division. */
1202 /* Otherwise we only attempt it if either or both operands
1203 would not be preserved by an NV. If both fit in NVs
1204 we fall through to the NV divide code below. However,
1205 as left >= right to ensure integer result here, we know that
1206 we can skip the test on the right operand - right big
1207 enough not to be preserved can't get here unless left is
1210 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1213 /* Integer division can't overflow, but it can be imprecise. */
1214 const UV result = left / right;
1215 if (result * right == left) {
1216 SP--; /* result is valid */
1217 if (left_non_neg == right_non_neg) {
1218 /* signs identical, result is positive. */
1222 /* 2s complement assumption */
1223 if (result <= (UV)IV_MIN)
1224 SETi( -(IV)result );
1226 /* It's exact but too negative for IV. */
1227 SETn( -(NV)result );
1230 } /* tried integer divide but it was not an integer result */
1231 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1232 } /* left wasn't SvIOK */
1233 } /* right wasn't SvIOK */
1234 #endif /* PERL_TRY_UV_DIVIDE */
1238 DIE(aTHX_ "Illegal division by zero");
1239 PUSHn( left / right );
1246 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1250 bool left_neg = FALSE;
1251 bool right_neg = FALSE;
1252 bool use_double = FALSE;
1253 bool dright_valid = FALSE;
1259 right_neg = !SvUOK(TOPs);
1261 right = SvUVX(POPs);
1263 const IV biv = SvIVX(POPs);
1266 right_neg = FALSE; /* effectively it's a UV now */
1274 right_neg = dright < 0;
1277 if (dright < UV_MAX_P1) {
1278 right = U_V(dright);
1279 dright_valid = TRUE; /* In case we need to use double below. */
1285 /* At this point use_double is only true if right is out of range for
1286 a UV. In range NV has been rounded down to nearest UV and
1287 use_double false. */
1289 if (!use_double && SvIOK(TOPs)) {
1291 left_neg = !SvUOK(TOPs);
1295 const IV aiv = SvIVX(POPs);
1298 left_neg = FALSE; /* effectively it's a UV now */
1307 left_neg = dleft < 0;
1311 /* This should be exactly the 5.6 behaviour - if left and right are
1312 both in range for UV then use U_V() rather than floor. */
1314 if (dleft < UV_MAX_P1) {
1315 /* right was in range, so is dleft, so use UVs not double.
1319 /* left is out of range for UV, right was in range, so promote
1320 right (back) to double. */
1322 /* The +0.5 is used in 5.6 even though it is not strictly
1323 consistent with the implicit +0 floor in the U_V()
1324 inside the #if 1. */
1325 dleft = Perl_floor(dleft + 0.5);
1328 dright = Perl_floor(dright + 0.5);
1338 DIE(aTHX_ "Illegal modulus zero");
1340 dans = Perl_fmod(dleft, dright);
1341 if ((left_neg != right_neg) && dans)
1342 dans = dright - dans;
1345 sv_setnv(TARG, dans);
1351 DIE(aTHX_ "Illegal modulus zero");
1354 if ((left_neg != right_neg) && ans)
1357 /* XXX may warn: unary minus operator applied to unsigned type */
1358 /* could change -foo to be (~foo)+1 instead */
1359 if (ans <= ~((UV)IV_MAX)+1)
1360 sv_setiv(TARG, ~ans+1);
1362 sv_setnv(TARG, -(NV)ans);
1365 sv_setuv(TARG, ans);
1374 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1381 const UV uv = SvUV(sv);
1383 count = IV_MAX; /* The best we can do? */
1387 const IV iv = SvIV(sv);
1394 else if (SvNOKp(sv)) {
1395 const NV nv = SvNV(sv);
1403 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1405 static const char oom_list_extend[] = "Out of memory during list extend";
1406 const I32 items = SP - MARK;
1407 const I32 max = items * count;
1409 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1410 /* Did the max computation overflow? */
1411 if (items > 0 && max > 0 && (max < items || max < count))
1412 Perl_croak(aTHX_ oom_list_extend);
1417 /* This code was intended to fix 20010809.028:
1420 for (($x =~ /./g) x 2) {
1421 print chop; # "abcdabcd" expected as output.
1424 * but that change (#11635) broke this code:
1426 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1428 * I can't think of a better fix that doesn't introduce
1429 * an efficiency hit by copying the SVs. The stack isn't
1430 * refcounted, and mortalisation obviously doesn't
1431 * Do The Right Thing when the stack has more than
1432 * one pointer to the same mortal value.
1436 *SP = sv_2mortal(newSVsv(*SP));
1446 repeatcpy((char*)(MARK + items), (char*)MARK,
1447 items * sizeof(SV*), count - 1);
1450 else if (count <= 0)
1453 else { /* Note: mark already snarfed by pp_list */
1454 SV * const tmpstr = POPs;
1457 static const char oom_string_extend[] =
1458 "Out of memory during string extend";
1460 SvSetSV(TARG, tmpstr);
1461 SvPV_force(TARG, len);
1462 isutf = DO_UTF8(TARG);
1467 const STRLEN max = (UV)count * len;
1468 if (len > ((MEM_SIZE)~0)/count)
1469 Perl_croak(aTHX_ oom_string_extend);
1470 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1471 SvGROW(TARG, max + 1);
1472 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1473 SvCUR_set(TARG, SvCUR(TARG) * count);
1475 *SvEND(TARG) = '\0';
1478 (void)SvPOK_only_UTF8(TARG);
1480 (void)SvPOK_only(TARG);
1482 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1483 /* The parser saw this as a list repeat, and there
1484 are probably several items on the stack. But we're
1485 in scalar context, and there's no pp_list to save us
1486 now. So drop the rest of the items -- robin@kitsite.com
1499 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1500 useleft = USE_LEFT(TOPm1s);
1501 #ifdef PERL_PRESERVE_IVUV
1502 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1503 "bad things" happen if you rely on signed integers wrapping. */
1506 /* Unless the left argument is integer in range we are going to have to
1507 use NV maths. Hence only attempt to coerce the right argument if
1508 we know the left is integer. */
1509 register UV auv = 0;
1515 a_valid = auvok = 1;
1516 /* left operand is undef, treat as zero. */
1518 /* Left operand is defined, so is it IV? */
1519 SvIV_please(TOPm1s);
1520 if (SvIOK(TOPm1s)) {
1521 if ((auvok = SvUOK(TOPm1s)))
1522 auv = SvUVX(TOPm1s);
1524 register const IV aiv = SvIVX(TOPm1s);
1527 auvok = 1; /* Now acting as a sign flag. */
1528 } else { /* 2s complement assumption for IV_MIN */
1536 bool result_good = 0;
1539 bool buvok = SvUOK(TOPs);
1544 register const IV biv = SvIVX(TOPs);
1551 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1552 else "IV" now, independent of how it came in.
1553 if a, b represents positive, A, B negative, a maps to -A etc
1558 all UV maths. negate result if A negative.
1559 subtract if signs same, add if signs differ. */
1561 if (auvok ^ buvok) {
1570 /* Must get smaller */
1575 if (result <= buv) {
1576 /* result really should be -(auv-buv). as its negation
1577 of true value, need to swap our result flag */
1589 if (result <= (UV)IV_MIN)
1590 SETi( -(IV)result );
1592 /* result valid, but out of range for IV. */
1593 SETn( -(NV)result );
1597 } /* Overflow, drop through to NVs. */
1601 useleft = USE_LEFT(TOPm1s);
1605 /* left operand is undef, treat as zero - value */
1609 SETn( TOPn - value );
1616 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1618 const IV shift = POPi;
1619 if (PL_op->op_private & HINT_INTEGER) {
1633 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1635 const IV shift = POPi;
1636 if (PL_op->op_private & HINT_INTEGER) {
1650 dVAR; dSP; tryAMAGICbinSET(lt,0);
1651 #ifdef PERL_PRESERVE_IVUV
1654 SvIV_please(TOPm1s);
1655 if (SvIOK(TOPm1s)) {
1656 bool auvok = SvUOK(TOPm1s);
1657 bool buvok = SvUOK(TOPs);
1659 if (!auvok && !buvok) { /* ## IV < IV ## */
1660 const IV aiv = SvIVX(TOPm1s);
1661 const IV biv = SvIVX(TOPs);
1664 SETs(boolSV(aiv < biv));
1667 if (auvok && buvok) { /* ## UV < UV ## */
1668 const UV auv = SvUVX(TOPm1s);
1669 const UV buv = SvUVX(TOPs);
1672 SETs(boolSV(auv < buv));
1675 if (auvok) { /* ## UV < IV ## */
1677 const IV biv = SvIVX(TOPs);
1680 /* As (a) is a UV, it's >=0, so it cannot be < */
1685 SETs(boolSV(auv < (UV)biv));
1688 { /* ## IV < UV ## */
1689 const IV aiv = SvIVX(TOPm1s);
1693 /* As (b) is a UV, it's >=0, so it must be < */
1700 SETs(boolSV((UV)aiv < buv));
1706 #ifndef NV_PRESERVES_UV
1707 #ifdef PERL_PRESERVE_IVUV
1710 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1712 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1718 SETs(boolSV(TOPn < value));
1725 dVAR; dSP; tryAMAGICbinSET(gt,0);
1726 #ifdef PERL_PRESERVE_IVUV
1729 SvIV_please(TOPm1s);
1730 if (SvIOK(TOPm1s)) {
1731 bool auvok = SvUOK(TOPm1s);
1732 bool buvok = SvUOK(TOPs);
1734 if (!auvok && !buvok) { /* ## IV > IV ## */
1735 const IV aiv = SvIVX(TOPm1s);
1736 const IV biv = SvIVX(TOPs);
1739 SETs(boolSV(aiv > biv));
1742 if (auvok && buvok) { /* ## UV > UV ## */
1743 const UV auv = SvUVX(TOPm1s);
1744 const UV buv = SvUVX(TOPs);
1747 SETs(boolSV(auv > buv));
1750 if (auvok) { /* ## UV > IV ## */
1752 const IV biv = SvIVX(TOPs);
1756 /* As (a) is a UV, it's >=0, so it must be > */
1761 SETs(boolSV(auv > (UV)biv));
1764 { /* ## IV > UV ## */
1765 const IV aiv = SvIVX(TOPm1s);
1769 /* As (b) is a UV, it's >=0, so it cannot be > */
1776 SETs(boolSV((UV)aiv > buv));
1782 #ifndef NV_PRESERVES_UV
1783 #ifdef PERL_PRESERVE_IVUV
1786 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1788 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1794 SETs(boolSV(TOPn > value));
1801 dVAR; dSP; tryAMAGICbinSET(le,0);
1802 #ifdef PERL_PRESERVE_IVUV
1805 SvIV_please(TOPm1s);
1806 if (SvIOK(TOPm1s)) {
1807 bool auvok = SvUOK(TOPm1s);
1808 bool buvok = SvUOK(TOPs);
1810 if (!auvok && !buvok) { /* ## IV <= IV ## */
1811 const IV aiv = SvIVX(TOPm1s);
1812 const IV biv = SvIVX(TOPs);
1815 SETs(boolSV(aiv <= biv));
1818 if (auvok && buvok) { /* ## UV <= UV ## */
1819 UV auv = SvUVX(TOPm1s);
1820 UV buv = SvUVX(TOPs);
1823 SETs(boolSV(auv <= buv));
1826 if (auvok) { /* ## UV <= IV ## */
1828 const IV biv = SvIVX(TOPs);
1832 /* As (a) is a UV, it's >=0, so a cannot be <= */
1837 SETs(boolSV(auv <= (UV)biv));
1840 { /* ## IV <= UV ## */
1841 const IV aiv = SvIVX(TOPm1s);
1845 /* As (b) is a UV, it's >=0, so a must be <= */
1852 SETs(boolSV((UV)aiv <= buv));
1858 #ifndef NV_PRESERVES_UV
1859 #ifdef PERL_PRESERVE_IVUV
1862 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1864 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1870 SETs(boolSV(TOPn <= value));
1877 dVAR; dSP; tryAMAGICbinSET(ge,0);
1878 #ifdef PERL_PRESERVE_IVUV
1881 SvIV_please(TOPm1s);
1882 if (SvIOK(TOPm1s)) {
1883 bool auvok = SvUOK(TOPm1s);
1884 bool buvok = SvUOK(TOPs);
1886 if (!auvok && !buvok) { /* ## IV >= IV ## */
1887 const IV aiv = SvIVX(TOPm1s);
1888 const IV biv = SvIVX(TOPs);
1891 SETs(boolSV(aiv >= biv));
1894 if (auvok && buvok) { /* ## UV >= UV ## */
1895 const UV auv = SvUVX(TOPm1s);
1896 const UV buv = SvUVX(TOPs);
1899 SETs(boolSV(auv >= buv));
1902 if (auvok) { /* ## UV >= IV ## */
1904 const IV biv = SvIVX(TOPs);
1908 /* As (a) is a UV, it's >=0, so it must be >= */
1913 SETs(boolSV(auv >= (UV)biv));
1916 { /* ## IV >= UV ## */
1917 const IV aiv = SvIVX(TOPm1s);
1921 /* As (b) is a UV, it's >=0, so a cannot be >= */
1928 SETs(boolSV((UV)aiv >= buv));
1934 #ifndef NV_PRESERVES_UV
1935 #ifdef PERL_PRESERVE_IVUV
1938 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1940 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1946 SETs(boolSV(TOPn >= value));
1953 dVAR; dSP; tryAMAGICbinSET(ne,0);
1954 #ifndef NV_PRESERVES_UV
1955 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1957 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1961 #ifdef PERL_PRESERVE_IVUV
1964 SvIV_please(TOPm1s);
1965 if (SvIOK(TOPm1s)) {
1966 const bool auvok = SvUOK(TOPm1s);
1967 const bool buvok = SvUOK(TOPs);
1969 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1970 /* Casting IV to UV before comparison isn't going to matter
1971 on 2s complement. On 1s complement or sign&magnitude
1972 (if we have any of them) it could make negative zero
1973 differ from normal zero. As I understand it. (Need to
1974 check - is negative zero implementation defined behaviour
1976 const UV buv = SvUVX(POPs);
1977 const UV auv = SvUVX(TOPs);
1979 SETs(boolSV(auv != buv));
1982 { /* ## Mixed IV,UV ## */
1986 /* != is commutative so swap if needed (save code) */
1988 /* swap. top of stack (b) is the iv */
1992 /* As (a) is a UV, it's >0, so it cannot be == */
2001 /* As (b) is a UV, it's >0, so it cannot be == */
2005 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2007 SETs(boolSV((UV)iv != uv));
2015 SETs(boolSV(TOPn != value));
2022 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2023 #ifndef NV_PRESERVES_UV
2024 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2025 const UV right = PTR2UV(SvRV(POPs));
2026 const UV left = PTR2UV(SvRV(TOPs));
2027 SETi((left > right) - (left < right));
2031 #ifdef PERL_PRESERVE_IVUV
2032 /* Fortunately it seems NaN isn't IOK */
2035 SvIV_please(TOPm1s);
2036 if (SvIOK(TOPm1s)) {
2037 const bool leftuvok = SvUOK(TOPm1s);
2038 const bool rightuvok = SvUOK(TOPs);
2040 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2041 const IV leftiv = SvIVX(TOPm1s);
2042 const IV rightiv = SvIVX(TOPs);
2044 if (leftiv > rightiv)
2046 else if (leftiv < rightiv)
2050 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2051 const UV leftuv = SvUVX(TOPm1s);
2052 const UV rightuv = SvUVX(TOPs);
2054 if (leftuv > rightuv)
2056 else if (leftuv < rightuv)
2060 } else if (leftuvok) { /* ## UV <=> IV ## */
2061 const IV rightiv = SvIVX(TOPs);
2063 /* As (a) is a UV, it's >=0, so it cannot be < */
2066 const UV leftuv = SvUVX(TOPm1s);
2067 if (leftuv > (UV)rightiv) {
2069 } else if (leftuv < (UV)rightiv) {
2075 } else { /* ## IV <=> UV ## */
2076 const IV leftiv = SvIVX(TOPm1s);
2078 /* As (b) is a UV, it's >=0, so it must be < */
2081 const UV rightuv = SvUVX(TOPs);
2082 if ((UV)leftiv > rightuv) {
2084 } else if ((UV)leftiv < rightuv) {
2102 if (Perl_isnan(left) || Perl_isnan(right)) {
2106 value = (left > right) - (left < right);
2110 else if (left < right)
2112 else if (left > right)
2128 int amg_type = sle_amg;
2132 switch (PL_op->op_type) {
2151 tryAMAGICbinSET_var(amg_type,0);
2154 const int cmp = (IN_LOCALE_RUNTIME
2155 ? sv_cmp_locale(left, right)
2156 : sv_cmp(left, right));
2157 SETs(boolSV(cmp * multiplier < rhs));
2164 dVAR; dSP; tryAMAGICbinSET(seq,0);
2167 SETs(boolSV(sv_eq(left, right)));
2174 dVAR; dSP; tryAMAGICbinSET(sne,0);
2177 SETs(boolSV(!sv_eq(left, right)));
2184 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2187 const int cmp = (IN_LOCALE_RUNTIME
2188 ? sv_cmp_locale(left, right)
2189 : sv_cmp(left, right));
2197 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2202 if (SvNIOKp(left) || SvNIOKp(right)) {
2203 if (PL_op->op_private & HINT_INTEGER) {
2204 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2208 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2213 do_vop(PL_op->op_type, TARG, left, right);
2222 dVAR; dSP; dATARGET;
2223 const int op_type = PL_op->op_type;
2225 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2230 if (SvNIOKp(left) || SvNIOKp(right)) {
2231 if (PL_op->op_private & HINT_INTEGER) {
2232 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2233 const IV r = SvIV_nomg(right);
2234 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2238 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2239 const UV r = SvUV_nomg(right);
2240 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2245 do_vop(op_type, TARG, left, right);
2254 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2257 const int flags = SvFLAGS(sv);
2259 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2260 /* It's publicly an integer, or privately an integer-not-float */
2263 if (SvIVX(sv) == IV_MIN) {
2264 /* 2s complement assumption. */
2265 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2268 else if (SvUVX(sv) <= IV_MAX) {
2273 else if (SvIVX(sv) != IV_MIN) {
2277 #ifdef PERL_PRESERVE_IVUV
2286 else if (SvPOKp(sv)) {
2288 const char * const s = SvPV_const(sv, len);
2289 if (isIDFIRST(*s)) {
2290 sv_setpvn(TARG, "-", 1);
2293 else if (*s == '+' || *s == '-') {
2295 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2297 else if (DO_UTF8(sv)) {
2300 goto oops_its_an_int;
2302 sv_setnv(TARG, -SvNV(sv));
2304 sv_setpvn(TARG, "-", 1);
2311 goto oops_its_an_int;
2312 sv_setnv(TARG, -SvNV(sv));
2324 dVAR; dSP; tryAMAGICunSET(not);
2325 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2331 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2336 if (PL_op->op_private & HINT_INTEGER) {
2337 const IV i = ~SvIV_nomg(sv);
2341 const UV u = ~SvUV_nomg(sv);
2350 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2351 sv_setsv_nomg(TARG, sv);
2352 tmps = (U8*)SvPV_force(TARG, len);
2355 /* Calculate exact length, let's not estimate. */
2364 while (tmps < send) {
2365 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2366 tmps += UTF8SKIP(tmps);
2367 targlen += UNISKIP(~c);
2373 /* Now rewind strings and write them. */
2377 Newxz(result, targlen + 1, U8);
2378 while (tmps < send) {
2379 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2380 tmps += UTF8SKIP(tmps);
2381 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2385 sv_setpvn(TARG, (char*)result, targlen);
2389 Newxz(result, nchar + 1, U8);
2390 while (tmps < send) {
2391 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2392 tmps += UTF8SKIP(tmps);
2397 sv_setpvn(TARG, (char*)result, nchar);
2406 register long *tmpl;
2407 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2410 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2415 for ( ; anum > 0; anum--, tmps++)
2424 /* integer versions of some of the above */
2428 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2431 SETi( left * right );
2439 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2443 DIE(aTHX_ "Illegal division by zero");
2446 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2450 value = num / value;
2459 /* This is the vanilla old i_modulo. */
2460 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2464 DIE(aTHX_ "Illegal modulus zero");
2465 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2469 SETi( left % right );
2474 #if defined(__GLIBC__) && IVSIZE == 8
2478 /* This is the i_modulo with the workaround for the _moddi3 bug
2479 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2480 * See below for pp_i_modulo. */
2481 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2485 DIE(aTHX_ "Illegal modulus zero");
2486 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2490 SETi( left % PERL_ABS(right) );
2498 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2502 DIE(aTHX_ "Illegal modulus zero");
2503 /* The assumption is to use hereafter the old vanilla version... */
2505 PL_ppaddr[OP_I_MODULO] =
2507 /* .. but if we have glibc, we might have a buggy _moddi3
2508 * (at least glicb 2.2.5 is known to have this bug), in other
2509 * words our integer modulus with negative quad as the second
2510 * argument might be broken. Test for this and re-patch the
2511 * opcode dispatch table if that is the case, remembering to
2512 * also apply the workaround so that this first round works
2513 * right, too. See [perl #9402] for more information. */
2514 #if defined(__GLIBC__) && IVSIZE == 8
2518 /* Cannot do this check with inlined IV constants since
2519 * that seems to work correctly even with the buggy glibc. */
2521 /* Yikes, we have the bug.
2522 * Patch in the workaround version. */
2524 PL_ppaddr[OP_I_MODULO] =
2525 &Perl_pp_i_modulo_1;
2526 /* Make certain we work right this time, too. */
2527 right = PERL_ABS(right);
2531 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2535 SETi( left % right );
2542 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2545 SETi( left + right );
2552 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2555 SETi( left - right );
2562 dVAR; dSP; tryAMAGICbinSET(lt,0);
2565 SETs(boolSV(left < right));
2572 dVAR; dSP; tryAMAGICbinSET(gt,0);
2575 SETs(boolSV(left > right));
2582 dVAR; dSP; tryAMAGICbinSET(le,0);
2585 SETs(boolSV(left <= right));
2592 dVAR; dSP; tryAMAGICbinSET(ge,0);
2595 SETs(boolSV(left >= right));
2602 dVAR; dSP; tryAMAGICbinSET(eq,0);
2605 SETs(boolSV(left == right));
2612 dVAR; dSP; tryAMAGICbinSET(ne,0);
2615 SETs(boolSV(left != right));
2622 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2629 else if (left < right)
2640 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2645 /* High falutin' math. */
2649 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2652 SETn(Perl_atan2(left, right));
2660 int amg_type = sin_amg;
2661 const char *neg_report = NULL;
2662 NV (*func)(NV) = Perl_sin;
2663 const int op_type = PL_op->op_type;
2680 amg_type = sqrt_amg;
2682 neg_report = "sqrt";
2686 tryAMAGICun_var(amg_type);
2688 const NV value = POPn;
2690 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2691 SET_NUMERIC_STANDARD();
2692 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2695 XPUSHn(func(value));
2700 /* Support Configure command-line overrides for rand() functions.
2701 After 5.005, perhaps we should replace this by Configure support
2702 for drand48(), random(), or rand(). For 5.005, though, maintain
2703 compatibility by calling rand() but allow the user to override it.
2704 See INSTALL for details. --Andy Dougherty 15 July 1998
2706 /* Now it's after 5.005, and Configure supports drand48() and random(),
2707 in addition to rand(). So the overrides should not be needed any more.
2708 --Jarkko Hietaniemi 27 September 1998
2711 #ifndef HAS_DRAND48_PROTO
2712 extern double drand48 (void);
2725 if (!PL_srand_called) {
2726 (void)seedDrand01((Rand_seed_t)seed());
2727 PL_srand_called = TRUE;
2737 const UV anum = (MAXARG < 1) ? seed() : POPu;
2738 (void)seedDrand01((Rand_seed_t)anum);
2739 PL_srand_called = TRUE;
2746 dVAR; dSP; dTARGET; tryAMAGICun(int);
2748 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2749 /* XXX it's arguable that compiler casting to IV might be subtly
2750 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2751 else preferring IV has introduced a subtle behaviour change bug. OTOH
2752 relying on floating point to be accurate is a bug. */
2756 else if (SvIOK(TOPs)) {
2763 const NV value = TOPn;
2765 if (value < (NV)UV_MAX + 0.5) {
2768 SETn(Perl_floor(value));
2772 if (value > (NV)IV_MIN - 0.5) {
2775 SETn(Perl_ceil(value));
2785 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2787 /* This will cache the NV value if string isn't actually integer */
2792 else if (SvIOK(TOPs)) {
2793 /* IVX is precise */
2795 SETu(TOPu); /* force it to be numeric only */
2803 /* 2s complement assumption. Also, not really needed as
2804 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2810 const NV value = TOPn;
2824 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2828 SV* const sv = POPs;
2830 tmps = (SvPV_const(sv, len));
2832 /* If Unicode, try to downgrade
2833 * If not possible, croak. */
2834 SV* const tsv = sv_2mortal(newSVsv(sv));
2837 sv_utf8_downgrade(tsv, FALSE);
2838 tmps = SvPV_const(tsv, len);
2840 if (PL_op->op_type == OP_HEX)
2843 while (*tmps && len && isSPACE(*tmps))
2849 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2851 else if (*tmps == 'b')
2852 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2854 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2856 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2870 SV * const sv = TOPs;
2873 SETi(sv_len_utf8(sv));
2889 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2891 const I32 arybase = PL_curcop->cop_arybase;
2893 const char *repl = NULL;
2895 const int num_args = PL_op->op_private & 7;
2896 bool repl_need_utf8_upgrade = FALSE;
2897 bool repl_is_utf8 = FALSE;
2899 SvTAINTED_off(TARG); /* decontaminate */
2900 SvUTF8_off(TARG); /* decontaminate */
2904 repl = SvPV_const(repl_sv, repl_len);
2905 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2915 sv_utf8_upgrade(sv);
2917 else if (DO_UTF8(sv))
2918 repl_need_utf8_upgrade = TRUE;
2920 tmps = SvPV_const(sv, curlen);
2922 utf8_curlen = sv_len_utf8(sv);
2923 if (utf8_curlen == curlen)
2926 curlen = utf8_curlen;
2931 if (pos >= arybase) {
2949 else if (len >= 0) {
2951 if (rem > (I32)curlen)
2966 Perl_croak(aTHX_ "substr outside of string");
2967 if (ckWARN(WARN_SUBSTR))
2968 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2972 const I32 upos = pos;
2973 const I32 urem = rem;
2975 sv_pos_u2b(sv, &pos, &rem);
2977 /* we either return a PV or an LV. If the TARG hasn't been used
2978 * before, or is of that type, reuse it; otherwise use a mortal
2979 * instead. Note that LVs can have an extended lifetime, so also
2980 * dont reuse if refcount > 1 (bug #20933) */
2981 if (SvTYPE(TARG) > SVt_NULL) {
2982 if ( (SvTYPE(TARG) == SVt_PVLV)
2983 ? (!lvalue || SvREFCNT(TARG) > 1)
2986 TARG = sv_newmortal();
2990 sv_setpvn(TARG, tmps, rem);
2991 #ifdef USE_LOCALE_COLLATE
2992 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2997 SV* repl_sv_copy = NULL;
2999 if (repl_need_utf8_upgrade) {
3000 repl_sv_copy = newSVsv(repl_sv);
3001 sv_utf8_upgrade(repl_sv_copy);
3002 repl = SvPV_const(repl_sv_copy, repl_len);
3003 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3005 sv_insert(sv, pos, rem, repl, repl_len);
3009 SvREFCNT_dec(repl_sv_copy);
3011 else if (lvalue) { /* it's an lvalue! */
3012 if (!SvGMAGICAL(sv)) {
3014 SvPV_force_nolen(sv);
3015 if (ckWARN(WARN_SUBSTR))
3016 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3017 "Attempt to use reference as lvalue in substr");
3019 if (SvOK(sv)) /* is it defined ? */
3020 (void)SvPOK_only_UTF8(sv);
3022 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3025 if (SvTYPE(TARG) < SVt_PVLV) {
3026 sv_upgrade(TARG, SVt_PVLV);
3027 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3033 if (LvTARG(TARG) != sv) {
3035 SvREFCNT_dec(LvTARG(TARG));
3036 LvTARG(TARG) = SvREFCNT_inc(sv);
3038 LvTARGOFF(TARG) = upos;
3039 LvTARGLEN(TARG) = urem;
3043 PUSHs(TARG); /* avoid SvSETMAGIC here */
3050 register const IV size = POPi;
3051 register const IV offset = POPi;
3052 register SV * const src = POPs;
3053 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3055 SvTAINTED_off(TARG); /* decontaminate */
3056 if (lvalue) { /* it's an lvalue! */
3057 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3058 TARG = sv_newmortal();
3059 if (SvTYPE(TARG) < SVt_PVLV) {
3060 sv_upgrade(TARG, SVt_PVLV);
3061 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3064 if (LvTARG(TARG) != src) {
3066 SvREFCNT_dec(LvTARG(TARG));
3067 LvTARG(TARG) = SvREFCNT_inc(src);
3069 LvTARGOFF(TARG) = offset;
3070 LvTARGLEN(TARG) = size;
3073 sv_setuv(TARG, do_vecget(src, offset, size));
3090 const I32 arybase = PL_curcop->cop_arybase;
3093 const bool is_index = PL_op->op_type == OP_INDEX;
3096 /* arybase is in characters, like offset, so combine prior to the
3097 UTF-8 to bytes calculation. */
3098 offset = POPi - arybase;
3102 big_utf8 = DO_UTF8(big);
3103 little_utf8 = DO_UTF8(little);
3104 if (big_utf8 ^ little_utf8) {
3105 /* One needs to be upgraded. */
3106 if (little_utf8 && !PL_encoding) {
3107 /* Well, maybe instead we might be able to downgrade the small
3110 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3111 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3114 /* If the large string is ISO-8859-1, and it's not possible to
3115 convert the small string to ISO-8859-1, then there is no
3116 way that it could be found anywhere by index. */
3121 /* At this point, pv is a malloc()ed string. So donate it to temp
3122 to ensure it will get free()d */
3123 little = temp = newSV(0);
3124 sv_usepvn(temp, pv, little_len);
3126 SV * const bytes = little_utf8 ? big : little;
3128 const char * const p = SvPV_const(bytes, len);
3130 temp = newSVpvn(p, len);
3133 sv_recode_to_utf8(temp, PL_encoding);
3135 sv_utf8_upgrade(temp);
3145 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3146 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3147 tmps = SvPV_const(big, biglen);
3150 offset = is_index ? 0 : biglen;
3152 if (big_utf8 && offset > 0)
3153 sv_pos_u2b(big, &offset, 0);
3158 else if (offset > (I32)biglen)
3160 if (!(tmps2 = is_index
3161 ? fbm_instr((unsigned char*)tmps + offset,
3162 (unsigned char*)tmps + biglen, little, 0)
3163 : rninstr(tmps, tmps + offset,
3164 tmps2, tmps2 + llen)))
3167 retval = tmps2 - tmps;
3168 if (retval > 0 && big_utf8)
3169 sv_pos_b2u(big, &retval);
3174 PUSHi(retval + arybase);
3180 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3181 do_sprintf(TARG, SP-MARK, MARK+1);
3182 TAINT_IF(SvTAINTED(TARG));
3193 const U8 *s = (U8*)SvPV_const(argsv, len);
3196 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3197 tmpsv = sv_2mortal(newSVsv(argsv));
3198 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3202 XPUSHu(DO_UTF8(argsv) ?
3203 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3215 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3217 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3219 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3221 (void) POPs; /* Ignore the argument value. */
3222 value = UNICODE_REPLACEMENT;
3228 SvUPGRADE(TARG,SVt_PV);
3230 if (value > 255 && !IN_BYTES) {
3231 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3232 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3233 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3235 (void)SvPOK_only(TARG);
3244 *tmps++ = (char)value;
3246 (void)SvPOK_only(TARG);
3247 if (PL_encoding && !IN_BYTES) {
3248 sv_recode_to_utf8(TARG, PL_encoding);
3250 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3251 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3255 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3256 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3271 const char *tmps = SvPV_const(left, len);
3273 if (DO_UTF8(left)) {
3274 /* If Unicode, try to downgrade.
3275 * If not possible, croak.
3276 * Yes, we made this up. */
3277 SV* const tsv = sv_2mortal(newSVsv(left));
3280 sv_utf8_downgrade(tsv, FALSE);
3281 tmps = SvPV_const(tsv, len);
3283 # ifdef USE_ITHREADS
3285 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3286 /* This should be threadsafe because in ithreads there is only
3287 * one thread per interpreter. If this would not be true,
3288 * we would need a mutex to protect this malloc. */
3289 PL_reentrant_buffer->_crypt_struct_buffer =
3290 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3291 #if defined(__GLIBC__) || defined(__EMX__)
3292 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3293 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3294 /* work around glibc-2.2.5 bug */
3295 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3299 # endif /* HAS_CRYPT_R */
3300 # endif /* USE_ITHREADS */
3302 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3304 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3310 "The crypt() function is unimplemented due to excessive paranoia.");
3321 const int op_type = PL_op->op_type;
3325 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3326 UTF8_IS_START(*s)) {
3327 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3331 utf8_to_uvchr(s, &ulen);
3332 if (op_type == OP_UCFIRST) {
3333 toTITLE_utf8(s, tmpbuf, &tculen);
3335 toLOWER_utf8(s, tmpbuf, &tculen);
3338 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3340 /* slen is the byte length of the whole SV.
3341 * ulen is the byte length of the original Unicode character
3342 * stored as UTF-8 at s.
3343 * tculen is the byte length of the freshly titlecased (or
3344 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3345 * We first set the result to be the titlecased (/lowercased)
3346 * character, and then append the rest of the SV data. */
3347 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3349 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3354 s = (U8*)SvPV_force_nomg(sv, slen);
3355 Copy(tmpbuf, s, tculen, U8);
3360 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3362 SvUTF8_off(TARG); /* decontaminate */
3363 sv_setsv_nomg(TARG, sv);
3367 s1 = (U8*)SvPV_force_nomg(sv, slen);
3369 if (IN_LOCALE_RUNTIME) {
3372 *s1 = (op_type == OP_UCFIRST)
3373 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3376 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3397 U8 tmpbuf[UTF8_MAXBYTES+1];
3399 s = (const U8*)SvPV_nomg_const(sv,len);
3401 SvUTF8_off(TARG); /* decontaminate */
3402 sv_setpvn(TARG, "", 0);
3406 STRLEN min = len + 1;
3408 SvUPGRADE(TARG, SVt_PV);
3410 (void)SvPOK_only(TARG);
3411 d = (U8*)SvPVX(TARG);
3414 STRLEN u = UTF8SKIP(s);
3416 toUPPER_utf8(s, tmpbuf, &ulen);
3417 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3418 /* If the eventually required minimum size outgrows
3419 * the available space, we need to grow. */
3420 const UV o = d - (U8*)SvPVX_const(TARG);
3422 /* If someone uppercases one million U+03B0s we
3423 * SvGROW() one million times. Or we could try
3424 * guessing how much to allocate without allocating
3425 * too much. Such is life. */
3427 d = (U8*)SvPVX(TARG) + o;
3429 Copy(tmpbuf, d, ulen, U8);
3435 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3441 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3443 SvUTF8_off(TARG); /* decontaminate */
3444 sv_setsv_nomg(TARG, sv);
3448 s = (U8*)SvPV_force_nomg(sv, len);
3450 register const U8 *send = s + len;
3452 if (IN_LOCALE_RUNTIME) {
3455 for (; s < send; s++)
3456 *s = toUPPER_LC(*s);
3459 for (; s < send; s++)
3482 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3484 s = (const U8*)SvPV_nomg_const(sv,len);
3486 SvUTF8_off(TARG); /* decontaminate */
3487 sv_setpvn(TARG, "", 0);
3491 STRLEN min = len + 1;
3493 SvUPGRADE(TARG, SVt_PV);
3495 (void)SvPOK_only(TARG);
3496 d = (U8*)SvPVX(TARG);
3499 const STRLEN u = UTF8SKIP(s);
3500 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3502 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3503 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3506 * Now if the sigma is NOT followed by
3507 * /$ignorable_sequence$cased_letter/;
3508 * and it IS preceded by
3509 * /$cased_letter$ignorable_sequence/;
3510 * where $ignorable_sequence is
3511 * [\x{2010}\x{AD}\p{Mn}]*
3512 * and $cased_letter is
3513 * [\p{Ll}\p{Lo}\p{Lt}]
3514 * then it should be mapped to 0x03C2,
3515 * (GREEK SMALL LETTER FINAL SIGMA),
3516 * instead of staying 0x03A3.
3517 * "should be": in other words,
3518 * this is not implemented yet.
3519 * See lib/unicore/SpecialCasing.txt.
3522 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3523 /* If the eventually required minimum size outgrows
3524 * the available space, we need to grow. */
3525 const UV o = d - (U8*)SvPVX_const(TARG);
3527 /* If someone lowercases one million U+0130s we
3528 * SvGROW() one million times. Or we could try
3529 * guessing how much to allocate without allocating.
3530 * too much. Such is life. */
3532 d = (U8*)SvPVX(TARG) + o;
3534 Copy(tmpbuf, d, ulen, U8);
3540 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3546 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3548 SvUTF8_off(TARG); /* decontaminate */
3549 sv_setsv_nomg(TARG, sv);
3554 s = (U8*)SvPV_force_nomg(sv, len);
3556 register const U8 * const send = s + len;
3558 if (IN_LOCALE_RUNTIME) {
3561 for (; s < send; s++)
3562 *s = toLOWER_LC(*s);
3565 for (; s < send; s++)
3577 SV * const sv = TOPs;
3579 register const char *s = SvPV_const(sv,len);
3581 SvUTF8_off(TARG); /* decontaminate */
3584 SvUPGRADE(TARG, SVt_PV);
3585 SvGROW(TARG, (len * 2) + 1);
3589 if (UTF8_IS_CONTINUED(*s)) {
3590 STRLEN ulen = UTF8SKIP(s);
3614 SvCUR_set(TARG, d - SvPVX_const(TARG));
3615 (void)SvPOK_only_UTF8(TARG);
3618 sv_setpvn(TARG, s, len);
3620 if (SvSMAGICAL(TARG))
3629 dVAR; dSP; dMARK; dORIGMARK;
3630 register AV* const av = (AV*)POPs;
3631 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3633 if (SvTYPE(av) == SVt_PVAV) {
3634 const I32 arybase = PL_curcop->cop_arybase;
3635 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3638 for (svp = MARK + 1; svp <= SP; svp++) {
3639 const I32 elem = SvIVx(*svp);
3643 if (max > AvMAX(av))
3646 while (++MARK <= SP) {
3648 I32 elem = SvIVx(*MARK);
3652 svp = av_fetch(av, elem, lval);
3654 if (!svp || *svp == &PL_sv_undef)
3655 DIE(aTHX_ PL_no_aelem, elem);
3656 if (PL_op->op_private & OPpLVAL_INTRO)
3657 save_aelem(av, elem, svp);
3659 *MARK = svp ? *svp : &PL_sv_undef;
3662 if (GIMME != G_ARRAY) {
3664 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3670 /* Associative arrays. */
3676 HV * const hash = (HV*)POPs;
3678 const I32 gimme = GIMME_V;
3681 /* might clobber stack_sp */
3682 entry = hv_iternext(hash);
3687 SV* const sv = hv_iterkeysv(entry);
3688 PUSHs(sv); /* won't clobber stack_sp */
3689 if (gimme == G_ARRAY) {
3692 /* might clobber stack_sp */
3693 val = hv_iterval(hash, entry);
3698 else if (gimme == G_SCALAR)
3708 const I32 gimme = GIMME_V;
3709 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3711 if (PL_op->op_private & OPpSLICE) {
3713 HV * const hv = (HV*)POPs;
3714 const U32 hvtype = SvTYPE(hv);
3715 if (hvtype == SVt_PVHV) { /* hash element */
3716 while (++MARK <= SP) {
3717 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3718 *MARK = sv ? sv : &PL_sv_undef;
3721 else if (hvtype == SVt_PVAV) { /* array element */
3722 if (PL_op->op_flags & OPf_SPECIAL) {
3723 while (++MARK <= SP) {
3724 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3725 *MARK = sv ? sv : &PL_sv_undef;
3730 DIE(aTHX_ "Not a HASH reference");
3733 else if (gimme == G_SCALAR) {
3738 *++MARK = &PL_sv_undef;
3744 HV * const hv = (HV*)POPs;
3746 if (SvTYPE(hv) == SVt_PVHV)
3747 sv = hv_delete_ent(hv, keysv, discard, 0);
3748 else if (SvTYPE(hv) == SVt_PVAV) {
3749 if (PL_op->op_flags & OPf_SPECIAL)
3750 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3752 DIE(aTHX_ "panic: avhv_delete no longer supported");
3755 DIE(aTHX_ "Not a HASH reference");
3771 if (PL_op->op_private & OPpEXISTS_SUB) {
3773 SV * const sv = POPs;
3774 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3777 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3783 if (SvTYPE(hv) == SVt_PVHV) {
3784 if (hv_exists_ent(hv, tmpsv, 0))
3787 else if (SvTYPE(hv) == SVt_PVAV) {
3788 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3789 if (av_exists((AV*)hv, SvIV(tmpsv)))
3794 DIE(aTHX_ "Not a HASH reference");
3801 dVAR; dSP; dMARK; dORIGMARK;
3802 register HV * const hv = (HV*)POPs;
3803 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3804 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3805 bool other_magic = FALSE;
3811 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3812 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3813 /* Try to preserve the existenceness of a tied hash
3814 * element by using EXISTS and DELETE if possible.
3815 * Fallback to FETCH and STORE otherwise */
3816 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3817 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3818 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3821 while (++MARK <= SP) {
3822 SV * const keysv = *MARK;
3825 bool preeminent = FALSE;
3828 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3829 hv_exists_ent(hv, keysv, 0);
3832 he = hv_fetch_ent(hv, keysv, lval, 0);
3833 svp = he ? &HeVAL(he) : 0;
3836 if (!svp || *svp == &PL_sv_undef) {
3837 DIE(aTHX_ PL_no_helem_sv, keysv);
3841 save_helem(hv, keysv, svp);
3844 const char *key = SvPV_const(keysv, keylen);
3845 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3849 *MARK = svp ? *svp : &PL_sv_undef;
3851 if (GIMME != G_ARRAY) {
3853 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3859 /* List operators. */
3864 if (GIMME != G_ARRAY) {
3866 *MARK = *SP; /* unwanted list, return last item */
3868 *MARK = &PL_sv_undef;
3878 SV ** const lastrelem = PL_stack_sp;
3879 SV ** const lastlelem = PL_stack_base + POPMARK;
3880 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3881 register SV ** const firstrelem = lastlelem + 1;
3882 const I32 arybase = PL_curcop->cop_arybase;
3883 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3885 register const I32 max = lastrelem - lastlelem;
3886 register SV **lelem;
3888 if (GIMME != G_ARRAY) {
3889 I32 ix = SvIVx(*lastlelem);
3894 if (ix < 0 || ix >= max)
3895 *firstlelem = &PL_sv_undef;
3897 *firstlelem = firstrelem[ix];
3903 SP = firstlelem - 1;
3907 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3908 I32 ix = SvIVx(*lelem);
3913 if (ix < 0 || ix >= max)
3914 *lelem = &PL_sv_undef;
3916 is_something_there = TRUE;
3917 if (!(*lelem = firstrelem[ix]))
3918 *lelem = &PL_sv_undef;
3921 if (is_something_there)
3924 SP = firstlelem - 1;
3930 dVAR; dSP; dMARK; dORIGMARK;
3931 const I32 items = SP - MARK;
3932 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3933 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3940 dVAR; dSP; dMARK; dORIGMARK;
3941 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3944 SV * const key = *++MARK;
3945 SV * const val = newSV(0);
3947 sv_setsv(val, *++MARK);
3948 else if (ckWARN(WARN_MISC))
3949 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3950 (void)hv_store_ent(hv,key,val,0);
3959 dVAR; dSP; dMARK; dORIGMARK;
3960 register AV *ary = (AV*)*++MARK;
3964 register I32 offset;
3965 register I32 length;
3969 SV **tmparyval = NULL;
3970 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
3973 *MARK-- = SvTIED_obj((SV*)ary, mg);
3977 call_method("SPLICE",GIMME_V);
3986 offset = i = SvIVx(*MARK);
3988 offset += AvFILLp(ary) + 1;
3990 offset -= PL_curcop->cop_arybase;
3992 DIE(aTHX_ PL_no_aelem, i);
3994 length = SvIVx(*MARK++);
3996 length += AvFILLp(ary) - offset + 1;
4002 length = AvMAX(ary) + 1; /* close enough to infinity */
4006 length = AvMAX(ary) + 1;
4008 if (offset > AvFILLp(ary) + 1) {
4009 if (ckWARN(WARN_MISC))
4010 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4011 offset = AvFILLp(ary) + 1;
4013 after = AvFILLp(ary) + 1 - (offset + length);
4014 if (after < 0) { /* not that much array */
4015 length += after; /* offset+length now in array */
4021 /* At this point, MARK .. SP-1 is our new LIST */
4024 diff = newlen - length;
4025 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4028 /* make new elements SVs now: avoid problems if they're from the array */
4029 for (dst = MARK, i = newlen; i; i--) {
4030 SV * const h = *dst;
4031 *dst++ = newSVsv(h);
4034 if (diff < 0) { /* shrinking the area */
4036 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4037 Copy(MARK, tmparyval, newlen, SV*);
4040 MARK = ORIGMARK + 1;
4041 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4042 MEXTEND(MARK, length);
4043 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4045 EXTEND_MORTAL(length);
4046 for (i = length, dst = MARK; i; i--) {
4047 sv_2mortal(*dst); /* free them eventualy */
4054 *MARK = AvARRAY(ary)[offset+length-1];
4057 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4058 SvREFCNT_dec(*dst++); /* free them now */
4061 AvFILLp(ary) += diff;
4063 /* pull up or down? */
4065 if (offset < after) { /* easier to pull up */
4066 if (offset) { /* esp. if nothing to pull */
4067 src = &AvARRAY(ary)[offset-1];
4068 dst = src - diff; /* diff is negative */
4069 for (i = offset; i > 0; i--) /* can't trust Copy */
4073 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4077 if (after) { /* anything to pull down? */
4078 src = AvARRAY(ary) + offset + length;
4079 dst = src + diff; /* diff is negative */
4080 Move(src, dst, after, SV*);
4082 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4083 /* avoid later double free */
4087 dst[--i] = &PL_sv_undef;
4090 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4091 Safefree(tmparyval);
4094 else { /* no, expanding (or same) */
4096 Newx(tmparyval, length, SV*); /* so remember deletion */
4097 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4100 if (diff > 0) { /* expanding */
4102 /* push up or down? */
4104 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4108 Move(src, dst, offset, SV*);
4110 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4112 AvFILLp(ary) += diff;
4115 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4116 av_extend(ary, AvFILLp(ary) + diff);
4117 AvFILLp(ary) += diff;
4120 dst = AvARRAY(ary) + AvFILLp(ary);
4122 for (i = after; i; i--) {
4130 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4133 MARK = ORIGMARK + 1;
4134 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4136 Copy(tmparyval, MARK, length, SV*);
4138 EXTEND_MORTAL(length);
4139 for (i = length, dst = MARK; i; i--) {
4140 sv_2mortal(*dst); /* free them eventualy */
4144 Safefree(tmparyval);
4148 else if (length--) {
4149 *MARK = tmparyval[length];
4152 while (length-- > 0)
4153 SvREFCNT_dec(tmparyval[length]);
4155 Safefree(tmparyval);
4158 *MARK = &PL_sv_undef;
4166 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4167 register AV *ary = (AV*)*++MARK;
4168 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4171 *MARK-- = SvTIED_obj((SV*)ary, mg);
4175 call_method("PUSH",G_SCALAR|G_DISCARD);
4179 PUSHi( AvFILL(ary) + 1 );
4182 for (++MARK; MARK <= SP; MARK++) {
4183 SV * const sv = newSV(0);
4185 sv_setsv(sv, *MARK);
4186 av_store(ary, AvFILLp(ary)+1, sv);
4189 PUSHi( AvFILLp(ary) + 1 );
4198 AV * const av = (AV*)POPs;
4199 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4203 (void)sv_2mortal(sv);
4210 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4211 register AV *ary = (AV*)*++MARK;
4212 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4215 *MARK-- = SvTIED_obj((SV*)ary, mg);
4219 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4225 av_unshift(ary, SP - MARK);
4227 SV * const sv = newSVsv(*++MARK);
4228 (void)av_store(ary, i++, sv);
4232 PUSHi( AvFILL(ary) + 1 );
4239 SV ** const oldsp = SP;
4241 if (GIMME == G_ARRAY) {
4244 register SV * const tmp = *MARK;
4248 /* safe as long as stack cannot get extended in the above */
4253 register char *down;
4259 SvUTF8_off(TARG); /* decontaminate */
4261 do_join(TARG, &PL_sv_no, MARK, SP);
4263 sv_setsv(TARG, (SP > MARK)
4265 : (padoff_du = find_rundefsvoffset(),
4266 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4267 ? DEFSV : PAD_SVl(padoff_du)));
4268 up = SvPV_force(TARG, len);
4270 if (DO_UTF8(TARG)) { /* first reverse each character */
4271 U8* s = (U8*)SvPVX(TARG);
4272 const U8* send = (U8*)(s + len);
4274 if (UTF8_IS_INVARIANT(*s)) {
4279 if (!utf8_to_uvchr(s, 0))
4283 down = (char*)(s - 1);
4284 /* reverse this character */
4288 *down-- = (char)tmp;
4294 down = SvPVX(TARG) + len - 1;
4298 *down-- = (char)tmp;
4300 (void)SvPOK_only_UTF8(TARG);
4312 register IV limit = POPi; /* note, negative is forever */
4313 SV * const sv = POPs;
4315 register const char *s = SvPV_const(sv, len);
4316 const bool do_utf8 = DO_UTF8(sv);
4317 const char *strend = s + len;
4319 register REGEXP *rx;
4321 register const char *m;
4323 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4324 I32 maxiters = slen + 10;
4326 const I32 origlimit = limit;
4329 const I32 gimme = GIMME_V;
4330 const I32 oldsave = PL_savestack_ix;
4331 I32 make_mortal = 1;
4333 MAGIC *mg = (MAGIC *) NULL;
4336 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4341 DIE(aTHX_ "panic: pp_split");
4344 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4345 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4347 RX_MATCH_UTF8_set(rx, do_utf8);
4349 if (pm->op_pmreplroot) {
4351 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4353 ary = GvAVn((GV*)pm->op_pmreplroot);
4356 else if (gimme != G_ARRAY)
4357 ary = GvAVn(PL_defgv);
4360 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4366 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4368 XPUSHs(SvTIED_obj((SV*)ary, mg));
4375 for (i = AvFILLp(ary); i >= 0; i--)
4376 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4378 /* temporarily switch stacks */
4379 SAVESWITCHSTACK(PL_curstack, ary);
4383 base = SP - PL_stack_base;
4385 if (pm->op_pmflags & PMf_SKIPWHITE) {
4386 if (pm->op_pmflags & PMf_LOCALE) {
4387 while (isSPACE_LC(*s))
4395 if (pm->op_pmflags & PMf_MULTILINE) {
4400 limit = maxiters + 2;
4401 if (pm->op_pmflags & PMf_WHITE) {
4404 while (m < strend &&
4405 !((pm->op_pmflags & PMf_LOCALE)
4406 ? isSPACE_LC(*m) : isSPACE(*m)))
4411 dstr = newSVpvn(s, m-s);
4415 (void)SvUTF8_on(dstr);
4419 while (s < strend &&
4420 ((pm->op_pmflags & PMf_LOCALE)
4421 ? isSPACE_LC(*s) : isSPACE(*s)))
4425 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4427 for (m = s; m < strend && *m != '\n'; m++)
4432 dstr = newSVpvn(s, m-s);
4436 (void)SvUTF8_on(dstr);
4441 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4442 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4443 && (rx->reganch & ROPT_CHECK_ALL)
4444 && !(rx->reganch & ROPT_ANCH)) {
4445 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4446 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4449 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4450 const char c = *SvPV_nolen_const(csv);
4452 for (m = s; m < strend && *m != c; m++)
4456 dstr = newSVpvn(s, m-s);
4460 (void)SvUTF8_on(dstr);
4462 /* The rx->minlen is in characters but we want to step
4463 * s ahead by bytes. */
4465 s = (char*)utf8_hop((U8*)m, len);
4467 s = m + len; /* Fake \n at the end */
4471 while (s < strend && --limit &&
4472 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4473 csv, multiline ? FBMrf_MULTILINE : 0)) )
4475 dstr = newSVpvn(s, m-s);
4479 (void)SvUTF8_on(dstr);
4481 /* The rx->minlen is in characters but we want to step
4482 * s ahead by bytes. */
4484 s = (char*)utf8_hop((U8*)m, len);
4486 s = m + len; /* Fake \n at the end */
4491 maxiters += slen * rx->nparens;
4492 while (s < strend && --limit)
4496 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4499 if (rex_return == 0)
4501 TAINT_IF(RX_MATCH_TAINTED(rx));
4502 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4507 strend = s + (strend - m);
4509 m = rx->startp[0] + orig;
4510 dstr = newSVpvn(s, m-s);
4514 (void)SvUTF8_on(dstr);
4518 for (i = 1; i <= (I32)rx->nparens; i++) {
4519 s = rx->startp[i] + orig;
4520 m = rx->endp[i] + orig;
4522 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4523 parens that didn't match -- they should be set to
4524 undef, not the empty string */
4525 if (m >= orig && s >= orig) {
4526 dstr = newSVpvn(s, m-s);
4529 dstr = &PL_sv_undef; /* undef, not "" */
4533 (void)SvUTF8_on(dstr);
4537 s = rx->endp[0] + orig;
4541 iters = (SP - PL_stack_base) - base;
4542 if (iters > maxiters)
4543 DIE(aTHX_ "Split loop");
4545 /* keep field after final delim? */
4546 if (s < strend || (iters && origlimit)) {
4547 const STRLEN l = strend - s;
4548 dstr = newSVpvn(s, l);
4552 (void)SvUTF8_on(dstr);
4556 else if (!origlimit) {
4557 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4558 if (TOPs && !make_mortal)
4561 *SP-- = &PL_sv_undef;
4566 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4570 if (SvSMAGICAL(ary)) {
4575 if (gimme == G_ARRAY) {
4577 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4585 call_method("PUSH",G_SCALAR|G_DISCARD);
4588 if (gimme == G_ARRAY) {
4590 /* EXTEND should not be needed - we just popped them */
4592 for (i=0; i < iters; i++) {
4593 SV **svp = av_fetch(ary, i, FALSE);
4594 PUSHs((svp) ? *svp : &PL_sv_undef);
4601 if (gimme == G_ARRAY)
4617 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4618 || SvTYPE(retsv) == SVt_PVCV) {
4619 retsv = refto(retsv);
4626 PP(unimplemented_op)
4629 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4635 * c-indentation-style: bsd
4637 * indent-tabs-mode: t
4640 * ex: set ts=8 sts=4 sw=4 noet: