3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
52 if (GIMME_V == G_SCALAR)
63 if (PL_op->op_private & OPpLVAL_INTRO)
64 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
66 if (PL_op->op_flags & OPf_REF) {
70 if (GIMME == G_SCALAR)
71 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
76 if (gimme == G_ARRAY) {
77 const I32 maxarg = AvFILL((AV*)TARG) + 1;
79 if (SvMAGICAL(TARG)) {
81 for (i=0; i < (U32)maxarg; i++) {
82 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
83 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
87 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
91 else if (gimme == G_SCALAR) {
92 SV* const sv = sv_newmortal();
93 const I32 maxarg = AvFILL((AV*)TARG) + 1;
106 if (PL_op->op_private & OPpLVAL_INTRO)
107 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
108 if (PL_op->op_flags & OPf_REF)
111 if (GIMME == G_SCALAR)
112 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
116 if (gimme == G_ARRAY) {
119 else if (gimme == G_SCALAR) {
120 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
134 tryAMAGICunDEREF(to_gv);
137 if (SvTYPE(sv) == SVt_PVIO) {
138 GV * const gv = (GV*) sv_newmortal();
139 gv_init(gv, 0, "", 0, 0);
140 GvIOp(gv) = (IO *)sv;
141 SvREFCNT_inc_void_NN(sv);
144 else if (SvTYPE(sv) != SVt_PVGV)
145 DIE(aTHX_ "Not a GLOB reference");
148 if (SvTYPE(sv) != SVt_PVGV) {
149 if (SvGMAGICAL(sv)) {
154 if (!SvOK(sv) && sv != &PL_sv_undef) {
155 /* If this is a 'my' scalar and flag is set then vivify
159 Perl_croak(aTHX_ PL_no_modify);
160 if (PL_op->op_private & OPpDEREF) {
162 if (cUNOP->op_targ) {
164 SV * const namesv = PAD_SV(cUNOP->op_targ);
165 const char * const name = SvPV(namesv, len);
167 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
170 const char * const name = CopSTASHPV(PL_curcop);
173 if (SvTYPE(sv) < SVt_RV)
174 sv_upgrade(sv, SVt_RV);
175 if (SvPVX_const(sv)) {
180 SvRV_set(sv, (SV*)gv);
185 if (PL_op->op_flags & OPf_REF ||
186 PL_op->op_private & HINT_STRICT_REFS)
187 DIE(aTHX_ PL_no_usym, "a symbol");
188 if (ckWARN(WARN_UNINITIALIZED))
192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
195 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
197 && (!is_gv_magical_sv(sv,0)
198 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
204 if (PL_op->op_private & HINT_STRICT_REFS)
205 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
206 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
207 == OPpDONT_INIT_GV) {
208 /* We are the target of a coderef assignment. Return
209 the scalar unchanged, and let pp_sasssign deal with
213 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
217 if (PL_op->op_private & OPpLVAL_INTRO)
218 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
230 tryAMAGICunDEREF(to_sv);
233 switch (SvTYPE(sv)) {
239 DIE(aTHX_ "Not a SCALAR reference");
245 if (SvTYPE(gv) != SVt_PVGV) {
246 if (SvGMAGICAL(sv)) {
251 if (PL_op->op_private & HINT_STRICT_REFS) {
253 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
255 DIE(aTHX_ PL_no_usym, "a SCALAR");
258 if (PL_op->op_flags & OPf_REF)
259 DIE(aTHX_ PL_no_usym, "a SCALAR");
260 if (ckWARN(WARN_UNINITIALIZED))
264 if ((PL_op->op_flags & OPf_SPECIAL) &&
265 !(PL_op->op_flags & OPf_MOD))
267 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
269 && (!is_gv_magical_sv(sv, 0)
270 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
276 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
281 if (PL_op->op_flags & OPf_MOD) {
282 if (PL_op->op_private & OPpLVAL_INTRO) {
283 if (cUNOP->op_first->op_type == OP_NULL)
284 sv = save_scalar((GV*)TOPs);
286 sv = save_scalar(gv);
288 Perl_croak(aTHX_ PL_no_localize_ref);
290 else if (PL_op->op_private & OPpDEREF)
291 vivify_ref(sv, PL_op->op_private & OPpDEREF);
300 AV * const av = (AV*)TOPs;
301 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
304 sv_upgrade(*sv, SVt_PVMG);
305 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
313 dVAR; dSP; dTARGET; dPOPss;
315 if (PL_op->op_flags & OPf_MOD || LVRET) {
316 if (SvTYPE(TARG) < SVt_PVLV) {
317 sv_upgrade(TARG, SVt_PVLV);
318 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
322 if (LvTARG(TARG) != sv) {
324 SvREFCNT_dec(LvTARG(TARG));
325 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
327 PUSHs(TARG); /* no SvSETMAGIC */
331 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
332 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
333 if (mg && mg->mg_len >= 0) {
337 PUSHi(i + 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 SvREFCNT_inc_void_NN(sv);
494 else if (SvTYPE(sv) == SVt_PVAV) {
495 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
498 SvREFCNT_inc_void_NN(sv);
500 else if (SvPADTMP(sv) && !IS_PADGV(sv))
504 SvREFCNT_inc_void_NN(sv);
507 sv_upgrade(rv, SVt_RV);
517 SV * const sv = POPs;
522 if (!sv || !SvROK(sv))
525 pv = sv_reftype(SvRV(sv),TRUE);
526 PUSHp(pv, strlen(pv));
536 stash = CopSTASH(PL_curcop);
538 SV * const ssv = POPs;
542 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
543 Perl_croak(aTHX_ "Attempt to bless into a reference");
544 ptr = SvPV_const(ssv,len);
545 if (len == 0 && ckWARN(WARN_MISC))
546 Perl_warner(aTHX_ packWARN(WARN_MISC),
547 "Explicit blessing to '' (assuming package main)");
548 stash = gv_stashpvn(ptr, len, TRUE);
551 (void)sv_bless(TOPs, stash);
560 const char * const elem = SvPV_nolen_const(sv);
561 GV * const gv = (GV*)POPs;
566 /* elem will always be NUL terminated. */
567 const char * const second_letter = elem + 1;
570 if (strEQ(second_letter, "RRAY"))
571 tmpRef = (SV*)GvAV(gv);
574 if (strEQ(second_letter, "ODE"))
575 tmpRef = (SV*)GvCVu(gv);
578 if (strEQ(second_letter, "ILEHANDLE")) {
579 /* finally deprecated in 5.8.0 */
580 deprecate("*glob{FILEHANDLE}");
581 tmpRef = (SV*)GvIOp(gv);
584 if (strEQ(second_letter, "ORMAT"))
585 tmpRef = (SV*)GvFORM(gv);
588 if (strEQ(second_letter, "LOB"))
592 if (strEQ(second_letter, "ASH"))
593 tmpRef = (SV*)GvHV(gv);
596 if (*second_letter == 'O' && !elem[2])
597 tmpRef = (SV*)GvIOp(gv);
600 if (strEQ(second_letter, "AME"))
601 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
604 if (strEQ(second_letter, "ACKAGE")) {
605 const HV * const stash = GvSTASH(gv);
606 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
607 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
611 if (strEQ(second_letter, "CALAR"))
626 /* Pattern matching */
631 register unsigned char *s;
634 register I32 *sfirst;
638 if (sv == PL_lastscream) {
642 s = (unsigned char*)(SvPV(sv, len));
644 if (pos <= 0 || !SvPOK(sv)) {
645 /* No point in studying a zero length string, and not safe to study
646 anything that doesn't appear to be a simple scalar (and hence might
647 change between now and when the regexp engine runs without our set
648 magic ever running) such as a reference to an object with overloaded
654 SvSCREAM_off(PL_lastscream);
655 SvREFCNT_dec(PL_lastscream);
657 PL_lastscream = SvREFCNT_inc_simple(sv);
659 s = (unsigned char*)(SvPV(sv, len));
663 if (pos > PL_maxscream) {
664 if (PL_maxscream < 0) {
665 PL_maxscream = pos + 80;
666 Newx(PL_screamfirst, 256, I32);
667 Newx(PL_screamnext, PL_maxscream, I32);
670 PL_maxscream = pos + pos / 4;
671 Renew(PL_screamnext, PL_maxscream, I32);
675 sfirst = PL_screamfirst;
676 snext = PL_screamnext;
678 if (!sfirst || !snext)
679 DIE(aTHX_ "do_study: out of memory");
681 for (ch = 256; ch; --ch)
686 register const I32 ch = s[pos];
688 snext[pos] = sfirst[ch] - pos;
695 /* piggyback on m//g magic */
696 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
705 if (PL_op->op_flags & OPf_STACKED)
707 else if (PL_op->op_private & OPpTARGET_MY)
713 TARG = sv_newmortal();
718 /* Lvalue operators. */
730 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
732 do_chop(TARG, *++MARK);
741 SETi(do_chomp(TOPs));
747 dVAR; dSP; dMARK; dTARGET;
748 register I32 count = 0;
751 count += do_chomp(POPs);
761 if (!PL_op->op_private) {
770 SV_CHECK_THINKFIRST_COW_DROP(sv);
772 switch (SvTYPE(sv)) {
782 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
783 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
784 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
788 /* let user-undef'd sub keep its identity */
789 GV* const gv = CvGV((CV*)sv);
796 SvSetMagicSV(sv, &PL_sv_undef);
801 GvGP(sv) = gp_ref(gp);
803 GvLINE(sv) = CopLINE(PL_curcop);
809 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
824 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
825 DIE(aTHX_ PL_no_modify);
826 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
827 && SvIVX(TOPs) != IV_MIN)
829 SvIV_set(TOPs, SvIVX(TOPs) - 1);
830 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
842 DIE(aTHX_ PL_no_modify);
843 sv_setsv(TARG, TOPs);
844 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
845 && SvIVX(TOPs) != IV_MAX)
847 SvIV_set(TOPs, SvIVX(TOPs) + 1);
848 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
853 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
863 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 sv_setsv(TARG, TOPs);
866 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
867 && SvIVX(TOPs) != IV_MIN)
869 SvIV_set(TOPs, SvIVX(TOPs) - 1);
870 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
879 /* Ordinary operators. */
884 #ifdef PERL_PRESERVE_IVUV
887 tryAMAGICbin(pow,opASSIGN);
888 #ifdef PERL_PRESERVE_IVUV
889 /* For integer to integer power, we do the calculation by hand wherever
890 we're sure it is safe; otherwise we call pow() and try to convert to
891 integer afterwards. */
904 const IV iv = SvIVX(TOPs);
908 goto float_it; /* Can't do negative powers this way. */
912 baseuok = SvUOK(TOPm1s);
914 baseuv = SvUVX(TOPm1s);
916 const IV iv = SvIVX(TOPm1s);
919 baseuok = TRUE; /* effectively it's a UV now */
921 baseuv = -iv; /* abs, baseuok == false records sign */
924 /* now we have integer ** positive integer. */
927 /* foo & (foo - 1) is zero only for a power of 2. */
928 if (!(baseuv & (baseuv - 1))) {
929 /* We are raising power-of-2 to a positive integer.
930 The logic here will work for any base (even non-integer
931 bases) but it can be less accurate than
932 pow (base,power) or exp (power * log (base)) when the
933 intermediate values start to spill out of the mantissa.
934 With powers of 2 we know this can't happen.
935 And powers of 2 are the favourite thing for perl
936 programmers to notice ** not doing what they mean. */
938 NV base = baseuok ? baseuv : -(NV)baseuv;
943 while (power >>= 1) {
954 register unsigned int highbit = 8 * sizeof(UV);
955 register unsigned int diff = 8 * sizeof(UV);
958 if (baseuv >> highbit) {
962 /* we now have baseuv < 2 ** highbit */
963 if (power * highbit <= 8 * sizeof(UV)) {
964 /* result will definitely fit in UV, so use UV math
965 on same algorithm as above */
966 register UV result = 1;
967 register UV base = baseuv;
968 const bool odd_power = (bool)(power & 1);
972 while (power >>= 1) {
979 if (baseuok || !odd_power)
980 /* answer is positive */
982 else if (result <= (UV)IV_MAX)
983 /* answer negative, fits in IV */
985 else if (result == (UV)IV_MIN)
986 /* 2's complement assumption: special case IV_MIN */
989 /* answer negative, doesn't fit */
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 (isGV_with_GP(sv))
3020 SvPV_force_nolen(sv);
3021 else if (SvOK(sv)) /* is it defined ? */
3022 (void)SvPOK_only_UTF8(sv);
3024 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3027 if (SvTYPE(TARG) < SVt_PVLV) {
3028 sv_upgrade(TARG, SVt_PVLV);
3029 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3035 if (LvTARG(TARG) != sv) {
3037 SvREFCNT_dec(LvTARG(TARG));
3038 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3040 LvTARGOFF(TARG) = upos;
3041 LvTARGLEN(TARG) = urem;
3045 PUSHs(TARG); /* avoid SvSETMAGIC here */
3052 register const IV size = POPi;
3053 register const IV offset = POPi;
3054 register SV * const src = POPs;
3055 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3057 SvTAINTED_off(TARG); /* decontaminate */
3058 if (lvalue) { /* it's an lvalue! */
3059 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3060 TARG = sv_newmortal();
3061 if (SvTYPE(TARG) < SVt_PVLV) {
3062 sv_upgrade(TARG, SVt_PVLV);
3063 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3066 if (LvTARG(TARG) != src) {
3068 SvREFCNT_dec(LvTARG(TARG));
3069 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3071 LvTARGOFF(TARG) = offset;
3072 LvTARGLEN(TARG) = size;
3075 sv_setuv(TARG, do_vecget(src, offset, size));
3092 const I32 arybase = PL_curcop->cop_arybase;
3095 const bool is_index = PL_op->op_type == OP_INDEX;
3098 /* arybase is in characters, like offset, so combine prior to the
3099 UTF-8 to bytes calculation. */
3100 offset = POPi - arybase;
3104 big_utf8 = DO_UTF8(big);
3105 little_utf8 = DO_UTF8(little);
3106 if (big_utf8 ^ little_utf8) {
3107 /* One needs to be upgraded. */
3108 if (little_utf8 && !PL_encoding) {
3109 /* Well, maybe instead we might be able to downgrade the small
3112 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3113 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3116 /* If the large string is ISO-8859-1, and it's not possible to
3117 convert the small string to ISO-8859-1, then there is no
3118 way that it could be found anywhere by index. */
3123 /* At this point, pv is a malloc()ed string. So donate it to temp
3124 to ensure it will get free()d */
3125 little = temp = newSV(0);
3126 sv_usepvn(temp, pv, little_len);
3128 SV * const bytes = little_utf8 ? big : little;
3130 const char * const p = SvPV_const(bytes, len);
3132 temp = newSVpvn(p, len);
3135 sv_recode_to_utf8(temp, PL_encoding);
3137 sv_utf8_upgrade(temp);
3147 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3148 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3149 tmps = SvPV_const(big, biglen);
3152 offset = is_index ? 0 : biglen;
3154 if (big_utf8 && offset > 0)
3155 sv_pos_u2b(big, &offset, 0);
3160 else if (offset > (I32)biglen)
3162 if (!(tmps2 = is_index
3163 ? fbm_instr((unsigned char*)tmps + offset,
3164 (unsigned char*)tmps + biglen, little, 0)
3165 : rninstr(tmps, tmps + offset,
3166 tmps2, tmps2 + llen)))
3169 retval = tmps2 - tmps;
3170 if (retval > 0 && big_utf8)
3171 sv_pos_b2u(big, &retval);
3176 PUSHi(retval + arybase);
3182 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3183 do_sprintf(TARG, SP-MARK, MARK+1);
3184 TAINT_IF(SvTAINTED(TARG));
3195 const U8 *s = (U8*)SvPV_const(argsv, len);
3198 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3199 tmpsv = sv_2mortal(newSVsv(argsv));
3200 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3204 XPUSHu(DO_UTF8(argsv) ?
3205 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3217 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3219 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3221 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3223 (void) POPs; /* Ignore the argument value. */
3224 value = UNICODE_REPLACEMENT;
3230 SvUPGRADE(TARG,SVt_PV);
3232 if (value > 255 && !IN_BYTES) {
3233 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3234 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3235 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3237 (void)SvPOK_only(TARG);
3246 *tmps++ = (char)value;
3248 (void)SvPOK_only(TARG);
3249 if (PL_encoding && !IN_BYTES) {
3250 sv_recode_to_utf8(TARG, PL_encoding);
3252 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3253 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3257 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3258 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3273 const char *tmps = SvPV_const(left, len);
3275 if (DO_UTF8(left)) {
3276 /* If Unicode, try to downgrade.
3277 * If not possible, croak.
3278 * Yes, we made this up. */
3279 SV* const tsv = sv_2mortal(newSVsv(left));
3282 sv_utf8_downgrade(tsv, FALSE);
3283 tmps = SvPV_const(tsv, len);
3285 # ifdef USE_ITHREADS
3287 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3288 /* This should be threadsafe because in ithreads there is only
3289 * one thread per interpreter. If this would not be true,
3290 * we would need a mutex to protect this malloc. */
3291 PL_reentrant_buffer->_crypt_struct_buffer =
3292 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3293 #if defined(__GLIBC__) || defined(__EMX__)
3294 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3295 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3296 /* work around glibc-2.2.5 bug */
3297 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3301 # endif /* HAS_CRYPT_R */
3302 # endif /* USE_ITHREADS */
3304 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3306 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3312 "The crypt() function is unimplemented due to excessive paranoia.");
3323 const int op_type = PL_op->op_type;
3327 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3328 UTF8_IS_START(*s)) {
3329 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3333 utf8_to_uvchr(s, &ulen);
3334 if (op_type == OP_UCFIRST) {
3335 toTITLE_utf8(s, tmpbuf, &tculen);
3337 toLOWER_utf8(s, tmpbuf, &tculen);
3340 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3342 /* slen is the byte length of the whole SV.
3343 * ulen is the byte length of the original Unicode character
3344 * stored as UTF-8 at s.
3345 * tculen is the byte length of the freshly titlecased (or
3346 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3347 * We first set the result to be the titlecased (/lowercased)
3348 * character, and then append the rest of the SV data. */
3349 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3351 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3357 s = (U8*)SvPV_force_nomg(sv, slen);
3358 Copy(tmpbuf, s, tculen, U8);
3363 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3365 SvUTF8_off(TARG); /* decontaminate */
3366 sv_setsv_nomg(TARG, sv);
3370 s1 = (U8*)SvPV_force_nomg(sv, slen);
3372 if (IN_LOCALE_RUNTIME) {
3375 *s1 = (op_type == OP_UCFIRST)
3376 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3379 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3400 U8 tmpbuf[UTF8_MAXBYTES+1];
3402 s = (const U8*)SvPV_nomg_const(sv,len);
3404 SvUTF8_off(TARG); /* decontaminate */
3405 sv_setpvn(TARG, "", 0);
3410 STRLEN min = len + 1;
3412 SvUPGRADE(TARG, SVt_PV);
3414 (void)SvPOK_only(TARG);
3415 d = (U8*)SvPVX(TARG);
3418 STRLEN u = UTF8SKIP(s);
3420 toUPPER_utf8(s, tmpbuf, &ulen);
3421 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3422 /* If the eventually required minimum size outgrows
3423 * the available space, we need to grow. */
3424 const UV o = d - (U8*)SvPVX_const(TARG);
3426 /* If someone uppercases one million U+03B0s we
3427 * SvGROW() one million times. Or we could try
3428 * guessing how much to allocate without allocating
3429 * too much. Such is life. */
3431 d = (U8*)SvPVX(TARG) + o;
3433 Copy(tmpbuf, d, ulen, U8);
3439 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3446 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3448 SvUTF8_off(TARG); /* decontaminate */
3449 sv_setsv_nomg(TARG, sv);
3453 s = (U8*)SvPV_force_nomg(sv, len);
3455 register const U8 *send = s + len;
3457 if (IN_LOCALE_RUNTIME) {
3460 for (; s < send; s++)
3461 *s = toUPPER_LC(*s);
3464 for (; s < send; s++)
3487 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3489 s = (const U8*)SvPV_nomg_const(sv,len);
3491 SvUTF8_off(TARG); /* decontaminate */
3492 sv_setpvn(TARG, "", 0);
3497 STRLEN min = len + 1;
3499 SvUPGRADE(TARG, SVt_PV);
3501 (void)SvPOK_only(TARG);
3502 d = (U8*)SvPVX(TARG);
3505 const STRLEN u = UTF8SKIP(s);
3506 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3508 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3509 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3512 * Now if the sigma is NOT followed by
3513 * /$ignorable_sequence$cased_letter/;
3514 * and it IS preceded by
3515 * /$cased_letter$ignorable_sequence/;
3516 * where $ignorable_sequence is
3517 * [\x{2010}\x{AD}\p{Mn}]*
3518 * and $cased_letter is
3519 * [\p{Ll}\p{Lo}\p{Lt}]
3520 * then it should be mapped to 0x03C2,
3521 * (GREEK SMALL LETTER FINAL SIGMA),
3522 * instead of staying 0x03A3.
3523 * "should be": in other words,
3524 * this is not implemented yet.
3525 * See lib/unicore/SpecialCasing.txt.
3528 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3529 /* If the eventually required minimum size outgrows
3530 * the available space, we need to grow. */
3531 const UV o = d - (U8*)SvPVX_const(TARG);
3533 /* If someone lowercases one million U+0130s we
3534 * SvGROW() one million times. Or we could try
3535 * guessing how much to allocate without allocating.
3536 * too much. Such is life. */
3538 d = (U8*)SvPVX(TARG) + o;
3540 Copy(tmpbuf, d, ulen, U8);
3546 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3553 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3555 SvUTF8_off(TARG); /* decontaminate */
3556 sv_setsv_nomg(TARG, sv);
3561 s = (U8*)SvPV_force_nomg(sv, len);
3563 register const U8 * const send = s + len;
3565 if (IN_LOCALE_RUNTIME) {
3568 for (; s < send; s++)
3569 *s = toLOWER_LC(*s);
3572 for (; s < send; s++)
3584 SV * const sv = TOPs;
3586 register const char *s = SvPV_const(sv,len);
3588 SvUTF8_off(TARG); /* decontaminate */
3591 SvUPGRADE(TARG, SVt_PV);
3592 SvGROW(TARG, (len * 2) + 1);
3596 if (UTF8_IS_CONTINUED(*s)) {
3597 STRLEN ulen = UTF8SKIP(s);
3621 SvCUR_set(TARG, d - SvPVX_const(TARG));
3622 (void)SvPOK_only_UTF8(TARG);
3625 sv_setpvn(TARG, s, len);
3627 if (SvSMAGICAL(TARG))
3636 dVAR; dSP; dMARK; dORIGMARK;
3637 register AV* const av = (AV*)POPs;
3638 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3640 if (SvTYPE(av) == SVt_PVAV) {
3641 const I32 arybase = PL_curcop->cop_arybase;
3642 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3645 for (svp = MARK + 1; svp <= SP; svp++) {
3646 const I32 elem = SvIVx(*svp);
3650 if (max > AvMAX(av))
3653 while (++MARK <= SP) {
3655 I32 elem = SvIVx(*MARK);
3659 svp = av_fetch(av, elem, lval);
3661 if (!svp || *svp == &PL_sv_undef)
3662 DIE(aTHX_ PL_no_aelem, elem);
3663 if (PL_op->op_private & OPpLVAL_INTRO)
3664 save_aelem(av, elem, svp);
3666 *MARK = svp ? *svp : &PL_sv_undef;
3669 if (GIMME != G_ARRAY) {
3671 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3677 /* Associative arrays. */
3683 HV * const hash = (HV*)POPs;
3685 const I32 gimme = GIMME_V;
3688 /* might clobber stack_sp */
3689 entry = hv_iternext(hash);
3694 SV* const sv = hv_iterkeysv(entry);
3695 PUSHs(sv); /* won't clobber stack_sp */
3696 if (gimme == G_ARRAY) {
3699 /* might clobber stack_sp */
3700 val = hv_iterval(hash, entry);
3705 else if (gimme == G_SCALAR)
3715 const I32 gimme = GIMME_V;
3716 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3718 if (PL_op->op_private & OPpSLICE) {
3720 HV * const hv = (HV*)POPs;
3721 const U32 hvtype = SvTYPE(hv);
3722 if (hvtype == SVt_PVHV) { /* hash element */
3723 while (++MARK <= SP) {
3724 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3725 *MARK = sv ? sv : &PL_sv_undef;
3728 else if (hvtype == SVt_PVAV) { /* array element */
3729 if (PL_op->op_flags & OPf_SPECIAL) {
3730 while (++MARK <= SP) {
3731 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3732 *MARK = sv ? sv : &PL_sv_undef;
3737 DIE(aTHX_ "Not a HASH reference");
3740 else if (gimme == G_SCALAR) {
3745 *++MARK = &PL_sv_undef;
3751 HV * const hv = (HV*)POPs;
3753 if (SvTYPE(hv) == SVt_PVHV)
3754 sv = hv_delete_ent(hv, keysv, discard, 0);
3755 else if (SvTYPE(hv) == SVt_PVAV) {
3756 if (PL_op->op_flags & OPf_SPECIAL)
3757 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3759 DIE(aTHX_ "panic: avhv_delete no longer supported");
3762 DIE(aTHX_ "Not a HASH reference");
3778 if (PL_op->op_private & OPpEXISTS_SUB) {
3780 SV * const sv = POPs;
3781 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3784 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3790 if (SvTYPE(hv) == SVt_PVHV) {
3791 if (hv_exists_ent(hv, tmpsv, 0))
3794 else if (SvTYPE(hv) == SVt_PVAV) {
3795 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3796 if (av_exists((AV*)hv, SvIV(tmpsv)))
3801 DIE(aTHX_ "Not a HASH reference");
3808 dVAR; dSP; dMARK; dORIGMARK;
3809 register HV * const hv = (HV*)POPs;
3810 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3811 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3812 bool other_magic = FALSE;
3818 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3819 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3820 /* Try to preserve the existenceness of a tied hash
3821 * element by using EXISTS and DELETE if possible.
3822 * Fallback to FETCH and STORE otherwise */
3823 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3824 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3825 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3828 while (++MARK <= SP) {
3829 SV * const keysv = *MARK;
3832 bool preeminent = FALSE;
3835 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3836 hv_exists_ent(hv, keysv, 0);
3839 he = hv_fetch_ent(hv, keysv, lval, 0);
3840 svp = he ? &HeVAL(he) : 0;
3843 if (!svp || *svp == &PL_sv_undef) {
3844 DIE(aTHX_ PL_no_helem_sv, keysv);
3848 save_helem(hv, keysv, svp);
3851 const char *key = SvPV_const(keysv, keylen);
3852 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3856 *MARK = svp ? *svp : &PL_sv_undef;
3858 if (GIMME != G_ARRAY) {
3860 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3866 /* List operators. */
3871 if (GIMME != G_ARRAY) {
3873 *MARK = *SP; /* unwanted list, return last item */
3875 *MARK = &PL_sv_undef;
3885 SV ** const lastrelem = PL_stack_sp;
3886 SV ** const lastlelem = PL_stack_base + POPMARK;
3887 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3888 register SV ** const firstrelem = lastlelem + 1;
3889 const I32 arybase = PL_curcop->cop_arybase;
3890 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3892 register const I32 max = lastrelem - lastlelem;
3893 register SV **lelem;
3895 if (GIMME != G_ARRAY) {
3896 I32 ix = SvIVx(*lastlelem);
3901 if (ix < 0 || ix >= max)
3902 *firstlelem = &PL_sv_undef;
3904 *firstlelem = firstrelem[ix];
3910 SP = firstlelem - 1;
3914 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3915 I32 ix = SvIVx(*lelem);
3920 if (ix < 0 || ix >= max)
3921 *lelem = &PL_sv_undef;
3923 is_something_there = TRUE;
3924 if (!(*lelem = firstrelem[ix]))
3925 *lelem = &PL_sv_undef;
3928 if (is_something_there)
3931 SP = firstlelem - 1;
3937 dVAR; dSP; dMARK; dORIGMARK;
3938 const I32 items = SP - MARK;
3939 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3940 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3947 dVAR; dSP; dMARK; dORIGMARK;
3948 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3951 SV * const key = *++MARK;
3952 SV * const val = newSV(0);
3954 sv_setsv(val, *++MARK);
3955 else if (ckWARN(WARN_MISC))
3956 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3957 (void)hv_store_ent(hv,key,val,0);
3966 dVAR; dSP; dMARK; dORIGMARK;
3967 register AV *ary = (AV*)*++MARK;
3971 register I32 offset;
3972 register I32 length;
3976 SV **tmparyval = NULL;
3977 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
3980 *MARK-- = SvTIED_obj((SV*)ary, mg);
3984 call_method("SPLICE",GIMME_V);
3993 offset = i = SvIVx(*MARK);
3995 offset += AvFILLp(ary) + 1;
3997 offset -= PL_curcop->cop_arybase;
3999 DIE(aTHX_ PL_no_aelem, i);
4001 length = SvIVx(*MARK++);
4003 length += AvFILLp(ary) - offset + 1;
4009 length = AvMAX(ary) + 1; /* close enough to infinity */
4013 length = AvMAX(ary) + 1;
4015 if (offset > AvFILLp(ary) + 1) {
4016 if (ckWARN(WARN_MISC))
4017 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4018 offset = AvFILLp(ary) + 1;
4020 after = AvFILLp(ary) + 1 - (offset + length);
4021 if (after < 0) { /* not that much array */
4022 length += after; /* offset+length now in array */
4028 /* At this point, MARK .. SP-1 is our new LIST */
4031 diff = newlen - length;
4032 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4035 /* make new elements SVs now: avoid problems if they're from the array */
4036 for (dst = MARK, i = newlen; i; i--) {
4037 SV * const h = *dst;
4038 *dst++ = newSVsv(h);
4041 if (diff < 0) { /* shrinking the area */
4043 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4044 Copy(MARK, tmparyval, newlen, SV*);
4047 MARK = ORIGMARK + 1;
4048 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4049 MEXTEND(MARK, length);
4050 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4052 EXTEND_MORTAL(length);
4053 for (i = length, dst = MARK; i; i--) {
4054 sv_2mortal(*dst); /* free them eventualy */
4061 *MARK = AvARRAY(ary)[offset+length-1];
4064 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4065 SvREFCNT_dec(*dst++); /* free them now */
4068 AvFILLp(ary) += diff;
4070 /* pull up or down? */
4072 if (offset < after) { /* easier to pull up */
4073 if (offset) { /* esp. if nothing to pull */
4074 src = &AvARRAY(ary)[offset-1];
4075 dst = src - diff; /* diff is negative */
4076 for (i = offset; i > 0; i--) /* can't trust Copy */
4080 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4084 if (after) { /* anything to pull down? */
4085 src = AvARRAY(ary) + offset + length;
4086 dst = src + diff; /* diff is negative */
4087 Move(src, dst, after, SV*);
4089 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4090 /* avoid later double free */
4094 dst[--i] = &PL_sv_undef;
4097 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4098 Safefree(tmparyval);
4101 else { /* no, expanding (or same) */
4103 Newx(tmparyval, length, SV*); /* so remember deletion */
4104 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4107 if (diff > 0) { /* expanding */
4109 /* push up or down? */
4111 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4115 Move(src, dst, offset, SV*);
4117 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4119 AvFILLp(ary) += diff;
4122 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4123 av_extend(ary, AvFILLp(ary) + diff);
4124 AvFILLp(ary) += diff;
4127 dst = AvARRAY(ary) + AvFILLp(ary);
4129 for (i = after; i; i--) {
4137 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4140 MARK = ORIGMARK + 1;
4141 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4143 Copy(tmparyval, MARK, length, SV*);
4145 EXTEND_MORTAL(length);
4146 for (i = length, dst = MARK; i; i--) {
4147 sv_2mortal(*dst); /* free them eventualy */
4151 Safefree(tmparyval);
4155 else if (length--) {
4156 *MARK = tmparyval[length];
4159 while (length-- > 0)
4160 SvREFCNT_dec(tmparyval[length]);
4162 Safefree(tmparyval);
4165 *MARK = &PL_sv_undef;
4173 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4174 register AV *ary = (AV*)*++MARK;
4175 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4178 *MARK-- = SvTIED_obj((SV*)ary, mg);
4182 call_method("PUSH",G_SCALAR|G_DISCARD);
4186 PUSHi( AvFILL(ary) + 1 );
4189 for (++MARK; MARK <= SP; MARK++) {
4190 SV * const sv = newSV(0);
4192 sv_setsv(sv, *MARK);
4193 av_store(ary, AvFILLp(ary)+1, sv);
4196 PUSHi( AvFILLp(ary) + 1 );
4205 AV * const av = (AV*)POPs;
4206 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4210 (void)sv_2mortal(sv);
4217 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4218 register AV *ary = (AV*)*++MARK;
4219 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4222 *MARK-- = SvTIED_obj((SV*)ary, mg);
4226 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4232 av_unshift(ary, SP - MARK);
4234 SV * const sv = newSVsv(*++MARK);
4235 (void)av_store(ary, i++, sv);
4239 PUSHi( AvFILL(ary) + 1 );
4246 SV ** const oldsp = SP;
4248 if (GIMME == G_ARRAY) {
4251 register SV * const tmp = *MARK;
4255 /* safe as long as stack cannot get extended in the above */
4260 register char *down;
4266 SvUTF8_off(TARG); /* decontaminate */
4268 do_join(TARG, &PL_sv_no, MARK, SP);
4270 sv_setsv(TARG, (SP > MARK)
4272 : (padoff_du = find_rundefsvoffset(),
4273 (padoff_du == NOT_IN_PAD
4274 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4275 ? DEFSV : PAD_SVl(padoff_du)));
4276 up = SvPV_force(TARG, len);
4278 if (DO_UTF8(TARG)) { /* first reverse each character */
4279 U8* s = (U8*)SvPVX(TARG);
4280 const U8* send = (U8*)(s + len);
4282 if (UTF8_IS_INVARIANT(*s)) {
4287 if (!utf8_to_uvchr(s, 0))
4291 down = (char*)(s - 1);
4292 /* reverse this character */
4296 *down-- = (char)tmp;
4302 down = SvPVX(TARG) + len - 1;
4306 *down-- = (char)tmp;
4308 (void)SvPOK_only_UTF8(TARG);
4320 register IV limit = POPi; /* note, negative is forever */
4321 SV * const sv = POPs;
4323 register const char *s = SvPV_const(sv, len);
4324 const bool do_utf8 = DO_UTF8(sv);
4325 const char *strend = s + len;
4327 register REGEXP *rx;
4329 register const char *m;
4331 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4332 I32 maxiters = slen + 10;
4334 const I32 origlimit = limit;
4337 const I32 gimme = GIMME_V;
4338 const I32 oldsave = PL_savestack_ix;
4339 I32 make_mortal = 1;
4344 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4349 DIE(aTHX_ "panic: pp_split");
4352 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4353 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4355 RX_MATCH_UTF8_set(rx, do_utf8);
4357 if (pm->op_pmreplroot) {
4359 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4361 ary = GvAVn((GV*)pm->op_pmreplroot);
4364 else if (gimme != G_ARRAY)
4365 ary = GvAVn(PL_defgv);
4368 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4374 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4376 XPUSHs(SvTIED_obj((SV*)ary, mg));
4383 for (i = AvFILLp(ary); i >= 0; i--)
4384 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4386 /* temporarily switch stacks */
4387 SAVESWITCHSTACK(PL_curstack, ary);
4391 base = SP - PL_stack_base;
4393 if (pm->op_pmflags & PMf_SKIPWHITE) {
4394 if (pm->op_pmflags & PMf_LOCALE) {
4395 while (isSPACE_LC(*s))
4403 if (pm->op_pmflags & PMf_MULTILINE) {
4408 limit = maxiters + 2;
4409 if (pm->op_pmflags & PMf_WHITE) {
4412 while (m < strend &&
4413 !((pm->op_pmflags & PMf_LOCALE)
4414 ? isSPACE_LC(*m) : isSPACE(*m)))
4419 dstr = newSVpvn(s, m-s);
4423 (void)SvUTF8_on(dstr);
4427 while (s < strend &&
4428 ((pm->op_pmflags & PMf_LOCALE)
4429 ? isSPACE_LC(*s) : isSPACE(*s)))
4433 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4435 for (m = s; m < strend && *m != '\n'; m++)
4440 dstr = newSVpvn(s, m-s);
4444 (void)SvUTF8_on(dstr);
4449 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4450 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4451 && (rx->reganch & ROPT_CHECK_ALL)
4452 && !(rx->reganch & ROPT_ANCH)) {
4453 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4454 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4457 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4458 const char c = *SvPV_nolen_const(csv);
4460 for (m = s; m < strend && *m != c; m++)
4464 dstr = newSVpvn(s, m-s);
4468 (void)SvUTF8_on(dstr);
4470 /* The rx->minlen is in characters but we want to step
4471 * s ahead by bytes. */
4473 s = (char*)utf8_hop((U8*)m, len);
4475 s = m + len; /* Fake \n at the end */
4479 while (s < strend && --limit &&
4480 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4481 csv, multiline ? FBMrf_MULTILINE : 0)) )
4483 dstr = newSVpvn(s, m-s);
4487 (void)SvUTF8_on(dstr);
4489 /* The rx->minlen is in characters but we want to step
4490 * s ahead by bytes. */
4492 s = (char*)utf8_hop((U8*)m, len);
4494 s = m + len; /* Fake \n at the end */
4499 maxiters += slen * rx->nparens;
4500 while (s < strend && --limit)
4504 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4507 if (rex_return == 0)
4509 TAINT_IF(RX_MATCH_TAINTED(rx));
4510 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4515 strend = s + (strend - m);
4517 m = rx->startp[0] + orig;
4518 dstr = newSVpvn(s, m-s);
4522 (void)SvUTF8_on(dstr);
4526 for (i = 1; i <= (I32)rx->nparens; i++) {
4527 s = rx->startp[i] + orig;
4528 m = rx->endp[i] + orig;
4530 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4531 parens that didn't match -- they should be set to
4532 undef, not the empty string */
4533 if (m >= orig && s >= orig) {
4534 dstr = newSVpvn(s, m-s);
4537 dstr = &PL_sv_undef; /* undef, not "" */
4541 (void)SvUTF8_on(dstr);
4545 s = rx->endp[0] + orig;
4549 iters = (SP - PL_stack_base) - base;
4550 if (iters > maxiters)
4551 DIE(aTHX_ "Split loop");
4553 /* keep field after final delim? */
4554 if (s < strend || (iters && origlimit)) {
4555 const STRLEN l = strend - s;
4556 dstr = newSVpvn(s, l);
4560 (void)SvUTF8_on(dstr);
4564 else if (!origlimit) {
4565 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4566 if (TOPs && !make_mortal)
4569 *SP-- = &PL_sv_undef;
4574 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4578 if (SvSMAGICAL(ary)) {
4583 if (gimme == G_ARRAY) {
4585 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4593 call_method("PUSH",G_SCALAR|G_DISCARD);
4596 if (gimme == G_ARRAY) {
4598 /* EXTEND should not be needed - we just popped them */
4600 for (i=0; i < iters; i++) {
4601 SV **svp = av_fetch(ary, i, FALSE);
4602 PUSHs((svp) ? *svp : &PL_sv_undef);
4609 if (gimme == G_ARRAY)
4625 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4626 || SvTYPE(retsv) == SVt_PVCV) {
4627 retsv = refto(retsv);
4634 PP(unimplemented_op)
4637 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4643 * c-indentation-style: bsd
4645 * indent-tabs-mode: t
4648 * ex: set ts=8 sts=4 sw=4 noet: