3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
34 it, since pid_t is an integral type.
37 #ifdef NEED_GETPID_PROTO
38 extern Pid_t getpid (void);
42 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
43 * This switches them over to IEEE.
45 #if defined(LIBM_LIB_VERSION)
46 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
49 /* variations on pp_null */
55 if (GIMME_V == G_SCALAR)
66 if (PL_op->op_private & OPpLVAL_INTRO)
67 if (!(PL_op->op_private & OPpPAD_STATE))
68 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
70 if (PL_op->op_flags & OPf_REF) {
74 if (GIMME == G_SCALAR)
75 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
80 if (gimme == G_ARRAY) {
81 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
83 if (SvMAGICAL(TARG)) {
85 for (i=0; i < (U32)maxarg; i++) {
86 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
87 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
91 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
95 else if (gimme == G_SCALAR) {
96 SV* const sv = sv_newmortal();
97 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
110 if (PL_op->op_private & OPpLVAL_INTRO)
111 if (!(PL_op->op_private & OPpPAD_STATE))
112 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
113 if (PL_op->op_flags & OPf_REF)
116 if (GIMME == G_SCALAR)
117 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
121 if (gimme == G_ARRAY) {
124 else if (gimme == G_SCALAR) {
125 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
139 tryAMAGICunDEREF(to_gv);
142 if (SvTYPE(sv) == SVt_PVIO) {
143 GV * const gv = MUTABLE_GV(sv_newmortal());
144 gv_init(gv, 0, "", 0, 0);
145 GvIOp(gv) = MUTABLE_IO(sv);
146 SvREFCNT_inc_void_NN(sv);
149 else if (!isGV_with_GP(sv))
150 DIE(aTHX_ "Not a GLOB reference");
153 if (!isGV_with_GP(sv)) {
154 if (SvGMAGICAL(sv)) {
159 if (!SvOK(sv) && sv != &PL_sv_undef) {
160 /* If this is a 'my' scalar and flag is set then vivify
164 Perl_croak(aTHX_ "%s", PL_no_modify);
165 if (PL_op->op_private & OPpDEREF) {
167 if (cUNOP->op_targ) {
169 SV * const namesv = PAD_SV(cUNOP->op_targ);
170 const char * const name = SvPV(namesv, len);
171 gv = MUTABLE_GV(newSV(0));
172 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
175 const char * const name = CopSTASHPV(PL_curcop);
178 prepare_SV_for_RV(sv);
179 SvRV_set(sv, MUTABLE_SV(gv));
184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
186 DIE(aTHX_ PL_no_usym, "a symbol");
187 if (ckWARN(WARN_UNINITIALIZED))
191 if ((PL_op->op_flags & OPf_SPECIAL) &&
192 !(PL_op->op_flags & OPf_MOD))
194 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
196 && (!is_gv_magical_sv(sv,0)
197 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
204 if (PL_op->op_private & HINT_STRICT_REFS)
205 DIE(aTHX_ PL_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), "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 = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
217 if (PL_op->op_private & OPpLVAL_INTRO)
218 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
223 /* Helper function for pp_rv2sv and pp_rv2av */
225 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
226 const svtype type, SV ***spp)
231 PERL_ARGS_ASSERT_SOFTREF2XV;
233 if (PL_op->op_private & HINT_STRICT_REFS) {
235 Perl_die(aTHX_ PL_no_symref_sv, sv, (SvCUR(sv)>32 ? "..." : ""), what);
237 Perl_die(aTHX_ PL_no_usym, what);
240 if (PL_op->op_flags & OPf_REF)
241 Perl_die(aTHX_ PL_no_usym, what);
242 if (ckWARN(WARN_UNINITIALIZED))
244 if (type != SVt_PV && GIMME_V == G_ARRAY) {
248 **spp = &PL_sv_undef;
251 if ((PL_op->op_flags & OPf_SPECIAL) &&
252 !(PL_op->op_flags & OPf_MOD))
254 gv = gv_fetchsv(sv, 0, type);
256 && (!is_gv_magical_sv(sv,0)
257 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
259 **spp = &PL_sv_undef;
264 gv = gv_fetchsv(sv, GV_ADD, type);
276 tryAMAGICunDEREF(to_sv);
279 switch (SvTYPE(sv)) {
285 DIE(aTHX_ "Not a SCALAR reference");
292 if (!isGV_with_GP(gv)) {
293 if (SvGMAGICAL(sv)) {
298 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
304 if (PL_op->op_flags & OPf_MOD) {
305 if (PL_op->op_private & OPpLVAL_INTRO) {
306 if (cUNOP->op_first->op_type == OP_NULL)
307 sv = save_scalar(MUTABLE_GV(TOPs));
309 sv = save_scalar(gv);
311 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
313 else if (PL_op->op_private & OPpDEREF)
314 vivify_ref(sv, PL_op->op_private & OPpDEREF);
323 AV * const av = MUTABLE_AV(TOPs);
324 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
326 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
328 *sv = newSV_type(SVt_PVMG);
329 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
333 SETs(sv_2mortal(newSViv(
334 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
342 dVAR; dSP; dTARGET; dPOPss;
344 if (PL_op->op_flags & OPf_MOD || LVRET) {
345 if (SvTYPE(TARG) < SVt_PVLV) {
346 sv_upgrade(TARG, SVt_PVLV);
347 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
351 if (LvTARG(TARG) != sv) {
353 SvREFCNT_dec(LvTARG(TARG));
354 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
356 PUSHs(TARG); /* no SvSETMAGIC */
360 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
361 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
362 if (mg && mg->mg_len >= 0) {
366 PUSHi(i + CopARYBASE_get(PL_curcop));
379 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
381 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
384 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
385 /* (But not in defined().) */
387 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
390 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
391 if ((PL_op->op_private & OPpLVAL_INTRO)) {
392 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
395 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
398 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
402 cv = MUTABLE_CV(&PL_sv_undef);
403 SETs(MUTABLE_SV(cv));
413 SV *ret = &PL_sv_undef;
415 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
416 const char * s = SvPVX_const(TOPs);
417 if (strnEQ(s, "CORE::", 6)) {
418 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
419 if (code < 0) { /* Overridable. */
420 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
421 int i = 0, n = 0, seen_question = 0, defgv = 0;
423 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
425 if (code == -KEY_chop || code == -KEY_chomp
426 || code == -KEY_exec || code == -KEY_system)
428 if (code == -KEY_mkdir) {
429 ret = newSVpvs_flags("_;$", SVs_TEMP);
432 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
433 ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
436 if (code == -KEY_readpipe) {
437 s = "CORE::backtick";
439 while (i < MAXO) { /* The slow way. */
440 if (strEQ(s + 6, PL_op_name[i])
441 || strEQ(s + 6, PL_op_desc[i]))
447 goto nonesuch; /* Should not happen... */
449 defgv = PL_opargs[i] & OA_DEFGV;
450 oa = PL_opargs[i] >> OASHIFT;
452 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
456 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
457 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
458 /* But globs are already references (kinda) */
459 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
463 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
466 if (defgv && str[n - 1] == '$')
469 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
471 else if (code) /* Non-Overridable */
473 else { /* None such */
475 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
479 cv = sv_2cv(TOPs, &stash, &gv, 0);
481 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
490 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
492 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
494 PUSHs(MUTABLE_SV(cv));
508 if (GIMME != G_ARRAY) {
512 *MARK = &PL_sv_undef;
513 *MARK = refto(*MARK);
517 EXTEND_MORTAL(SP - MARK);
519 *MARK = refto(*MARK);
524 S_refto(pTHX_ SV *sv)
529 PERL_ARGS_ASSERT_REFTO;
531 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
534 if (!(sv = LvTARG(sv)))
537 SvREFCNT_inc_void_NN(sv);
539 else if (SvTYPE(sv) == SVt_PVAV) {
540 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
541 av_reify(MUTABLE_AV(sv));
543 SvREFCNT_inc_void_NN(sv);
545 else if (SvPADTMP(sv) && !IS_PADGV(sv))
549 SvREFCNT_inc_void_NN(sv);
552 sv_upgrade(rv, SVt_IV);
562 SV * const sv = POPs;
567 if (!sv || !SvROK(sv))
570 pv = sv_reftype(SvRV(sv),TRUE);
571 PUSHp(pv, strlen(pv));
581 stash = CopSTASH(PL_curcop);
583 SV * const ssv = POPs;
587 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
588 Perl_croak(aTHX_ "Attempt to bless into a reference");
589 ptr = SvPV_const(ssv,len);
591 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
592 "Explicit blessing to '' (assuming package main)");
593 stash = gv_stashpvn(ptr, len, GV_ADD);
596 (void)sv_bless(TOPs, stash);
605 const char * const elem = SvPV_nolen_const(sv);
606 GV * const gv = MUTABLE_GV(POPs);
611 /* elem will always be NUL terminated. */
612 const char * const second_letter = elem + 1;
615 if (strEQ(second_letter, "RRAY"))
616 tmpRef = MUTABLE_SV(GvAV(gv));
619 if (strEQ(second_letter, "ODE"))
620 tmpRef = MUTABLE_SV(GvCVu(gv));
623 if (strEQ(second_letter, "ILEHANDLE")) {
624 /* finally deprecated in 5.8.0 */
625 deprecate("*glob{FILEHANDLE}");
626 tmpRef = MUTABLE_SV(GvIOp(gv));
629 if (strEQ(second_letter, "ORMAT"))
630 tmpRef = MUTABLE_SV(GvFORM(gv));
633 if (strEQ(second_letter, "LOB"))
634 tmpRef = MUTABLE_SV(gv);
637 if (strEQ(second_letter, "ASH"))
638 tmpRef = MUTABLE_SV(GvHV(gv));
641 if (*second_letter == 'O' && !elem[2])
642 tmpRef = MUTABLE_SV(GvIOp(gv));
645 if (strEQ(second_letter, "AME"))
646 sv = newSVhek(GvNAME_HEK(gv));
649 if (strEQ(second_letter, "ACKAGE")) {
650 const HV * const stash = GvSTASH(gv);
651 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
652 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
656 if (strEQ(second_letter, "CALAR"))
671 /* Pattern matching */
676 register unsigned char *s;
679 register I32 *sfirst;
683 if (sv == PL_lastscream) {
687 s = (unsigned char*)(SvPV(sv, len));
689 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
690 /* No point in studying a zero length string, and not safe to study
691 anything that doesn't appear to be a simple scalar (and hence might
692 change between now and when the regexp engine runs without our set
693 magic ever running) such as a reference to an object with overloaded
699 SvSCREAM_off(PL_lastscream);
700 SvREFCNT_dec(PL_lastscream);
702 PL_lastscream = SvREFCNT_inc_simple(sv);
704 s = (unsigned char*)(SvPV(sv, len));
708 if (pos > PL_maxscream) {
709 if (PL_maxscream < 0) {
710 PL_maxscream = pos + 80;
711 Newx(PL_screamfirst, 256, I32);
712 Newx(PL_screamnext, PL_maxscream, I32);
715 PL_maxscream = pos + pos / 4;
716 Renew(PL_screamnext, PL_maxscream, I32);
720 sfirst = PL_screamfirst;
721 snext = PL_screamnext;
723 if (!sfirst || !snext)
724 DIE(aTHX_ "do_study: out of memory");
726 for (ch = 256; ch; --ch)
731 register const I32 ch = s[pos];
733 snext[pos] = sfirst[ch] - pos;
740 /* piggyback on m//g magic */
741 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
750 if (PL_op->op_flags & OPf_STACKED)
752 else if (PL_op->op_private & OPpTARGET_MY)
758 TARG = sv_newmortal();
763 /* Lvalue operators. */
775 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
777 do_chop(TARG, *++MARK);
786 SETi(do_chomp(TOPs));
792 dVAR; dSP; dMARK; dTARGET;
793 register I32 count = 0;
796 count += do_chomp(POPs);
806 if (!PL_op->op_private) {
815 SV_CHECK_THINKFIRST_COW_DROP(sv);
817 switch (SvTYPE(sv)) {
821 av_undef(MUTABLE_AV(sv));
824 hv_undef(MUTABLE_HV(sv));
827 if (cv_const_sv((const CV *)sv))
828 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
829 CvANON((const CV *)sv) ? "(anonymous)"
830 : GvENAME(CvGV((const CV *)sv)));
834 /* let user-undef'd sub keep its identity */
835 GV* const gv = CvGV((const CV *)sv);
836 cv_undef(MUTABLE_CV(sv));
837 CvGV((const CV *)sv) = gv;
842 SvSetMagicSV(sv, &PL_sv_undef);
845 else if (isGV_with_GP(sv)) {
850 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
851 mro_isa_changed_in(stash);
852 /* undef *Pkg::meth_name ... */
853 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
854 && HvNAME_get(stash))
855 mro_method_changed_in(stash);
857 gp_free(MUTABLE_GV(sv));
859 GvGP(sv) = gp_ref(gp);
861 GvLINE(sv) = CopLINE(PL_curcop);
862 GvEGV(sv) = MUTABLE_GV(sv);
868 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
883 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
884 DIE(aTHX_ "%s", PL_no_modify);
885 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
886 && SvIVX(TOPs) != IV_MIN)
888 SvIV_set(TOPs, SvIVX(TOPs) - 1);
889 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
900 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
901 DIE(aTHX_ "%s", PL_no_modify);
902 sv_setsv(TARG, TOPs);
903 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
904 && SvIVX(TOPs) != IV_MAX)
906 SvIV_set(TOPs, SvIVX(TOPs) + 1);
907 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
912 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
922 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
923 DIE(aTHX_ "%s", PL_no_modify);
924 sv_setsv(TARG, TOPs);
925 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
926 && SvIVX(TOPs) != IV_MIN)
928 SvIV_set(TOPs, SvIVX(TOPs) - 1);
929 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
938 /* Ordinary operators. */
942 dVAR; dSP; dATARGET; SV *svl, *svr;
943 #ifdef PERL_PRESERVE_IVUV
946 tryAMAGICbin(pow,opASSIGN);
947 svl = sv_2num(TOPm1s);
949 #ifdef PERL_PRESERVE_IVUV
950 /* For integer to integer power, we do the calculation by hand wherever
951 we're sure it is safe; otherwise we call pow() and try to convert to
952 integer afterwards. */
965 const IV iv = SvIVX(svr);
969 goto float_it; /* Can't do negative powers this way. */
973 baseuok = SvUOK(svl);
977 const IV iv = SvIVX(svl);
980 baseuok = TRUE; /* effectively it's a UV now */
982 baseuv = -iv; /* abs, baseuok == false records sign */
985 /* now we have integer ** positive integer. */
988 /* foo & (foo - 1) is zero only for a power of 2. */
989 if (!(baseuv & (baseuv - 1))) {
990 /* We are raising power-of-2 to a positive integer.
991 The logic here will work for any base (even non-integer
992 bases) but it can be less accurate than
993 pow (base,power) or exp (power * log (base)) when the
994 intermediate values start to spill out of the mantissa.
995 With powers of 2 we know this can't happen.
996 And powers of 2 are the favourite thing for perl
997 programmers to notice ** not doing what they mean. */
999 NV base = baseuok ? baseuv : -(NV)baseuv;
1004 while (power >>= 1) {
1015 register unsigned int highbit = 8 * sizeof(UV);
1016 register unsigned int diff = 8 * sizeof(UV);
1017 while (diff >>= 1) {
1019 if (baseuv >> highbit) {
1023 /* we now have baseuv < 2 ** highbit */
1024 if (power * highbit <= 8 * sizeof(UV)) {
1025 /* result will definitely fit in UV, so use UV math
1026 on same algorithm as above */
1027 register UV result = 1;
1028 register UV base = baseuv;
1029 const bool odd_power = (bool)(power & 1);
1033 while (power >>= 1) {
1040 if (baseuok || !odd_power)
1041 /* answer is positive */
1043 else if (result <= (UV)IV_MAX)
1044 /* answer negative, fits in IV */
1045 SETi( -(IV)result );
1046 else if (result == (UV)IV_MIN)
1047 /* 2's complement assumption: special case IV_MIN */
1050 /* answer negative, doesn't fit */
1051 SETn( -(NV)result );
1061 NV right = SvNV(svr);
1062 NV left = SvNV(svl);
1065 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1067 We are building perl with long double support and are on an AIX OS
1068 afflicted with a powl() function that wrongly returns NaNQ for any
1069 negative base. This was reported to IBM as PMR #23047-379 on
1070 03/06/2006. The problem exists in at least the following versions
1071 of AIX and the libm fileset, and no doubt others as well:
1073 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1074 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1075 AIX 5.2.0 bos.adt.libm 5.2.0.85
1077 So, until IBM fixes powl(), we provide the following workaround to
1078 handle the problem ourselves. Our logic is as follows: for
1079 negative bases (left), we use fmod(right, 2) to check if the
1080 exponent is an odd or even integer:
1082 - if odd, powl(left, right) == -powl(-left, right)
1083 - if even, powl(left, right) == powl(-left, right)
1085 If the exponent is not an integer, the result is rightly NaNQ, so
1086 we just return that (as NV_NAN).
1090 NV mod2 = Perl_fmod( right, 2.0 );
1091 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1092 SETn( -Perl_pow( -left, right) );
1093 } else if (mod2 == 0.0) { /* even integer */
1094 SETn( Perl_pow( -left, right) );
1095 } else { /* fractional power */
1099 SETn( Perl_pow( left, right) );
1102 SETn( Perl_pow( left, right) );
1103 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1105 #ifdef PERL_PRESERVE_IVUV
1115 dVAR; dSP; dATARGET; SV *svl, *svr;
1116 tryAMAGICbin(mult,opASSIGN);
1117 svl = sv_2num(TOPm1s);
1118 svr = sv_2num(TOPs);
1119 #ifdef PERL_PRESERVE_IVUV
1122 /* Unless the left argument is integer in range we are going to have to
1123 use NV maths. Hence only attempt to coerce the right argument if
1124 we know the left is integer. */
1125 /* Left operand is defined, so is it IV? */
1128 bool auvok = SvUOK(svl);
1129 bool buvok = SvUOK(svr);
1130 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1131 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1140 const IV aiv = SvIVX(svl);
1143 auvok = TRUE; /* effectively it's a UV now */
1145 alow = -aiv; /* abs, auvok == false records sign */
1151 const IV biv = SvIVX(svr);
1154 buvok = TRUE; /* effectively it's a UV now */
1156 blow = -biv; /* abs, buvok == false records sign */
1160 /* If this does sign extension on unsigned it's time for plan B */
1161 ahigh = alow >> (4 * sizeof (UV));
1163 bhigh = blow >> (4 * sizeof (UV));
1165 if (ahigh && bhigh) {
1167 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1168 which is overflow. Drop to NVs below. */
1169 } else if (!ahigh && !bhigh) {
1170 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1171 so the unsigned multiply cannot overflow. */
1172 const UV product = alow * blow;
1173 if (auvok == buvok) {
1174 /* -ve * -ve or +ve * +ve gives a +ve result. */
1178 } else if (product <= (UV)IV_MIN) {
1179 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1180 /* -ve result, which could overflow an IV */
1182 SETi( -(IV)product );
1184 } /* else drop to NVs below. */
1186 /* One operand is large, 1 small */
1189 /* swap the operands */
1191 bhigh = blow; /* bhigh now the temp var for the swap */
1195 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1196 multiplies can't overflow. shift can, add can, -ve can. */
1197 product_middle = ahigh * blow;
1198 if (!(product_middle & topmask)) {
1199 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1201 product_middle <<= (4 * sizeof (UV));
1202 product_low = alow * blow;
1204 /* as for pp_add, UV + something mustn't get smaller.
1205 IIRC ANSI mandates this wrapping *behaviour* for
1206 unsigned whatever the actual representation*/
1207 product_low += product_middle;
1208 if (product_low >= product_middle) {
1209 /* didn't overflow */
1210 if (auvok == buvok) {
1211 /* -ve * -ve or +ve * +ve gives a +ve result. */
1213 SETu( product_low );
1215 } else if (product_low <= (UV)IV_MIN) {
1216 /* 2s complement assumption again */
1217 /* -ve result, which could overflow an IV */
1219 SETi( -(IV)product_low );
1221 } /* else drop to NVs below. */
1223 } /* product_middle too large */
1224 } /* ahigh && bhigh */
1229 NV right = SvNV(svr);
1230 NV left = SvNV(svl);
1232 SETn( left * right );
1239 dVAR; dSP; dATARGET; SV *svl, *svr;
1240 tryAMAGICbin(div,opASSIGN);
1241 svl = sv_2num(TOPm1s);
1242 svr = sv_2num(TOPs);
1243 /* Only try to do UV divide first
1244 if ((SLOPPYDIVIDE is true) or
1245 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1247 The assumption is that it is better to use floating point divide
1248 whenever possible, only doing integer divide first if we can't be sure.
1249 If NV_PRESERVES_UV is true then we know at compile time that no UV
1250 can be too large to preserve, so don't need to compile the code to
1251 test the size of UVs. */
1254 # define PERL_TRY_UV_DIVIDE
1255 /* ensure that 20./5. == 4. */
1257 # ifdef PERL_PRESERVE_IVUV
1258 # ifndef NV_PRESERVES_UV
1259 # define PERL_TRY_UV_DIVIDE
1264 #ifdef PERL_TRY_UV_DIVIDE
1269 bool left_non_neg = SvUOK(svl);
1270 bool right_non_neg = SvUOK(svr);
1274 if (right_non_neg) {
1278 const IV biv = SvIVX(svr);
1281 right_non_neg = TRUE; /* effectively it's a UV now */
1287 /* historically undef()/0 gives a "Use of uninitialized value"
1288 warning before dieing, hence this test goes here.
1289 If it were immediately before the second SvIV_please, then
1290 DIE() would be invoked before left was even inspected, so
1291 no inpsection would give no warning. */
1293 DIE(aTHX_ "Illegal division by zero");
1299 const IV aiv = SvIVX(svl);
1302 left_non_neg = TRUE; /* effectively it's a UV now */
1311 /* For sloppy divide we always attempt integer division. */
1313 /* Otherwise we only attempt it if either or both operands
1314 would not be preserved by an NV. If both fit in NVs
1315 we fall through to the NV divide code below. However,
1316 as left >= right to ensure integer result here, we know that
1317 we can skip the test on the right operand - right big
1318 enough not to be preserved can't get here unless left is
1321 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1324 /* Integer division can't overflow, but it can be imprecise. */
1325 const UV result = left / right;
1326 if (result * right == left) {
1327 SP--; /* result is valid */
1328 if (left_non_neg == right_non_neg) {
1329 /* signs identical, result is positive. */
1333 /* 2s complement assumption */
1334 if (result <= (UV)IV_MIN)
1335 SETi( -(IV)result );
1337 /* It's exact but too negative for IV. */
1338 SETn( -(NV)result );
1341 } /* tried integer divide but it was not an integer result */
1342 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1343 } /* left wasn't SvIOK */
1344 } /* right wasn't SvIOK */
1345 #endif /* PERL_TRY_UV_DIVIDE */
1347 NV right = SvNV(svr);
1348 NV left = SvNV(svl);
1349 (void)POPs;(void)POPs;
1350 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1351 if (! Perl_isnan(right) && right == 0.0)
1355 DIE(aTHX_ "Illegal division by zero");
1356 PUSHn( left / right );
1363 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1367 bool left_neg = FALSE;
1368 bool right_neg = FALSE;
1369 bool use_double = FALSE;
1370 bool dright_valid = FALSE;
1374 SV * const svr = sv_2num(TOPs);
1377 right_neg = !SvUOK(svr);
1381 const IV biv = SvIVX(svr);
1384 right_neg = FALSE; /* effectively it's a UV now */
1392 right_neg = dright < 0;
1395 if (dright < UV_MAX_P1) {
1396 right = U_V(dright);
1397 dright_valid = TRUE; /* In case we need to use double below. */
1404 /* At this point use_double is only true if right is out of range for
1405 a UV. In range NV has been rounded down to nearest UV and
1406 use_double false. */
1407 svl = sv_2num(TOPs);
1409 if (!use_double && SvIOK(svl)) {
1411 left_neg = !SvUOK(svl);
1415 const IV aiv = SvIVX(svl);
1418 left_neg = FALSE; /* effectively it's a UV now */
1427 left_neg = dleft < 0;
1431 /* This should be exactly the 5.6 behaviour - if left and right are
1432 both in range for UV then use U_V() rather than floor. */
1434 if (dleft < UV_MAX_P1) {
1435 /* right was in range, so is dleft, so use UVs not double.
1439 /* left is out of range for UV, right was in range, so promote
1440 right (back) to double. */
1442 /* The +0.5 is used in 5.6 even though it is not strictly
1443 consistent with the implicit +0 floor in the U_V()
1444 inside the #if 1. */
1445 dleft = Perl_floor(dleft + 0.5);
1448 dright = Perl_floor(dright + 0.5);
1459 DIE(aTHX_ "Illegal modulus zero");
1461 dans = Perl_fmod(dleft, dright);
1462 if ((left_neg != right_neg) && dans)
1463 dans = dright - dans;
1466 sv_setnv(TARG, dans);
1472 DIE(aTHX_ "Illegal modulus zero");
1475 if ((left_neg != right_neg) && ans)
1478 /* XXX may warn: unary minus operator applied to unsigned type */
1479 /* could change -foo to be (~foo)+1 instead */
1480 if (ans <= ~((UV)IV_MAX)+1)
1481 sv_setiv(TARG, ~ans+1);
1483 sv_setnv(TARG, -(NV)ans);
1486 sv_setuv(TARG, ans);
1495 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1502 const UV uv = SvUV(sv);
1504 count = IV_MAX; /* The best we can do? */
1508 const IV iv = SvIV(sv);
1515 else if (SvNOKp(sv)) {
1516 const NV nv = SvNV(sv);
1524 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1526 static const char oom_list_extend[] = "Out of memory during list extend";
1527 const I32 items = SP - MARK;
1528 const I32 max = items * count;
1530 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1531 /* Did the max computation overflow? */
1532 if (items > 0 && max > 0 && (max < items || max < count))
1533 Perl_croak(aTHX_ oom_list_extend);
1538 /* This code was intended to fix 20010809.028:
1541 for (($x =~ /./g) x 2) {
1542 print chop; # "abcdabcd" expected as output.
1545 * but that change (#11635) broke this code:
1547 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1549 * I can't think of a better fix that doesn't introduce
1550 * an efficiency hit by copying the SVs. The stack isn't
1551 * refcounted, and mortalisation obviously doesn't
1552 * Do The Right Thing when the stack has more than
1553 * one pointer to the same mortal value.
1557 *SP = sv_2mortal(newSVsv(*SP));
1567 repeatcpy((char*)(MARK + items), (char*)MARK,
1568 items * sizeof(const SV *), count - 1);
1571 else if (count <= 0)
1574 else { /* Note: mark already snarfed by pp_list */
1575 SV * const tmpstr = POPs;
1578 static const char oom_string_extend[] =
1579 "Out of memory during string extend";
1581 SvSetSV(TARG, tmpstr);
1582 SvPV_force(TARG, len);
1583 isutf = DO_UTF8(TARG);
1588 const STRLEN max = (UV)count * len;
1589 if (len > MEM_SIZE_MAX / count)
1590 Perl_croak(aTHX_ oom_string_extend);
1591 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1592 SvGROW(TARG, max + 1);
1593 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1594 SvCUR_set(TARG, SvCUR(TARG) * count);
1596 *SvEND(TARG) = '\0';
1599 (void)SvPOK_only_UTF8(TARG);
1601 (void)SvPOK_only(TARG);
1603 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1604 /* The parser saw this as a list repeat, and there
1605 are probably several items on the stack. But we're
1606 in scalar context, and there's no pp_list to save us
1607 now. So drop the rest of the items -- robin@kitsite.com
1620 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1621 tryAMAGICbin(subtr,opASSIGN);
1622 svl = sv_2num(TOPm1s);
1623 svr = sv_2num(TOPs);
1624 useleft = USE_LEFT(svl);
1625 #ifdef PERL_PRESERVE_IVUV
1626 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1627 "bad things" happen if you rely on signed integers wrapping. */
1630 /* Unless the left argument is integer in range we are going to have to
1631 use NV maths. Hence only attempt to coerce the right argument if
1632 we know the left is integer. */
1633 register UV auv = 0;
1639 a_valid = auvok = 1;
1640 /* left operand is undef, treat as zero. */
1642 /* Left operand is defined, so is it IV? */
1645 if ((auvok = SvUOK(svl)))
1648 register const IV aiv = SvIVX(svl);
1651 auvok = 1; /* Now acting as a sign flag. */
1652 } else { /* 2s complement assumption for IV_MIN */
1660 bool result_good = 0;
1663 bool buvok = SvUOK(svr);
1668 register const IV biv = SvIVX(svr);
1675 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1676 else "IV" now, independent of how it came in.
1677 if a, b represents positive, A, B negative, a maps to -A etc
1682 all UV maths. negate result if A negative.
1683 subtract if signs same, add if signs differ. */
1685 if (auvok ^ buvok) {
1694 /* Must get smaller */
1699 if (result <= buv) {
1700 /* result really should be -(auv-buv). as its negation
1701 of true value, need to swap our result flag */
1713 if (result <= (UV)IV_MIN)
1714 SETi( -(IV)result );
1716 /* result valid, but out of range for IV. */
1717 SETn( -(NV)result );
1721 } /* Overflow, drop through to NVs. */
1726 NV value = SvNV(svr);
1730 /* left operand is undef, treat as zero - value */
1734 SETn( SvNV(svl) - value );
1741 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1743 const IV shift = POPi;
1744 if (PL_op->op_private & HINT_INTEGER) {
1758 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1760 const IV shift = POPi;
1761 if (PL_op->op_private & HINT_INTEGER) {
1775 dVAR; dSP; tryAMAGICbinSET(lt,0);
1776 #ifdef PERL_PRESERVE_IVUV
1779 SvIV_please(TOPm1s);
1780 if (SvIOK(TOPm1s)) {
1781 bool auvok = SvUOK(TOPm1s);
1782 bool buvok = SvUOK(TOPs);
1784 if (!auvok && !buvok) { /* ## IV < IV ## */
1785 const IV aiv = SvIVX(TOPm1s);
1786 const IV biv = SvIVX(TOPs);
1789 SETs(boolSV(aiv < biv));
1792 if (auvok && buvok) { /* ## UV < UV ## */
1793 const UV auv = SvUVX(TOPm1s);
1794 const UV buv = SvUVX(TOPs);
1797 SETs(boolSV(auv < buv));
1800 if (auvok) { /* ## UV < IV ## */
1802 const IV biv = SvIVX(TOPs);
1805 /* As (a) is a UV, it's >=0, so it cannot be < */
1810 SETs(boolSV(auv < (UV)biv));
1813 { /* ## IV < UV ## */
1814 const IV aiv = SvIVX(TOPm1s);
1818 /* As (b) is a UV, it's >=0, so it must be < */
1825 SETs(boolSV((UV)aiv < buv));
1831 #ifndef NV_PRESERVES_UV
1832 #ifdef PERL_PRESERVE_IVUV
1835 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1837 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1842 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1844 if (Perl_isnan(left) || Perl_isnan(right))
1846 SETs(boolSV(left < right));
1849 SETs(boolSV(TOPn < value));
1857 dVAR; dSP; tryAMAGICbinSET(gt,0);
1858 #ifdef PERL_PRESERVE_IVUV
1861 SvIV_please(TOPm1s);
1862 if (SvIOK(TOPm1s)) {
1863 bool auvok = SvUOK(TOPm1s);
1864 bool buvok = SvUOK(TOPs);
1866 if (!auvok && !buvok) { /* ## IV > IV ## */
1867 const IV aiv = SvIVX(TOPm1s);
1868 const IV biv = SvIVX(TOPs);
1871 SETs(boolSV(aiv > biv));
1874 if (auvok && buvok) { /* ## UV > UV ## */
1875 const UV auv = SvUVX(TOPm1s);
1876 const UV buv = SvUVX(TOPs);
1879 SETs(boolSV(auv > buv));
1882 if (auvok) { /* ## UV > IV ## */
1884 const IV biv = SvIVX(TOPs);
1888 /* As (a) is a UV, it's >=0, so it must be > */
1893 SETs(boolSV(auv > (UV)biv));
1896 { /* ## IV > UV ## */
1897 const IV aiv = SvIVX(TOPm1s);
1901 /* As (b) is a UV, it's >=0, so it cannot be > */
1908 SETs(boolSV((UV)aiv > buv));
1914 #ifndef NV_PRESERVES_UV
1915 #ifdef PERL_PRESERVE_IVUV
1918 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1920 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1925 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1927 if (Perl_isnan(left) || Perl_isnan(right))
1929 SETs(boolSV(left > right));
1932 SETs(boolSV(TOPn > value));
1940 dVAR; dSP; tryAMAGICbinSET(le,0);
1941 #ifdef PERL_PRESERVE_IVUV
1944 SvIV_please(TOPm1s);
1945 if (SvIOK(TOPm1s)) {
1946 bool auvok = SvUOK(TOPm1s);
1947 bool buvok = SvUOK(TOPs);
1949 if (!auvok && !buvok) { /* ## IV <= IV ## */
1950 const IV aiv = SvIVX(TOPm1s);
1951 const IV biv = SvIVX(TOPs);
1954 SETs(boolSV(aiv <= biv));
1957 if (auvok && buvok) { /* ## UV <= UV ## */
1958 UV auv = SvUVX(TOPm1s);
1959 UV buv = SvUVX(TOPs);
1962 SETs(boolSV(auv <= buv));
1965 if (auvok) { /* ## UV <= IV ## */
1967 const IV biv = SvIVX(TOPs);
1971 /* As (a) is a UV, it's >=0, so a cannot be <= */
1976 SETs(boolSV(auv <= (UV)biv));
1979 { /* ## IV <= UV ## */
1980 const IV aiv = SvIVX(TOPm1s);
1984 /* As (b) is a UV, it's >=0, so a must be <= */
1991 SETs(boolSV((UV)aiv <= buv));
1997 #ifndef NV_PRESERVES_UV
1998 #ifdef PERL_PRESERVE_IVUV
2001 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2003 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2008 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2010 if (Perl_isnan(left) || Perl_isnan(right))
2012 SETs(boolSV(left <= right));
2015 SETs(boolSV(TOPn <= value));
2023 dVAR; dSP; tryAMAGICbinSET(ge,0);
2024 #ifdef PERL_PRESERVE_IVUV
2027 SvIV_please(TOPm1s);
2028 if (SvIOK(TOPm1s)) {
2029 bool auvok = SvUOK(TOPm1s);
2030 bool buvok = SvUOK(TOPs);
2032 if (!auvok && !buvok) { /* ## IV >= IV ## */
2033 const IV aiv = SvIVX(TOPm1s);
2034 const IV biv = SvIVX(TOPs);
2037 SETs(boolSV(aiv >= biv));
2040 if (auvok && buvok) { /* ## UV >= UV ## */
2041 const UV auv = SvUVX(TOPm1s);
2042 const UV buv = SvUVX(TOPs);
2045 SETs(boolSV(auv >= buv));
2048 if (auvok) { /* ## UV >= IV ## */
2050 const IV biv = SvIVX(TOPs);
2054 /* As (a) is a UV, it's >=0, so it must be >= */
2059 SETs(boolSV(auv >= (UV)biv));
2062 { /* ## IV >= UV ## */
2063 const IV aiv = SvIVX(TOPm1s);
2067 /* As (b) is a UV, it's >=0, so a cannot be >= */
2074 SETs(boolSV((UV)aiv >= buv));
2080 #ifndef NV_PRESERVES_UV
2081 #ifdef PERL_PRESERVE_IVUV
2084 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2086 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2091 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2093 if (Perl_isnan(left) || Perl_isnan(right))
2095 SETs(boolSV(left >= right));
2098 SETs(boolSV(TOPn >= value));
2106 dVAR; dSP; tryAMAGICbinSET(ne,0);
2107 #ifndef NV_PRESERVES_UV
2108 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2110 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2114 #ifdef PERL_PRESERVE_IVUV
2117 SvIV_please(TOPm1s);
2118 if (SvIOK(TOPm1s)) {
2119 const bool auvok = SvUOK(TOPm1s);
2120 const bool buvok = SvUOK(TOPs);
2122 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2123 /* Casting IV to UV before comparison isn't going to matter
2124 on 2s complement. On 1s complement or sign&magnitude
2125 (if we have any of them) it could make negative zero
2126 differ from normal zero. As I understand it. (Need to
2127 check - is negative zero implementation defined behaviour
2129 const UV buv = SvUVX(POPs);
2130 const UV auv = SvUVX(TOPs);
2132 SETs(boolSV(auv != buv));
2135 { /* ## Mixed IV,UV ## */
2139 /* != is commutative so swap if needed (save code) */
2141 /* swap. top of stack (b) is the iv */
2145 /* As (a) is a UV, it's >0, so it cannot be == */
2154 /* As (b) is a UV, it's >0, so it cannot be == */
2158 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2160 SETs(boolSV((UV)iv != uv));
2167 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2169 if (Perl_isnan(left) || Perl_isnan(right))
2171 SETs(boolSV(left != right));
2174 SETs(boolSV(TOPn != value));
2182 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2183 #ifndef NV_PRESERVES_UV
2184 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2185 const UV right = PTR2UV(SvRV(POPs));
2186 const UV left = PTR2UV(SvRV(TOPs));
2187 SETi((left > right) - (left < right));
2191 #ifdef PERL_PRESERVE_IVUV
2192 /* Fortunately it seems NaN isn't IOK */
2195 SvIV_please(TOPm1s);
2196 if (SvIOK(TOPm1s)) {
2197 const bool leftuvok = SvUOK(TOPm1s);
2198 const bool rightuvok = SvUOK(TOPs);
2200 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2201 const IV leftiv = SvIVX(TOPm1s);
2202 const IV rightiv = SvIVX(TOPs);
2204 if (leftiv > rightiv)
2206 else if (leftiv < rightiv)
2210 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2211 const UV leftuv = SvUVX(TOPm1s);
2212 const UV rightuv = SvUVX(TOPs);
2214 if (leftuv > rightuv)
2216 else if (leftuv < rightuv)
2220 } else if (leftuvok) { /* ## UV <=> IV ## */
2221 const IV rightiv = SvIVX(TOPs);
2223 /* As (a) is a UV, it's >=0, so it cannot be < */
2226 const UV leftuv = SvUVX(TOPm1s);
2227 if (leftuv > (UV)rightiv) {
2229 } else if (leftuv < (UV)rightiv) {
2235 } else { /* ## IV <=> UV ## */
2236 const IV leftiv = SvIVX(TOPm1s);
2238 /* As (b) is a UV, it's >=0, so it must be < */
2241 const UV rightuv = SvUVX(TOPs);
2242 if ((UV)leftiv > rightuv) {
2244 } else if ((UV)leftiv < rightuv) {
2262 if (Perl_isnan(left) || Perl_isnan(right)) {
2266 value = (left > right) - (left < right);
2270 else if (left < right)
2272 else if (left > right)
2288 int amg_type = sle_amg;
2292 switch (PL_op->op_type) {
2311 tryAMAGICbinSET_var(amg_type,0);
2314 const int cmp = (IN_LOCALE_RUNTIME
2315 ? sv_cmp_locale(left, right)
2316 : sv_cmp(left, right));
2317 SETs(boolSV(cmp * multiplier < rhs));
2324 dVAR; dSP; tryAMAGICbinSET(seq,0);
2327 SETs(boolSV(sv_eq(left, right)));
2334 dVAR; dSP; tryAMAGICbinSET(sne,0);
2337 SETs(boolSV(!sv_eq(left, right)));
2344 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2347 const int cmp = (IN_LOCALE_RUNTIME
2348 ? sv_cmp_locale(left, right)
2349 : sv_cmp(left, right));
2357 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2362 if (SvNIOKp(left) || SvNIOKp(right)) {
2363 if (PL_op->op_private & HINT_INTEGER) {
2364 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2368 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2373 do_vop(PL_op->op_type, TARG, left, right);
2382 dVAR; dSP; dATARGET;
2383 const int op_type = PL_op->op_type;
2385 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2390 if (SvNIOKp(left) || SvNIOKp(right)) {
2391 if (PL_op->op_private & HINT_INTEGER) {
2392 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2393 const IV r = SvIV_nomg(right);
2394 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2398 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2399 const UV r = SvUV_nomg(right);
2400 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2405 do_vop(op_type, TARG, left, right);
2414 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2416 SV * const sv = sv_2num(TOPs);
2417 const int flags = SvFLAGS(sv);
2419 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2420 /* It's publicly an integer, or privately an integer-not-float */
2423 if (SvIVX(sv) == IV_MIN) {
2424 /* 2s complement assumption. */
2425 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2428 else if (SvUVX(sv) <= IV_MAX) {
2433 else if (SvIVX(sv) != IV_MIN) {
2437 #ifdef PERL_PRESERVE_IVUV
2446 else if (SvPOKp(sv)) {
2448 const char * const s = SvPV_const(sv, len);
2449 if (isIDFIRST(*s)) {
2450 sv_setpvs(TARG, "-");
2453 else if (*s == '+' || *s == '-') {
2455 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2457 else if (DO_UTF8(sv)) {
2460 goto oops_its_an_int;
2462 sv_setnv(TARG, -SvNV(sv));
2464 sv_setpvs(TARG, "-");
2471 goto oops_its_an_int;
2472 sv_setnv(TARG, -SvNV(sv));
2484 dVAR; dSP; tryAMAGICunSET(not);
2485 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2491 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2496 if (PL_op->op_private & HINT_INTEGER) {
2497 const IV i = ~SvIV_nomg(sv);
2501 const UV u = ~SvUV_nomg(sv);
2510 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2511 sv_setsv_nomg(TARG, sv);
2512 tmps = (U8*)SvPV_force(TARG, len);
2515 /* Calculate exact length, let's not estimate. */
2520 U8 * const send = tmps + len;
2521 U8 * const origtmps = tmps;
2522 const UV utf8flags = UTF8_ALLOW_ANYUV;
2524 while (tmps < send) {
2525 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2527 targlen += UNISKIP(~c);
2533 /* Now rewind strings and write them. */
2540 Newx(result, targlen + 1, U8);
2542 while (tmps < send) {
2543 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2545 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2548 sv_usepvn_flags(TARG, (char*)result, targlen,
2549 SV_HAS_TRAILING_NUL);
2556 Newx(result, nchar + 1, U8);
2558 while (tmps < send) {
2559 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2564 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2572 register long *tmpl;
2573 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2576 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2581 for ( ; anum > 0; anum--, tmps++)
2589 /* integer versions of some of the above */
2593 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2596 SETi( left * right );
2604 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2608 DIE(aTHX_ "Illegal division by zero");
2611 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2615 value = num / value;
2621 #if defined(__GLIBC__) && IVSIZE == 8
2628 /* This is the vanilla old i_modulo. */
2629 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2633 DIE(aTHX_ "Illegal modulus zero");
2634 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2638 SETi( left % right );
2643 #if defined(__GLIBC__) && IVSIZE == 8
2648 /* This is the i_modulo with the workaround for the _moddi3 bug
2649 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2650 * See below for pp_i_modulo. */
2651 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2655 DIE(aTHX_ "Illegal modulus zero");
2656 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2660 SETi( left % PERL_ABS(right) );
2667 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2671 DIE(aTHX_ "Illegal modulus zero");
2672 /* The assumption is to use hereafter the old vanilla version... */
2674 PL_ppaddr[OP_I_MODULO] =
2676 /* .. but if we have glibc, we might have a buggy _moddi3
2677 * (at least glicb 2.2.5 is known to have this bug), in other
2678 * words our integer modulus with negative quad as the second
2679 * argument might be broken. Test for this and re-patch the
2680 * opcode dispatch table if that is the case, remembering to
2681 * also apply the workaround so that this first round works
2682 * right, too. See [perl #9402] for more information. */
2686 /* Cannot do this check with inlined IV constants since
2687 * that seems to work correctly even with the buggy glibc. */
2689 /* Yikes, we have the bug.
2690 * Patch in the workaround version. */
2692 PL_ppaddr[OP_I_MODULO] =
2693 &Perl_pp_i_modulo_1;
2694 /* Make certain we work right this time, too. */
2695 right = PERL_ABS(right);
2698 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2702 SETi( left % right );
2710 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2713 SETi( left + right );
2720 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2723 SETi( left - right );
2730 dVAR; dSP; tryAMAGICbinSET(lt,0);
2733 SETs(boolSV(left < right));
2740 dVAR; dSP; tryAMAGICbinSET(gt,0);
2743 SETs(boolSV(left > right));
2750 dVAR; dSP; tryAMAGICbinSET(le,0);
2753 SETs(boolSV(left <= right));
2760 dVAR; dSP; tryAMAGICbinSET(ge,0);
2763 SETs(boolSV(left >= right));
2770 dVAR; dSP; tryAMAGICbinSET(eq,0);
2773 SETs(boolSV(left == right));
2780 dVAR; dSP; tryAMAGICbinSET(ne,0);
2783 SETs(boolSV(left != right));
2790 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2797 else if (left < right)
2808 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2813 /* High falutin' math. */
2817 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2820 SETn(Perl_atan2(left, right));
2828 int amg_type = sin_amg;
2829 const char *neg_report = NULL;
2830 NV (*func)(NV) = Perl_sin;
2831 const int op_type = PL_op->op_type;
2848 amg_type = sqrt_amg;
2850 neg_report = "sqrt";
2854 tryAMAGICun_var(amg_type);
2856 const NV value = POPn;
2858 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2859 SET_NUMERIC_STANDARD();
2860 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2863 XPUSHn(func(value));
2868 /* Support Configure command-line overrides for rand() functions.
2869 After 5.005, perhaps we should replace this by Configure support
2870 for drand48(), random(), or rand(). For 5.005, though, maintain
2871 compatibility by calling rand() but allow the user to override it.
2872 See INSTALL for details. --Andy Dougherty 15 July 1998
2874 /* Now it's after 5.005, and Configure supports drand48() and random(),
2875 in addition to rand(). So the overrides should not be needed any more.
2876 --Jarkko Hietaniemi 27 September 1998
2879 #ifndef HAS_DRAND48_PROTO
2880 extern double drand48 (void);
2893 if (!PL_srand_called) {
2894 (void)seedDrand01((Rand_seed_t)seed());
2895 PL_srand_called = TRUE;
2905 const UV anum = (MAXARG < 1) ? seed() : POPu;
2906 (void)seedDrand01((Rand_seed_t)anum);
2907 PL_srand_called = TRUE;
2914 dVAR; dSP; dTARGET; tryAMAGICun(int);
2916 SV * const sv = sv_2num(TOPs);
2917 const IV iv = SvIV(sv);
2918 /* XXX it's arguable that compiler casting to IV might be subtly
2919 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2920 else preferring IV has introduced a subtle behaviour change bug. OTOH
2921 relying on floating point to be accurate is a bug. */
2926 else if (SvIOK(sv)) {
2933 const NV value = SvNV(sv);
2935 if (value < (NV)UV_MAX + 0.5) {
2938 SETn(Perl_floor(value));
2942 if (value > (NV)IV_MIN - 0.5) {
2945 SETn(Perl_ceil(value));
2955 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2957 SV * const sv = sv_2num(TOPs);
2958 /* This will cache the NV value if string isn't actually integer */
2959 const IV iv = SvIV(sv);
2964 else if (SvIOK(sv)) {
2965 /* IVX is precise */
2967 SETu(SvUV(sv)); /* force it to be numeric only */
2975 /* 2s complement assumption. Also, not really needed as
2976 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2982 const NV value = SvNV(sv);
2996 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3000 SV* const sv = POPs;
3002 tmps = (SvPV_const(sv, len));
3004 /* If Unicode, try to downgrade
3005 * If not possible, croak. */
3006 SV* const tsv = sv_2mortal(newSVsv(sv));
3009 sv_utf8_downgrade(tsv, FALSE);
3010 tmps = SvPV_const(tsv, len);
3012 if (PL_op->op_type == OP_HEX)
3015 while (*tmps && len && isSPACE(*tmps))
3021 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3023 else if (*tmps == 'b')
3024 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3026 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3028 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3042 SV * const sv = TOPs;
3044 if (SvGAMAGIC(sv)) {
3045 /* For an overloaded or magic scalar, we can't know in advance if
3046 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3047 it likes to cache the length. Maybe that should be a documented
3052 = sv_2pv_flags(sv, &len,
3053 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3057 else if (DO_UTF8(sv)) {
3058 SETi(utf8_length((U8*)p, (U8*)p + len));
3062 } else if (SvOK(sv)) {
3063 /* Neither magic nor overloaded. */
3065 SETi(sv_len_utf8(sv));
3084 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3086 const I32 arybase = CopARYBASE_get(PL_curcop);
3088 const char *repl = NULL;
3090 const int num_args = PL_op->op_private & 7;
3091 bool repl_need_utf8_upgrade = FALSE;
3092 bool repl_is_utf8 = FALSE;
3094 SvTAINTED_off(TARG); /* decontaminate */
3095 SvUTF8_off(TARG); /* decontaminate */
3099 repl = SvPV_const(repl_sv, repl_len);
3100 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3110 sv_utf8_upgrade(sv);
3112 else if (DO_UTF8(sv))
3113 repl_need_utf8_upgrade = TRUE;
3115 tmps = SvPV_const(sv, curlen);
3117 utf8_curlen = sv_len_utf8(sv);
3118 if (utf8_curlen == curlen)
3121 curlen = utf8_curlen;
3126 if (pos >= arybase) {
3144 else if (len >= 0) {
3146 if (rem > (I32)curlen)
3161 Perl_croak(aTHX_ "substr outside of string");
3162 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3166 const I32 upos = pos;
3167 const I32 urem = rem;
3169 sv_pos_u2b(sv, &pos, &rem);
3171 /* we either return a PV or an LV. If the TARG hasn't been used
3172 * before, or is of that type, reuse it; otherwise use a mortal
3173 * instead. Note that LVs can have an extended lifetime, so also
3174 * dont reuse if refcount > 1 (bug #20933) */
3175 if (SvTYPE(TARG) > SVt_NULL) {
3176 if ( (SvTYPE(TARG) == SVt_PVLV)
3177 ? (!lvalue || SvREFCNT(TARG) > 1)
3180 TARG = sv_newmortal();
3184 sv_setpvn(TARG, tmps, rem);
3185 #ifdef USE_LOCALE_COLLATE
3186 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3191 SV* repl_sv_copy = NULL;
3193 if (repl_need_utf8_upgrade) {
3194 repl_sv_copy = newSVsv(repl_sv);
3195 sv_utf8_upgrade(repl_sv_copy);
3196 repl = SvPV_const(repl_sv_copy, repl_len);
3197 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3201 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3205 SvREFCNT_dec(repl_sv_copy);
3207 else if (lvalue) { /* it's an lvalue! */
3208 if (!SvGMAGICAL(sv)) {
3210 SvPV_force_nolen(sv);
3211 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3212 "Attempt to use reference as lvalue in substr");
3214 if (isGV_with_GP(sv))
3215 SvPV_force_nolen(sv);
3216 else if (SvOK(sv)) /* is it defined ? */
3217 (void)SvPOK_only_UTF8(sv);
3219 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3222 if (SvTYPE(TARG) < SVt_PVLV) {
3223 sv_upgrade(TARG, SVt_PVLV);
3224 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3228 if (LvTARG(TARG) != sv) {
3230 SvREFCNT_dec(LvTARG(TARG));
3231 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3233 LvTARGOFF(TARG) = upos;
3234 LvTARGLEN(TARG) = urem;
3238 PUSHs(TARG); /* avoid SvSETMAGIC here */
3245 register const IV size = POPi;
3246 register const IV offset = POPi;
3247 register SV * const src = POPs;
3248 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3250 SvTAINTED_off(TARG); /* decontaminate */
3251 if (lvalue) { /* it's an lvalue! */
3252 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3253 TARG = sv_newmortal();
3254 if (SvTYPE(TARG) < SVt_PVLV) {
3255 sv_upgrade(TARG, SVt_PVLV);
3256 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3259 if (LvTARG(TARG) != src) {
3261 SvREFCNT_dec(LvTARG(TARG));
3262 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3264 LvTARGOFF(TARG) = offset;
3265 LvTARGLEN(TARG) = size;
3268 sv_setuv(TARG, do_vecget(src, offset, size));
3284 const char *little_p;
3285 const I32 arybase = CopARYBASE_get(PL_curcop);
3288 const bool is_index = PL_op->op_type == OP_INDEX;
3291 /* arybase is in characters, like offset, so combine prior to the
3292 UTF-8 to bytes calculation. */
3293 offset = POPi - arybase;
3297 big_p = SvPV_const(big, biglen);
3298 little_p = SvPV_const(little, llen);
3300 big_utf8 = DO_UTF8(big);
3301 little_utf8 = DO_UTF8(little);
3302 if (big_utf8 ^ little_utf8) {
3303 /* One needs to be upgraded. */
3304 if (little_utf8 && !PL_encoding) {
3305 /* Well, maybe instead we might be able to downgrade the small
3307 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3310 /* If the large string is ISO-8859-1, and it's not possible to
3311 convert the small string to ISO-8859-1, then there is no
3312 way that it could be found anywhere by index. */
3317 /* At this point, pv is a malloc()ed string. So donate it to temp
3318 to ensure it will get free()d */
3319 little = temp = newSV(0);
3320 sv_usepvn(temp, pv, llen);
3321 little_p = SvPVX(little);
3324 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3327 sv_recode_to_utf8(temp, PL_encoding);
3329 sv_utf8_upgrade(temp);
3334 big_p = SvPV_const(big, biglen);
3337 little_p = SvPV_const(little, llen);
3341 if (SvGAMAGIC(big)) {
3342 /* Life just becomes a lot easier if I use a temporary here.
3343 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3344 will trigger magic and overloading again, as will fbm_instr()
3346 big = newSVpvn_flags(big_p, biglen,
3347 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3350 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3351 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3352 warn on undef, and we've already triggered a warning with the
3353 SvPV_const some lines above. We can't remove that, as we need to
3354 call some SvPV to trigger overloading early and find out if the
3356 This is all getting to messy. The API isn't quite clean enough,
3357 because data access has side effects.
3359 little = newSVpvn_flags(little_p, llen,
3360 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3361 little_p = SvPVX(little);
3365 offset = is_index ? 0 : biglen;
3367 if (big_utf8 && offset > 0)
3368 sv_pos_u2b(big, &offset, 0);
3374 else if (offset > (I32)biglen)
3376 if (!(little_p = is_index
3377 ? fbm_instr((unsigned char*)big_p + offset,
3378 (unsigned char*)big_p + biglen, little, 0)
3379 : rninstr(big_p, big_p + offset,
3380 little_p, little_p + llen)))
3383 retval = little_p - big_p;
3384 if (retval > 0 && big_utf8)
3385 sv_pos_b2u(big, &retval);
3390 PUSHi(retval + arybase);
3396 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3397 if (SvTAINTED(MARK[1]))
3398 TAINT_PROPER("sprintf");
3399 do_sprintf(TARG, SP-MARK, MARK+1);
3400 TAINT_IF(SvTAINTED(TARG));
3412 const U8 *s = (U8*)SvPV_const(argsv, len);
3414 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3415 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3416 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3420 XPUSHu(DO_UTF8(argsv) ?
3421 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3433 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3435 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3437 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3439 (void) POPs; /* Ignore the argument value. */
3440 value = UNICODE_REPLACEMENT;
3446 SvUPGRADE(TARG,SVt_PV);
3448 if (value > 255 && !IN_BYTES) {
3449 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3450 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3451 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3453 (void)SvPOK_only(TARG);
3462 *tmps++ = (char)value;
3464 (void)SvPOK_only(TARG);
3466 if (PL_encoding && !IN_BYTES) {
3467 sv_recode_to_utf8(TARG, PL_encoding);
3469 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3470 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3474 *tmps++ = (char)value;
3490 const char *tmps = SvPV_const(left, len);
3492 if (DO_UTF8(left)) {
3493 /* If Unicode, try to downgrade.
3494 * If not possible, croak.
3495 * Yes, we made this up. */
3496 SV* const tsv = sv_2mortal(newSVsv(left));
3499 sv_utf8_downgrade(tsv, FALSE);
3500 tmps = SvPV_const(tsv, len);
3502 # ifdef USE_ITHREADS
3504 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3505 /* This should be threadsafe because in ithreads there is only
3506 * one thread per interpreter. If this would not be true,
3507 * we would need a mutex to protect this malloc. */
3508 PL_reentrant_buffer->_crypt_struct_buffer =
3509 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3510 #if defined(__GLIBC__) || defined(__EMX__)
3511 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3512 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3513 /* work around glibc-2.2.5 bug */
3514 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3518 # endif /* HAS_CRYPT_R */
3519 # endif /* USE_ITHREADS */
3521 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3523 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3529 "The crypt() function is unimplemented due to excessive paranoia.");
3541 bool inplace = TRUE;
3543 const int op_type = PL_op->op_type;
3546 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3552 s = (const U8*)SvPV_nomg_const(source, slen);
3554 if (ckWARN(WARN_UNINITIALIZED))
3555 report_uninit(source);
3560 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3562 utf8_to_uvchr(s, &ulen);
3563 if (op_type == OP_UCFIRST) {
3564 toTITLE_utf8(s, tmpbuf, &tculen);
3566 toLOWER_utf8(s, tmpbuf, &tculen);
3568 /* If the two differ, we definately cannot do inplace. */
3569 inplace = (ulen == tculen);
3570 need = slen + 1 - ulen + tculen;
3576 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3577 /* We can convert in place. */
3580 s = d = (U8*)SvPV_force_nomg(source, slen);
3586 SvUPGRADE(dest, SVt_PV);
3587 d = (U8*)SvGROW(dest, need);
3588 (void)SvPOK_only(dest);
3597 /* slen is the byte length of the whole SV.
3598 * ulen is the byte length of the original Unicode character
3599 * stored as UTF-8 at s.
3600 * tculen is the byte length of the freshly titlecased (or
3601 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3602 * We first set the result to be the titlecased (/lowercased)
3603 * character, and then append the rest of the SV data. */
3604 sv_setpvn(dest, (char*)tmpbuf, tculen);
3606 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3610 Copy(tmpbuf, d, tculen, U8);
3611 SvCUR_set(dest, need - 1);
3616 if (IN_LOCALE_RUNTIME) {
3619 *d = (op_type == OP_UCFIRST)
3620 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3623 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3625 /* See bug #39028 */
3633 /* This will copy the trailing NUL */
3634 Copy(s + 1, d + 1, slen, U8);
3635 SvCUR_set(dest, need - 1);
3642 /* There's so much setup/teardown code common between uc and lc, I wonder if
3643 it would be worth merging the two, and just having a switch outside each
3644 of the three tight loops. */
3658 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3659 && SvTEMP(source) && !DO_UTF8(source)) {
3660 /* We can convert in place. */
3663 s = d = (U8*)SvPV_force_nomg(source, len);
3670 /* The old implementation would copy source into TARG at this point.
3671 This had the side effect that if source was undef, TARG was now
3672 an undefined SV with PADTMP set, and they don't warn inside
3673 sv_2pv_flags(). However, we're now getting the PV direct from
3674 source, which doesn't have PADTMP set, so it would warn. Hence the
3678 s = (const U8*)SvPV_nomg_const(source, len);
3680 if (ckWARN(WARN_UNINITIALIZED))
3681 report_uninit(source);
3687 SvUPGRADE(dest, SVt_PV);
3688 d = (U8*)SvGROW(dest, min);
3689 (void)SvPOK_only(dest);
3694 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3695 to check DO_UTF8 again here. */
3697 if (DO_UTF8(source)) {
3698 const U8 *const send = s + len;
3699 U8 tmpbuf[UTF8_MAXBYTES+1];
3702 const STRLEN u = UTF8SKIP(s);
3705 toUPPER_utf8(s, tmpbuf, &ulen);
3706 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3707 /* If the eventually required minimum size outgrows
3708 * the available space, we need to grow. */
3709 const UV o = d - (U8*)SvPVX_const(dest);
3711 /* If someone uppercases one million U+03B0s we SvGROW() one
3712 * million times. Or we could try guessing how much to
3713 allocate without allocating too much. Such is life. */
3715 d = (U8*)SvPVX(dest) + o;
3717 Copy(tmpbuf, d, ulen, U8);
3723 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3726 const U8 *const send = s + len;
3727 if (IN_LOCALE_RUNTIME) {
3730 for (; s < send; d++, s++)
3731 *d = toUPPER_LC(*s);
3734 for (; s < send; d++, s++)
3738 if (source != dest) {
3740 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3760 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3761 && SvTEMP(source) && !DO_UTF8(source)) {
3762 /* We can convert in place. */
3765 s = d = (U8*)SvPV_force_nomg(source, len);
3772 /* The old implementation would copy source into TARG at this point.
3773 This had the side effect that if source was undef, TARG was now
3774 an undefined SV with PADTMP set, and they don't warn inside
3775 sv_2pv_flags(). However, we're now getting the PV direct from
3776 source, which doesn't have PADTMP set, so it would warn. Hence the
3780 s = (const U8*)SvPV_nomg_const(source, len);
3782 if (ckWARN(WARN_UNINITIALIZED))
3783 report_uninit(source);
3789 SvUPGRADE(dest, SVt_PV);
3790 d = (U8*)SvGROW(dest, min);
3791 (void)SvPOK_only(dest);
3796 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3797 to check DO_UTF8 again here. */
3799 if (DO_UTF8(source)) {
3800 const U8 *const send = s + len;
3801 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3804 const STRLEN u = UTF8SKIP(s);
3806 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3808 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3809 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3812 * Now if the sigma is NOT followed by
3813 * /$ignorable_sequence$cased_letter/;
3814 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3815 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3816 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3817 * then it should be mapped to 0x03C2,
3818 * (GREEK SMALL LETTER FINAL SIGMA),
3819 * instead of staying 0x03A3.
3820 * "should be": in other words, this is not implemented yet.
3821 * See lib/unicore/SpecialCasing.txt.
3824 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3825 /* If the eventually required minimum size outgrows
3826 * the available space, we need to grow. */
3827 const UV o = d - (U8*)SvPVX_const(dest);
3829 /* If someone lowercases one million U+0130s we SvGROW() one
3830 * million times. Or we could try guessing how much to
3831 allocate without allocating too much. Such is life. */
3833 d = (U8*)SvPVX(dest) + o;
3835 Copy(tmpbuf, d, ulen, U8);
3841 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3844 const U8 *const send = s + len;
3845 if (IN_LOCALE_RUNTIME) {
3848 for (; s < send; d++, s++)
3849 *d = toLOWER_LC(*s);
3852 for (; s < send; d++, s++)
3856 if (source != dest) {
3858 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3868 SV * const sv = TOPs;
3870 register const char *s = SvPV_const(sv,len);
3872 SvUTF8_off(TARG); /* decontaminate */
3875 SvUPGRADE(TARG, SVt_PV);
3876 SvGROW(TARG, (len * 2) + 1);
3880 if (UTF8_IS_CONTINUED(*s)) {
3881 STRLEN ulen = UTF8SKIP(s);
3905 SvCUR_set(TARG, d - SvPVX_const(TARG));
3906 (void)SvPOK_only_UTF8(TARG);
3909 sv_setpvn(TARG, s, len);
3918 dVAR; dSP; dMARK; dORIGMARK;
3919 register AV *const av = MUTABLE_AV(POPs);
3920 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3922 if (SvTYPE(av) == SVt_PVAV) {
3923 const I32 arybase = CopARYBASE_get(PL_curcop);
3924 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3925 bool can_preserve = FALSE;
3931 can_preserve = SvCANEXISTDELETE(av);
3934 if (lval && localizing) {
3937 for (svp = MARK + 1; svp <= SP; svp++) {
3938 const I32 elem = SvIV(*svp);
3942 if (max > AvMAX(av))
3946 while (++MARK <= SP) {
3948 I32 elem = SvIV(*MARK);
3949 bool preeminent = TRUE;
3953 if (localizing && can_preserve) {
3954 /* If we can determine whether the element exist,
3955 * Try to preserve the existenceness of a tied array
3956 * element by using EXISTS and DELETE if possible.
3957 * Fallback to FETCH and STORE otherwise. */
3958 preeminent = av_exists(av, elem);
3961 svp = av_fetch(av, elem, lval);
3963 if (!svp || *svp == &PL_sv_undef)
3964 DIE(aTHX_ PL_no_aelem, elem);
3967 save_aelem(av, elem, svp);
3969 SAVEADELETE(av, elem);
3972 *MARK = svp ? *svp : &PL_sv_undef;
3975 if (GIMME != G_ARRAY) {
3977 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3987 AV *array = MUTABLE_AV(POPs);
3988 const I32 gimme = GIMME_V;
3989 IV *iterp = Perl_av_iter_p(aTHX_ array);
3990 const IV current = (*iterp)++;
3992 if (current > av_len(array)) {
3994 if (gimme == G_SCALAR)
4001 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4002 if (gimme == G_ARRAY) {
4003 SV **const element = av_fetch(array, current, 0);
4004 PUSHs(element ? *element : &PL_sv_undef);
4013 AV *array = MUTABLE_AV(POPs);
4014 const I32 gimme = GIMME_V;
4016 *Perl_av_iter_p(aTHX_ array) = 0;
4018 if (gimme == G_SCALAR) {
4020 PUSHi(av_len(array) + 1);
4022 else if (gimme == G_ARRAY) {
4023 IV n = Perl_av_len(aTHX_ array);
4024 IV i = CopARYBASE_get(PL_curcop);
4028 if (PL_op->op_type == OP_AKEYS) {
4030 for (; i <= n; i++) {
4035 for (i = 0; i <= n; i++) {
4036 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4037 PUSHs(elem ? *elem : &PL_sv_undef);
4044 /* Associative arrays. */
4050 HV * hash = MUTABLE_HV(POPs);
4052 const I32 gimme = GIMME_V;
4055 /* might clobber stack_sp */
4056 entry = hv_iternext(hash);
4061 SV* const sv = hv_iterkeysv(entry);
4062 PUSHs(sv); /* won't clobber stack_sp */
4063 if (gimme == G_ARRAY) {
4066 /* might clobber stack_sp */
4067 val = hv_iterval(hash, entry);
4072 else if (gimme == G_SCALAR)
4079 S_do_delete_local(pTHX)
4083 const I32 gimme = GIMME_V;
4087 if (PL_op->op_private & OPpSLICE) {
4089 SV * const osv = POPs;
4090 const bool tied = SvRMAGICAL(osv)
4091 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4092 const bool can_preserve = SvCANEXISTDELETE(osv)
4093 || mg_find((const SV *)osv, PERL_MAGIC_env);
4094 const U32 type = SvTYPE(osv);
4095 if (type == SVt_PVHV) { /* hash element */
4096 HV * const hv = MUTABLE_HV(osv);
4097 while (++MARK <= SP) {
4098 SV * const keysv = *MARK;
4100 bool preeminent = TRUE;
4102 preeminent = hv_exists_ent(hv, keysv, 0);
4104 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4111 sv = hv_delete_ent(hv, keysv, 0, 0);
4112 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4115 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4117 *MARK = sv_mortalcopy(sv);
4123 SAVEHDELETE(hv, keysv);
4124 *MARK = &PL_sv_undef;
4128 else if (type == SVt_PVAV) { /* array element */
4129 if (PL_op->op_flags & OPf_SPECIAL) {
4130 AV * const av = MUTABLE_AV(osv);
4131 while (++MARK <= SP) {
4132 I32 idx = SvIV(*MARK);
4134 bool preeminent = TRUE;
4136 preeminent = av_exists(av, idx);
4138 SV **svp = av_fetch(av, idx, 1);
4145 sv = av_delete(av, idx, 0);
4146 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4149 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4151 *MARK = sv_mortalcopy(sv);
4157 SAVEADELETE(av, idx);
4158 *MARK = &PL_sv_undef;
4164 DIE(aTHX_ "Not a HASH reference");
4165 if (gimme == G_VOID)
4167 else if (gimme == G_SCALAR) {
4172 *++MARK = &PL_sv_undef;
4177 SV * const keysv = POPs;
4178 SV * const osv = POPs;
4179 const bool tied = SvRMAGICAL(osv)
4180 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4181 const bool can_preserve = SvCANEXISTDELETE(osv)
4182 || mg_find((const SV *)osv, PERL_MAGIC_env);
4183 const U32 type = SvTYPE(osv);
4185 if (type == SVt_PVHV) {
4186 HV * const hv = MUTABLE_HV(osv);
4187 bool preeminent = TRUE;
4189 preeminent = hv_exists_ent(hv, keysv, 0);
4191 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4198 sv = hv_delete_ent(hv, keysv, 0, 0);
4199 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4202 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4204 SV *nsv = sv_mortalcopy(sv);
4210 SAVEHDELETE(hv, keysv);
4212 else if (type == SVt_PVAV) {
4213 if (PL_op->op_flags & OPf_SPECIAL) {
4214 AV * const av = MUTABLE_AV(osv);
4215 I32 idx = SvIV(keysv);
4216 bool preeminent = TRUE;
4218 preeminent = av_exists(av, idx);
4220 SV **svp = av_fetch(av, idx, 1);
4227 sv = av_delete(av, idx, 0);
4228 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4231 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4233 SV *nsv = sv_mortalcopy(sv);
4239 SAVEADELETE(av, idx);
4242 DIE(aTHX_ "panic: avhv_delete no longer supported");
4245 DIE(aTHX_ "Not a HASH reference");
4248 if (gimme != G_VOID)
4262 if (PL_op->op_private & OPpLVAL_INTRO)
4263 return do_delete_local();
4266 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4268 if (PL_op->op_private & OPpSLICE) {
4270 HV * const hv = MUTABLE_HV(POPs);
4271 const U32 hvtype = SvTYPE(hv);
4272 if (hvtype == SVt_PVHV) { /* hash element */
4273 while (++MARK <= SP) {
4274 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4275 *MARK = sv ? sv : &PL_sv_undef;
4278 else if (hvtype == SVt_PVAV) { /* array element */
4279 if (PL_op->op_flags & OPf_SPECIAL) {
4280 while (++MARK <= SP) {
4281 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4282 *MARK = sv ? sv : &PL_sv_undef;
4287 DIE(aTHX_ "Not a HASH reference");
4290 else if (gimme == G_SCALAR) {
4295 *++MARK = &PL_sv_undef;
4301 HV * const hv = MUTABLE_HV(POPs);
4303 if (SvTYPE(hv) == SVt_PVHV)
4304 sv = hv_delete_ent(hv, keysv, discard, 0);
4305 else if (SvTYPE(hv) == SVt_PVAV) {
4306 if (PL_op->op_flags & OPf_SPECIAL)
4307 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4309 DIE(aTHX_ "panic: avhv_delete no longer supported");
4312 DIE(aTHX_ "Not a HASH reference");
4328 if (PL_op->op_private & OPpEXISTS_SUB) {
4330 SV * const sv = POPs;
4331 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4334 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4339 hv = MUTABLE_HV(POPs);
4340 if (SvTYPE(hv) == SVt_PVHV) {
4341 if (hv_exists_ent(hv, tmpsv, 0))
4344 else if (SvTYPE(hv) == SVt_PVAV) {
4345 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4346 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4351 DIE(aTHX_ "Not a HASH reference");
4358 dVAR; dSP; dMARK; dORIGMARK;
4359 register HV * const hv = MUTABLE_HV(POPs);
4360 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4361 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4362 bool can_preserve = FALSE;
4368 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4369 can_preserve = TRUE;
4372 while (++MARK <= SP) {
4373 SV * const keysv = *MARK;
4376 bool preeminent = TRUE;
4378 if (localizing && can_preserve) {
4379 /* If we can determine whether the element exist,
4380 * try to preserve the existenceness of a tied hash
4381 * element by using EXISTS and DELETE if possible.
4382 * Fallback to FETCH and STORE otherwise. */
4383 preeminent = hv_exists_ent(hv, keysv, 0);
4386 he = hv_fetch_ent(hv, keysv, lval, 0);
4387 svp = he ? &HeVAL(he) : NULL;
4390 if (!svp || *svp == &PL_sv_undef) {
4391 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4394 if (HvNAME_get(hv) && isGV(*svp))
4395 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4396 else if (preeminent)
4397 save_helem_flags(hv, keysv, svp,
4398 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4400 SAVEHDELETE(hv, keysv);
4403 *MARK = svp ? *svp : &PL_sv_undef;
4405 if (GIMME != G_ARRAY) {
4407 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4413 /* List operators. */
4418 if (GIMME != G_ARRAY) {
4420 *MARK = *SP; /* unwanted list, return last item */
4422 *MARK = &PL_sv_undef;
4432 SV ** const lastrelem = PL_stack_sp;
4433 SV ** const lastlelem = PL_stack_base + POPMARK;
4434 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4435 register SV ** const firstrelem = lastlelem + 1;
4436 const I32 arybase = CopARYBASE_get(PL_curcop);
4437 I32 is_something_there = FALSE;
4439 register const I32 max = lastrelem - lastlelem;
4440 register SV **lelem;
4442 if (GIMME != G_ARRAY) {
4443 I32 ix = SvIV(*lastlelem);
4448 if (ix < 0 || ix >= max)
4449 *firstlelem = &PL_sv_undef;
4451 *firstlelem = firstrelem[ix];
4457 SP = firstlelem - 1;
4461 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4462 I32 ix = SvIV(*lelem);
4467 if (ix < 0 || ix >= max)
4468 *lelem = &PL_sv_undef;
4470 is_something_there = TRUE;
4471 if (!(*lelem = firstrelem[ix]))
4472 *lelem = &PL_sv_undef;
4475 if (is_something_there)
4478 SP = firstlelem - 1;
4484 dVAR; dSP; dMARK; dORIGMARK;
4485 const I32 items = SP - MARK;
4486 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4487 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4488 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4489 ? newRV_noinc(av) : av);
4495 dVAR; dSP; dMARK; dORIGMARK;
4496 HV* const hv = newHV();
4499 SV * const key = *++MARK;
4500 SV * const val = newSV(0);
4502 sv_setsv(val, *++MARK);
4504 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4505 (void)hv_store_ent(hv,key,val,0);
4508 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4509 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4515 dVAR; dSP; dMARK; dORIGMARK;
4516 register AV *ary = MUTABLE_AV(*++MARK);
4520 register I32 offset;
4521 register I32 length;
4525 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4528 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4532 call_method("SPLICE",GIMME_V);
4541 offset = i = SvIV(*MARK);
4543 offset += AvFILLp(ary) + 1;
4545 offset -= CopARYBASE_get(PL_curcop);
4547 DIE(aTHX_ PL_no_aelem, i);
4549 length = SvIVx(*MARK++);
4551 length += AvFILLp(ary) - offset + 1;
4557 length = AvMAX(ary) + 1; /* close enough to infinity */
4561 length = AvMAX(ary) + 1;
4563 if (offset > AvFILLp(ary) + 1) {
4564 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4565 offset = AvFILLp(ary) + 1;
4567 after = AvFILLp(ary) + 1 - (offset + length);
4568 if (after < 0) { /* not that much array */
4569 length += after; /* offset+length now in array */
4575 /* At this point, MARK .. SP-1 is our new LIST */
4578 diff = newlen - length;
4579 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4582 /* make new elements SVs now: avoid problems if they're from the array */
4583 for (dst = MARK, i = newlen; i; i--) {
4584 SV * const h = *dst;
4585 *dst++ = newSVsv(h);
4588 if (diff < 0) { /* shrinking the area */
4589 SV **tmparyval = NULL;
4591 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4592 Copy(MARK, tmparyval, newlen, SV*);
4595 MARK = ORIGMARK + 1;
4596 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4597 MEXTEND(MARK, length);
4598 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4600 EXTEND_MORTAL(length);
4601 for (i = length, dst = MARK; i; i--) {
4602 sv_2mortal(*dst); /* free them eventualy */
4609 *MARK = AvARRAY(ary)[offset+length-1];
4612 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4613 SvREFCNT_dec(*dst++); /* free them now */
4616 AvFILLp(ary) += diff;
4618 /* pull up or down? */
4620 if (offset < after) { /* easier to pull up */
4621 if (offset) { /* esp. if nothing to pull */
4622 src = &AvARRAY(ary)[offset-1];
4623 dst = src - diff; /* diff is negative */
4624 for (i = offset; i > 0; i--) /* can't trust Copy */
4628 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4632 if (after) { /* anything to pull down? */
4633 src = AvARRAY(ary) + offset + length;
4634 dst = src + diff; /* diff is negative */
4635 Move(src, dst, after, SV*);
4637 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4638 /* avoid later double free */
4642 dst[--i] = &PL_sv_undef;
4645 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4646 Safefree(tmparyval);
4649 else { /* no, expanding (or same) */
4650 SV** tmparyval = NULL;
4652 Newx(tmparyval, length, SV*); /* so remember deletion */
4653 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4656 if (diff > 0) { /* expanding */
4657 /* push up or down? */
4658 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4662 Move(src, dst, offset, SV*);
4664 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4666 AvFILLp(ary) += diff;
4669 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4670 av_extend(ary, AvFILLp(ary) + diff);
4671 AvFILLp(ary) += diff;
4674 dst = AvARRAY(ary) + AvFILLp(ary);
4676 for (i = after; i; i--) {
4684 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4687 MARK = ORIGMARK + 1;
4688 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4690 Copy(tmparyval, MARK, length, SV*);
4692 EXTEND_MORTAL(length);
4693 for (i = length, dst = MARK; i; i--) {
4694 sv_2mortal(*dst); /* free them eventualy */
4701 else if (length--) {
4702 *MARK = tmparyval[length];
4705 while (length-- > 0)
4706 SvREFCNT_dec(tmparyval[length]);
4710 *MARK = &PL_sv_undef;
4711 Safefree(tmparyval);
4719 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4720 register AV * const ary = MUTABLE_AV(*++MARK);
4721 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4724 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4728 call_method("PUSH",G_SCALAR|G_DISCARD);
4733 PL_delaymagic = DM_DELAY;
4734 for (++MARK; MARK <= SP; MARK++) {
4735 SV * const sv = newSV(0);
4737 sv_setsv(sv, *MARK);
4738 av_store(ary, AvFILLp(ary)+1, sv);
4740 if (PL_delaymagic & DM_ARRAY)
4741 mg_set(MUTABLE_SV(ary));
4746 if (OP_GIMME(PL_op, 0) != G_VOID) {
4747 PUSHi( AvFILL(ary) + 1 );
4756 AV * const av = MUTABLE_AV(POPs);
4757 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4761 (void)sv_2mortal(sv);
4768 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4769 register AV *ary = MUTABLE_AV(*++MARK);
4770 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4773 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4777 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4783 av_unshift(ary, SP - MARK);
4785 SV * const sv = newSVsv(*++MARK);
4786 (void)av_store(ary, i++, sv);
4790 if (OP_GIMME(PL_op, 0) != G_VOID) {
4791 PUSHi( AvFILL(ary) + 1 );
4799 SV ** const oldsp = SP;
4801 if (GIMME == G_ARRAY) {
4804 register SV * const tmp = *MARK;
4808 /* safe as long as stack cannot get extended in the above */
4813 register char *down;
4817 PADOFFSET padoff_du;
4819 SvUTF8_off(TARG); /* decontaminate */
4821 do_join(TARG, &PL_sv_no, MARK, SP);
4823 sv_setsv(TARG, (SP > MARK)
4825 : (padoff_du = find_rundefsvoffset(),
4826 (padoff_du == NOT_IN_PAD
4827 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4828 ? DEFSV : PAD_SVl(padoff_du)));
4830 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4831 report_uninit(TARG);
4834 up = SvPV_force(TARG, len);
4836 if (DO_UTF8(TARG)) { /* first reverse each character */
4837 U8* s = (U8*)SvPVX(TARG);
4838 const U8* send = (U8*)(s + len);
4840 if (UTF8_IS_INVARIANT(*s)) {
4845 if (!utf8_to_uvchr(s, 0))
4849 down = (char*)(s - 1);
4850 /* reverse this character */
4854 *down-- = (char)tmp;
4860 down = SvPVX(TARG) + len - 1;
4864 *down-- = (char)tmp;
4866 (void)SvPOK_only_UTF8(TARG);
4878 register IV limit = POPi; /* note, negative is forever */
4879 SV * const sv = POPs;
4881 register const char *s = SvPV_const(sv, len);
4882 const bool do_utf8 = DO_UTF8(sv);
4883 const char *strend = s + len;
4885 register REGEXP *rx;
4887 register const char *m;
4889 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4890 I32 maxiters = slen + 10;
4891 I32 trailing_empty = 0;
4893 const I32 origlimit = limit;
4896 const I32 gimme = GIMME_V;
4898 const I32 oldsave = PL_savestack_ix;
4899 U32 make_mortal = SVs_TEMP;
4904 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4909 DIE(aTHX_ "panic: pp_split");
4912 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4913 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4915 RX_MATCH_UTF8_set(rx, do_utf8);
4918 if (pm->op_pmreplrootu.op_pmtargetoff) {
4919 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
4922 if (pm->op_pmreplrootu.op_pmtargetgv) {
4923 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4928 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4934 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
4936 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
4943 for (i = AvFILLp(ary); i >= 0; i--)
4944 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4946 /* temporarily switch stacks */
4947 SAVESWITCHSTACK(PL_curstack, ary);
4951 base = SP - PL_stack_base;
4953 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4955 while (*s == ' ' || is_utf8_space((U8*)s))
4958 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4959 while (isSPACE_LC(*s))
4967 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4971 gimme_scalar = gimme == G_SCALAR && !ary;
4974 limit = maxiters + 2;
4975 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4978 /* this one uses 'm' and is a negative test */
4980 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4981 const int t = UTF8SKIP(m);
4982 /* is_utf8_space returns FALSE for malform utf8 */
4988 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4989 while (m < strend && !isSPACE_LC(*m))
4992 while (m < strend && !isSPACE(*m))
5005 dstr = newSVpvn_flags(s, m-s,
5006 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5010 /* skip the whitespace found last */
5012 s = m + UTF8SKIP(m);
5016 /* this one uses 's' and is a positive test */
5018 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5020 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5021 while (s < strend && isSPACE_LC(*s))
5024 while (s < strend && isSPACE(*s))
5029 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5031 for (m = s; m < strend && *m != '\n'; m++)
5044 dstr = newSVpvn_flags(s, m-s,
5045 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5051 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5053 Pre-extend the stack, either the number of bytes or
5054 characters in the string or a limited amount, triggered by:
5056 my ($x, $y) = split //, $str;
5060 if (!gimme_scalar) {
5061 const U32 items = limit - 1;
5070 /* keep track of how many bytes we skip over */
5080 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5093 dstr = newSVpvn(s, 1);
5109 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5110 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5111 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5112 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5113 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5114 SV * const csv = CALLREG_INTUIT_STRING(rx);
5116 len = RX_MINLENRET(rx);
5117 if (len == 1 && !RX_UTF8(rx) && !tail) {
5118 const char c = *SvPV_nolen_const(csv);
5120 for (m = s; m < strend && *m != c; m++)
5131 dstr = newSVpvn_flags(s, m-s,
5132 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5135 /* The rx->minlen is in characters but we want to step
5136 * s ahead by bytes. */
5138 s = (char*)utf8_hop((U8*)m, len);
5140 s = m + len; /* Fake \n at the end */
5144 while (s < strend && --limit &&
5145 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5146 csv, multiline ? FBMrf_MULTILINE : 0)) )
5155 dstr = newSVpvn_flags(s, m-s,
5156 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5159 /* The rx->minlen is in characters but we want to step
5160 * s ahead by bytes. */
5162 s = (char*)utf8_hop((U8*)m, len);
5164 s = m + len; /* Fake \n at the end */
5169 maxiters += slen * RX_NPARENS(rx);
5170 while (s < strend && --limit)
5174 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5177 if (rex_return == 0)
5179 TAINT_IF(RX_MATCH_TAINTED(rx));
5180 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5183 orig = RX_SUBBEG(rx);
5185 strend = s + (strend - m);
5187 m = RX_OFFS(rx)[0].start + orig;
5196 dstr = newSVpvn_flags(s, m-s,
5197 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5200 if (RX_NPARENS(rx)) {
5202 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5203 s = RX_OFFS(rx)[i].start + orig;
5204 m = RX_OFFS(rx)[i].end + orig;
5206 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5207 parens that didn't match -- they should be set to
5208 undef, not the empty string */
5216 if (m >= orig && s >= orig) {
5217 dstr = newSVpvn_flags(s, m-s,
5218 (do_utf8 ? SVf_UTF8 : 0)
5222 dstr = &PL_sv_undef; /* undef, not "" */
5228 s = RX_OFFS(rx)[0].end + orig;
5232 if (!gimme_scalar) {
5233 iters = (SP - PL_stack_base) - base;
5235 if (iters > maxiters)
5236 DIE(aTHX_ "Split loop");
5238 /* keep field after final delim? */
5239 if (s < strend || (iters && origlimit)) {
5240 if (!gimme_scalar) {
5241 const STRLEN l = strend - s;
5242 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5247 else if (!origlimit) {
5249 iters -= trailing_empty;
5251 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5252 if (TOPs && !make_mortal)
5254 *SP-- = &PL_sv_undef;
5261 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5265 if (SvSMAGICAL(ary)) {
5267 mg_set(MUTABLE_SV(ary));
5270 if (gimme == G_ARRAY) {
5272 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5280 call_method("PUSH",G_SCALAR|G_DISCARD);
5283 if (gimme == G_ARRAY) {
5285 /* EXTEND should not be needed - we just popped them */
5287 for (i=0; i < iters; i++) {
5288 SV **svp = av_fetch(ary, i, FALSE);
5289 PUSHs((svp) ? *svp : &PL_sv_undef);
5296 if (gimme == G_ARRAY)
5308 SV *const sv = PAD_SVl(PL_op->op_targ);
5310 if (SvPADSTALE(sv)) {
5313 RETURNOP(cLOGOP->op_other);
5315 RETURNOP(cLOGOP->op_next);
5324 assert(SvTYPE(retsv) != SVt_PVCV);
5326 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
5327 retsv = refto(retsv);
5334 PP(unimplemented_op)
5337 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5345 HV * const hv = (HV*)POPs;
5347 if (SvRMAGICAL(hv)) {
5348 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5350 XPUSHs(magic_scalarpack(hv, mg));
5355 XPUSHs(boolSV(HvKEYS(hv) != 0));
5361 * c-indentation-style: bsd
5363 * indent-tabs-mode: t
5366 * ex: set ts=8 sts=4 sw=4 noet: