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 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
326 *sv = newSV_type(SVt_PVMG);
327 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
335 dVAR; dSP; dTARGET; dPOPss;
337 if (PL_op->op_flags & OPf_MOD || LVRET) {
338 if (SvTYPE(TARG) < SVt_PVLV) {
339 sv_upgrade(TARG, SVt_PVLV);
340 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
344 if (LvTARG(TARG) != sv) {
346 SvREFCNT_dec(LvTARG(TARG));
347 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
349 PUSHs(TARG); /* no SvSETMAGIC */
353 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
354 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
355 if (mg && mg->mg_len >= 0) {
359 PUSHi(i + CopARYBASE_get(PL_curcop));
372 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
374 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
377 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
378 /* (But not in defined().) */
380 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
383 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
384 if ((PL_op->op_private & OPpLVAL_INTRO)) {
385 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
388 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
391 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
395 cv = MUTABLE_CV(&PL_sv_undef);
396 SETs(MUTABLE_SV(cv));
406 SV *ret = &PL_sv_undef;
408 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
409 const char * s = SvPVX_const(TOPs);
410 if (strnEQ(s, "CORE::", 6)) {
411 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
412 if (code < 0) { /* Overridable. */
413 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
414 int i = 0, n = 0, seen_question = 0, defgv = 0;
416 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
418 if (code == -KEY_chop || code == -KEY_chomp
419 || code == -KEY_exec || code == -KEY_system)
421 if (code == -KEY_mkdir) {
422 ret = newSVpvs_flags("_;$", SVs_TEMP);
425 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
426 ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
429 if (code == -KEY_readpipe) {
430 s = "CORE::backtick";
432 while (i < MAXO) { /* The slow way. */
433 if (strEQ(s + 6, PL_op_name[i])
434 || strEQ(s + 6, PL_op_desc[i]))
440 goto nonesuch; /* Should not happen... */
442 defgv = PL_opargs[i] & OA_DEFGV;
443 oa = PL_opargs[i] >> OASHIFT;
445 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
449 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
450 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
451 /* But globs are already references (kinda) */
452 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
456 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
459 if (defgv && str[n - 1] == '$')
462 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
464 else if (code) /* Non-Overridable */
466 else { /* None such */
468 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
472 cv = sv_2cv(TOPs, &stash, &gv, 0);
474 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
483 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
485 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
487 PUSHs(MUTABLE_SV(cv));
501 if (GIMME != G_ARRAY) {
505 *MARK = &PL_sv_undef;
506 *MARK = refto(*MARK);
510 EXTEND_MORTAL(SP - MARK);
512 *MARK = refto(*MARK);
517 S_refto(pTHX_ SV *sv)
522 PERL_ARGS_ASSERT_REFTO;
524 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
527 if (!(sv = LvTARG(sv)))
530 SvREFCNT_inc_void_NN(sv);
532 else if (SvTYPE(sv) == SVt_PVAV) {
533 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
534 av_reify(MUTABLE_AV(sv));
536 SvREFCNT_inc_void_NN(sv);
538 else if (SvPADTMP(sv) && !IS_PADGV(sv))
542 SvREFCNT_inc_void_NN(sv);
545 sv_upgrade(rv, SVt_IV);
555 SV * const sv = POPs;
560 if (!sv || !SvROK(sv))
563 pv = sv_reftype(SvRV(sv),TRUE);
564 PUSHp(pv, strlen(pv));
574 stash = CopSTASH(PL_curcop);
576 SV * const ssv = POPs;
580 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
581 Perl_croak(aTHX_ "Attempt to bless into a reference");
582 ptr = SvPV_const(ssv,len);
584 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
585 "Explicit blessing to '' (assuming package main)");
586 stash = gv_stashpvn(ptr, len, GV_ADD);
589 (void)sv_bless(TOPs, stash);
598 const char * const elem = SvPV_nolen_const(sv);
599 GV * const gv = MUTABLE_GV(POPs);
604 /* elem will always be NUL terminated. */
605 const char * const second_letter = elem + 1;
608 if (strEQ(second_letter, "RRAY"))
609 tmpRef = MUTABLE_SV(GvAV(gv));
612 if (strEQ(second_letter, "ODE"))
613 tmpRef = MUTABLE_SV(GvCVu(gv));
616 if (strEQ(second_letter, "ILEHANDLE")) {
617 /* finally deprecated in 5.8.0 */
618 deprecate("*glob{FILEHANDLE}");
619 tmpRef = MUTABLE_SV(GvIOp(gv));
622 if (strEQ(second_letter, "ORMAT"))
623 tmpRef = MUTABLE_SV(GvFORM(gv));
626 if (strEQ(second_letter, "LOB"))
627 tmpRef = MUTABLE_SV(gv);
630 if (strEQ(second_letter, "ASH"))
631 tmpRef = MUTABLE_SV(GvHV(gv));
634 if (*second_letter == 'O' && !elem[2])
635 tmpRef = MUTABLE_SV(GvIOp(gv));
638 if (strEQ(second_letter, "AME"))
639 sv = newSVhek(GvNAME_HEK(gv));
642 if (strEQ(second_letter, "ACKAGE")) {
643 const HV * const stash = GvSTASH(gv);
644 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
645 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
649 if (strEQ(second_letter, "CALAR"))
664 /* Pattern matching */
669 register unsigned char *s;
672 register I32 *sfirst;
676 if (sv == PL_lastscream) {
680 s = (unsigned char*)(SvPV(sv, len));
682 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
683 /* No point in studying a zero length string, and not safe to study
684 anything that doesn't appear to be a simple scalar (and hence might
685 change between now and when the regexp engine runs without our set
686 magic ever running) such as a reference to an object with overloaded
692 SvSCREAM_off(PL_lastscream);
693 SvREFCNT_dec(PL_lastscream);
695 PL_lastscream = SvREFCNT_inc_simple(sv);
697 s = (unsigned char*)(SvPV(sv, len));
701 if (pos > PL_maxscream) {
702 if (PL_maxscream < 0) {
703 PL_maxscream = pos + 80;
704 Newx(PL_screamfirst, 256, I32);
705 Newx(PL_screamnext, PL_maxscream, I32);
708 PL_maxscream = pos + pos / 4;
709 Renew(PL_screamnext, PL_maxscream, I32);
713 sfirst = PL_screamfirst;
714 snext = PL_screamnext;
716 if (!sfirst || !snext)
717 DIE(aTHX_ "do_study: out of memory");
719 for (ch = 256; ch; --ch)
724 register const I32 ch = s[pos];
726 snext[pos] = sfirst[ch] - pos;
733 /* piggyback on m//g magic */
734 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
743 if (PL_op->op_flags & OPf_STACKED)
745 else if (PL_op->op_private & OPpTARGET_MY)
751 TARG = sv_newmortal();
756 /* Lvalue operators. */
768 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
770 do_chop(TARG, *++MARK);
779 SETi(do_chomp(TOPs));
785 dVAR; dSP; dMARK; dTARGET;
786 register I32 count = 0;
789 count += do_chomp(POPs);
799 if (!PL_op->op_private) {
808 SV_CHECK_THINKFIRST_COW_DROP(sv);
810 switch (SvTYPE(sv)) {
814 av_undef(MUTABLE_AV(sv));
817 hv_undef(MUTABLE_HV(sv));
820 if (cv_const_sv((const CV *)sv))
821 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
822 CvANON((const CV *)sv) ? "(anonymous)"
823 : GvENAME(CvGV((const CV *)sv)));
827 /* let user-undef'd sub keep its identity */
828 GV* const gv = CvGV((const CV *)sv);
829 cv_undef(MUTABLE_CV(sv));
830 CvGV((const CV *)sv) = gv;
835 SvSetMagicSV(sv, &PL_sv_undef);
838 else if (isGV_with_GP(sv)) {
843 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
844 mro_isa_changed_in(stash);
845 /* undef *Pkg::meth_name ... */
846 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
847 && HvNAME_get(stash))
848 mro_method_changed_in(stash);
850 gp_free(MUTABLE_GV(sv));
852 GvGP(sv) = gp_ref(gp);
854 GvLINE(sv) = CopLINE(PL_curcop);
855 GvEGV(sv) = MUTABLE_GV(sv);
861 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
876 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
877 DIE(aTHX_ "%s", PL_no_modify);
878 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
879 && SvIVX(TOPs) != IV_MIN)
881 SvIV_set(TOPs, SvIVX(TOPs) - 1);
882 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
893 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
894 DIE(aTHX_ "%s", PL_no_modify);
895 sv_setsv(TARG, TOPs);
896 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
897 && SvIVX(TOPs) != IV_MAX)
899 SvIV_set(TOPs, SvIVX(TOPs) + 1);
900 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
905 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
915 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
916 DIE(aTHX_ "%s", PL_no_modify);
917 sv_setsv(TARG, TOPs);
918 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
919 && SvIVX(TOPs) != IV_MIN)
921 SvIV_set(TOPs, SvIVX(TOPs) - 1);
922 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
931 /* Ordinary operators. */
935 dVAR; dSP; dATARGET; SV *svl, *svr;
936 #ifdef PERL_PRESERVE_IVUV
939 tryAMAGICbin(pow,opASSIGN);
940 svl = sv_2num(TOPm1s);
942 #ifdef PERL_PRESERVE_IVUV
943 /* For integer to integer power, we do the calculation by hand wherever
944 we're sure it is safe; otherwise we call pow() and try to convert to
945 integer afterwards. */
958 const IV iv = SvIVX(svr);
962 goto float_it; /* Can't do negative powers this way. */
966 baseuok = SvUOK(svl);
970 const IV iv = SvIVX(svl);
973 baseuok = TRUE; /* effectively it's a UV now */
975 baseuv = -iv; /* abs, baseuok == false records sign */
978 /* now we have integer ** positive integer. */
981 /* foo & (foo - 1) is zero only for a power of 2. */
982 if (!(baseuv & (baseuv - 1))) {
983 /* We are raising power-of-2 to a positive integer.
984 The logic here will work for any base (even non-integer
985 bases) but it can be less accurate than
986 pow (base,power) or exp (power * log (base)) when the
987 intermediate values start to spill out of the mantissa.
988 With powers of 2 we know this can't happen.
989 And powers of 2 are the favourite thing for perl
990 programmers to notice ** not doing what they mean. */
992 NV base = baseuok ? baseuv : -(NV)baseuv;
997 while (power >>= 1) {
1008 register unsigned int highbit = 8 * sizeof(UV);
1009 register unsigned int diff = 8 * sizeof(UV);
1010 while (diff >>= 1) {
1012 if (baseuv >> highbit) {
1016 /* we now have baseuv < 2 ** highbit */
1017 if (power * highbit <= 8 * sizeof(UV)) {
1018 /* result will definitely fit in UV, so use UV math
1019 on same algorithm as above */
1020 register UV result = 1;
1021 register UV base = baseuv;
1022 const bool odd_power = (bool)(power & 1);
1026 while (power >>= 1) {
1033 if (baseuok || !odd_power)
1034 /* answer is positive */
1036 else if (result <= (UV)IV_MAX)
1037 /* answer negative, fits in IV */
1038 SETi( -(IV)result );
1039 else if (result == (UV)IV_MIN)
1040 /* 2's complement assumption: special case IV_MIN */
1043 /* answer negative, doesn't fit */
1044 SETn( -(NV)result );
1054 NV right = SvNV(svr);
1055 NV left = SvNV(svl);
1058 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1060 We are building perl with long double support and are on an AIX OS
1061 afflicted with a powl() function that wrongly returns NaNQ for any
1062 negative base. This was reported to IBM as PMR #23047-379 on
1063 03/06/2006. The problem exists in at least the following versions
1064 of AIX and the libm fileset, and no doubt others as well:
1066 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1067 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1068 AIX 5.2.0 bos.adt.libm 5.2.0.85
1070 So, until IBM fixes powl(), we provide the following workaround to
1071 handle the problem ourselves. Our logic is as follows: for
1072 negative bases (left), we use fmod(right, 2) to check if the
1073 exponent is an odd or even integer:
1075 - if odd, powl(left, right) == -powl(-left, right)
1076 - if even, powl(left, right) == powl(-left, right)
1078 If the exponent is not an integer, the result is rightly NaNQ, so
1079 we just return that (as NV_NAN).
1083 NV mod2 = Perl_fmod( right, 2.0 );
1084 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1085 SETn( -Perl_pow( -left, right) );
1086 } else if (mod2 == 0.0) { /* even integer */
1087 SETn( Perl_pow( -left, right) );
1088 } else { /* fractional power */
1092 SETn( Perl_pow( left, right) );
1095 SETn( Perl_pow( left, right) );
1096 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1098 #ifdef PERL_PRESERVE_IVUV
1108 dVAR; dSP; dATARGET; SV *svl, *svr;
1109 tryAMAGICbin(mult,opASSIGN);
1110 svl = sv_2num(TOPm1s);
1111 svr = sv_2num(TOPs);
1112 #ifdef PERL_PRESERVE_IVUV
1115 /* Unless the left argument is integer in range we are going to have to
1116 use NV maths. Hence only attempt to coerce the right argument if
1117 we know the left is integer. */
1118 /* Left operand is defined, so is it IV? */
1121 bool auvok = SvUOK(svl);
1122 bool buvok = SvUOK(svr);
1123 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1124 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1133 const IV aiv = SvIVX(svl);
1136 auvok = TRUE; /* effectively it's a UV now */
1138 alow = -aiv; /* abs, auvok == false records sign */
1144 const IV biv = SvIVX(svr);
1147 buvok = TRUE; /* effectively it's a UV now */
1149 blow = -biv; /* abs, buvok == false records sign */
1153 /* If this does sign extension on unsigned it's time for plan B */
1154 ahigh = alow >> (4 * sizeof (UV));
1156 bhigh = blow >> (4 * sizeof (UV));
1158 if (ahigh && bhigh) {
1160 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1161 which is overflow. Drop to NVs below. */
1162 } else if (!ahigh && !bhigh) {
1163 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1164 so the unsigned multiply cannot overflow. */
1165 const UV product = alow * blow;
1166 if (auvok == buvok) {
1167 /* -ve * -ve or +ve * +ve gives a +ve result. */
1171 } else if (product <= (UV)IV_MIN) {
1172 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1173 /* -ve result, which could overflow an IV */
1175 SETi( -(IV)product );
1177 } /* else drop to NVs below. */
1179 /* One operand is large, 1 small */
1182 /* swap the operands */
1184 bhigh = blow; /* bhigh now the temp var for the swap */
1188 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1189 multiplies can't overflow. shift can, add can, -ve can. */
1190 product_middle = ahigh * blow;
1191 if (!(product_middle & topmask)) {
1192 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1194 product_middle <<= (4 * sizeof (UV));
1195 product_low = alow * blow;
1197 /* as for pp_add, UV + something mustn't get smaller.
1198 IIRC ANSI mandates this wrapping *behaviour* for
1199 unsigned whatever the actual representation*/
1200 product_low += product_middle;
1201 if (product_low >= product_middle) {
1202 /* didn't overflow */
1203 if (auvok == buvok) {
1204 /* -ve * -ve or +ve * +ve gives a +ve result. */
1206 SETu( product_low );
1208 } else if (product_low <= (UV)IV_MIN) {
1209 /* 2s complement assumption again */
1210 /* -ve result, which could overflow an IV */
1212 SETi( -(IV)product_low );
1214 } /* else drop to NVs below. */
1216 } /* product_middle too large */
1217 } /* ahigh && bhigh */
1222 NV right = SvNV(svr);
1223 NV left = SvNV(svl);
1225 SETn( left * right );
1232 dVAR; dSP; dATARGET; SV *svl, *svr;
1233 tryAMAGICbin(div,opASSIGN);
1234 svl = sv_2num(TOPm1s);
1235 svr = sv_2num(TOPs);
1236 /* Only try to do UV divide first
1237 if ((SLOPPYDIVIDE is true) or
1238 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1240 The assumption is that it is better to use floating point divide
1241 whenever possible, only doing integer divide first if we can't be sure.
1242 If NV_PRESERVES_UV is true then we know at compile time that no UV
1243 can be too large to preserve, so don't need to compile the code to
1244 test the size of UVs. */
1247 # define PERL_TRY_UV_DIVIDE
1248 /* ensure that 20./5. == 4. */
1250 # ifdef PERL_PRESERVE_IVUV
1251 # ifndef NV_PRESERVES_UV
1252 # define PERL_TRY_UV_DIVIDE
1257 #ifdef PERL_TRY_UV_DIVIDE
1262 bool left_non_neg = SvUOK(svl);
1263 bool right_non_neg = SvUOK(svr);
1267 if (right_non_neg) {
1271 const IV biv = SvIVX(svr);
1274 right_non_neg = TRUE; /* effectively it's a UV now */
1280 /* historically undef()/0 gives a "Use of uninitialized value"
1281 warning before dieing, hence this test goes here.
1282 If it were immediately before the second SvIV_please, then
1283 DIE() would be invoked before left was even inspected, so
1284 no inpsection would give no warning. */
1286 DIE(aTHX_ "Illegal division by zero");
1292 const IV aiv = SvIVX(svl);
1295 left_non_neg = TRUE; /* effectively it's a UV now */
1304 /* For sloppy divide we always attempt integer division. */
1306 /* Otherwise we only attempt it if either or both operands
1307 would not be preserved by an NV. If both fit in NVs
1308 we fall through to the NV divide code below. However,
1309 as left >= right to ensure integer result here, we know that
1310 we can skip the test on the right operand - right big
1311 enough not to be preserved can't get here unless left is
1314 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1317 /* Integer division can't overflow, but it can be imprecise. */
1318 const UV result = left / right;
1319 if (result * right == left) {
1320 SP--; /* result is valid */
1321 if (left_non_neg == right_non_neg) {
1322 /* signs identical, result is positive. */
1326 /* 2s complement assumption */
1327 if (result <= (UV)IV_MIN)
1328 SETi( -(IV)result );
1330 /* It's exact but too negative for IV. */
1331 SETn( -(NV)result );
1334 } /* tried integer divide but it was not an integer result */
1335 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1336 } /* left wasn't SvIOK */
1337 } /* right wasn't SvIOK */
1338 #endif /* PERL_TRY_UV_DIVIDE */
1340 NV right = SvNV(svr);
1341 NV left = SvNV(svl);
1342 (void)POPs;(void)POPs;
1343 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1344 if (! Perl_isnan(right) && right == 0.0)
1348 DIE(aTHX_ "Illegal division by zero");
1349 PUSHn( left / right );
1356 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1360 bool left_neg = FALSE;
1361 bool right_neg = FALSE;
1362 bool use_double = FALSE;
1363 bool dright_valid = FALSE;
1367 SV * const svr = sv_2num(TOPs);
1370 right_neg = !SvUOK(svr);
1374 const IV biv = SvIVX(svr);
1377 right_neg = FALSE; /* effectively it's a UV now */
1385 right_neg = dright < 0;
1388 if (dright < UV_MAX_P1) {
1389 right = U_V(dright);
1390 dright_valid = TRUE; /* In case we need to use double below. */
1397 /* At this point use_double is only true if right is out of range for
1398 a UV. In range NV has been rounded down to nearest UV and
1399 use_double false. */
1400 svl = sv_2num(TOPs);
1402 if (!use_double && SvIOK(svl)) {
1404 left_neg = !SvUOK(svl);
1408 const IV aiv = SvIVX(svl);
1411 left_neg = FALSE; /* effectively it's a UV now */
1420 left_neg = dleft < 0;
1424 /* This should be exactly the 5.6 behaviour - if left and right are
1425 both in range for UV then use U_V() rather than floor. */
1427 if (dleft < UV_MAX_P1) {
1428 /* right was in range, so is dleft, so use UVs not double.
1432 /* left is out of range for UV, right was in range, so promote
1433 right (back) to double. */
1435 /* The +0.5 is used in 5.6 even though it is not strictly
1436 consistent with the implicit +0 floor in the U_V()
1437 inside the #if 1. */
1438 dleft = Perl_floor(dleft + 0.5);
1441 dright = Perl_floor(dright + 0.5);
1452 DIE(aTHX_ "Illegal modulus zero");
1454 dans = Perl_fmod(dleft, dright);
1455 if ((left_neg != right_neg) && dans)
1456 dans = dright - dans;
1459 sv_setnv(TARG, dans);
1465 DIE(aTHX_ "Illegal modulus zero");
1468 if ((left_neg != right_neg) && ans)
1471 /* XXX may warn: unary minus operator applied to unsigned type */
1472 /* could change -foo to be (~foo)+1 instead */
1473 if (ans <= ~((UV)IV_MAX)+1)
1474 sv_setiv(TARG, ~ans+1);
1476 sv_setnv(TARG, -(NV)ans);
1479 sv_setuv(TARG, ans);
1488 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1495 const UV uv = SvUV(sv);
1497 count = IV_MAX; /* The best we can do? */
1501 const IV iv = SvIV(sv);
1508 else if (SvNOKp(sv)) {
1509 const NV nv = SvNV(sv);
1517 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1519 static const char oom_list_extend[] = "Out of memory during list extend";
1520 const I32 items = SP - MARK;
1521 const I32 max = items * count;
1523 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1524 /* Did the max computation overflow? */
1525 if (items > 0 && max > 0 && (max < items || max < count))
1526 Perl_croak(aTHX_ oom_list_extend);
1531 /* This code was intended to fix 20010809.028:
1534 for (($x =~ /./g) x 2) {
1535 print chop; # "abcdabcd" expected as output.
1538 * but that change (#11635) broke this code:
1540 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1542 * I can't think of a better fix that doesn't introduce
1543 * an efficiency hit by copying the SVs. The stack isn't
1544 * refcounted, and mortalisation obviously doesn't
1545 * Do The Right Thing when the stack has more than
1546 * one pointer to the same mortal value.
1550 *SP = sv_2mortal(newSVsv(*SP));
1560 repeatcpy((char*)(MARK + items), (char*)MARK,
1561 items * sizeof(const SV *), count - 1);
1564 else if (count <= 0)
1567 else { /* Note: mark already snarfed by pp_list */
1568 SV * const tmpstr = POPs;
1571 static const char oom_string_extend[] =
1572 "Out of memory during string extend";
1574 SvSetSV(TARG, tmpstr);
1575 SvPV_force(TARG, len);
1576 isutf = DO_UTF8(TARG);
1581 const STRLEN max = (UV)count * len;
1582 if (len > MEM_SIZE_MAX / count)
1583 Perl_croak(aTHX_ oom_string_extend);
1584 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1585 SvGROW(TARG, max + 1);
1586 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1587 SvCUR_set(TARG, SvCUR(TARG) * count);
1589 *SvEND(TARG) = '\0';
1592 (void)SvPOK_only_UTF8(TARG);
1594 (void)SvPOK_only(TARG);
1596 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1597 /* The parser saw this as a list repeat, and there
1598 are probably several items on the stack. But we're
1599 in scalar context, and there's no pp_list to save us
1600 now. So drop the rest of the items -- robin@kitsite.com
1613 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1614 tryAMAGICbin(subtr,opASSIGN);
1615 svl = sv_2num(TOPm1s);
1616 svr = sv_2num(TOPs);
1617 useleft = USE_LEFT(svl);
1618 #ifdef PERL_PRESERVE_IVUV
1619 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1620 "bad things" happen if you rely on signed integers wrapping. */
1623 /* Unless the left argument is integer in range we are going to have to
1624 use NV maths. Hence only attempt to coerce the right argument if
1625 we know the left is integer. */
1626 register UV auv = 0;
1632 a_valid = auvok = 1;
1633 /* left operand is undef, treat as zero. */
1635 /* Left operand is defined, so is it IV? */
1638 if ((auvok = SvUOK(svl)))
1641 register const IV aiv = SvIVX(svl);
1644 auvok = 1; /* Now acting as a sign flag. */
1645 } else { /* 2s complement assumption for IV_MIN */
1653 bool result_good = 0;
1656 bool buvok = SvUOK(svr);
1661 register const IV biv = SvIVX(svr);
1668 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1669 else "IV" now, independent of how it came in.
1670 if a, b represents positive, A, B negative, a maps to -A etc
1675 all UV maths. negate result if A negative.
1676 subtract if signs same, add if signs differ. */
1678 if (auvok ^ buvok) {
1687 /* Must get smaller */
1692 if (result <= buv) {
1693 /* result really should be -(auv-buv). as its negation
1694 of true value, need to swap our result flag */
1706 if (result <= (UV)IV_MIN)
1707 SETi( -(IV)result );
1709 /* result valid, but out of range for IV. */
1710 SETn( -(NV)result );
1714 } /* Overflow, drop through to NVs. */
1719 NV value = SvNV(svr);
1723 /* left operand is undef, treat as zero - value */
1727 SETn( SvNV(svl) - value );
1734 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1736 const IV shift = POPi;
1737 if (PL_op->op_private & HINT_INTEGER) {
1751 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1753 const IV shift = POPi;
1754 if (PL_op->op_private & HINT_INTEGER) {
1768 dVAR; dSP; tryAMAGICbinSET(lt,0);
1769 #ifdef PERL_PRESERVE_IVUV
1772 SvIV_please(TOPm1s);
1773 if (SvIOK(TOPm1s)) {
1774 bool auvok = SvUOK(TOPm1s);
1775 bool buvok = SvUOK(TOPs);
1777 if (!auvok && !buvok) { /* ## IV < IV ## */
1778 const IV aiv = SvIVX(TOPm1s);
1779 const IV biv = SvIVX(TOPs);
1782 SETs(boolSV(aiv < biv));
1785 if (auvok && buvok) { /* ## UV < UV ## */
1786 const UV auv = SvUVX(TOPm1s);
1787 const UV buv = SvUVX(TOPs);
1790 SETs(boolSV(auv < buv));
1793 if (auvok) { /* ## UV < IV ## */
1795 const IV biv = SvIVX(TOPs);
1798 /* As (a) is a UV, it's >=0, so it cannot be < */
1803 SETs(boolSV(auv < (UV)biv));
1806 { /* ## IV < UV ## */
1807 const IV aiv = SvIVX(TOPm1s);
1811 /* As (b) is a UV, it's >=0, so it must be < */
1818 SETs(boolSV((UV)aiv < buv));
1824 #ifndef NV_PRESERVES_UV
1825 #ifdef PERL_PRESERVE_IVUV
1828 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1830 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1835 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1837 if (Perl_isnan(left) || Perl_isnan(right))
1839 SETs(boolSV(left < right));
1842 SETs(boolSV(TOPn < value));
1850 dVAR; dSP; tryAMAGICbinSET(gt,0);
1851 #ifdef PERL_PRESERVE_IVUV
1854 SvIV_please(TOPm1s);
1855 if (SvIOK(TOPm1s)) {
1856 bool auvok = SvUOK(TOPm1s);
1857 bool buvok = SvUOK(TOPs);
1859 if (!auvok && !buvok) { /* ## IV > IV ## */
1860 const IV aiv = SvIVX(TOPm1s);
1861 const IV biv = SvIVX(TOPs);
1864 SETs(boolSV(aiv > biv));
1867 if (auvok && buvok) { /* ## UV > UV ## */
1868 const UV auv = SvUVX(TOPm1s);
1869 const UV buv = SvUVX(TOPs);
1872 SETs(boolSV(auv > buv));
1875 if (auvok) { /* ## UV > IV ## */
1877 const IV biv = SvIVX(TOPs);
1881 /* As (a) is a UV, it's >=0, so it must be > */
1886 SETs(boolSV(auv > (UV)biv));
1889 { /* ## IV > UV ## */
1890 const IV aiv = SvIVX(TOPm1s);
1894 /* As (b) is a UV, it's >=0, so it cannot be > */
1901 SETs(boolSV((UV)aiv > buv));
1907 #ifndef NV_PRESERVES_UV
1908 #ifdef PERL_PRESERVE_IVUV
1911 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1913 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1918 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1920 if (Perl_isnan(left) || Perl_isnan(right))
1922 SETs(boolSV(left > right));
1925 SETs(boolSV(TOPn > value));
1933 dVAR; dSP; tryAMAGICbinSET(le,0);
1934 #ifdef PERL_PRESERVE_IVUV
1937 SvIV_please(TOPm1s);
1938 if (SvIOK(TOPm1s)) {
1939 bool auvok = SvUOK(TOPm1s);
1940 bool buvok = SvUOK(TOPs);
1942 if (!auvok && !buvok) { /* ## IV <= IV ## */
1943 const IV aiv = SvIVX(TOPm1s);
1944 const IV biv = SvIVX(TOPs);
1947 SETs(boolSV(aiv <= biv));
1950 if (auvok && buvok) { /* ## UV <= UV ## */
1951 UV auv = SvUVX(TOPm1s);
1952 UV buv = SvUVX(TOPs);
1955 SETs(boolSV(auv <= buv));
1958 if (auvok) { /* ## UV <= IV ## */
1960 const IV biv = SvIVX(TOPs);
1964 /* As (a) is a UV, it's >=0, so a cannot be <= */
1969 SETs(boolSV(auv <= (UV)biv));
1972 { /* ## IV <= UV ## */
1973 const IV aiv = SvIVX(TOPm1s);
1977 /* As (b) is a UV, it's >=0, so a must be <= */
1984 SETs(boolSV((UV)aiv <= buv));
1990 #ifndef NV_PRESERVES_UV
1991 #ifdef PERL_PRESERVE_IVUV
1994 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1996 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2001 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2003 if (Perl_isnan(left) || Perl_isnan(right))
2005 SETs(boolSV(left <= right));
2008 SETs(boolSV(TOPn <= value));
2016 dVAR; dSP; tryAMAGICbinSET(ge,0);
2017 #ifdef PERL_PRESERVE_IVUV
2020 SvIV_please(TOPm1s);
2021 if (SvIOK(TOPm1s)) {
2022 bool auvok = SvUOK(TOPm1s);
2023 bool buvok = SvUOK(TOPs);
2025 if (!auvok && !buvok) { /* ## IV >= IV ## */
2026 const IV aiv = SvIVX(TOPm1s);
2027 const IV biv = SvIVX(TOPs);
2030 SETs(boolSV(aiv >= biv));
2033 if (auvok && buvok) { /* ## UV >= UV ## */
2034 const UV auv = SvUVX(TOPm1s);
2035 const UV buv = SvUVX(TOPs);
2038 SETs(boolSV(auv >= buv));
2041 if (auvok) { /* ## UV >= IV ## */
2043 const IV biv = SvIVX(TOPs);
2047 /* As (a) is a UV, it's >=0, so it must be >= */
2052 SETs(boolSV(auv >= (UV)biv));
2055 { /* ## IV >= UV ## */
2056 const IV aiv = SvIVX(TOPm1s);
2060 /* As (b) is a UV, it's >=0, so a cannot be >= */
2067 SETs(boolSV((UV)aiv >= buv));
2073 #ifndef NV_PRESERVES_UV
2074 #ifdef PERL_PRESERVE_IVUV
2077 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2079 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2084 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2086 if (Perl_isnan(left) || Perl_isnan(right))
2088 SETs(boolSV(left >= right));
2091 SETs(boolSV(TOPn >= value));
2099 dVAR; dSP; tryAMAGICbinSET(ne,0);
2100 #ifndef NV_PRESERVES_UV
2101 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2103 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2107 #ifdef PERL_PRESERVE_IVUV
2110 SvIV_please(TOPm1s);
2111 if (SvIOK(TOPm1s)) {
2112 const bool auvok = SvUOK(TOPm1s);
2113 const bool buvok = SvUOK(TOPs);
2115 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2116 /* Casting IV to UV before comparison isn't going to matter
2117 on 2s complement. On 1s complement or sign&magnitude
2118 (if we have any of them) it could make negative zero
2119 differ from normal zero. As I understand it. (Need to
2120 check - is negative zero implementation defined behaviour
2122 const UV buv = SvUVX(POPs);
2123 const UV auv = SvUVX(TOPs);
2125 SETs(boolSV(auv != buv));
2128 { /* ## Mixed IV,UV ## */
2132 /* != is commutative so swap if needed (save code) */
2134 /* swap. top of stack (b) is the iv */
2138 /* As (a) is a UV, it's >0, so it cannot be == */
2147 /* As (b) is a UV, it's >0, so it cannot be == */
2151 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2153 SETs(boolSV((UV)iv != uv));
2160 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2162 if (Perl_isnan(left) || Perl_isnan(right))
2164 SETs(boolSV(left != right));
2167 SETs(boolSV(TOPn != value));
2175 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2176 #ifndef NV_PRESERVES_UV
2177 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2178 const UV right = PTR2UV(SvRV(POPs));
2179 const UV left = PTR2UV(SvRV(TOPs));
2180 SETi((left > right) - (left < right));
2184 #ifdef PERL_PRESERVE_IVUV
2185 /* Fortunately it seems NaN isn't IOK */
2188 SvIV_please(TOPm1s);
2189 if (SvIOK(TOPm1s)) {
2190 const bool leftuvok = SvUOK(TOPm1s);
2191 const bool rightuvok = SvUOK(TOPs);
2193 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2194 const IV leftiv = SvIVX(TOPm1s);
2195 const IV rightiv = SvIVX(TOPs);
2197 if (leftiv > rightiv)
2199 else if (leftiv < rightiv)
2203 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2204 const UV leftuv = SvUVX(TOPm1s);
2205 const UV rightuv = SvUVX(TOPs);
2207 if (leftuv > rightuv)
2209 else if (leftuv < rightuv)
2213 } else if (leftuvok) { /* ## UV <=> IV ## */
2214 const IV rightiv = SvIVX(TOPs);
2216 /* As (a) is a UV, it's >=0, so it cannot be < */
2219 const UV leftuv = SvUVX(TOPm1s);
2220 if (leftuv > (UV)rightiv) {
2222 } else if (leftuv < (UV)rightiv) {
2228 } else { /* ## IV <=> UV ## */
2229 const IV leftiv = SvIVX(TOPm1s);
2231 /* As (b) is a UV, it's >=0, so it must be < */
2234 const UV rightuv = SvUVX(TOPs);
2235 if ((UV)leftiv > rightuv) {
2237 } else if ((UV)leftiv < rightuv) {
2255 if (Perl_isnan(left) || Perl_isnan(right)) {
2259 value = (left > right) - (left < right);
2263 else if (left < right)
2265 else if (left > right)
2281 int amg_type = sle_amg;
2285 switch (PL_op->op_type) {
2304 tryAMAGICbinSET_var(amg_type,0);
2307 const int cmp = (IN_LOCALE_RUNTIME
2308 ? sv_cmp_locale(left, right)
2309 : sv_cmp(left, right));
2310 SETs(boolSV(cmp * multiplier < rhs));
2317 dVAR; dSP; tryAMAGICbinSET(seq,0);
2320 SETs(boolSV(sv_eq(left, right)));
2327 dVAR; dSP; tryAMAGICbinSET(sne,0);
2330 SETs(boolSV(!sv_eq(left, right)));
2337 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2340 const int cmp = (IN_LOCALE_RUNTIME
2341 ? sv_cmp_locale(left, right)
2342 : sv_cmp(left, right));
2350 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2355 if (SvNIOKp(left) || SvNIOKp(right)) {
2356 if (PL_op->op_private & HINT_INTEGER) {
2357 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2361 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2366 do_vop(PL_op->op_type, TARG, left, right);
2375 dVAR; dSP; dATARGET;
2376 const int op_type = PL_op->op_type;
2378 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2383 if (SvNIOKp(left) || SvNIOKp(right)) {
2384 if (PL_op->op_private & HINT_INTEGER) {
2385 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2386 const IV r = SvIV_nomg(right);
2387 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2391 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2392 const UV r = SvUV_nomg(right);
2393 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2398 do_vop(op_type, TARG, left, right);
2407 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2409 SV * const sv = sv_2num(TOPs);
2410 const int flags = SvFLAGS(sv);
2412 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2413 /* It's publicly an integer, or privately an integer-not-float */
2416 if (SvIVX(sv) == IV_MIN) {
2417 /* 2s complement assumption. */
2418 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2421 else if (SvUVX(sv) <= IV_MAX) {
2426 else if (SvIVX(sv) != IV_MIN) {
2430 #ifdef PERL_PRESERVE_IVUV
2439 else if (SvPOKp(sv)) {
2441 const char * const s = SvPV_const(sv, len);
2442 if (isIDFIRST(*s)) {
2443 sv_setpvs(TARG, "-");
2446 else if (*s == '+' || *s == '-') {
2448 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2450 else if (DO_UTF8(sv)) {
2453 goto oops_its_an_int;
2455 sv_setnv(TARG, -SvNV(sv));
2457 sv_setpvs(TARG, "-");
2464 goto oops_its_an_int;
2465 sv_setnv(TARG, -SvNV(sv));
2477 dVAR; dSP; tryAMAGICunSET(not);
2478 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2484 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2489 if (PL_op->op_private & HINT_INTEGER) {
2490 const IV i = ~SvIV_nomg(sv);
2494 const UV u = ~SvUV_nomg(sv);
2503 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2504 sv_setsv_nomg(TARG, sv);
2505 tmps = (U8*)SvPV_force(TARG, len);
2508 /* Calculate exact length, let's not estimate. */
2513 U8 * const send = tmps + len;
2514 U8 * const origtmps = tmps;
2515 const UV utf8flags = UTF8_ALLOW_ANYUV;
2517 while (tmps < send) {
2518 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2520 targlen += UNISKIP(~c);
2526 /* Now rewind strings and write them. */
2533 Newx(result, targlen + 1, U8);
2535 while (tmps < send) {
2536 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2538 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2541 sv_usepvn_flags(TARG, (char*)result, targlen,
2542 SV_HAS_TRAILING_NUL);
2549 Newx(result, nchar + 1, U8);
2551 while (tmps < send) {
2552 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2557 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2565 register long *tmpl;
2566 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2569 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2574 for ( ; anum > 0; anum--, tmps++)
2582 /* integer versions of some of the above */
2586 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2589 SETi( left * right );
2597 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2601 DIE(aTHX_ "Illegal division by zero");
2604 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2608 value = num / value;
2614 #if defined(__GLIBC__) && IVSIZE == 8
2621 /* This is the vanilla old i_modulo. */
2622 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2626 DIE(aTHX_ "Illegal modulus zero");
2627 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2631 SETi( left % right );
2636 #if defined(__GLIBC__) && IVSIZE == 8
2641 /* This is the i_modulo with the workaround for the _moddi3 bug
2642 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2643 * See below for pp_i_modulo. */
2644 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2648 DIE(aTHX_ "Illegal modulus zero");
2649 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2653 SETi( left % PERL_ABS(right) );
2660 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2664 DIE(aTHX_ "Illegal modulus zero");
2665 /* The assumption is to use hereafter the old vanilla version... */
2667 PL_ppaddr[OP_I_MODULO] =
2669 /* .. but if we have glibc, we might have a buggy _moddi3
2670 * (at least glicb 2.2.5 is known to have this bug), in other
2671 * words our integer modulus with negative quad as the second
2672 * argument might be broken. Test for this and re-patch the
2673 * opcode dispatch table if that is the case, remembering to
2674 * also apply the workaround so that this first round works
2675 * right, too. See [perl #9402] for more information. */
2679 /* Cannot do this check with inlined IV constants since
2680 * that seems to work correctly even with the buggy glibc. */
2682 /* Yikes, we have the bug.
2683 * Patch in the workaround version. */
2685 PL_ppaddr[OP_I_MODULO] =
2686 &Perl_pp_i_modulo_1;
2687 /* Make certain we work right this time, too. */
2688 right = PERL_ABS(right);
2691 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2695 SETi( left % right );
2703 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2706 SETi( left + right );
2713 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2716 SETi( left - right );
2723 dVAR; dSP; tryAMAGICbinSET(lt,0);
2726 SETs(boolSV(left < right));
2733 dVAR; dSP; tryAMAGICbinSET(gt,0);
2736 SETs(boolSV(left > right));
2743 dVAR; dSP; tryAMAGICbinSET(le,0);
2746 SETs(boolSV(left <= right));
2753 dVAR; dSP; tryAMAGICbinSET(ge,0);
2756 SETs(boolSV(left >= right));
2763 dVAR; dSP; tryAMAGICbinSET(eq,0);
2766 SETs(boolSV(left == right));
2773 dVAR; dSP; tryAMAGICbinSET(ne,0);
2776 SETs(boolSV(left != right));
2783 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2790 else if (left < right)
2801 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2806 /* High falutin' math. */
2810 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2813 SETn(Perl_atan2(left, right));
2821 int amg_type = sin_amg;
2822 const char *neg_report = NULL;
2823 NV (*func)(NV) = Perl_sin;
2824 const int op_type = PL_op->op_type;
2841 amg_type = sqrt_amg;
2843 neg_report = "sqrt";
2847 tryAMAGICun_var(amg_type);
2849 const NV value = POPn;
2851 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2852 SET_NUMERIC_STANDARD();
2853 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2856 XPUSHn(func(value));
2861 /* Support Configure command-line overrides for rand() functions.
2862 After 5.005, perhaps we should replace this by Configure support
2863 for drand48(), random(), or rand(). For 5.005, though, maintain
2864 compatibility by calling rand() but allow the user to override it.
2865 See INSTALL for details. --Andy Dougherty 15 July 1998
2867 /* Now it's after 5.005, and Configure supports drand48() and random(),
2868 in addition to rand(). So the overrides should not be needed any more.
2869 --Jarkko Hietaniemi 27 September 1998
2872 #ifndef HAS_DRAND48_PROTO
2873 extern double drand48 (void);
2886 if (!PL_srand_called) {
2887 (void)seedDrand01((Rand_seed_t)seed());
2888 PL_srand_called = TRUE;
2898 const UV anum = (MAXARG < 1) ? seed() : POPu;
2899 (void)seedDrand01((Rand_seed_t)anum);
2900 PL_srand_called = TRUE;
2907 dVAR; dSP; dTARGET; tryAMAGICun(int);
2909 SV * const sv = sv_2num(TOPs);
2910 const IV iv = SvIV(sv);
2911 /* XXX it's arguable that compiler casting to IV might be subtly
2912 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2913 else preferring IV has introduced a subtle behaviour change bug. OTOH
2914 relying on floating point to be accurate is a bug. */
2919 else if (SvIOK(sv)) {
2926 const NV value = SvNV(sv);
2928 if (value < (NV)UV_MAX + 0.5) {
2931 SETn(Perl_floor(value));
2935 if (value > (NV)IV_MIN - 0.5) {
2938 SETn(Perl_ceil(value));
2948 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2950 SV * const sv = sv_2num(TOPs);
2951 /* This will cache the NV value if string isn't actually integer */
2952 const IV iv = SvIV(sv);
2957 else if (SvIOK(sv)) {
2958 /* IVX is precise */
2960 SETu(SvUV(sv)); /* force it to be numeric only */
2968 /* 2s complement assumption. Also, not really needed as
2969 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2975 const NV value = SvNV(sv);
2989 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2993 SV* const sv = POPs;
2995 tmps = (SvPV_const(sv, len));
2997 /* If Unicode, try to downgrade
2998 * If not possible, croak. */
2999 SV* const tsv = sv_2mortal(newSVsv(sv));
3002 sv_utf8_downgrade(tsv, FALSE);
3003 tmps = SvPV_const(tsv, len);
3005 if (PL_op->op_type == OP_HEX)
3008 while (*tmps && len && isSPACE(*tmps))
3014 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3016 else if (*tmps == 'b')
3017 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3019 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3021 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3035 SV * const sv = TOPs;
3037 if (SvGAMAGIC(sv)) {
3038 /* For an overloaded or magic scalar, we can't know in advance if
3039 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3040 it likes to cache the length. Maybe that should be a documented
3045 = sv_2pv_flags(sv, &len,
3046 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3050 else if (DO_UTF8(sv)) {
3051 SETi(utf8_length((U8*)p, (U8*)p + len));
3055 } else if (SvOK(sv)) {
3056 /* Neither magic nor overloaded. */
3058 SETi(sv_len_utf8(sv));
3077 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3079 const I32 arybase = CopARYBASE_get(PL_curcop);
3081 const char *repl = NULL;
3083 const int num_args = PL_op->op_private & 7;
3084 bool repl_need_utf8_upgrade = FALSE;
3085 bool repl_is_utf8 = FALSE;
3087 SvTAINTED_off(TARG); /* decontaminate */
3088 SvUTF8_off(TARG); /* decontaminate */
3092 repl = SvPV_const(repl_sv, repl_len);
3093 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3103 sv_utf8_upgrade(sv);
3105 else if (DO_UTF8(sv))
3106 repl_need_utf8_upgrade = TRUE;
3108 tmps = SvPV_const(sv, curlen);
3110 utf8_curlen = sv_len_utf8(sv);
3111 if (utf8_curlen == curlen)
3114 curlen = utf8_curlen;
3119 if (pos >= arybase) {
3137 else if (len >= 0) {
3139 if (rem > (I32)curlen)
3154 Perl_croak(aTHX_ "substr outside of string");
3155 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3159 const I32 upos = pos;
3160 const I32 urem = rem;
3162 sv_pos_u2b(sv, &pos, &rem);
3164 /* we either return a PV or an LV. If the TARG hasn't been used
3165 * before, or is of that type, reuse it; otherwise use a mortal
3166 * instead. Note that LVs can have an extended lifetime, so also
3167 * dont reuse if refcount > 1 (bug #20933) */
3168 if (SvTYPE(TARG) > SVt_NULL) {
3169 if ( (SvTYPE(TARG) == SVt_PVLV)
3170 ? (!lvalue || SvREFCNT(TARG) > 1)
3173 TARG = sv_newmortal();
3177 sv_setpvn(TARG, tmps, rem);
3178 #ifdef USE_LOCALE_COLLATE
3179 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3184 SV* repl_sv_copy = NULL;
3186 if (repl_need_utf8_upgrade) {
3187 repl_sv_copy = newSVsv(repl_sv);
3188 sv_utf8_upgrade(repl_sv_copy);
3189 repl = SvPV_const(repl_sv_copy, repl_len);
3190 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3194 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3198 SvREFCNT_dec(repl_sv_copy);
3200 else if (lvalue) { /* it's an lvalue! */
3201 if (!SvGMAGICAL(sv)) {
3203 SvPV_force_nolen(sv);
3204 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3205 "Attempt to use reference as lvalue in substr");
3207 if (isGV_with_GP(sv))
3208 SvPV_force_nolen(sv);
3209 else if (SvOK(sv)) /* is it defined ? */
3210 (void)SvPOK_only_UTF8(sv);
3212 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3215 if (SvTYPE(TARG) < SVt_PVLV) {
3216 sv_upgrade(TARG, SVt_PVLV);
3217 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3221 if (LvTARG(TARG) != sv) {
3223 SvREFCNT_dec(LvTARG(TARG));
3224 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3226 LvTARGOFF(TARG) = upos;
3227 LvTARGLEN(TARG) = urem;
3231 PUSHs(TARG); /* avoid SvSETMAGIC here */
3238 register const IV size = POPi;
3239 register const IV offset = POPi;
3240 register SV * const src = POPs;
3241 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3243 SvTAINTED_off(TARG); /* decontaminate */
3244 if (lvalue) { /* it's an lvalue! */
3245 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3246 TARG = sv_newmortal();
3247 if (SvTYPE(TARG) < SVt_PVLV) {
3248 sv_upgrade(TARG, SVt_PVLV);
3249 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3252 if (LvTARG(TARG) != src) {
3254 SvREFCNT_dec(LvTARG(TARG));
3255 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3257 LvTARGOFF(TARG) = offset;
3258 LvTARGLEN(TARG) = size;
3261 sv_setuv(TARG, do_vecget(src, offset, size));
3277 const char *little_p;
3278 const I32 arybase = CopARYBASE_get(PL_curcop);
3281 const bool is_index = PL_op->op_type == OP_INDEX;
3284 /* arybase is in characters, like offset, so combine prior to the
3285 UTF-8 to bytes calculation. */
3286 offset = POPi - arybase;
3290 big_p = SvPV_const(big, biglen);
3291 little_p = SvPV_const(little, llen);
3293 big_utf8 = DO_UTF8(big);
3294 little_utf8 = DO_UTF8(little);
3295 if (big_utf8 ^ little_utf8) {
3296 /* One needs to be upgraded. */
3297 if (little_utf8 && !PL_encoding) {
3298 /* Well, maybe instead we might be able to downgrade the small
3300 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3303 /* If the large string is ISO-8859-1, and it's not possible to
3304 convert the small string to ISO-8859-1, then there is no
3305 way that it could be found anywhere by index. */
3310 /* At this point, pv is a malloc()ed string. So donate it to temp
3311 to ensure it will get free()d */
3312 little = temp = newSV(0);
3313 sv_usepvn(temp, pv, llen);
3314 little_p = SvPVX(little);
3317 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3320 sv_recode_to_utf8(temp, PL_encoding);
3322 sv_utf8_upgrade(temp);
3327 big_p = SvPV_const(big, biglen);
3330 little_p = SvPV_const(little, llen);
3334 if (SvGAMAGIC(big)) {
3335 /* Life just becomes a lot easier if I use a temporary here.
3336 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3337 will trigger magic and overloading again, as will fbm_instr()
3339 big = newSVpvn_flags(big_p, biglen,
3340 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3343 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3344 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3345 warn on undef, and we've already triggered a warning with the
3346 SvPV_const some lines above. We can't remove that, as we need to
3347 call some SvPV to trigger overloading early and find out if the
3349 This is all getting to messy. The API isn't quite clean enough,
3350 because data access has side effects.
3352 little = newSVpvn_flags(little_p, llen,
3353 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3354 little_p = SvPVX(little);
3358 offset = is_index ? 0 : biglen;
3360 if (big_utf8 && offset > 0)
3361 sv_pos_u2b(big, &offset, 0);
3367 else if (offset > (I32)biglen)
3369 if (!(little_p = is_index
3370 ? fbm_instr((unsigned char*)big_p + offset,
3371 (unsigned char*)big_p + biglen, little, 0)
3372 : rninstr(big_p, big_p + offset,
3373 little_p, little_p + llen)))
3376 retval = little_p - big_p;
3377 if (retval > 0 && big_utf8)
3378 sv_pos_b2u(big, &retval);
3383 PUSHi(retval + arybase);
3389 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3390 if (SvTAINTED(MARK[1]))
3391 TAINT_PROPER("sprintf");
3392 do_sprintf(TARG, SP-MARK, MARK+1);
3393 TAINT_IF(SvTAINTED(TARG));
3405 const U8 *s = (U8*)SvPV_const(argsv, len);
3407 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3408 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3409 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3413 XPUSHu(DO_UTF8(argsv) ?
3414 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3426 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3428 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3430 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3432 (void) POPs; /* Ignore the argument value. */
3433 value = UNICODE_REPLACEMENT;
3439 SvUPGRADE(TARG,SVt_PV);
3441 if (value > 255 && !IN_BYTES) {
3442 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3443 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3444 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3446 (void)SvPOK_only(TARG);
3455 *tmps++ = (char)value;
3457 (void)SvPOK_only(TARG);
3459 if (PL_encoding && !IN_BYTES) {
3460 sv_recode_to_utf8(TARG, PL_encoding);
3462 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3463 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3467 *tmps++ = (char)value;
3483 const char *tmps = SvPV_const(left, len);
3485 if (DO_UTF8(left)) {
3486 /* If Unicode, try to downgrade.
3487 * If not possible, croak.
3488 * Yes, we made this up. */
3489 SV* const tsv = sv_2mortal(newSVsv(left));
3492 sv_utf8_downgrade(tsv, FALSE);
3493 tmps = SvPV_const(tsv, len);
3495 # ifdef USE_ITHREADS
3497 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3498 /* This should be threadsafe because in ithreads there is only
3499 * one thread per interpreter. If this would not be true,
3500 * we would need a mutex to protect this malloc. */
3501 PL_reentrant_buffer->_crypt_struct_buffer =
3502 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3503 #if defined(__GLIBC__) || defined(__EMX__)
3504 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3505 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3506 /* work around glibc-2.2.5 bug */
3507 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3511 # endif /* HAS_CRYPT_R */
3512 # endif /* USE_ITHREADS */
3514 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3516 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3522 "The crypt() function is unimplemented due to excessive paranoia.");
3534 bool inplace = TRUE;
3536 const int op_type = PL_op->op_type;
3539 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3545 s = (const U8*)SvPV_nomg_const(source, slen);
3547 if (ckWARN(WARN_UNINITIALIZED))
3548 report_uninit(source);
3553 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3555 utf8_to_uvchr(s, &ulen);
3556 if (op_type == OP_UCFIRST) {
3557 toTITLE_utf8(s, tmpbuf, &tculen);
3559 toLOWER_utf8(s, tmpbuf, &tculen);
3561 /* If the two differ, we definately cannot do inplace. */
3562 inplace = (ulen == tculen);
3563 need = slen + 1 - ulen + tculen;
3569 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3570 /* We can convert in place. */
3573 s = d = (U8*)SvPV_force_nomg(source, slen);
3579 SvUPGRADE(dest, SVt_PV);
3580 d = (U8*)SvGROW(dest, need);
3581 (void)SvPOK_only(dest);
3590 /* slen is the byte length of the whole SV.
3591 * ulen is the byte length of the original Unicode character
3592 * stored as UTF-8 at s.
3593 * tculen is the byte length of the freshly titlecased (or
3594 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3595 * We first set the result to be the titlecased (/lowercased)
3596 * character, and then append the rest of the SV data. */
3597 sv_setpvn(dest, (char*)tmpbuf, tculen);
3599 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3603 Copy(tmpbuf, d, tculen, U8);
3604 SvCUR_set(dest, need - 1);
3609 if (IN_LOCALE_RUNTIME) {
3612 *d = (op_type == OP_UCFIRST)
3613 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3616 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3618 /* See bug #39028 */
3626 /* This will copy the trailing NUL */
3627 Copy(s + 1, d + 1, slen, U8);
3628 SvCUR_set(dest, need - 1);
3635 /* There's so much setup/teardown code common between uc and lc, I wonder if
3636 it would be worth merging the two, and just having a switch outside each
3637 of the three tight loops. */
3651 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3652 && SvTEMP(source) && !DO_UTF8(source)) {
3653 /* We can convert in place. */
3656 s = d = (U8*)SvPV_force_nomg(source, len);
3663 /* The old implementation would copy source into TARG at this point.
3664 This had the side effect that if source was undef, TARG was now
3665 an undefined SV with PADTMP set, and they don't warn inside
3666 sv_2pv_flags(). However, we're now getting the PV direct from
3667 source, which doesn't have PADTMP set, so it would warn. Hence the
3671 s = (const U8*)SvPV_nomg_const(source, len);
3673 if (ckWARN(WARN_UNINITIALIZED))
3674 report_uninit(source);
3680 SvUPGRADE(dest, SVt_PV);
3681 d = (U8*)SvGROW(dest, min);
3682 (void)SvPOK_only(dest);
3687 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3688 to check DO_UTF8 again here. */
3690 if (DO_UTF8(source)) {
3691 const U8 *const send = s + len;
3692 U8 tmpbuf[UTF8_MAXBYTES+1];
3695 const STRLEN u = UTF8SKIP(s);
3698 toUPPER_utf8(s, tmpbuf, &ulen);
3699 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3700 /* If the eventually required minimum size outgrows
3701 * the available space, we need to grow. */
3702 const UV o = d - (U8*)SvPVX_const(dest);
3704 /* If someone uppercases one million U+03B0s we SvGROW() one
3705 * million times. Or we could try guessing how much to
3706 allocate without allocating too much. Such is life. */
3708 d = (U8*)SvPVX(dest) + o;
3710 Copy(tmpbuf, d, ulen, U8);
3716 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3719 const U8 *const send = s + len;
3720 if (IN_LOCALE_RUNTIME) {
3723 for (; s < send; d++, s++)
3724 *d = toUPPER_LC(*s);
3727 for (; s < send; d++, s++)
3731 if (source != dest) {
3733 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3753 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3754 && SvTEMP(source) && !DO_UTF8(source)) {
3755 /* We can convert in place. */
3758 s = d = (U8*)SvPV_force_nomg(source, len);
3765 /* The old implementation would copy source into TARG at this point.
3766 This had the side effect that if source was undef, TARG was now
3767 an undefined SV with PADTMP set, and they don't warn inside
3768 sv_2pv_flags(). However, we're now getting the PV direct from
3769 source, which doesn't have PADTMP set, so it would warn. Hence the
3773 s = (const U8*)SvPV_nomg_const(source, len);
3775 if (ckWARN(WARN_UNINITIALIZED))
3776 report_uninit(source);
3782 SvUPGRADE(dest, SVt_PV);
3783 d = (U8*)SvGROW(dest, min);
3784 (void)SvPOK_only(dest);
3789 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3790 to check DO_UTF8 again here. */
3792 if (DO_UTF8(source)) {
3793 const U8 *const send = s + len;
3794 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3797 const STRLEN u = UTF8SKIP(s);
3799 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3801 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3802 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3805 * Now if the sigma is NOT followed by
3806 * /$ignorable_sequence$cased_letter/;
3807 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3808 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3809 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3810 * then it should be mapped to 0x03C2,
3811 * (GREEK SMALL LETTER FINAL SIGMA),
3812 * instead of staying 0x03A3.
3813 * "should be": in other words, this is not implemented yet.
3814 * See lib/unicore/SpecialCasing.txt.
3817 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3818 /* If the eventually required minimum size outgrows
3819 * the available space, we need to grow. */
3820 const UV o = d - (U8*)SvPVX_const(dest);
3822 /* If someone lowercases one million U+0130s we SvGROW() one
3823 * million times. Or we could try guessing how much to
3824 allocate without allocating too much. Such is life. */
3826 d = (U8*)SvPVX(dest) + o;
3828 Copy(tmpbuf, d, ulen, U8);
3834 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3837 const U8 *const send = s + len;
3838 if (IN_LOCALE_RUNTIME) {
3841 for (; s < send; d++, s++)
3842 *d = toLOWER_LC(*s);
3845 for (; s < send; d++, s++)
3849 if (source != dest) {
3851 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3861 SV * const sv = TOPs;
3863 register const char *s = SvPV_const(sv,len);
3865 SvUTF8_off(TARG); /* decontaminate */
3868 SvUPGRADE(TARG, SVt_PV);
3869 SvGROW(TARG, (len * 2) + 1);
3873 if (UTF8_IS_CONTINUED(*s)) {
3874 STRLEN ulen = UTF8SKIP(s);
3898 SvCUR_set(TARG, d - SvPVX_const(TARG));
3899 (void)SvPOK_only_UTF8(TARG);
3902 sv_setpvn(TARG, s, len);
3911 dVAR; dSP; dMARK; dORIGMARK;
3912 register AV *const av = MUTABLE_AV(POPs);
3913 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3915 if (SvTYPE(av) == SVt_PVAV) {
3916 const I32 arybase = CopARYBASE_get(PL_curcop);
3917 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3918 bool can_preserve = FALSE;
3924 can_preserve = SvCANEXISTDELETE(av);
3927 if (lval && localizing) {
3930 for (svp = MARK + 1; svp <= SP; svp++) {
3931 const I32 elem = SvIV(*svp);
3935 if (max > AvMAX(av))
3939 while (++MARK <= SP) {
3941 I32 elem = SvIV(*MARK);
3942 bool preeminent = TRUE;
3946 if (localizing && can_preserve) {
3947 /* If we can determine whether the element exist,
3948 * Try to preserve the existenceness of a tied array
3949 * element by using EXISTS and DELETE if possible.
3950 * Fallback to FETCH and STORE otherwise. */
3951 preeminent = av_exists(av, elem);
3954 svp = av_fetch(av, elem, lval);
3956 if (!svp || *svp == &PL_sv_undef)
3957 DIE(aTHX_ PL_no_aelem, elem);
3960 save_aelem(av, elem, svp);
3962 SAVEADELETE(av, elem);
3965 *MARK = svp ? *svp : &PL_sv_undef;
3968 if (GIMME != G_ARRAY) {
3970 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3980 AV *array = MUTABLE_AV(POPs);
3981 const I32 gimme = GIMME_V;
3982 IV *iterp = Perl_av_iter_p(aTHX_ array);
3983 const IV current = (*iterp)++;
3985 if (current > av_len(array)) {
3987 if (gimme == G_SCALAR)
3994 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3995 if (gimme == G_ARRAY) {
3996 SV **const element = av_fetch(array, current, 0);
3997 PUSHs(element ? *element : &PL_sv_undef);
4006 AV *array = MUTABLE_AV(POPs);
4007 const I32 gimme = GIMME_V;
4009 *Perl_av_iter_p(aTHX_ array) = 0;
4011 if (gimme == G_SCALAR) {
4013 PUSHi(av_len(array) + 1);
4015 else if (gimme == G_ARRAY) {
4016 IV n = Perl_av_len(aTHX_ array);
4017 IV i = CopARYBASE_get(PL_curcop);
4021 if (PL_op->op_type == OP_AKEYS) {
4023 for (; i <= n; i++) {
4028 for (i = 0; i <= n; i++) {
4029 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4030 PUSHs(elem ? *elem : &PL_sv_undef);
4037 /* Associative arrays. */
4043 HV * hash = MUTABLE_HV(POPs);
4045 const I32 gimme = GIMME_V;
4048 /* might clobber stack_sp */
4049 entry = hv_iternext(hash);
4054 SV* const sv = hv_iterkeysv(entry);
4055 PUSHs(sv); /* won't clobber stack_sp */
4056 if (gimme == G_ARRAY) {
4059 /* might clobber stack_sp */
4060 val = hv_iterval(hash, entry);
4065 else if (gimme == G_SCALAR)
4072 S_do_delete_local(pTHX)
4076 const I32 gimme = GIMME_V;
4080 if (PL_op->op_private & OPpSLICE) {
4082 SV * const osv = POPs;
4083 const bool tied = SvRMAGICAL(osv)
4084 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4085 const bool can_preserve = SvCANEXISTDELETE(osv)
4086 || mg_find((const SV *)osv, PERL_MAGIC_env);
4087 const U32 type = SvTYPE(osv);
4088 if (type == SVt_PVHV) { /* hash element */
4089 HV * const hv = MUTABLE_HV(osv);
4090 while (++MARK <= SP) {
4091 SV * const keysv = *MARK;
4093 bool preeminent = TRUE;
4095 preeminent = hv_exists_ent(hv, keysv, 0);
4097 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4104 sv = hv_delete_ent(hv, keysv, 0, 0);
4105 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4108 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4110 *MARK = sv_mortalcopy(sv);
4116 SAVEHDELETE(hv, keysv);
4117 *MARK = &PL_sv_undef;
4121 else if (type == SVt_PVAV) { /* array element */
4122 if (PL_op->op_flags & OPf_SPECIAL) {
4123 AV * const av = MUTABLE_AV(osv);
4124 while (++MARK <= SP) {
4125 I32 idx = SvIV(*MARK);
4127 bool preeminent = TRUE;
4129 preeminent = av_exists(av, idx);
4131 SV **svp = av_fetch(av, idx, 1);
4138 sv = av_delete(av, idx, 0);
4139 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4142 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4144 *MARK = sv_mortalcopy(sv);
4150 SAVEADELETE(av, idx);
4151 *MARK = &PL_sv_undef;
4157 DIE(aTHX_ "Not a HASH reference");
4158 if (gimme == G_VOID)
4160 else if (gimme == G_SCALAR) {
4165 *++MARK = &PL_sv_undef;
4170 SV * const keysv = POPs;
4171 SV * const osv = POPs;
4172 const bool tied = SvRMAGICAL(osv)
4173 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4174 const bool can_preserve = SvCANEXISTDELETE(osv)
4175 || mg_find((const SV *)osv, PERL_MAGIC_env);
4176 const U32 type = SvTYPE(osv);
4178 if (type == SVt_PVHV) {
4179 HV * const hv = MUTABLE_HV(osv);
4180 bool preeminent = TRUE;
4182 preeminent = hv_exists_ent(hv, keysv, 0);
4184 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4191 sv = hv_delete_ent(hv, keysv, 0, 0);
4192 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4195 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4197 SV *nsv = sv_mortalcopy(sv);
4203 SAVEHDELETE(hv, keysv);
4205 else if (type == SVt_PVAV) {
4206 if (PL_op->op_flags & OPf_SPECIAL) {
4207 AV * const av = MUTABLE_AV(osv);
4208 I32 idx = SvIV(keysv);
4209 bool preeminent = TRUE;
4211 preeminent = av_exists(av, idx);
4213 SV **svp = av_fetch(av, idx, 1);
4220 sv = av_delete(av, idx, 0);
4221 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4224 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4226 SV *nsv = sv_mortalcopy(sv);
4232 SAVEADELETE(av, idx);
4235 DIE(aTHX_ "panic: avhv_delete no longer supported");
4238 DIE(aTHX_ "Not a HASH reference");
4241 if (gimme != G_VOID)
4255 if (PL_op->op_private & OPpLVAL_INTRO)
4256 return do_delete_local();
4259 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4261 if (PL_op->op_private & OPpSLICE) {
4263 HV * const hv = MUTABLE_HV(POPs);
4264 const U32 hvtype = SvTYPE(hv);
4265 if (hvtype == SVt_PVHV) { /* hash element */
4266 while (++MARK <= SP) {
4267 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4268 *MARK = sv ? sv : &PL_sv_undef;
4271 else if (hvtype == SVt_PVAV) { /* array element */
4272 if (PL_op->op_flags & OPf_SPECIAL) {
4273 while (++MARK <= SP) {
4274 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4275 *MARK = sv ? sv : &PL_sv_undef;
4280 DIE(aTHX_ "Not a HASH reference");
4283 else if (gimme == G_SCALAR) {
4288 *++MARK = &PL_sv_undef;
4294 HV * const hv = MUTABLE_HV(POPs);
4296 if (SvTYPE(hv) == SVt_PVHV)
4297 sv = hv_delete_ent(hv, keysv, discard, 0);
4298 else if (SvTYPE(hv) == SVt_PVAV) {
4299 if (PL_op->op_flags & OPf_SPECIAL)
4300 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4302 DIE(aTHX_ "panic: avhv_delete no longer supported");
4305 DIE(aTHX_ "Not a HASH reference");
4321 if (PL_op->op_private & OPpEXISTS_SUB) {
4323 SV * const sv = POPs;
4324 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4327 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4332 hv = MUTABLE_HV(POPs);
4333 if (SvTYPE(hv) == SVt_PVHV) {
4334 if (hv_exists_ent(hv, tmpsv, 0))
4337 else if (SvTYPE(hv) == SVt_PVAV) {
4338 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4339 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4344 DIE(aTHX_ "Not a HASH reference");
4351 dVAR; dSP; dMARK; dORIGMARK;
4352 register HV * const hv = MUTABLE_HV(POPs);
4353 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4354 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4355 bool can_preserve = FALSE;
4361 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4362 can_preserve = TRUE;
4365 while (++MARK <= SP) {
4366 SV * const keysv = *MARK;
4369 bool preeminent = TRUE;
4371 if (localizing && can_preserve) {
4372 /* If we can determine whether the element exist,
4373 * try to preserve the existenceness of a tied hash
4374 * element by using EXISTS and DELETE if possible.
4375 * Fallback to FETCH and STORE otherwise. */
4376 preeminent = hv_exists_ent(hv, keysv, 0);
4379 he = hv_fetch_ent(hv, keysv, lval, 0);
4380 svp = he ? &HeVAL(he) : NULL;
4383 if (!svp || *svp == &PL_sv_undef) {
4384 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4387 if (HvNAME_get(hv) && isGV(*svp))
4388 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4389 else if (preeminent)
4390 save_helem_flags(hv, keysv, svp,
4391 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4393 SAVEHDELETE(hv, keysv);
4396 *MARK = svp ? *svp : &PL_sv_undef;
4398 if (GIMME != G_ARRAY) {
4400 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4406 /* List operators. */
4411 if (GIMME != G_ARRAY) {
4413 *MARK = *SP; /* unwanted list, return last item */
4415 *MARK = &PL_sv_undef;
4425 SV ** const lastrelem = PL_stack_sp;
4426 SV ** const lastlelem = PL_stack_base + POPMARK;
4427 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4428 register SV ** const firstrelem = lastlelem + 1;
4429 const I32 arybase = CopARYBASE_get(PL_curcop);
4430 I32 is_something_there = FALSE;
4432 register const I32 max = lastrelem - lastlelem;
4433 register SV **lelem;
4435 if (GIMME != G_ARRAY) {
4436 I32 ix = SvIV(*lastlelem);
4441 if (ix < 0 || ix >= max)
4442 *firstlelem = &PL_sv_undef;
4444 *firstlelem = firstrelem[ix];
4450 SP = firstlelem - 1;
4454 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4455 I32 ix = SvIV(*lelem);
4460 if (ix < 0 || ix >= max)
4461 *lelem = &PL_sv_undef;
4463 is_something_there = TRUE;
4464 if (!(*lelem = firstrelem[ix]))
4465 *lelem = &PL_sv_undef;
4468 if (is_something_there)
4471 SP = firstlelem - 1;
4477 dVAR; dSP; dMARK; dORIGMARK;
4478 const I32 items = SP - MARK;
4479 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4480 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4481 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4482 ? newRV_noinc(av) : av);
4488 dVAR; dSP; dMARK; dORIGMARK;
4489 HV* const hv = newHV();
4492 SV * const key = *++MARK;
4493 SV * const val = newSV(0);
4495 sv_setsv(val, *++MARK);
4497 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4498 (void)hv_store_ent(hv,key,val,0);
4501 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4502 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4508 dVAR; dSP; dMARK; dORIGMARK;
4509 register AV *ary = MUTABLE_AV(*++MARK);
4513 register I32 offset;
4514 register I32 length;
4518 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4521 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4525 call_method("SPLICE",GIMME_V);
4534 offset = i = SvIV(*MARK);
4536 offset += AvFILLp(ary) + 1;
4538 offset -= CopARYBASE_get(PL_curcop);
4540 DIE(aTHX_ PL_no_aelem, i);
4542 length = SvIVx(*MARK++);
4544 length += AvFILLp(ary) - offset + 1;
4550 length = AvMAX(ary) + 1; /* close enough to infinity */
4554 length = AvMAX(ary) + 1;
4556 if (offset > AvFILLp(ary) + 1) {
4557 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4558 offset = AvFILLp(ary) + 1;
4560 after = AvFILLp(ary) + 1 - (offset + length);
4561 if (after < 0) { /* not that much array */
4562 length += after; /* offset+length now in array */
4568 /* At this point, MARK .. SP-1 is our new LIST */
4571 diff = newlen - length;
4572 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4575 /* make new elements SVs now: avoid problems if they're from the array */
4576 for (dst = MARK, i = newlen; i; i--) {
4577 SV * const h = *dst;
4578 *dst++ = newSVsv(h);
4581 if (diff < 0) { /* shrinking the area */
4582 SV **tmparyval = NULL;
4584 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4585 Copy(MARK, tmparyval, newlen, SV*);
4588 MARK = ORIGMARK + 1;
4589 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4590 MEXTEND(MARK, length);
4591 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4593 EXTEND_MORTAL(length);
4594 for (i = length, dst = MARK; i; i--) {
4595 sv_2mortal(*dst); /* free them eventualy */
4602 *MARK = AvARRAY(ary)[offset+length-1];
4605 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4606 SvREFCNT_dec(*dst++); /* free them now */
4609 AvFILLp(ary) += diff;
4611 /* pull up or down? */
4613 if (offset < after) { /* easier to pull up */
4614 if (offset) { /* esp. if nothing to pull */
4615 src = &AvARRAY(ary)[offset-1];
4616 dst = src - diff; /* diff is negative */
4617 for (i = offset; i > 0; i--) /* can't trust Copy */
4621 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4625 if (after) { /* anything to pull down? */
4626 src = AvARRAY(ary) + offset + length;
4627 dst = src + diff; /* diff is negative */
4628 Move(src, dst, after, SV*);
4630 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4631 /* avoid later double free */
4635 dst[--i] = &PL_sv_undef;
4638 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4639 Safefree(tmparyval);
4642 else { /* no, expanding (or same) */
4643 SV** tmparyval = NULL;
4645 Newx(tmparyval, length, SV*); /* so remember deletion */
4646 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4649 if (diff > 0) { /* expanding */
4650 /* push up or down? */
4651 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4655 Move(src, dst, offset, SV*);
4657 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4659 AvFILLp(ary) += diff;
4662 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4663 av_extend(ary, AvFILLp(ary) + diff);
4664 AvFILLp(ary) += diff;
4667 dst = AvARRAY(ary) + AvFILLp(ary);
4669 for (i = after; i; i--) {
4677 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4680 MARK = ORIGMARK + 1;
4681 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4683 Copy(tmparyval, MARK, length, SV*);
4685 EXTEND_MORTAL(length);
4686 for (i = length, dst = MARK; i; i--) {
4687 sv_2mortal(*dst); /* free them eventualy */
4694 else if (length--) {
4695 *MARK = tmparyval[length];
4698 while (length-- > 0)
4699 SvREFCNT_dec(tmparyval[length]);
4703 *MARK = &PL_sv_undef;
4704 Safefree(tmparyval);
4712 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4713 register AV * const ary = MUTABLE_AV(*++MARK);
4714 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4717 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4721 call_method("PUSH",G_SCALAR|G_DISCARD);
4726 PL_delaymagic = DM_DELAY;
4727 for (++MARK; MARK <= SP; MARK++) {
4728 SV * const sv = newSV(0);
4730 sv_setsv(sv, *MARK);
4731 av_store(ary, AvFILLp(ary)+1, sv);
4733 if (PL_delaymagic & DM_ARRAY)
4734 mg_set(MUTABLE_SV(ary));
4739 if (OP_GIMME(PL_op, 0) != G_VOID) {
4740 PUSHi( AvFILL(ary) + 1 );
4749 AV * const av = MUTABLE_AV(POPs);
4750 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4754 (void)sv_2mortal(sv);
4761 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4762 register AV *ary = MUTABLE_AV(*++MARK);
4763 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4766 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4770 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4776 av_unshift(ary, SP - MARK);
4778 SV * const sv = newSVsv(*++MARK);
4779 (void)av_store(ary, i++, sv);
4783 if (OP_GIMME(PL_op, 0) != G_VOID) {
4784 PUSHi( AvFILL(ary) + 1 );
4792 SV ** const oldsp = SP;
4794 if (GIMME == G_ARRAY) {
4797 register SV * const tmp = *MARK;
4801 /* safe as long as stack cannot get extended in the above */
4806 register char *down;
4810 PADOFFSET padoff_du;
4812 SvUTF8_off(TARG); /* decontaminate */
4814 do_join(TARG, &PL_sv_no, MARK, SP);
4816 sv_setsv(TARG, (SP > MARK)
4818 : (padoff_du = find_rundefsvoffset(),
4819 (padoff_du == NOT_IN_PAD
4820 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4821 ? DEFSV : PAD_SVl(padoff_du)));
4823 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4824 report_uninit(TARG);
4827 up = SvPV_force(TARG, len);
4829 if (DO_UTF8(TARG)) { /* first reverse each character */
4830 U8* s = (U8*)SvPVX(TARG);
4831 const U8* send = (U8*)(s + len);
4833 if (UTF8_IS_INVARIANT(*s)) {
4838 if (!utf8_to_uvchr(s, 0))
4842 down = (char*)(s - 1);
4843 /* reverse this character */
4847 *down-- = (char)tmp;
4853 down = SvPVX(TARG) + len - 1;
4857 *down-- = (char)tmp;
4859 (void)SvPOK_only_UTF8(TARG);
4871 register IV limit = POPi; /* note, negative is forever */
4872 SV * const sv = POPs;
4874 register const char *s = SvPV_const(sv, len);
4875 const bool do_utf8 = DO_UTF8(sv);
4876 const char *strend = s + len;
4878 register REGEXP *rx;
4880 register const char *m;
4882 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4883 I32 maxiters = slen + 10;
4884 I32 trailing_empty = 0;
4886 const I32 origlimit = limit;
4889 const I32 gimme = GIMME_V;
4890 const bool gimme_scalar = (GIMME_V == G_SCALAR);
4891 const I32 oldsave = PL_savestack_ix;
4892 U32 make_mortal = SVs_TEMP;
4897 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4902 DIE(aTHX_ "panic: pp_split");
4905 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4906 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4908 RX_MATCH_UTF8_set(rx, do_utf8);
4911 if (pm->op_pmreplrootu.op_pmtargetoff) {
4912 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
4915 if (pm->op_pmreplrootu.op_pmtargetgv) {
4916 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4921 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4927 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
4929 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
4936 for (i = AvFILLp(ary); i >= 0; i--)
4937 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4939 /* temporarily switch stacks */
4940 SAVESWITCHSTACK(PL_curstack, ary);
4944 base = SP - PL_stack_base;
4946 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4948 while (*s == ' ' || is_utf8_space((U8*)s))
4951 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4952 while (isSPACE_LC(*s))
4960 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4965 limit = maxiters + 2;
4966 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4969 /* this one uses 'm' and is a negative test */
4971 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4972 const int t = UTF8SKIP(m);
4973 /* is_utf8_space returns FALSE for malform utf8 */
4979 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4980 while (m < strend && !isSPACE_LC(*m))
4983 while (m < strend && !isSPACE(*m))
4996 dstr = newSVpvn_flags(s, m-s,
4997 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5001 /* skip the whitespace found last */
5003 s = m + UTF8SKIP(m);
5007 /* this one uses 's' and is a positive test */
5009 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5011 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5012 while (s < strend && isSPACE_LC(*s))
5015 while (s < strend && isSPACE(*s))
5020 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5022 for (m = s; m < strend && *m != '\n'; m++)
5035 dstr = newSVpvn_flags(s, m-s,
5036 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5042 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5044 Pre-extend the stack, either the number of bytes or
5045 characters in the string or a limited amount, triggered by:
5047 my ($x, $y) = split //, $str;
5051 if (!gimme_scalar) {
5052 const U32 items = limit - 1;
5061 /* keep track of how many bytes we skip over */
5071 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5084 dstr = newSVpvn(s, 1);
5100 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5101 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5102 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5103 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5104 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5105 SV * const csv = CALLREG_INTUIT_STRING(rx);
5107 len = RX_MINLENRET(rx);
5108 if (len == 1 && !RX_UTF8(rx) && !tail) {
5109 const char c = *SvPV_nolen_const(csv);
5111 for (m = s; m < strend && *m != c; m++)
5122 dstr = newSVpvn_flags(s, m-s,
5123 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5126 /* The rx->minlen is in characters but we want to step
5127 * s ahead by bytes. */
5129 s = (char*)utf8_hop((U8*)m, len);
5131 s = m + len; /* Fake \n at the end */
5135 while (s < strend && --limit &&
5136 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5137 csv, multiline ? FBMrf_MULTILINE : 0)) )
5146 dstr = newSVpvn_flags(s, m-s,
5147 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5150 /* The rx->minlen is in characters but we want to step
5151 * s ahead by bytes. */
5153 s = (char*)utf8_hop((U8*)m, len);
5155 s = m + len; /* Fake \n at the end */
5160 maxiters += slen * RX_NPARENS(rx);
5161 while (s < strend && --limit)
5165 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5168 if (rex_return == 0)
5170 TAINT_IF(RX_MATCH_TAINTED(rx));
5171 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5174 orig = RX_SUBBEG(rx);
5176 strend = s + (strend - m);
5178 m = RX_OFFS(rx)[0].start + orig;
5187 dstr = newSVpvn_flags(s, m-s,
5188 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5191 if (RX_NPARENS(rx)) {
5193 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5194 s = RX_OFFS(rx)[i].start + orig;
5195 m = RX_OFFS(rx)[i].end + orig;
5197 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5198 parens that didn't match -- they should be set to
5199 undef, not the empty string */
5207 if (m >= orig && s >= orig) {
5208 dstr = newSVpvn_flags(s, m-s,
5209 (do_utf8 ? SVf_UTF8 : 0)
5213 dstr = &PL_sv_undef; /* undef, not "" */
5219 s = RX_OFFS(rx)[0].end + orig;
5223 if (!gimme_scalar) {
5224 iters = (SP - PL_stack_base) - base;
5226 if (iters > maxiters)
5227 DIE(aTHX_ "Split loop");
5229 /* keep field after final delim? */
5230 if (s < strend || (iters && origlimit)) {
5231 if (!gimme_scalar) {
5232 const STRLEN l = strend - s;
5233 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5238 else if (!origlimit) {
5240 iters -= trailing_empty;
5242 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5243 if (TOPs && !make_mortal)
5245 *SP-- = &PL_sv_undef;
5252 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5256 if (SvSMAGICAL(ary)) {
5258 mg_set(MUTABLE_SV(ary));
5261 if (gimme == G_ARRAY) {
5263 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5271 call_method("PUSH",G_SCALAR|G_DISCARD);
5274 if (gimme == G_ARRAY) {
5276 /* EXTEND should not be needed - we just popped them */
5278 for (i=0; i < iters; i++) {
5279 SV **svp = av_fetch(ary, i, FALSE);
5280 PUSHs((svp) ? *svp : &PL_sv_undef);
5287 if (gimme == G_ARRAY)
5299 SV *const sv = PAD_SVl(PL_op->op_targ);
5301 if (SvPADSTALE(sv)) {
5304 RETURNOP(cLOGOP->op_other);
5306 RETURNOP(cLOGOP->op_next);
5315 assert(SvTYPE(retsv) != SVt_PVCV);
5317 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
5318 retsv = refto(retsv);
5325 PP(unimplemented_op)
5328 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5336 HV * const hv = (HV*)POPs;
5338 if (SvRMAGICAL(hv)) {
5339 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5341 XPUSHs(magic_scalarpack(hv, mg));
5346 XPUSHs(boolSV(HvKEYS(hv) != 0));
5352 * c-indentation-style: bsd
5354 * indent-tabs-mode: t
5357 * ex: set ts=8 sts=4 sw=4 noet: