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.
31 #include "invlist_inline.h"
33 #include "regcharclass.h"
35 /* variations on pp_null */
40 if (GIMME_V == G_SCALAR)
52 assert(SvTYPE(TARG) == SVt_PVCV);
67 CV * const protocv = PadnamePROTOCV(
68 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
70 assert(SvTYPE(TARG) == SVt_PVCV);
72 if (CvISXSUB(protocv)) { /* constant */
73 /* XXX Should we clone it here? */
74 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
75 to introcv and remove the SvPADSTALE_off. */
76 SAVEPADSVANDMORTALIZE(ARGTARG);
77 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
80 if (CvROOT(protocv)) {
81 assert(CvCLONE(protocv));
82 assert(!CvCLONED(protocv));
84 cv_clone_into(protocv,(CV *)TARG);
85 SAVECLEARSV(PAD_SVl(ARGTARG));
92 /* In some cases this function inspects PL_op. If this function is called
93 for new op types, more bool parameters may need to be added in place of
96 When noinit is true, the absence of a gv will cause a retval of undef.
97 This is unrelated to the cv-to-gv assignment case.
101 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
104 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
107 sv = amagic_deref_call(sv, to_gv_amg);
111 if (SvTYPE(sv) == SVt_PVIO) {
112 GV * const gv = MUTABLE_GV(sv_newmortal());
113 gv_init(gv, 0, "__ANONIO__", 10, 0);
114 GvIOp(gv) = MUTABLE_IO(sv);
115 SvREFCNT_inc_void_NN(sv);
118 else if (!isGV_with_GP(sv)) {
119 Perl_die(aTHX_ "Not a GLOB reference");
123 if (!isGV_with_GP(sv)) {
125 /* If this is a 'my' scalar and flag is set then vivify
128 if (vivify_sv && sv != &PL_sv_undef) {
132 Perl_croak_no_modify();
133 gv = MUTABLE_GV(newSV(0));
134 stash = CopSTASH(PL_curcop);
135 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
136 if (cUNOP->op_targ) {
137 SV * const namesv = PAD_SV(cUNOP->op_targ);
138 gv_init_sv(gv, stash, namesv, 0);
141 gv_init_pv(gv, stash, "__ANONIO__", 0);
143 sv_setrv_noinc_mg(sv, MUTABLE_SV(gv));
146 if (PL_op->op_flags & OPf_REF || strict) {
147 Perl_die(aTHX_ PL_no_usym, "a symbol");
149 if (ckWARN(WARN_UNINITIALIZED))
155 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
156 sv, GV_ADDMG, SVt_PVGV
165 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
169 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
170 == OPpDONT_INIT_GV) {
171 /* We are the target of a coderef assignment. Return
172 the scalar unchanged, and let pp_sasssign deal with
176 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
178 /* FAKE globs in the symbol table cause weird bugs (#77810) */
182 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
183 SV *newsv = sv_mortalcopy_flags(sv, 0);
195 sv, PL_op->op_private & OPpDEREF,
196 PL_op->op_private & HINT_STRICT_REFS,
197 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
198 || PL_op->op_type == OP_READLINE
200 if (PL_op->op_private & OPpLVAL_INTRO)
201 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
206 /* Helper function for pp_rv2sv and pp_rv2av */
208 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
209 const svtype type, SV ***spp)
213 PERL_ARGS_ASSERT_SOFTREF2XV;
215 if (PL_op->op_private & HINT_STRICT_REFS) {
217 Perl_die(aTHX_ PL_no_symref_sv, sv,
218 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
220 Perl_die(aTHX_ PL_no_usym, what);
224 PL_op->op_flags & OPf_REF
226 Perl_die(aTHX_ PL_no_usym, what);
227 if (ckWARN(WARN_UNINITIALIZED))
229 if (type != SVt_PV && GIMME_V == G_LIST) {
233 **spp = &PL_sv_undef;
236 if ((PL_op->op_flags & OPf_SPECIAL) &&
237 !(PL_op->op_flags & OPf_MOD))
239 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
241 **spp = &PL_sv_undef;
246 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
259 sv = amagic_deref_call(sv, to_sv_amg);
263 if (SvTYPE(sv) >= SVt_PVAV)
264 DIE(aTHX_ "Not a SCALAR reference");
269 if (!isGV_with_GP(gv)) {
270 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
276 if (PL_op->op_flags & OPf_MOD) {
277 if (PL_op->op_private & OPpLVAL_INTRO) {
278 if (cUNOP->op_first->op_type == OP_NULL)
279 sv = save_scalar(MUTABLE_GV(TOPs));
281 sv = save_scalar(gv);
283 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
285 else if (PL_op->op_private & OPpDEREF)
286 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
288 SPAGAIN; /* in case chasing soft refs reallocated the stack */
296 AV * const av = MUTABLE_AV(TOPs);
297 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
299 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
301 *svp = newSV_type(SVt_PVMG);
302 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
306 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
315 if (PL_op->op_flags & OPf_MOD || LVRET) {
316 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
317 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
319 LvTARG(ret) = SvREFCNT_inc_simple(sv);
320 SETs(ret); /* no SvSETMAGIC */
323 const MAGIC * const mg = mg_find_mglob(sv);
324 if (mg && mg->mg_len != -1) {
325 STRLEN i = mg->mg_len;
326 if (PL_op->op_private & OPpTRUEBOOL)
327 SETs(i ? &PL_sv_yes : &PL_sv_zero);
330 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
331 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
346 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
348 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
349 == OPpMAY_RETURN_CONSTANT)
352 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
353 /* (But not in defined().) */
355 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
357 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
358 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
359 ? MUTABLE_CV(SvRV(gv))
363 cv = MUTABLE_CV(&PL_sv_undef);
364 SETs(MUTABLE_SV(cv));
374 SV *ret = &PL_sv_undef;
376 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
377 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
378 const char * s = SvPVX_const(TOPs);
379 if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
380 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
382 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
383 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
385 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
391 cv = sv_2cv(TOPs, &stash, &gv, 0);
393 ret = newSVpvn_flags(
394 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
404 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
406 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
408 PUSHs(MUTABLE_SV(cv));
422 if (GIMME_V != G_LIST) {
428 *MARK = &PL_sv_undef;
430 *MARK = refto(*MARK);
434 EXTEND_MORTAL(SP - MARK);
436 *MARK = refto(*MARK);
441 S_refto(pTHX_ SV *sv)
445 PERL_ARGS_ASSERT_REFTO;
447 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
450 if (!(sv = LvTARG(sv)))
453 SvREFCNT_inc_void_NN(sv);
455 else if (SvTYPE(sv) == SVt_PVAV) {
456 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
457 av_reify(MUTABLE_AV(sv));
459 SvREFCNT_inc_void_NN(sv);
461 else if (SvPADTMP(sv)) {
464 else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
465 sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
468 SvREFCNT_inc_void_NN(sv);
471 sv_setrv_noinc(rv, sv);
478 SV * const sv = TOPs;
486 /* op is in boolean context? */
487 if ( (PL_op->op_private & OPpTRUEBOOL)
488 || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL)
489 && block_gimme() == G_VOID))
491 /* refs are always true - unless it's to an object blessed into a
492 * class with a false name, i.e. "0". So we have to check for
493 * that remote possibility. The following is is basically an
494 * unrolled SvTRUE(sv_reftype(rv)) */
495 SV * const rv = SvRV(sv);
497 HV *stash = SvSTASH(rv);
498 HEK *hek = HvNAME_HEK(stash);
500 I32 len = HEK_LEN(hek);
501 /* bail out and do it the hard way? */
504 || (len == 1 && HEK_KEY(hek)[0] == '0')
517 sv_ref(TARG, SvRV(sv), TRUE);
533 stash = CopSTASH(PL_curcop);
534 if (SvTYPE(stash) != SVt_PVHV)
535 Perl_croak(aTHX_ "Attempt to bless into a freed package");
538 SV * const ssv = POPs;
542 if (!ssv) goto curstash;
545 if (!SvAMAGIC(ssv)) {
547 Perl_croak(aTHX_ "Attempt to bless into a reference");
549 /* SvAMAGIC is on here, but it only means potentially overloaded,
550 so after stringification: */
551 ptr = SvPV_nomg_const(ssv,len);
552 /* We need to check the flag again: */
553 if (!SvAMAGIC(ssv)) goto frog;
555 else ptr = SvPV_nomg_const(ssv,len);
557 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
558 "Explicit blessing to '' (assuming package main)");
559 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
562 (void)sv_bless(TOPs, stash);
572 const char * const elem = SvPV_const(sv, len);
573 GV * const gv = MUTABLE_GV(TOPs);
578 /* elem will always be NUL terminated. */
581 if (memEQs(elem, len, "ARRAY"))
583 tmpRef = MUTABLE_SV(GvAV(gv));
584 if (tmpRef && !AvREAL((const AV *)tmpRef)
585 && AvREIFY((const AV *)tmpRef))
586 av_reify(MUTABLE_AV(tmpRef));
590 if (memEQs(elem, len, "CODE"))
591 tmpRef = MUTABLE_SV(GvCVu(gv));
594 if (memEQs(elem, len, "FILEHANDLE")) {
595 tmpRef = MUTABLE_SV(GvIOp(gv));
598 if (memEQs(elem, len, "FORMAT"))
599 tmpRef = MUTABLE_SV(GvFORM(gv));
602 if (memEQs(elem, len, "GLOB"))
603 tmpRef = MUTABLE_SV(gv);
606 if (memEQs(elem, len, "HASH"))
607 tmpRef = MUTABLE_SV(GvHV(gv));
610 if (memEQs(elem, len, "IO"))
611 tmpRef = MUTABLE_SV(GvIOp(gv));
614 if (memEQs(elem, len, "NAME"))
615 sv = newSVhek(GvNAME_HEK(gv));
618 if (memEQs(elem, len, "PACKAGE")) {
619 const HV * const stash = GvSTASH(gv);
620 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
621 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
625 if (memEQs(elem, len, "SCALAR"))
640 /* Pattern matching */
648 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
649 /* Historically, study was skipped in these cases. */
654 /* Make study a no-op. It's no longer useful and its existence
655 complicates matters elsewhere. */
661 /* also used for: pp_transr() */
668 if (PL_op->op_flags & OPf_STACKED)
673 sv = PAD_SV(ARGTARG);
678 if(PL_op->op_type == OP_TRANSR) {
680 const char * const pv = SvPV(sv,len);
681 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
686 Size_t i = do_trans(sv);
692 /* Lvalue operators. */
695 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
701 PERL_ARGS_ASSERT_DO_CHOMP;
703 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
705 if (SvTYPE(sv) == SVt_PVAV) {
707 AV *const av = MUTABLE_AV(sv);
708 const I32 max = AvFILL(av);
710 for (i = 0; i <= max; i++) {
711 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
712 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
713 count += do_chomp(retval, sv, chomping);
717 else if (SvTYPE(sv) == SVt_PVHV) {
718 HV* const hv = MUTABLE_HV(sv);
720 (void)hv_iterinit(hv);
721 while ((entry = hv_iternext(hv)))
722 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
725 else if (SvREADONLY(sv)) {
726 Perl_croak_no_modify();
732 char *temp_buffer = NULL;
737 goto nope_free_nothing;
739 while (len && s[-1] == '\n') {
746 STRLEN rslen, rs_charlen;
747 const char *rsptr = SvPV_const(PL_rs, rslen);
749 rs_charlen = SvUTF8(PL_rs)
753 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
754 /* Assumption is that rs is shorter than the scalar. */
756 /* RS is utf8, scalar is 8 bit. */
758 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
761 /* Cannot downgrade, therefore cannot possibly match.
762 At this point, temp_buffer is not alloced, and
763 is the buffer inside PL_rs, so dont free it.
765 assert (temp_buffer == rsptr);
771 /* RS is 8 bit, scalar is utf8. */
772 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
786 if (memNE(s, rsptr, rslen))
791 SvPV_force_nomg_nolen(sv);
798 Safefree(temp_buffer);
800 SvREFCNT_dec(svrecode);
804 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
805 s = SvPV_force_nomg(sv, len);
808 char * const send = s + len;
809 char * const start = s;
811 while (s > start && UTF8_IS_CONTINUATION(*s))
813 if (is_utf8_string((U8*)s, send - s)) {
814 sv_setpvn(retval, s, send - s);
816 SvCUR_set(sv, s - start);
826 sv_setpvn(retval, s, 1);
840 /* also used for: pp_schomp() */
845 const bool chomping = PL_op->op_type == OP_SCHOMP;
847 const size_t count = do_chomp(TARG, TOPs, chomping);
849 sv_setiv(TARG, count);
855 /* also used for: pp_chomp() */
859 dSP; dMARK; dTARGET; dORIGMARK;
860 const bool chomping = PL_op->op_type == OP_CHOMP;
864 count += do_chomp(TARG, *++MARK, chomping);
866 sv_setiv(TARG, count);
877 if (!PL_op->op_private) {
889 if (SvTHINKFIRST(sv))
890 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
892 switch (SvTYPE(sv)) {
896 av_undef(MUTABLE_AV(sv));
899 hv_undef(MUTABLE_HV(sv));
902 if (cv_const_sv((const CV *)sv))
903 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
904 "Constant subroutine %" SVf " undefined",
905 SVfARG(CvANON((const CV *)sv)
906 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
907 : sv_2mortal(newSVhek(
909 ? CvNAME_HEK((CV *)sv)
910 : GvENAME_HEK(CvGV((const CV *)sv))
915 /* let user-undef'd sub keep its identity */
916 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
919 assert(isGV_with_GP(sv));
925 /* undef *Pkg::meth_name ... */
927 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
928 && HvENAME_get(stash);
930 if((stash = GvHV((const GV *)sv))) {
931 if(HvENAME_get(stash))
932 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
936 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
937 gp_free(MUTABLE_GV(sv));
939 GvGP_set(sv, gp_ref(gp));
940 #ifndef PERL_DONT_CREATE_GVSV
943 GvLINE(sv) = CopLINE(PL_curcop);
944 GvEGV(sv) = MUTABLE_GV(sv);
948 mro_package_moved(NULL, stash, (const GV *)sv, 0);
950 /* undef *Foo::ISA */
951 if( strEQ(GvNAME((const GV *)sv), "ISA")
952 && (stash = GvSTASH((const GV *)sv))
953 && (method_changed || HvENAME(stash)) )
954 mro_isa_changed_in(stash);
955 else if(method_changed)
956 mro_method_changed_in(
957 GvSTASH((const GV *)sv)
963 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
977 /* common "slow" code for pp_postinc and pp_postdec */
980 S_postincdec_common(pTHX_ SV *sv, SV *targ)
984 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
987 TARG = sv_newmortal();
994 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
995 if (inc && !SvOK(TARG))
1002 /* also used for: pp_i_postinc() */
1009 /* special-case sv being a simple integer */
1010 if (LIKELY(((sv->sv_flags &
1011 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1012 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1014 && SvIVX(sv) != IV_MAX)
1017 SvIV_set(sv, iv + 1);
1018 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1023 return S_postincdec_common(aTHX_ sv, TARG);
1027 /* also used for: pp_i_postdec() */
1034 /* special-case sv being a simple integer */
1035 if (LIKELY(((sv->sv_flags &
1036 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1037 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1039 && SvIVX(sv) != IV_MIN)
1042 SvIV_set(sv, iv - 1);
1043 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1048 return S_postincdec_common(aTHX_ sv, TARG);
1052 /* Ordinary operators. */
1056 dSP; dATARGET; SV *svl, *svr;
1057 #ifdef PERL_PRESERVE_IVUV
1060 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1063 #ifdef PERL_PRESERVE_IVUV
1064 /* For integer to integer power, we do the calculation by hand wherever
1065 we're sure it is safe; otherwise we call pow() and try to convert to
1066 integer afterwards. */
1067 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1075 const IV iv = SvIVX(svr);
1079 goto float_it; /* Can't do negative powers this way. */
1083 baseuok = SvUOK(svl);
1085 baseuv = SvUVX(svl);
1087 const IV iv = SvIVX(svl);
1090 baseuok = TRUE; /* effectively it's a UV now */
1092 baseuv = -iv; /* abs, baseuok == false records sign */
1095 /* now we have integer ** positive integer. */
1098 /* foo & (foo - 1) is zero only for a power of 2. */
1099 if (!(baseuv & (baseuv - 1))) {
1100 /* We are raising power-of-2 to a positive integer.
1101 The logic here will work for any base (even non-integer
1102 bases) but it can be less accurate than
1103 pow (base,power) or exp (power * log (base)) when the
1104 intermediate values start to spill out of the mantissa.
1105 With powers of 2 we know this can't happen.
1106 And powers of 2 are the favourite thing for perl
1107 programmers to notice ** not doing what they mean. */
1109 NV base = baseuok ? baseuv : -(NV)baseuv;
1114 while (power >>= 1) {
1122 SvIV_please_nomg(svr);
1125 unsigned int highbit = 8 * sizeof(UV);
1126 unsigned int diff = 8 * sizeof(UV);
1127 while (diff >>= 1) {
1129 if (baseuv >> highbit) {
1133 /* we now have baseuv < 2 ** highbit */
1134 if (power * highbit <= 8 * sizeof(UV)) {
1135 /* result will definitely fit in UV, so use UV math
1136 on same algorithm as above */
1139 const bool odd_power = cBOOL(power & 1);
1143 while (power >>= 1) {
1150 if (baseuok || !odd_power)
1151 /* answer is positive */
1153 else if (result <= (UV)IV_MAX)
1154 /* answer negative, fits in IV */
1155 SETi( -(IV)result );
1156 else if (result == (UV)IV_MIN)
1157 /* 2's complement assumption: special case IV_MIN */
1160 /* answer negative, doesn't fit */
1161 SETn( -(NV)result );
1169 NV right = SvNV_nomg(svr);
1170 NV left = SvNV_nomg(svl);
1173 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1175 We are building perl with long double support and are on an AIX OS
1176 afflicted with a powl() function that wrongly returns NaNQ for any
1177 negative base. This was reported to IBM as PMR #23047-379 on
1178 03/06/2006. The problem exists in at least the following versions
1179 of AIX and the libm fileset, and no doubt others as well:
1181 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1182 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1183 AIX 5.2.0 bos.adt.libm 5.2.0.85
1185 So, until IBM fixes powl(), we provide the following workaround to
1186 handle the problem ourselves. Our logic is as follows: for
1187 negative bases (left), we use fmod(right, 2) to check if the
1188 exponent is an odd or even integer:
1190 - if odd, powl(left, right) == -powl(-left, right)
1191 - if even, powl(left, right) == powl(-left, right)
1193 If the exponent is not an integer, the result is rightly NaNQ, so
1194 we just return that (as NV_NAN).
1198 NV mod2 = Perl_fmod( right, 2.0 );
1199 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1200 SETn( -Perl_pow( -left, right) );
1201 } else if (mod2 == 0.0) { /* even integer */
1202 SETn( Perl_pow( -left, right) );
1203 } else { /* fractional power */
1207 SETn( Perl_pow( left, right) );
1210 SETn( Perl_pow( left, right) );
1211 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1213 #ifdef PERL_PRESERVE_IVUV
1215 SvIV_please_nomg(svr);
1223 dSP; dATARGET; SV *svl, *svr;
1224 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1228 #ifdef PERL_PRESERVE_IVUV
1230 /* special-case some simple common cases */
1231 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1233 U32 flags = (svl->sv_flags & svr->sv_flags);
1234 if (flags & SVf_IOK) {
1235 /* both args are simple IVs */
1240 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1241 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1243 /* if both are in a range that can't under/overflow, do a
1244 * simple integer multiply: if the top halves(*) of both numbers
1245 * are 00...00 or 11...11, then it's safe.
1246 * (*) for 32-bits, the "top half" is the top 17 bits,
1247 * for 64-bits, its 33 bits */
1249 ((topl+1) | (topr+1))
1250 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1253 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1259 else if (flags & SVf_NOK) {
1260 /* both args are NVs */
1265 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1266 /* nothing was lost by converting to IVs */
1271 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1272 if (Perl_isinf(result)) {
1273 Zero((U8*)&result + 8, 8, U8);
1276 TARGn(result, 0); /* args not GMG, so can't be tainted */
1284 if (SvIV_please_nomg(svr)) {
1285 /* Unless the left argument is integer in range we are going to have to
1286 use NV maths. Hence only attempt to coerce the right argument if
1287 we know the left is integer. */
1288 /* Left operand is defined, so is it IV? */
1289 if (SvIV_please_nomg(svl)) {
1290 bool auvok = SvUOK(svl);
1291 bool buvok = SvUOK(svr);
1292 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1293 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1302 const IV aiv = SvIVX(svl);
1305 auvok = TRUE; /* effectively it's a UV now */
1307 /* abs, auvok == false records sign; Using 0- here and
1308 * later to silence bogus warning from MS VC */
1309 alow = (UV) (0 - (UV) aiv);
1315 const IV biv = SvIVX(svr);
1318 buvok = TRUE; /* effectively it's a UV now */
1320 /* abs, buvok == false records sign */
1321 blow = (UV) (0 - (UV) biv);
1325 /* If this does sign extension on unsigned it's time for plan B */
1326 ahigh = alow >> (4 * sizeof (UV));
1328 bhigh = blow >> (4 * sizeof (UV));
1330 if (ahigh && bhigh) {
1332 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1333 which is overflow. Drop to NVs below. */
1334 } else if (!ahigh && !bhigh) {
1335 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1336 so the unsigned multiply cannot overflow. */
1337 const UV product = alow * blow;
1338 if (auvok == buvok) {
1339 /* -ve * -ve or +ve * +ve gives a +ve result. */
1343 } else if (product <= (UV)IV_MIN) {
1344 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1345 /* -ve result, which could overflow an IV */
1347 /* can't negate IV_MIN, but there are aren't two
1348 * integers such that !ahigh && !bhigh, where the
1349 * product equals 0x800....000 */
1350 assert(product != (UV)IV_MIN);
1351 SETi( -(IV)product );
1353 } /* else drop to NVs below. */
1355 /* One operand is large, 1 small */
1358 /* swap the operands */
1360 bhigh = blow; /* bhigh now the temp var for the swap */
1364 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1365 multiplies can't overflow. shift can, add can, -ve can. */
1366 product_middle = ahigh * blow;
1367 if (!(product_middle & topmask)) {
1368 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1370 product_middle <<= (4 * sizeof (UV));
1371 product_low = alow * blow;
1373 /* as for pp_add, UV + something mustn't get smaller.
1374 IIRC ANSI mandates this wrapping *behaviour* for
1375 unsigned whatever the actual representation*/
1376 product_low += product_middle;
1377 if (product_low >= product_middle) {
1378 /* didn't overflow */
1379 if (auvok == buvok) {
1380 /* -ve * -ve or +ve * +ve gives a +ve result. */
1382 SETu( product_low );
1384 } else if (product_low <= (UV)IV_MIN) {
1385 /* 2s complement assumption again */
1386 /* -ve result, which could overflow an IV */
1388 SETi(product_low == (UV)IV_MIN
1389 ? IV_MIN : -(IV)product_low);
1391 } /* else drop to NVs below. */
1393 } /* product_middle too large */
1394 } /* ahigh && bhigh */
1399 NV right = SvNV_nomg(svr);
1400 NV left = SvNV_nomg(svl);
1401 NV result = left * right;
1404 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1405 if (Perl_isinf(result)) {
1406 Zero((U8*)&result + 8, 8, U8);
1416 dSP; dATARGET; SV *svl, *svr;
1417 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1420 /* Only try to do UV divide first
1421 if ((SLOPPYDIVIDE is true) or
1422 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1424 The assumption is that it is better to use floating point divide
1425 whenever possible, only doing integer divide first if we can't be sure.
1426 If NV_PRESERVES_UV is true then we know at compile time that no UV
1427 can be too large to preserve, so don't need to compile the code to
1428 test the size of UVs. */
1430 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1431 # define PERL_TRY_UV_DIVIDE
1432 /* ensure that 20./5. == 4. */
1435 #ifdef PERL_TRY_UV_DIVIDE
1436 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1437 bool left_non_neg = SvUOK(svl);
1438 bool right_non_neg = SvUOK(svr);
1442 if (right_non_neg) {
1446 const IV biv = SvIVX(svr);
1449 right_non_neg = TRUE; /* effectively it's a UV now */
1455 /* historically undef()/0 gives a "Use of uninitialized value"
1456 warning before dieing, hence this test goes here.
1457 If it were immediately before the second SvIV_please, then
1458 DIE() would be invoked before left was even inspected, so
1459 no inspection would give no warning. */
1461 DIE(aTHX_ "Illegal division by zero");
1467 const IV aiv = SvIVX(svl);
1470 left_non_neg = TRUE; /* effectively it's a UV now */
1479 /* For sloppy divide we always attempt integer division. */
1481 /* Otherwise we only attempt it if either or both operands
1482 would not be preserved by an NV. If both fit in NVs
1483 we fall through to the NV divide code below. However,
1484 as left >= right to ensure integer result here, we know that
1485 we can skip the test on the right operand - right big
1486 enough not to be preserved can't get here unless left is
1489 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1492 /* Integer division can't overflow, but it can be imprecise. */
1494 /* Modern compilers optimize division followed by
1495 * modulo into a single div instruction */
1496 const UV result = left / right;
1497 if (left % right == 0) {
1498 SP--; /* result is valid */
1499 if (left_non_neg == right_non_neg) {
1500 /* signs identical, result is positive. */
1504 /* 2s complement assumption */
1505 if (result <= (UV)IV_MIN)
1506 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1508 /* It's exact but too negative for IV. */
1509 SETn( -(NV)result );
1512 } /* tried integer divide but it was not an integer result */
1513 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1514 } /* one operand wasn't SvIOK */
1515 #endif /* PERL_TRY_UV_DIVIDE */
1517 NV right = SvNV_nomg(svr);
1518 NV left = SvNV_nomg(svl);
1519 (void)POPs;(void)POPs;
1520 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1521 if (! Perl_isnan(right) && right == 0.0)
1525 DIE(aTHX_ "Illegal division by zero");
1526 PUSHn( left / right );
1534 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1538 bool left_neg = FALSE;
1539 bool right_neg = FALSE;
1540 bool use_double = FALSE;
1541 bool dright_valid = FALSE;
1544 SV * const svr = TOPs;
1545 SV * const svl = TOPm1s;
1546 if (SvIV_please_nomg(svr)) {
1547 right_neg = !SvUOK(svr);
1551 const IV biv = SvIVX(svr);
1554 right_neg = FALSE; /* effectively it's a UV now */
1556 right = (UV) (0 - (UV) biv);
1561 dright = SvNV_nomg(svr);
1562 right_neg = dright < 0;
1565 if (dright < UV_MAX_P1) {
1566 right = U_V(dright);
1567 dright_valid = TRUE; /* In case we need to use double below. */
1573 /* At this point use_double is only true if right is out of range for
1574 a UV. In range NV has been rounded down to nearest UV and
1575 use_double false. */
1576 if (!use_double && SvIV_please_nomg(svl)) {
1577 left_neg = !SvUOK(svl);
1581 const IV aiv = SvIVX(svl);
1584 left_neg = FALSE; /* effectively it's a UV now */
1586 left = (UV) (0 - (UV) aiv);
1591 dleft = SvNV_nomg(svl);
1592 left_neg = dleft < 0;
1596 /* This should be exactly the 5.6 behaviour - if left and right are
1597 both in range for UV then use U_V() rather than floor. */
1599 if (dleft < UV_MAX_P1) {
1600 /* right was in range, so is dleft, so use UVs not double.
1604 /* left is out of range for UV, right was in range, so promote
1605 right (back) to double. */
1607 /* The +0.5 is used in 5.6 even though it is not strictly
1608 consistent with the implicit +0 floor in the U_V()
1609 inside the #if 1. */
1610 dleft = Perl_floor(dleft + 0.5);
1613 dright = Perl_floor(dright + 0.5);
1624 DIE(aTHX_ "Illegal modulus zero");
1626 dans = Perl_fmod(dleft, dright);
1627 if ((left_neg != right_neg) && dans)
1628 dans = dright - dans;
1631 sv_setnv(TARG, dans);
1637 DIE(aTHX_ "Illegal modulus zero");
1640 if ((left_neg != right_neg) && ans)
1643 /* XXX may warn: unary minus operator applied to unsigned type */
1644 /* could change -foo to be (~foo)+1 instead */
1645 if (ans <= ~((UV)IV_MAX)+1)
1646 sv_setiv(TARG, ~ans+1);
1648 sv_setnv(TARG, -(NV)ans);
1651 sv_setuv(TARG, ans);
1663 bool infnan = FALSE;
1664 const U8 gimme = GIMME_V;
1666 if (gimme == G_LIST && PL_op->op_private & OPpREPEAT_DOLIST) {
1667 /* TODO: think of some way of doing list-repeat overloading ??? */
1672 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1673 /* The parser saw this as a list repeat, and there
1674 are probably several items on the stack. But we're
1675 in scalar/void context, and there's no pp_list to save us
1676 now. So drop the rest of the items -- robin@kitsite.com
1679 if (MARK + 1 < SP) {
1685 ASSUME(MARK + 1 == SP);
1688 MARK[1] = &PL_sv_undef;
1692 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1698 const UV uv = SvUV_nomg(sv);
1700 count = IV_MAX; /* The best we can do? */
1704 count = SvIV_nomg(sv);
1707 else if (SvNOKp(sv)) {
1708 const NV nv = SvNV_nomg(sv);
1709 infnan = Perl_isinfnan(nv);
1710 if (UNLIKELY(infnan)) {
1714 count = -1; /* An arbitrary negative integer */
1720 count = SvIV_nomg(sv);
1723 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1724 "Non-finite repeat count does nothing");
1725 } else if (count < 0) {
1727 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1728 "Negative repeat count does nothing");
1731 if (gimme == G_LIST && PL_op->op_private & OPpREPEAT_DOLIST) {
1733 const SSize_t items = SP - MARK;
1734 const U8 mod = PL_op->op_flags & OPf_MOD;
1739 if ( items > SSize_t_MAX / count /* max would overflow */
1740 /* repeatcpy would overflow */
1741 || items > I32_MAX / (I32)sizeof(SV *)
1743 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1744 max = items * count;
1749 if (mod && SvPADTMP(*SP)) {
1750 *SP = sv_mortalcopy(*SP);
1757 repeatcpy((char*)(MARK + items), (char*)MARK,
1758 items * sizeof(const SV *), count - 1);
1761 else if (count <= 0)
1764 else { /* Note: mark already snarfed by pp_list */
1765 SV * const tmpstr = POPs;
1770 sv_setsv_nomg(TARG, tmpstr);
1771 SvPV_force_nomg(TARG, len);
1772 isutf = DO_UTF8(TARG);
1779 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1780 || len > (U32)I32_MAX /* repeatcpy would overflow */
1782 Perl_croak(aTHX_ "%s",
1783 "Out of memory during string extend");
1784 max = (UV)count * len + 1;
1787 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1788 SvCUR_set(TARG, SvCUR(TARG) * count);
1790 *SvEND(TARG) = '\0';
1793 (void)SvPOK_only_UTF8(TARG);
1795 (void)SvPOK_only(TARG);
1804 dSP; dATARGET; bool useleft; SV *svl, *svr;
1805 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1809 #ifdef PERL_PRESERVE_IVUV
1811 /* special-case some simple common cases */
1812 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1814 U32 flags = (svl->sv_flags & svr->sv_flags);
1815 if (flags & SVf_IOK) {
1816 /* both args are simple IVs */
1821 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1822 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1824 /* if both are in a range that can't under/overflow, do a
1825 * simple integer subtract: if the top of both numbers
1826 * are 00 or 11, then it's safe */
1827 if (!( ((topl+1) | (topr+1)) & 2)) {
1829 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1835 else if (flags & SVf_NOK) {
1836 /* both args are NVs */
1840 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1841 /* nothing was lost by converting to IVs */
1845 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1853 useleft = USE_LEFT(svl);
1854 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1855 "bad things" happen if you rely on signed integers wrapping. */
1856 if (SvIV_please_nomg(svr)) {
1857 /* Unless the left argument is integer in range we are going to have to
1858 use NV maths. Hence only attempt to coerce the right argument if
1859 we know the left is integer. */
1866 a_valid = auvok = 1;
1867 /* left operand is undef, treat as zero. */
1869 /* Left operand is defined, so is it IV? */
1870 if (SvIV_please_nomg(svl)) {
1871 if ((auvok = SvUOK(svl)))
1874 const IV aiv = SvIVX(svl);
1877 auvok = 1; /* Now acting as a sign flag. */
1879 auv = (UV) (0 - (UV) aiv);
1886 bool result_good = 0;
1889 bool buvok = SvUOK(svr);
1894 const IV biv = SvIVX(svr);
1899 buv = (UV) (0 - (UV) biv);
1901 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1902 else "IV" now, independent of how it came in.
1903 if a, b represents positive, A, B negative, a maps to -A etc
1908 all UV maths. negate result if A negative.
1909 subtract if signs same, add if signs differ. */
1911 if (auvok ^ buvok) {
1920 /* Must get smaller */
1925 if (result <= buv) {
1926 /* result really should be -(auv-buv). as its negation
1927 of true value, need to swap our result flag */
1939 if (result <= (UV)IV_MIN)
1940 SETi(result == (UV)IV_MIN
1941 ? IV_MIN : -(IV)result);
1943 /* result valid, but out of range for IV. */
1944 SETn( -(NV)result );
1948 } /* Overflow, drop through to NVs. */
1952 useleft = USE_LEFT(svl);
1955 NV value = SvNV_nomg(svr);
1959 /* left operand is undef, treat as zero - value */
1963 SETn( SvNV_nomg(svl) - value );
1968 #define IV_BITS (IVSIZE * 8)
1970 /* Taking the right operand of bitwise shift operators, returns an int
1971 * indicating the shift amount clipped to the range [-IV_BITS, +IV_BITS].
1974 S_shift_amount(pTHX_ SV *const svr)
1976 const IV iv = SvIV_nomg(svr);
1978 /* Note that [INT_MIN, INT_MAX] cannot be used as the clipping bound;
1979 * INT_MIN will cause overflow in "shift = -shift;" in S_{iv,uv}_shift.
1982 return SvUVX(svr) > IV_BITS ? IV_BITS : (int)SvUVX(svr);
1983 return iv < -IV_BITS ? -IV_BITS : iv > IV_BITS ? IV_BITS : (int)iv;
1986 static UV S_uv_shift(UV uv, int shift, bool left)
1992 if (UNLIKELY(shift >= IV_BITS)) {
1995 return left ? uv << shift : uv >> shift;
1998 static IV S_iv_shift(IV iv, int shift, bool left)
2005 if (UNLIKELY(shift >= IV_BITS)) {
2006 return iv < 0 && !left ? -1 : 0;
2009 /* For left shifts, perl 5 has chosen to treat the value as unsigned for
2010 * the purposes of shifting, then cast back to signed. This is very
2011 * different from Raku:
2013 * $ raku -e 'say -2 +< 5'
2016 * $ ./perl -le 'print -2 << 5'
2017 * 18446744073709551552
2020 return (IV) (((UV) iv) << shift);
2023 /* Here is right shift */
2027 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2028 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2029 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2030 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2034 dSP; dATARGET; SV *svl, *svr;
2035 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2039 const int shift = S_shift_amount(aTHX_ svr);
2040 if (PL_op->op_private & OPpUSEINT) {
2041 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2044 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2052 dSP; dATARGET; SV *svl, *svr;
2053 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2057 const int shift = S_shift_amount(aTHX_ svr);
2058 if (PL_op->op_private & OPpUSEINT) {
2059 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2062 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2072 U32 flags_and, flags_or;
2074 tryAMAGICbin_MG(lt_amg, AMGf_numeric);
2077 flags_and = SvFLAGS(left) & SvFLAGS(right);
2078 flags_or = SvFLAGS(left) | SvFLAGS(right);
2081 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2082 ? (SvIVX(left) < SvIVX(right))
2083 : (flags_and & SVf_NOK)
2084 ? (SvNVX(left) < SvNVX(right))
2085 : (do_ncmp(left, right) == -1)
2094 U32 flags_and, flags_or;
2096 tryAMAGICbin_MG(gt_amg, AMGf_numeric);
2099 flags_and = SvFLAGS(left) & SvFLAGS(right);
2100 flags_or = SvFLAGS(left) | SvFLAGS(right);
2103 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2104 ? (SvIVX(left) > SvIVX(right))
2105 : (flags_and & SVf_NOK)
2106 ? (SvNVX(left) > SvNVX(right))
2107 : (do_ncmp(left, right) == 1)
2116 U32 flags_and, flags_or;
2118 tryAMAGICbin_MG(le_amg, AMGf_numeric);
2121 flags_and = SvFLAGS(left) & SvFLAGS(right);
2122 flags_or = SvFLAGS(left) | SvFLAGS(right);
2125 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2126 ? (SvIVX(left) <= SvIVX(right))
2127 : (flags_and & SVf_NOK)
2128 ? (SvNVX(left) <= SvNVX(right))
2129 : (do_ncmp(left, right) <= 0)
2138 U32 flags_and, flags_or;
2140 tryAMAGICbin_MG(ge_amg, AMGf_numeric);
2143 flags_and = SvFLAGS(left) & SvFLAGS(right);
2144 flags_or = SvFLAGS(left) | SvFLAGS(right);
2147 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2148 ? (SvIVX(left) >= SvIVX(right))
2149 : (flags_and & SVf_NOK)
2150 ? (SvNVX(left) >= SvNVX(right))
2151 : ( (do_ncmp(left, right) & 2) == 0)
2160 U32 flags_and, flags_or;
2162 tryAMAGICbin_MG(ne_amg, AMGf_numeric);
2165 flags_and = SvFLAGS(left) & SvFLAGS(right);
2166 flags_or = SvFLAGS(left) | SvFLAGS(right);
2169 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2170 ? (SvIVX(left) != SvIVX(right))
2171 : (flags_and & SVf_NOK)
2172 ? (SvNVX(left) != SvNVX(right))
2173 : (do_ncmp(left, right) != 0)
2178 /* compare left and right SVs. Returns:
2182 * 2: left or right was a NaN
2185 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2187 PERL_ARGS_ASSERT_DO_NCMP;
2188 #ifdef PERL_PRESERVE_IVUV
2189 /* Fortunately it seems NaN isn't IOK */
2190 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2192 const IV leftiv = SvIVX(left);
2193 if (!SvUOK(right)) {
2194 /* ## IV <=> IV ## */
2195 const IV rightiv = SvIVX(right);
2196 return (leftiv > rightiv) - (leftiv < rightiv);
2198 /* ## IV <=> UV ## */
2200 /* As (b) is a UV, it's >=0, so it must be < */
2203 const UV rightuv = SvUVX(right);
2204 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2209 /* ## UV <=> UV ## */
2210 const UV leftuv = SvUVX(left);
2211 const UV rightuv = SvUVX(right);
2212 return (leftuv > rightuv) - (leftuv < rightuv);
2214 /* ## UV <=> IV ## */
2216 const IV rightiv = SvIVX(right);
2218 /* As (a) is a UV, it's >=0, so it cannot be < */
2221 const UV leftuv = SvUVX(left);
2222 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2225 NOT_REACHED; /* NOTREACHED */
2229 NV const rnv = SvNV_nomg(right);
2230 NV const lnv = SvNV_nomg(left);
2232 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2233 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2236 return (lnv > rnv) - (lnv < rnv);
2255 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2258 value = do_ncmp(left, right);
2270 /* also used for: pp_sge() pp_sgt() pp_slt() */
2276 int amg_type = sle_amg;
2280 switch (PL_op->op_type) {
2299 tryAMAGICbin_MG(amg_type, 0);
2303 #ifdef USE_LOCALE_COLLATE
2304 (IN_LC_RUNTIME(LC_COLLATE))
2305 ? sv_cmp_locale_flags(left, right, 0)
2308 sv_cmp_flags(left, right, 0);
2309 SETs(boolSV(cmp * multiplier < rhs));
2317 tryAMAGICbin_MG(seq_amg, 0);
2320 SETs(boolSV(sv_eq_flags(left, right, 0)));
2328 tryAMAGICbin_MG(sne_amg, 0);
2331 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2339 tryAMAGICbin_MG(scmp_amg, 0);
2343 #ifdef USE_LOCALE_COLLATE
2344 (IN_LC_RUNTIME(LC_COLLATE))
2345 ? sv_cmp_locale_flags(left, right, 0)
2348 sv_cmp_flags(left, right, 0);
2357 tryAMAGICbin_MG(band_amg, AMGf_assign);
2360 if (SvNIOKp(left) || SvNIOKp(right)) {
2361 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2362 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2363 if (PL_op->op_private & OPpUSEINT) {
2364 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2368 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2371 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2372 if (right_ro_nonnum) SvNIOK_off(right);
2375 do_vop(PL_op->op_type, TARG, left, right);
2385 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2387 dATARGET; dPOPTOPssrl;
2388 if (PL_op->op_private & OPpUSEINT) {
2389 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2393 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2403 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2405 dATARGET; dPOPTOPssrl;
2406 do_vop(OP_BIT_AND, TARG, left, right);
2411 /* also used for: pp_bit_xor() */
2416 const int op_type = PL_op->op_type;
2418 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2421 if (SvNIOKp(left) || SvNIOKp(right)) {
2422 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2423 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2424 if (PL_op->op_private & OPpUSEINT) {
2425 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2426 const IV r = SvIV_nomg(right);
2427 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2431 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2432 const UV r = SvUV_nomg(right);
2433 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2436 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2437 if (right_ro_nonnum) SvNIOK_off(right);
2440 do_vop(op_type, TARG, left, right);
2447 /* also used for: pp_nbit_xor() */
2452 const int op_type = PL_op->op_type;
2454 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2455 AMGf_assign|AMGf_numarg);
2457 dATARGET; dPOPTOPssrl;
2458 if (PL_op->op_private & OPpUSEINT) {
2459 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2460 const IV r = SvIV_nomg(right);
2461 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2465 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2466 const UV r = SvUV_nomg(right);
2467 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2474 /* also used for: pp_sbit_xor() */
2479 const int op_type = PL_op->op_type;
2481 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2484 dATARGET; dPOPTOPssrl;
2485 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2491 PERL_STATIC_INLINE bool
2492 S_negate_string(pTHX)
2497 SV * const sv = TOPs;
2498 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2500 s = SvPV_nomg_const(sv, len);
2501 if (isIDFIRST(*s)) {
2502 sv_setpvs(TARG, "-");
2505 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2506 sv_setsv_nomg(TARG, sv);
2507 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2517 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2518 if (S_negate_string(aTHX)) return NORMAL;
2520 SV * const sv = TOPs;
2523 /* It's publicly an integer */
2526 if (SvIVX(sv) == IV_MIN) {
2527 /* 2s complement assumption. */
2528 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2532 else if (SvUVX(sv) <= IV_MAX) {
2537 else if (SvIVX(sv) != IV_MIN) {
2541 #ifdef PERL_PRESERVE_IVUV
2548 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2549 SETn(-SvNV_nomg(sv));
2550 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2551 goto oops_its_an_int;
2553 SETn(-SvNV_nomg(sv));
2563 tryAMAGICun_MG(not_amg, 0);
2565 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2570 S_scomplement(pTHX_ SV *targ, SV *sv)
2576 sv_copypv_nomg(TARG, sv);
2577 tmps = (U8*)SvPV_nomg(TARG, len);
2580 if (len && ! utf8_to_bytes(tmps, &len)) {
2581 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2583 SvCUR_set(TARG, len);
2591 for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++)
2594 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2599 for ( ; anum > 0; anum--, tmps++)
2606 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2610 if (PL_op->op_private & OPpUSEINT) {
2611 const IV i = ~SvIV_nomg(sv);
2615 const UV u = ~SvUV_nomg(sv);
2620 S_scomplement(aTHX_ TARG, sv);
2630 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2633 if (PL_op->op_private & OPpUSEINT) {
2634 const IV i = ~SvIV_nomg(sv);
2638 const UV u = ~SvUV_nomg(sv);
2648 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2651 S_scomplement(aTHX_ TARG, sv);
2657 /* integer versions of some of the above */
2662 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2665 SETi( left * right );
2674 tryAMAGICbin_MG(div_amg, AMGf_assign);
2677 IV value = SvIV_nomg(right);
2679 DIE(aTHX_ "Illegal division by zero");
2680 num = SvIV_nomg(left);
2682 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2686 value = num / value;
2695 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2699 DIE(aTHX_ "Illegal modulus zero");
2700 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2704 SETi( left % right );
2712 tryAMAGICbin_MG(add_amg, AMGf_assign);
2714 dPOPTOPiirl_ul_nomg;
2715 SETi( left + right );
2723 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2725 dPOPTOPiirl_ul_nomg;
2726 SETi( left - right );
2734 tryAMAGICbin_MG(lt_amg, 0);
2737 SETs(boolSV(left < right));
2745 tryAMAGICbin_MG(gt_amg, 0);
2748 SETs(boolSV(left > right));
2756 tryAMAGICbin_MG(le_amg, 0);
2759 SETs(boolSV(left <= right));
2767 tryAMAGICbin_MG(ge_amg, 0);
2770 SETs(boolSV(left >= right));
2778 tryAMAGICbin_MG(eq_amg, 0);
2781 SETs(boolSV(left == right));
2789 tryAMAGICbin_MG(ne_amg, 0);
2792 SETs(boolSV(left != right));
2800 tryAMAGICbin_MG(ncmp_amg, 0);
2807 else if (left < right)
2819 tryAMAGICun_MG(neg_amg, 0);
2820 if (S_negate_string(aTHX)) return NORMAL;
2822 SV * const sv = TOPs;
2823 IV const i = SvIV_nomg(sv);
2829 /* High falutin' math. */
2834 tryAMAGICbin_MG(atan2_amg, 0);
2837 SETn(Perl_atan2(left, right));
2843 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2848 int amg_type = fallback_amg;
2849 const char *neg_report = NULL;
2850 const int op_type = PL_op->op_type;
2853 case OP_SIN: amg_type = sin_amg; break;
2854 case OP_COS: amg_type = cos_amg; break;
2855 case OP_EXP: amg_type = exp_amg; break;
2856 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2857 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2860 assert(amg_type != fallback_amg);
2862 tryAMAGICun_MG(amg_type, 0);
2864 SV * const arg = TOPs;
2865 const NV value = SvNV_nomg(arg);
2871 if (neg_report) { /* log or sqrt */
2873 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2874 ! Perl_isnan(value) &&
2876 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2877 SET_NUMERIC_STANDARD();
2878 /* diag_listed_as: Can't take log of %g */
2879 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2884 case OP_SIN: result = Perl_sin(value); break;
2885 case OP_COS: result = Perl_cos(value); break;
2886 case OP_EXP: result = Perl_exp(value); break;
2887 case OP_LOG: result = Perl_log(value); break;
2888 case OP_SQRT: result = Perl_sqrt(value); break;
2895 /* Support Configure command-line overrides for rand() functions.
2896 After 5.005, perhaps we should replace this by Configure support
2897 for drand48(), random(), or rand(). For 5.005, though, maintain
2898 compatibility by calling rand() but allow the user to override it.
2899 See INSTALL for details. --Andy Dougherty 15 July 1998
2901 /* Now it's after 5.005, and Configure supports drand48() and random(),
2902 in addition to rand(). So the overrides should not be needed any more.
2903 --Jarkko Hietaniemi 27 September 1998
2908 if (!PL_srand_called) {
2909 (void)seedDrand01((Rand_seed_t)seed());
2910 PL_srand_called = TRUE;
2922 SV * const sv = POPs;
2928 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2929 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2930 if (! Perl_isnan(value) && value == 0.0)
2940 sv_setnv_mg(TARG, value);
2951 if (MAXARG >= 1 && (TOPs || POPs)) {
2958 pv = SvPV(top, len);
2959 flags = grok_number(pv, len, &anum);
2961 if (!(flags & IS_NUMBER_IN_UV)) {
2962 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2963 "Integer overflow in srand");
2971 (void)seedDrand01((Rand_seed_t)anum);
2972 PL_srand_called = TRUE;
2976 /* Historically srand always returned true. We can avoid breaking
2978 sv_setpvs(TARG, "0 but true");
2987 tryAMAGICun_MG(int_amg, AMGf_numeric);
2989 SV * const sv = TOPs;
2990 const IV iv = SvIV_nomg(sv);
2991 /* XXX it's arguable that compiler casting to IV might be subtly
2992 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2993 else preferring IV has introduced a subtle behaviour change bug. OTOH
2994 relying on floating point to be accurate is a bug. */
2999 else if (SvIOK(sv)) {
3001 SETu(SvUV_nomg(sv));
3006 const NV value = SvNV_nomg(sv);
3007 if (UNLIKELY(Perl_isinfnan(value)))
3009 else if (value >= 0.0) {
3010 if (value < (NV)UV_MAX + 0.5) {
3013 SETn(Perl_floor(value));
3017 if (value > (NV)IV_MIN - 0.5) {
3020 SETn(Perl_ceil(value));
3031 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3033 SV * const sv = TOPs;
3034 /* This will cache the NV value if string isn't actually integer */
3035 const IV iv = SvIV_nomg(sv);
3042 else if (SvIOK(sv)) {
3043 /* IVX is precise */
3045 uv = SvUVX(sv); /* force it to be numeric only */
3050 /* "(UV)-(iv + 1) + 1" below is mathematically "-iv", but
3051 transformed so that every subexpression will never trigger
3052 overflows even on 2's complement representation (note that
3053 iv is always < 0 here), and modern compilers could optimize
3054 this to a single negation. */
3055 uv = (UV)-(iv + 1) + 1;
3061 const NV value = SvNV_nomg(sv);
3062 SETn(Perl_fabs(value));
3069 /* also used for: pp_hex() */
3075 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3079 SV* const sv = TOPs;
3081 tmps = (SvPV_const(sv, len));
3083 /* If Unicode, try to downgrade
3084 * If not possible, croak. */
3085 SV* const tsv = sv_2mortal(newSVsv(sv));
3088 sv_utf8_downgrade(tsv, FALSE);
3089 tmps = SvPV_const(tsv, len);
3091 if (PL_op->op_type == OP_HEX)
3094 while (*tmps && len && isSPACE(*tmps))
3098 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3100 flags |= PERL_SCAN_DISALLOW_PREFIX;
3102 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3104 else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
3106 flags |= PERL_SCAN_DISALLOW_PREFIX;
3107 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3110 if (isALPHA_FOLD_EQ(*tmps, 'o')) {
3113 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3116 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3131 SV * const sv = TOPs;
3133 U32 in_bytes = IN_BYTES;
3134 /* Simplest case shortcut:
3135 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3136 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3139 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3141 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3144 if (LIKELY(svflags == SVf_POK))
3147 if (svflags & SVs_GMG)
3152 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3153 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3155 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3156 /* no need to convert from bytes to chars */
3160 len = sv_len_utf8_nomg(sv);
3163 /* unrolled SvPV_nomg_const(sv,len) */
3164 if (SvPOK_nog(sv)) {
3167 if (PL_op->op_private & OPpTRUEBOOL) {
3169 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3174 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3177 TARGi((IV)(len), 1);
3180 if (!SvPADTMP(TARG)) {
3181 /* OPpTARGET_MY: targ is var in '$lex = length()' */
3186 /* TARG is on stack at this point and is overwriten by SETs.
3187 * This branch is the odd one out, so put TARG by default on
3188 * stack earlier to let local SP go out of liveness sooner */
3191 return NORMAL; /* no putback, SP didn't move in this opcode */
3195 /* Returns false if substring is completely outside original string.
3196 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3197 always be true for an explicit 0.
3200 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3201 bool pos1_is_uv, IV len_iv,
3202 bool len_is_uv, STRLEN *posp,
3208 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3210 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3211 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3214 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3217 if (len_iv || len_is_uv) {
3218 if (!len_is_uv && len_iv < 0) {
3219 pos2_iv = curlen + len_iv;
3221 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3224 } else { /* len_iv >= 0 */
3225 if (!pos1_is_uv && pos1_iv < 0) {
3226 pos2_iv = pos1_iv + len_iv;
3227 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3229 if ((UV)len_iv > curlen-(UV)pos1_iv)
3232 pos2_iv = pos1_iv+len_iv;
3242 if (!pos2_is_uv && pos2_iv < 0) {
3243 if (!pos1_is_uv && pos1_iv < 0)
3247 else if (!pos1_is_uv && pos1_iv < 0)
3250 if ((UV)pos2_iv < (UV)pos1_iv)
3252 if ((UV)pos2_iv > curlen)
3255 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3256 *posp = (STRLEN)( (UV)pos1_iv );
3257 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3274 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3275 const bool rvalue = (GIMME_V != G_VOID);
3278 const char *repl = NULL;
3280 int num_args = PL_op->op_private & 7;
3281 bool repl_need_utf8_upgrade = FALSE;
3285 if(!(repl_sv = POPs)) num_args--;
3287 if ((len_sv = POPs)) {
3288 len_iv = SvIV(len_sv);
3289 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3294 pos1_iv = SvIV(pos_sv);
3295 pos1_is_uv = SvIOK_UV(pos_sv);
3297 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3301 if (lvalue && !repl_sv) {
3303 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3304 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3306 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3308 pos1_is_uv || pos1_iv >= 0
3309 ? (STRLEN)(UV)pos1_iv
3310 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3312 len_is_uv || len_iv > 0
3313 ? (STRLEN)(UV)len_iv
3314 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3316 PUSHs(ret); /* avoid SvSETMAGIC here */
3320 repl = SvPV_const(repl_sv, repl_len);
3323 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3324 "Attempt to use reference as lvalue in substr"
3326 tmps = SvPV_force_nomg(sv, curlen);
3327 if (DO_UTF8(repl_sv) && repl_len) {
3329 /* Upgrade the dest, and recalculate tmps in case the buffer
3330 * got reallocated; curlen may also have been changed */
3331 sv_utf8_upgrade_nomg(sv);
3332 tmps = SvPV_nomg(sv, curlen);
3335 else if (DO_UTF8(sv))
3336 repl_need_utf8_upgrade = TRUE;
3338 else tmps = SvPV_const(sv, curlen);
3340 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3341 if (utf8_curlen == curlen)
3344 curlen = utf8_curlen;
3350 STRLEN pos, len, byte_len, byte_pos;
3352 if (!translate_substr_offsets(
3353 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3357 byte_pos = utf8_curlen
3358 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3363 SvTAINTED_off(TARG); /* decontaminate */
3364 SvUTF8_off(TARG); /* decontaminate */
3365 sv_setpvn(TARG, tmps, byte_len);
3366 #ifdef USE_LOCALE_COLLATE
3367 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3374 SV* repl_sv_copy = NULL;
3376 if (repl_need_utf8_upgrade) {
3377 repl_sv_copy = newSVsv(repl_sv);
3378 sv_utf8_upgrade(repl_sv_copy);
3379 repl = SvPV_const(repl_sv_copy, repl_len);
3383 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3384 SvREFCNT_dec(repl_sv_copy);
3387 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3397 Perl_croak(aTHX_ "substr outside of string");
3398 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3405 const IV size = POPi;
3406 SV* offsetsv = POPs;
3407 SV * const src = POPs;
3408 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3414 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3415 * or flag that its out of range */
3417 IV iv = SvIV(offsetsv);
3419 /* avoid a large UV being wrapped to a negative value */
3420 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3421 errflags = LVf_OUT_OF_RANGE;
3423 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3424 #if PTRSIZE < IVSIZE
3425 else if (iv > Size_t_MAX)
3426 errflags = LVf_OUT_OF_RANGE;
3429 offset = (STRLEN)iv;
3432 retuv = errflags ? 0 : do_vecget(src, offset, size);
3434 if (lvalue) { /* it's an lvalue! */
3435 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3436 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3438 LvTARG(ret) = SvREFCNT_inc_simple(src);
3439 LvTARGOFF(ret) = offset;
3440 LvTARGLEN(ret) = size;
3441 LvFLAGS(ret) = errflags;
3445 SvTAINTED_off(TARG); /* decontaminate */
3449 sv_setuv(ret, retuv);
3457 /* also used for: pp_rindex() */
3470 const char *little_p;
3473 const bool is_index = PL_op->op_type == OP_INDEX;
3474 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3480 big_p = SvPV_const(big, biglen);
3481 little_p = SvPV_const(little, llen);
3483 big_utf8 = DO_UTF8(big);
3484 little_utf8 = DO_UTF8(little);
3485 if (big_utf8 ^ little_utf8) {
3486 /* One needs to be upgraded. */
3488 /* Well, maybe instead we might be able to downgrade the small
3490 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3493 /* If the large string is ISO-8859-1, and it's not possible to
3494 convert the small string to ISO-8859-1, then there is no
3495 way that it could be found anywhere by index. */
3500 /* At this point, pv is a malloc()ed string. So donate it to temp
3501 to ensure it will get free()d */
3502 little = temp = newSV(0);
3503 sv_usepvn(temp, pv, llen);
3504 little_p = SvPVX(little);
3506 temp = newSVpvn(little_p, llen);
3508 sv_utf8_upgrade(temp);
3510 little_p = SvPV_const(little, llen);
3513 if (SvGAMAGIC(big)) {
3514 /* Life just becomes a lot easier if I use a temporary here.
3515 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3516 will trigger magic and overloading again, as will fbm_instr()
3518 big = newSVpvn_flags(big_p, biglen,
3519 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3522 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3523 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3524 warn on undef, and we've already triggered a warning with the
3525 SvPV_const some lines above. We can't remove that, as we need to
3526 call some SvPV to trigger overloading early and find out if the
3528 This is all getting too messy. The API isn't quite clean enough,
3529 because data access has side effects.
3531 little = newSVpvn_flags(little_p, llen,
3532 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3533 little_p = SvPVX(little);
3537 offset = is_index ? 0 : biglen;
3539 if (big_utf8 && offset > 0)
3540 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3546 else if (offset > (SSize_t)biglen)
3548 if (!(little_p = is_index
3549 ? fbm_instr((unsigned char*)big_p + offset,
3550 (unsigned char*)big_p + biglen, little, 0)
3551 : rninstr(big_p, big_p + offset,
3552 little_p, little_p + llen)))
3555 retval = little_p - big_p;
3556 if (retval > 1 && big_utf8)
3557 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3562 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3563 if (PL_op->op_private & OPpTRUEBOOL) {
3564 SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3565 ? &PL_sv_yes : &PL_sv_no;
3566 if (PL_op->op_private & OPpTARGET_MY) {
3567 /* $lex = (index() == -1) */
3568 sv_setsv_mg(TARG, result);
3582 dSP; dMARK; dORIGMARK; dTARGET;
3583 SvTAINTED_off(TARG);
3584 do_sprintf(TARG, SP-MARK, MARK+1);
3585 TAINT_IF(SvTAINTED(TARG));
3597 const U8 *s = (U8*)SvPV_const(argsv, len);
3600 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3614 if (UNLIKELY(SvAMAGIC(top)))
3616 if (UNLIKELY(isinfnansv(top)))
3617 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3619 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3620 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3622 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3623 && SvNV_nomg(top) < 0.0)))
3625 if (ckWARN(WARN_UTF8)) {
3626 if (SvGMAGICAL(top)) {
3627 SV *top2 = sv_newmortal();
3628 sv_setsv_nomg(top2, top);
3631 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3632 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3634 value = UNICODE_REPLACEMENT;
3636 value = SvUV_nomg(top);
3640 SvUPGRADE(TARG,SVt_PV);
3642 if (value > 255 && !IN_BYTES) {
3643 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3644 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3645 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3647 (void)SvPOK_only(TARG);
3656 *tmps++ = (char)value;
3658 (void)SvPOK_only(TARG);
3670 const char *tmps = SvPV_const(left, len);
3672 if (DO_UTF8(left)) {
3673 /* If Unicode, try to downgrade.
3674 * If not possible, croak.
3675 * Yes, we made this up. */
3676 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3678 sv_utf8_downgrade(tsv, FALSE);
3679 tmps = SvPV_const(tsv, len);
3681 # ifdef USE_ITHREADS
3683 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3684 /* This should be threadsafe because in ithreads there is only
3685 * one thread per interpreter. If this would not be true,
3686 * we would need a mutex to protect this malloc. */
3687 PL_reentrant_buffer->_crypt_struct_buffer =
3688 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3689 # if defined(__GLIBC__) || defined(__EMX__)
3690 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3691 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3695 # endif /* HAS_CRYPT_R */
3696 # endif /* USE_ITHREADS */
3698 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3705 "The crypt() function is unimplemented due to excessive paranoia.");
3709 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3710 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3713 /* also used for: pp_lcfirst() */
3717 /* Actually is both lcfirst() and ucfirst(). Only the first character
3718 * changes. This means that possibly we can change in-place, ie., just
3719 * take the source and change that one character and store it back, but not
3720 * if read-only etc, or if the length changes */
3724 STRLEN slen; /* slen is the byte length of the whole SV. */
3727 bool inplace; /* ? Convert first char only, in-place */
3728 bool doing_utf8 = FALSE; /* ? using utf8 */
3729 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3730 const int op_type = PL_op->op_type;
3733 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3734 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3735 * stored as UTF-8 at s. */
3736 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3737 * lowercased) character stored in tmpbuf. May be either
3738 * UTF-8 or not, but in either case is the number of bytes */
3739 bool remove_dot_above = FALSE;
3741 s = (const U8*)SvPV_const(source, slen);
3743 /* We may be able to get away with changing only the first character, in
3744 * place, but not if read-only, etc. Later we may discover more reasons to
3745 * not convert in-place. */
3746 inplace = !SvREADONLY(source) && SvPADTMP(source);
3748 #ifdef USE_LOCALE_CTYPE
3750 if (IN_LC_RUNTIME(LC_CTYPE)) {
3751 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3756 /* First calculate what the changed first character should be. This affects
3757 * whether we can just swap it out, leaving the rest of the string unchanged,
3758 * or even if have to convert the dest to UTF-8 when the source isn't */
3760 if (! slen) { /* If empty */
3761 need = 1; /* still need a trailing NUL */
3765 else if (DO_UTF8(source)) { /* Is the source utf8? */
3769 if (op_type == OP_UCFIRST) {
3770 #ifdef USE_LOCALE_CTYPE
3771 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3773 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3778 #ifdef USE_LOCALE_CTYPE
3780 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3782 /* In turkic locales, lower casing an 'I' normally yields U+0131,
3783 * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3784 * contains a COMBINING DOT ABOVE. Instead it is treated like
3785 * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'. The
3786 * call to lowercase above has handled this. But SpecialCasing.txt
3787 * says we are supposed to remove the COMBINING DOT ABOVE. We can
3788 * tell if we have this situation if I ==> i in a turkic locale. */
3789 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3790 && IN_LC_RUNTIME(LC_CTYPE)
3791 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3793 /* Here, we know there was a COMBINING DOT ABOVE. We won't be
3794 * able to handle this in-place. */
3797 /* It seems likely that the DOT will immediately follow the
3798 * 'I'. If so, we can remove it simply by indicating to the
3799 * code below to start copying the source just beyond the DOT.
3800 * We know its length is 2 */
3801 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3804 else { /* But if it doesn't follow immediately, set a flag for
3806 remove_dot_above = TRUE;
3810 PERL_UNUSED_VAR(remove_dot_above);
3812 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3817 /* we can't do in-place if the length changes. */
3818 if (ulen != tculen) inplace = FALSE;
3819 need = slen + 1 - ulen + tculen;
3821 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3822 * latin1 is treated as caseless. Note that a locale takes
3824 ulen = 1; /* Original character is 1 byte */
3825 tculen = 1; /* Most characters will require one byte, but this will
3826 * need to be overridden for the tricky ones */
3830 #ifdef USE_LOCALE_CTYPE
3832 if (IN_LC_RUNTIME(LC_CTYPE)) {
3833 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3834 && ( (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3835 || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3837 if (*s == 'I') { /* lcfirst('I') */
3838 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3839 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3841 else { /* ucfirst('i') */
3842 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3843 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3848 convert_source_to_utf8 = TRUE;
3849 need += variant_under_utf8_count(s, s + slen);
3851 else if (op_type == OP_LCFIRST) {
3853 /* For lc, there are no gotchas for UTF-8 locales (other than
3854 * the turkish ones already handled above) */
3855 *tmpbuf = toLOWER_LC(*s);
3857 else { /* ucfirst */
3859 /* But for uc, some characters require special handling */
3860 if (IN_UTF8_CTYPE_LOCALE) {
3864 /* This would be a bug if any locales have upper and title case
3866 *tmpbuf = (U8) toUPPER_LC(*s);
3871 /* Here, not in locale. If not using Unicode rules, is a simple
3872 * lower/upper, depending */
3873 if (! IN_UNI_8_BIT) {
3874 *tmpbuf = (op_type == OP_LCFIRST)
3878 else if (op_type == OP_LCFIRST) {
3879 /* lower case the first letter: no trickiness for any character */
3880 *tmpbuf = toLOWER_LATIN1(*s);
3883 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3884 * non-turkic UTF-8, which we treat as not in locale), and cased
3887 #ifdef USE_LOCALE_CTYPE
3891 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3893 assert(tculen == 2);
3895 /* If the result is an upper Latin1-range character, it can
3896 * still be represented in one byte, which is its ordinal */
3897 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3898 *tmpbuf = (U8) title_ord;
3902 /* Otherwise it became more than one ASCII character (in
3903 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3904 * beyond Latin1, so the number of bytes changed, so can't
3905 * replace just the first character in place. */
3908 /* If the result won't fit in a byte, the entire result
3909 * will have to be in UTF-8. Allocate enough space for the
3910 * expanded first byte, and if UTF-8, the rest of the input
3911 * string, some or all of which may also expand to two
3912 * bytes, plus the terminating NUL. */
3913 if (title_ord > 255) {
3915 convert_source_to_utf8 = TRUE;
3917 + variant_under_utf8_count(s, s + slen)
3920 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3921 * characters whose title case is above 255 is
3925 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3926 need = slen + 1 + 1;
3930 } /* End of use Unicode (Latin1) semantics */
3931 } /* End of changing the case of the first character */
3933 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3934 * generate the result */
3937 /* We can convert in place. This means we change just the first
3938 * character without disturbing the rest; no need to grow */
3940 s = d = (U8*)SvPV_force_nomg(source, slen);
3946 /* Here, we can't convert in place; we earlier calculated how much
3947 * space we will need, so grow to accommodate that */
3948 SvUPGRADE(dest, SVt_PV);
3949 d = (U8*)SvGROW(dest, need);
3950 (void)SvPOK_only(dest);
3957 if (! convert_source_to_utf8) {
3959 /* Here both source and dest are in UTF-8, but have to create
3960 * the entire output. We initialize the result to be the
3961 * title/lower cased first character, and then append the rest
3963 sv_setpvn(dest, (char*)tmpbuf, tculen);
3966 /* But this boolean being set means we are in a turkic
3967 * locale, and there is a DOT character that needs to be
3968 * removed, and it isn't immediately after the current
3969 * character. Keep concatenating characters to the output
3970 * one at a time, until we find the DOT, which we simply
3972 if (UNLIKELY(remove_dot_above)) {
3974 Size_t this_len = UTF8SKIP(s + ulen);
3976 sv_catpvn(dest, (char*)(s + ulen), this_len);
3979 if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3983 } while (s + ulen < s + slen);
3986 /* The rest of the string can be concatenated unchanged,
3988 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3992 const U8 *const send = s + slen;
3994 /* Here the dest needs to be in UTF-8, but the source isn't,
3995 * except we earlier UTF-8'd the first character of the source
3996 * into tmpbuf. First put that into dest, and then append the
3997 * rest of the source, converting it to UTF-8 as we go. */
3999 /* Assert tculen is 2 here because the only characters that
4000 * get to this part of the code have 2-byte UTF-8 equivalents */
4001 assert(tculen == 2);
4003 *d++ = *(tmpbuf + 1);
4004 s++; /* We have just processed the 1st char */
4007 append_utf8_from_native_byte(*s, &d);
4012 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4016 else { /* in-place UTF-8. Just overwrite the first character */
4017 Copy(tmpbuf, d, tculen, U8);
4018 SvCUR_set(dest, need - 1);
4022 else { /* Neither source nor dest are, nor need to be UTF-8 */
4024 if (inplace) { /* in-place, only need to change the 1st char */
4027 else { /* Not in-place */
4029 /* Copy the case-changed character(s) from tmpbuf */
4030 Copy(tmpbuf, d, tculen, U8);
4031 d += tculen - 1; /* Code below expects d to point to final
4032 * character stored */
4035 else { /* empty source */
4036 /* See bug #39028: Don't taint if empty */
4040 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4041 * the destination to retain that flag */
4042 if (DO_UTF8(source))
4045 if (!inplace) { /* Finish the rest of the string, unchanged */
4046 /* This will copy the trailing NUL */
4047 Copy(s + 1, d + 1, slen, U8);
4048 SvCUR_set(dest, need - 1);
4051 #ifdef USE_LOCALE_CTYPE
4052 if (IN_LC_RUNTIME(LC_CTYPE)) {
4057 if (dest != source && SvTAINTED(source))
4075 if ( SvPADTMP(source)
4076 && !SvREADONLY(source) && SvPOK(source)
4079 #ifdef USE_LOCALE_CTYPE
4080 (IN_LC_RUNTIME(LC_CTYPE))
4081 ? ! IN_UTF8_CTYPE_LOCALE
4087 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4088 * make the loop tight, so we overwrite the source with the dest before
4089 * looking at it, and we need to look at the original source
4090 * afterwards. There would also need to be code added to handle
4091 * switching to not in-place in midstream if we run into characters
4092 * that change the length. Since being in locale overrides UNI_8_BIT,
4093 * that latter becomes irrelevant in the above test; instead for
4094 * locale, the size can't normally change, except if the locale is a
4097 s = d = (U8*)SvPV_force_nomg(source, len);
4104 s = (const U8*)SvPV_nomg_const(source, len);
4107 SvUPGRADE(dest, SVt_PV);
4108 d = (U8*)SvGROW(dest, min);
4109 (void)SvPOK_only(dest);
4114 #ifdef USE_LOCALE_CTYPE
4116 if (IN_LC_RUNTIME(LC_CTYPE)) {
4117 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4122 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4123 to check DO_UTF8 again here. */
4125 if (DO_UTF8(source)) {
4126 const U8 *const send = s + len;
4127 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4129 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4130 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4131 /* All occurrences of these are to be moved to follow any other marks.
4132 * This is context-dependent. We may not be passed enough context to
4133 * move the iota subscript beyond all of them, but we do the best we can
4134 * with what we're given. The result is always better than if we
4135 * hadn't done this. And, the problem would only arise if we are
4136 * passed a character without all its combining marks, which would be
4137 * the caller's mistake. The information this is based on comes from a
4138 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4139 * itself) and so can't be checked properly to see if it ever gets
4140 * revised. But the likelihood of it changing is remote */
4141 bool in_iota_subscript = FALSE;
4147 if (UNLIKELY(in_iota_subscript)) {
4148 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4150 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4152 /* A non-mark. Time to output the iota subscript */
4153 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4154 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4155 in_iota_subscript = FALSE;
4159 /* Then handle the current character. Get the changed case value
4160 * and copy it to the output buffer */
4163 #ifdef USE_LOCALE_CTYPE
4164 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4166 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4168 if (uv == GREEK_CAPITAL_LETTER_IOTA
4169 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4171 in_iota_subscript = TRUE;
4174 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4175 /* If the eventually required minimum size outgrows the
4176 * available space, we need to grow. */
4177 const UV o = d - (U8*)SvPVX_const(dest);
4179 /* If someone uppercases one million U+03B0s we SvGROW()
4180 * one million times. Or we could try guessing how much to
4181 * allocate without allocating too much. But we can't
4182 * really guess without examining the rest of the string.
4183 * Such is life. See corresponding comment in lc code for
4185 d = o + (U8*) SvGROW(dest, min);
4187 Copy(tmpbuf, d, ulen, U8);
4192 if (in_iota_subscript) {
4193 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4194 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4199 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4201 else { /* Not UTF-8 */
4203 const U8 *const send = s + len;
4205 /* Use locale casing if in locale; regular style if not treating
4206 * latin1 as having case; otherwise the latin1 casing. Do the
4207 * whole thing in a tight loop, for speed, */
4208 #ifdef USE_LOCALE_CTYPE
4209 if (IN_LC_RUNTIME(LC_CTYPE)) {
4210 if (IN_UTF8_CTYPE_LOCALE) {
4213 for (; s < send; d++, s++)
4214 *d = (U8) toUPPER_LC(*s);
4218 if (! IN_UNI_8_BIT) {
4219 for (; s < send; d++, s++) {
4224 #ifdef USE_LOCALE_CTYPE
4227 for (; s < send; d++, s++) {
4230 *d = toUPPER_LATIN1_MOD(*s);
4231 if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4233 #ifdef USE_LOCALE_CTYPE
4235 && (LIKELY( ! PL_in_utf8_turkic_locale
4236 || ! IN_LC_RUNTIME(LC_CTYPE))
4244 /* The mainstream case is the tight loop above. To avoid
4245 * extra tests in that, all three characters that always
4246 * require special handling are mapped by the MOD to the
4247 * one tested just above. Use the source to distinguish
4248 * between those cases */
4250 #if UNICODE_MAJOR_VERSION > 2 \
4251 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4252 && UNICODE_DOT_DOT_VERSION >= 8)
4253 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4255 /* uc() of this requires 2 characters, but they are
4256 * ASCII. If not enough room, grow the string */
4257 if (SvLEN(dest) < ++min) {
4258 const UV o = d - (U8*)SvPVX_const(dest);
4259 d = o + (U8*) SvGROW(dest, min);
4261 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4262 continue; /* Back to the tight loop; still in ASCII */
4266 /* The other special handling characters have their
4267 * upper cases outside the latin1 range, hence need to be
4268 * in UTF-8, so the whole result needs to be in UTF-8.
4270 * So, here we are somewhere in the middle of processing a
4271 * non-UTF-8 string, and realize that we will have to
4272 * convert the whole thing to UTF-8. What to do? There
4273 * are several possibilities. The simplest to code is to
4274 * convert what we have so far, set a flag, and continue on
4275 * in the loop. The flag would be tested each time through
4276 * the loop, and if set, the next character would be
4277 * converted to UTF-8 and stored. But, I (khw) didn't want
4278 * to slow down the mainstream case at all for this fairly
4279 * rare case, so I didn't want to add a test that didn't
4280 * absolutely have to be there in the loop, besides the
4281 * possibility that it would get too complicated for
4282 * optimizers to deal with. Another possibility is to just
4283 * give up, convert the source to UTF-8, and restart the
4284 * function that way. Another possibility is to convert
4285 * both what has already been processed and what is yet to
4286 * come separately to UTF-8, then jump into the loop that
4287 * handles UTF-8. But the most efficient time-wise of the
4288 * ones I could think of is what follows, and turned out to
4289 * not require much extra code.
4291 * First, calculate the extra space needed for the
4292 * remainder of the source needing to be in UTF-8. Except
4293 * for the 'i' in Turkic locales, in UTF-8 strings, the
4294 * uppercase of a character below 256 occupies the same
4295 * number of bytes as the original. Therefore, the space
4296 * needed is the that number plus the number of characters
4297 * that become two bytes when converted to UTF-8, plus, in
4298 * turkish locales, the number of 'i's. */
4300 extra = send - s + variant_under_utf8_count(s, send);
4302 #ifdef USE_LOCALE_CTYPE
4304 if (UNLIKELY(*s == 'i')) { /* We wouldn't get an 'i' here
4305 unless are in a Turkic
4307 const U8 * s_peek = s;
4312 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4313 send - (s_peek + 1));
4314 } while (s_peek != NULL);
4318 /* Convert what we have so far into UTF-8, telling the
4319 * function that we know it should be converted, and to
4320 * allow extra space for what we haven't processed yet.
4322 * This may cause the string pointer to move, so need to
4323 * save and re-find it. */
4325 len = d - (U8*)SvPVX_const(dest);
4326 SvCUR_set(dest, len);
4327 len = sv_utf8_upgrade_flags_grow(dest,
4328 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4330 + 1 /* trailing NUL */ );
4331 d = (U8*)SvPVX(dest) + len;
4333 /* Now process the remainder of the source, simultaneously
4334 * converting to upper and UTF-8.
4336 * To avoid extra tests in the loop body, and since the
4337 * loop is so simple, split out the rare Turkic case into
4340 #ifdef USE_LOCALE_CTYPE
4341 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4342 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4344 for (; s < send; s++) {
4346 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4347 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4350 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4357 for (; s < send; s++) {
4358 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4362 /* Here have processed the whole source; no need to
4363 * continue with the outer loop. Each character has been
4364 * converted to upper case and converted to UTF-8. */
4366 } /* End of processing all latin1-style chars */
4367 } /* End of processing all chars */
4368 } /* End of source is not empty */
4370 if (source != dest) {
4371 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4372 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4374 } /* End of isn't utf8 */
4375 #ifdef USE_LOCALE_CTYPE
4376 if (IN_LC_RUNTIME(LC_CTYPE)) {
4381 if (dest != source && SvTAINTED(source))
4396 bool has_turkic_I = FALSE;
4400 if ( SvPADTMP(source)
4401 && !SvREADONLY(source) && SvPOK(source)
4404 #ifdef USE_LOCALE_CTYPE
4406 && ( LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4407 || LIKELY(! PL_in_utf8_turkic_locale))
4413 /* We can convert in place, as, outside of Turkic UTF-8 locales,
4414 * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4415 * been on) doesn't lengthen it. */
4417 s = d = (U8*)SvPV_force_nomg(source, len);
4424 s = (const U8*)SvPV_nomg_const(source, len);
4427 SvUPGRADE(dest, SVt_PV);
4428 d = (U8*)SvGROW(dest, min);
4429 (void)SvPOK_only(dest);
4434 #ifdef USE_LOCALE_CTYPE
4436 if (IN_LC_RUNTIME(LC_CTYPE)) {
4439 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4441 /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4442 * UTF-8 for the single case of the character 'I' */
4443 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4444 && ! DO_UTF8(source)
4445 && (next_I = (U8 *) memchr(s, 'I', len)))
4448 const U8 *const send = s + len;
4453 next_I = (U8 *) memchr(next_I + 1, 'I',
4454 send - (next_I + 1));
4455 } while (next_I != NULL);
4457 /* Except for the 'I', in UTF-8 strings, the lower case of a
4458 * character below 256 occupies the same number of bytes as the
4459 * original. Therefore, the space needed is the original length
4460 * plus I_count plus the number of characters that become two bytes
4461 * when converted to UTF-8 */
4462 sv_utf8_upgrade_flags_grow(dest, 0, len
4464 + variant_under_utf8_count(s, send)
4465 + 1 /* Trailing NUL */ );
4466 d = (U8*)SvPVX(dest);
4467 has_turkic_I = TRUE;
4472 PERL_UNUSED_VAR(has_turkic_I);
4475 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4476 to check DO_UTF8 again here. */
4478 if (DO_UTF8(source)) {
4479 const U8 *const send = s + len;
4480 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4481 bool remove_dot_above = FALSE;
4484 const STRLEN u = UTF8SKIP(s);
4487 #ifdef USE_LOCALE_CTYPE
4489 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4491 /* If we are in a Turkic locale, we have to do more work. As noted
4492 * in the comments for lcfirst, there is a special case if a 'I'
4493 * is in a grapheme with COMBINING DOT ABOVE UTF8. It turns into a
4494 * 'i', and the DOT must be removed. We check for that situation,
4495 * and set a flag if the DOT is there. Then each time through the
4496 * loop, we have to see if we need to remove the next DOT above,
4497 * and if so, do it. We know that there is a DOT because
4498 * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4499 * was one in a proper position. */
4500 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4501 && IN_LC_RUNTIME(LC_CTYPE))
4503 if ( UNLIKELY(remove_dot_above)
4504 && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4507 remove_dot_above = FALSE;
4510 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4511 remove_dot_above = TRUE;
4515 PERL_UNUSED_VAR(remove_dot_above);
4517 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4520 /* Here is where we would do context-sensitive actions for the
4521 * Greek final sigma. See the commit message for 86510fb15 for why
4522 * there isn't any */
4524 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4526 /* If the eventually required minimum size outgrows the
4527 * available space, we need to grow. */
4528 const UV o = d - (U8*)SvPVX_const(dest);
4530 /* If someone lowercases one million U+0130s we SvGROW() one
4531 * million times. Or we could try guessing how much to
4532 * allocate without allocating too much. Such is life.
4533 * Another option would be to grow an extra byte or two more
4534 * each time we need to grow, which would cut down the million
4535 * to 500K, with little waste */
4536 d = o + (U8*) SvGROW(dest, min);
4539 /* Copy the newly lowercased letter to the output buffer we're
4541 Copy(tmpbuf, d, ulen, U8);
4544 } /* End of looping through the source string */
4547 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4548 } else { /* 'source' not utf8 */
4550 const U8 *const send = s + len;
4552 /* Use locale casing if in locale; regular style if not treating
4553 * latin1 as having case; otherwise the latin1 casing. Do the
4554 * whole thing in a tight loop, for speed, */
4555 #ifdef USE_LOCALE_CTYPE
4556 if (IN_LC_RUNTIME(LC_CTYPE)) {
4557 if (LIKELY( ! has_turkic_I)) {
4558 for (; s < send; d++, s++)
4559 *d = toLOWER_LC(*s);
4561 else { /* This is the only case where lc() converts 'dest'
4562 into UTF-8 from a non-UTF-8 'source' */
4563 for (; s < send; s++) {
4565 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4566 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4569 append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4576 if (! IN_UNI_8_BIT) {
4577 for (; s < send; d++, s++) {
4582 for (; s < send; d++, s++) {
4583 *d = toLOWER_LATIN1(*s);
4587 if (source != dest) {
4589 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4592 #ifdef USE_LOCALE_CTYPE
4593 if (IN_LC_RUNTIME(LC_CTYPE)) {
4598 if (dest != source && SvTAINTED(source))
4607 SV * const sv = TOPs;
4609 const char *s = SvPV_const(sv,len);
4611 SvUTF8_off(TARG); /* decontaminate */
4614 SvUPGRADE(TARG, SVt_PV);
4615 SvGROW(TARG, (len * 2) + 1);
4619 STRLEN ulen = UTF8SKIP(s);
4620 bool to_quote = FALSE;
4622 if (UTF8_IS_INVARIANT(*s)) {
4623 if (_isQUOTEMETA(*s)) {
4627 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4629 #ifdef USE_LOCALE_CTYPE
4630 /* In locale, we quote all non-ASCII Latin1 chars.
4631 * Otherwise use the quoting rules */
4633 IN_LC_RUNTIME(LC_CTYPE)
4636 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4641 else if (is_QUOTEMETA_high(s)) {
4656 else if (IN_UNI_8_BIT) {
4658 if (_isQUOTEMETA(*s))
4664 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4665 * including everything above ASCII */
4667 if (!isWORDCHAR_A(*s))
4673 SvCUR_set(TARG, d - SvPVX_const(TARG));
4674 (void)SvPOK_only_UTF8(TARG);
4677 sv_setpvn(TARG, s, len);
4693 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4694 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4695 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4696 || UNICODE_DOT_DOT_VERSION > 0)
4697 const bool full_folding = TRUE; /* This variable is here so we can easily
4698 move to more generality later */
4700 const bool full_folding = FALSE;
4702 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4703 #ifdef USE_LOCALE_CTYPE
4704 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4708 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4709 * You are welcome(?) -Hugmeir
4717 s = (const U8*)SvPV_nomg_const(source, len);
4719 if (ckWARN(WARN_UNINITIALIZED))
4720 report_uninit(source);
4727 SvUPGRADE(dest, SVt_PV);
4728 d = (U8*)SvGROW(dest, min);
4729 (void)SvPOK_only(dest);
4735 #ifdef USE_LOCALE_CTYPE
4737 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4738 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4743 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4745 const STRLEN u = UTF8SKIP(s);
4748 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4750 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4751 const UV o = d - (U8*)SvPVX_const(dest);
4752 d = o + (U8*) SvGROW(dest, min);
4755 Copy(tmpbuf, d, ulen, U8);
4760 } /* Unflagged string */
4762 #ifdef USE_LOCALE_CTYPE
4763 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4764 if (IN_UTF8_CTYPE_LOCALE) {
4765 goto do_uni_folding;
4767 for (; s < send; d++, s++)
4768 *d = (U8) toFOLD_LC(*s);
4772 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4773 for (; s < send; d++, s++)
4777 #ifdef USE_LOCALE_CTYPE
4780 /* For ASCII and the Latin-1 range, there's potentially three
4781 * troublesome folds:
4782 * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4783 * casefolding becomes 'ss';
4784 * \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4785 * \x{3BC} (\N{GREEK SMALL LETTER MU})
4786 * I only in Turkic locales, this folds to \x{131}
4787 * \N{LATIN SMALL LETTER DOTLESS I}
4788 * For the rest, the casefold is their lowercase. */
4789 for (; s < send; d++, s++) {
4790 if ( UNLIKELY(*s == MICRO_SIGN)
4791 #ifdef USE_LOCALE_CTYPE
4792 || ( UNLIKELY(PL_in_utf8_turkic_locale)
4793 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4794 && UNLIKELY(*s == 'I'))
4797 Size_t extra = send - s
4798 + variant_under_utf8_count(s, send);
4800 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4801 * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4802 * DOTLESS I} both of which are outside of the latin-1
4803 * range. There's a couple of ways to deal with this -- khw
4804 * discusses them in pp_lc/uc, so go there :) What we do
4805 * here is upgrade what we had already casefolded, then
4806 * enter an inner loop that appends the rest of the
4807 * characters as UTF-8.
4809 * First we calculate the needed size of the upgraded dest
4810 * beyond what's been processed already (the upgrade
4811 * function figures that out). Except for the 'I' in
4812 * Turkic locales, in UTF-8 strings, the fold case of a
4813 * character below 256 occupies the same number of bytes as
4814 * the original (even the Sharp S). Therefore, the space
4815 * needed is the number of bytes remaining plus the number
4816 * of characters that become two bytes when converted to
4817 * UTF-8 plus, in turkish locales, the number of 'I's */
4819 if (UNLIKELY(*s == 'I')) {
4820 const U8 * s_peek = s;
4825 s_peek = (U8 *) memchr(s_peek + 1, 'I',
4826 send - (s_peek + 1));
4827 } while (s_peek != NULL);
4830 /* Growing may move things, so have to save and recalculate
4832 len = d - (U8*)SvPVX_const(dest);
4833 SvCUR_set(dest, len);
4834 len = sv_utf8_upgrade_flags_grow(dest,
4835 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4837 + 1 /* Trailing NUL */ );
4838 d = (U8*)SvPVX(dest) + len;
4841 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4842 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4845 *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4846 *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4850 for (; s < send; s++) {
4852 _to_uni_fold_flags(*s, d, &ulen, flags);
4857 else if ( UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4860 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4861 * becomes "ss", which may require growing the SV. */
4862 if (SvLEN(dest) < ++min) {
4863 const UV o = d - (U8*)SvPVX_const(dest);
4864 d = o + (U8*) SvGROW(dest, min);
4869 else { /* Else, the fold is the lower case */
4870 *d = toLOWER_LATIN1(*s);
4876 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4878 #ifdef USE_LOCALE_CTYPE
4879 if (IN_LC_RUNTIME(LC_CTYPE)) {
4884 if (SvTAINTED(source))
4894 dSP; dMARK; dORIGMARK;
4895 AV *const av = MUTABLE_AV(POPs);
4896 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4898 if (SvTYPE(av) == SVt_PVAV) {
4899 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4900 bool can_preserve = FALSE;
4906 can_preserve = SvCANEXISTDELETE(av);
4909 if (lval && localizing) {
4912 for (svp = MARK + 1; svp <= SP; svp++) {
4913 const SSize_t elem = SvIV(*svp);
4917 if (max > AvMAX(av))
4921 while (++MARK <= SP) {
4923 SSize_t elem = SvIV(*MARK);
4924 bool preeminent = TRUE;
4926 if (localizing && can_preserve) {
4927 /* If we can determine whether the element exist,
4928 * Try to preserve the existenceness of a tied array
4929 * element by using EXISTS and DELETE if possible.
4930 * Fallback to FETCH and STORE otherwise. */
4931 preeminent = av_exists(av, elem);
4934 svp = av_fetch(av, elem, lval);
4937 DIE(aTHX_ PL_no_aelem, elem);
4940 save_aelem(av, elem, svp);
4942 SAVEADELETE(av, elem);
4945 *MARK = svp ? *svp : &PL_sv_undef;
4948 if (GIMME_V != G_LIST) {
4950 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4959 AV *const av = MUTABLE_AV(POPs);
4960 I32 lval = (PL_op->op_flags & OPf_MOD);
4961 SSize_t items = SP - MARK;
4963 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4964 const I32 flags = is_lvalue_sub();
4966 if (!(flags & OPpENTERSUB_INARGS))
4967 /* diag_listed_as: Can't modify %s in %s */
4968 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4975 *(MARK+items*2-1) = *(MARK+items);
4981 while (++MARK <= SP) {
4984 svp = av_fetch(av, SvIV(*MARK), lval);
4986 if (!svp || !*svp || *svp == &PL_sv_undef) {
4987 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4989 *MARK = sv_mortalcopy(*MARK);
4991 *++MARK = svp ? *svp : &PL_sv_undef;
4993 if (GIMME_V != G_LIST) {
4994 MARK = SP - items*2;
4995 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5005 AV *array = MUTABLE_AV(POPs);
5006 const U8 gimme = GIMME_V;
5007 IV *iterp = Perl_av_iter_p(aTHX_ array);
5008 const IV current = (*iterp)++;
5010 if (current > av_top_index(array)) {
5012 if (gimme == G_SCALAR)
5020 if (gimme == G_LIST) {
5021 SV **const element = av_fetch(array, current, 0);
5022 PUSHs(element ? *element : &PL_sv_undef);
5027 /* also used for: pp_avalues()*/
5031 AV *array = MUTABLE_AV(POPs);
5032 const U8 gimme = GIMME_V;
5034 *Perl_av_iter_p(aTHX_ array) = 0;
5036 if (gimme == G_SCALAR) {
5038 PUSHi(av_count(array));
5040 else if (gimme == G_LIST) {
5041 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5042 const I32 flags = is_lvalue_sub();
5043 if (flags && !(flags & OPpENTERSUB_INARGS))
5044 /* diag_listed_as: Can't modify %s in %s */
5046 "Can't modify keys on array in list assignment");
5049 IV n = av_top_index(array);
5054 if ( PL_op->op_type == OP_AKEYS
5055 || ( PL_op->op_type == OP_AVHVSWITCH
5056 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
5058 for (i = 0; i <= n; i++) {
5063 for (i = 0; i <= n; i++) {
5064 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5065 PUSHs(elem ? *elem : &PL_sv_undef);
5073 /* Associative arrays. */
5078 HV * hash = MUTABLE_HV(POPs);
5080 const U8 gimme = GIMME_V;
5082 entry = hv_iternext(hash);
5086 SV* const sv = hv_iterkeysv(entry);
5088 if (gimme == G_LIST) {
5090 val = hv_iterval(hash, entry);
5094 else if (gimme == G_SCALAR)
5101 S_do_delete_local(pTHX)
5104 const U8 gimme = GIMME_V;
5107 const bool sliced = !!(PL_op->op_private & OPpSLICE);
5108 SV **unsliced_keysv = sliced ? NULL : sp--;
5109 SV * const osv = POPs;
5110 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5112 const bool tied = SvRMAGICAL(osv)
5113 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5114 const bool can_preserve = SvCANEXISTDELETE(osv);
5115 const U32 type = SvTYPE(osv);
5116 SV ** const end = sliced ? SP : unsliced_keysv;
5118 if (type == SVt_PVHV) { /* hash element */
5119 HV * const hv = MUTABLE_HV(osv);
5120 while (++MARK <= end) {
5121 SV * const keysv = *MARK;
5123 bool preeminent = TRUE;
5125 preeminent = hv_exists_ent(hv, keysv, 0);
5127 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5134 sv = hv_delete_ent(hv, keysv, 0, 0);
5136 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5139 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5140 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5142 *MARK = sv_mortalcopy(sv);
5148 SAVEHDELETE(hv, keysv);
5149 *MARK = &PL_sv_undef;
5153 else if (type == SVt_PVAV) { /* array element */
5154 if (PL_op->op_flags & OPf_SPECIAL) {
5155 AV * const av = MUTABLE_AV(osv);
5156 while (++MARK <= end) {
5157 SSize_t idx = SvIV(*MARK);
5159 bool preeminent = TRUE;
5161 preeminent = av_exists(av, idx);
5163 SV **svp = av_fetch(av, idx, 1);
5170 sv = av_delete(av, idx, 0);
5172 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5175 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5177 *MARK = sv_mortalcopy(sv);
5183 SAVEADELETE(av, idx);
5184 *MARK = &PL_sv_undef;
5189 DIE(aTHX_ "panic: avhv_delete no longer supported");
5192 DIE(aTHX_ "Not a HASH reference");
5194 if (gimme == G_VOID)
5196 else if (gimme == G_SCALAR) {
5201 *++MARK = &PL_sv_undef;
5205 else if (gimme != G_VOID)
5206 PUSHs(*unsliced_keysv);
5217 if (PL_op->op_private & OPpLVAL_INTRO)
5218 return do_delete_local();
5221 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5223 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5225 HV * const hv = MUTABLE_HV(POPs);
5226 const U32 hvtype = SvTYPE(hv);
5228 if (PL_op->op_private & OPpKVSLICE) {
5229 SSize_t items = SP - MARK;
5233 *(MARK+items*2-1) = *(MARK+items);
5240 if (hvtype == SVt_PVHV) { /* hash element */
5241 while ((MARK += (1+skip)) <= SP) {
5242 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5243 *MARK = sv ? sv : &PL_sv_undef;
5246 else if (hvtype == SVt_PVAV) { /* array element */
5247 if (PL_op->op_flags & OPf_SPECIAL) {
5248 while ((MARK += (1+skip)) <= SP) {
5249 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5250 *MARK = sv ? sv : &PL_sv_undef;
5255 DIE(aTHX_ "Not a HASH reference");
5258 else if (gimme == G_SCALAR) {
5263 *++MARK = &PL_sv_undef;
5269 HV * const hv = MUTABLE_HV(POPs);
5271 if (SvTYPE(hv) == SVt_PVHV)
5272 sv = hv_delete_ent(hv, keysv, discard, 0);
5273 else if (SvTYPE(hv) == SVt_PVAV) {
5274 if (PL_op->op_flags & OPf_SPECIAL)
5275 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5277 DIE(aTHX_ "panic: avhv_delete no longer supported");
5280 DIE(aTHX_ "Not a HASH reference");
5295 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5297 SV * const sv = POPs;
5298 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5301 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5306 hv = MUTABLE_HV(POPs);
5307 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5308 if (hv_exists_ent(hv, tmpsv, 0))
5311 else if (SvTYPE(hv) == SVt_PVAV) {
5312 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5313 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5318 DIE(aTHX_ "Not a HASH reference");
5325 dSP; dMARK; dORIGMARK;
5326 HV * const hv = MUTABLE_HV(POPs);
5327 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5328 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5329 bool can_preserve = FALSE;
5335 if (SvCANEXISTDELETE(hv))
5336 can_preserve = TRUE;
5339 while (++MARK <= SP) {
5340 SV * const keysv = *MARK;
5343 bool preeminent = TRUE;
5345 if (localizing && can_preserve) {
5346 /* If we can determine whether the element exist,
5347 * try to preserve the existenceness of a tied hash
5348 * element by using EXISTS and DELETE if possible.
5349 * Fallback to FETCH and STORE otherwise. */
5350 preeminent = hv_exists_ent(hv, keysv, 0);
5353 he = hv_fetch_ent(hv, keysv, lval, 0);
5354 svp = he ? &HeVAL(he) : NULL;
5357 if (!svp || !*svp || *svp == &PL_sv_undef) {
5358 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5361 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5362 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5363 else if (preeminent)
5364 save_helem_flags(hv, keysv, svp,
5365 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5367 SAVEHDELETE(hv, keysv);
5370 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5372 if (GIMME_V != G_LIST) {
5374 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5383 HV * const hv = MUTABLE_HV(POPs);
5384 I32 lval = (PL_op->op_flags & OPf_MOD);
5385 SSize_t items = SP - MARK;
5387 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5388 const I32 flags = is_lvalue_sub();
5390 if (!(flags & OPpENTERSUB_INARGS))
5391 /* diag_listed_as: Can't modify %s in %s */
5392 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5393 GIMME_V == G_LIST ? "list" : "scalar");
5400 *(MARK+items*2-1) = *(MARK+items);
5406 while (++MARK <= SP) {
5407 SV * const keysv = *MARK;
5411 he = hv_fetch_ent(hv, keysv, lval, 0);
5412 svp = he ? &HeVAL(he) : NULL;
5415 if (!svp || !*svp || *svp == &PL_sv_undef) {
5416 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5418 *MARK = sv_mortalcopy(*MARK);
5420 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5422 if (GIMME_V != G_LIST) {
5423 MARK = SP - items*2;
5424 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5430 /* List operators. */
5434 I32 markidx = POPMARK;
5435 if (GIMME_V != G_LIST) {
5436 /* don't initialize mark here, EXTEND() may move the stack */
5439 EXTEND(SP, 1); /* in case no arguments, as in @empty */
5440 mark = PL_stack_base + markidx;
5442 *MARK = *SP; /* unwanted list, return last item */
5444 *MARK = &PL_sv_undef;
5454 SV ** const lastrelem = PL_stack_sp;
5455 SV ** const lastlelem = PL_stack_base + POPMARK;
5456 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5457 SV ** const firstrelem = lastlelem + 1;
5458 const U8 mod = PL_op->op_flags & OPf_MOD;
5460 const I32 max = lastrelem - lastlelem;
5463 if (GIMME_V != G_LIST) {
5464 if (lastlelem < firstlelem) {
5466 *firstlelem = &PL_sv_undef;
5469 I32 ix = SvIV(*lastlelem);
5472 if (ix < 0 || ix >= max)
5473 *firstlelem = &PL_sv_undef;
5475 *firstlelem = firstrelem[ix];
5482 SP = firstlelem - 1;
5486 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5487 I32 ix = SvIV(*lelem);
5490 if (ix < 0 || ix >= max)
5491 *lelem = &PL_sv_undef;
5493 if (!(*lelem = firstrelem[ix]))
5494 *lelem = &PL_sv_undef;
5495 else if (mod && SvPADTMP(*lelem)) {
5496 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5507 const I32 items = SP - MARK;
5508 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5510 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5511 ? newRV_noinc(av) : av);
5517 dSP; dMARK; dORIGMARK;
5518 HV* const hv = newHV();
5519 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5520 ? newRV_noinc(MUTABLE_SV(hv))
5522 /* This isn't quite true for an odd sized list (it's one too few) but it's
5523 not worth the runtime +1 just to optimise for the warning case. */
5524 SSize_t pairs = (SP - MARK) >> 1;
5525 if (pairs > PERL_HASH_DEFAULT_HvMAX) {
5526 hv_ksplit(hv, pairs);
5531 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5538 sv_setsv_nomg(val, *MARK);
5542 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5545 (void)hv_store_ent(hv,key,val,0);
5554 dSP; dMARK; dORIGMARK;
5555 int num_args = (SP - MARK);
5556 AV *ary = MUTABLE_AV(*++MARK);
5565 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5568 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5569 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5573 if (SvREADONLY(ary))
5574 Perl_croak_no_modify();
5579 offset = i = SvIV(*MARK);
5581 offset += AvFILLp(ary) + 1;
5583 DIE(aTHX_ PL_no_aelem, i);
5585 length = SvIVx(*MARK++);
5587 length += AvFILLp(ary) - offset + 1;
5593 length = AvMAX(ary) + 1; /* close enough to infinity */
5597 length = AvMAX(ary) + 1;
5599 if (offset > AvFILLp(ary) + 1) {
5601 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5602 offset = AvFILLp(ary) + 1;
5604 after = AvFILLp(ary) + 1 - (offset + length);
5605 if (after < 0) { /* not that much array */
5606 length += after; /* offset+length now in array */
5612 /* At this point, MARK .. SP-1 is our new LIST */
5615 diff = newlen - length;
5616 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5619 /* make new elements SVs now: avoid problems if they're from the array */
5620 for (dst = MARK, i = newlen; i; i--) {
5621 SV * const h = *dst;
5622 *dst++ = newSVsv(h);
5625 if (diff < 0) { /* shrinking the area */
5626 SV **tmparyval = NULL;
5628 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5629 Copy(MARK, tmparyval, newlen, SV*);
5632 MARK = ORIGMARK + 1;
5633 if (GIMME_V == G_LIST) { /* copy return vals to stack */
5634 const bool real = cBOOL(AvREAL(ary));
5635 MEXTEND(MARK, length);
5637 EXTEND_MORTAL(length);
5638 for (i = 0, dst = MARK; i < length; i++) {
5639 if ((*dst = AvARRAY(ary)[i+offset])) {
5641 sv_2mortal(*dst); /* free them eventually */
5644 *dst = &PL_sv_undef;
5650 *MARK = AvARRAY(ary)[offset+length-1];
5653 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5654 SvREFCNT_dec(*dst++); /* free them now */
5657 *MARK = &PL_sv_undef;
5659 AvFILLp(ary) += diff;
5661 /* pull up or down? */
5663 if (offset < after) { /* easier to pull up */
5664 if (offset) { /* esp. if nothing to pull */
5665 src = &AvARRAY(ary)[offset-1];
5666 dst = src - diff; /* diff is negative */
5667 for (i = offset; i > 0; i--) /* can't trust Copy */
5671 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5675 if (after) { /* anything to pull down? */
5676 src = AvARRAY(ary) + offset + length;
5677 dst = src + diff; /* diff is negative */
5678 Move(src, dst, after, SV*);
5680 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5681 /* avoid later double free */
5688 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5689 Safefree(tmparyval);
5692 else { /* no, expanding (or same) */
5693 SV** tmparyval = NULL;
5695 Newx(tmparyval, length, SV*); /* so remember deletion */
5696 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5699 if (diff > 0) { /* expanding */
5700 /* push up or down? */
5701 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5705 Move(src, dst, offset, SV*);
5707 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5709 AvFILLp(ary) += diff;
5712 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5713 av_extend(ary, AvFILLp(ary) + diff);
5714 AvFILLp(ary) += diff;
5717 dst = AvARRAY(ary) + AvFILLp(ary);
5719 for (i = after; i; i--) {
5727 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5730 MARK = ORIGMARK + 1;
5731 if (GIMME_V == G_LIST) { /* copy return vals to stack */
5733 const bool real = cBOOL(AvREAL(ary));
5735 EXTEND_MORTAL(length);
5736 for (i = 0, dst = MARK; i < length; i++) {
5737 if ((*dst = tmparyval[i])) {
5739 sv_2mortal(*dst); /* free them eventually */
5741 else *dst = &PL_sv_undef;
5747 else if (length--) {
5748 *MARK = tmparyval[length];
5751 while (length-- > 0)
5752 SvREFCNT_dec(tmparyval[length]);
5755 *MARK = &PL_sv_undef;
5758 *MARK = &PL_sv_undef;
5759 Safefree(tmparyval);
5763 mg_set(MUTABLE_SV(ary));
5771 dSP; dMARK; dORIGMARK; dTARGET;
5772 AV * const ary = MUTABLE_AV(*++MARK);
5773 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5776 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5779 ENTER_with_name("call_PUSH");
5780 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5781 LEAVE_with_name("call_PUSH");
5782 /* SPAGAIN; not needed: SP is assigned to immediately below */
5785 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5786 * only need to save locally, not on the save stack */
5787 U16 old_delaymagic = PL_delaymagic;
5789 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5790 PL_delaymagic = DM_DELAY;
5791 for (++MARK; MARK <= SP; MARK++) {
5793 if (*MARK) SvGETMAGIC(*MARK);
5796 sv_setsv_nomg(sv, *MARK);
5797 av_store(ary, AvFILLp(ary)+1, sv);
5799 if (PL_delaymagic & DM_ARRAY_ISA)
5800 mg_set(MUTABLE_SV(ary));
5801 PL_delaymagic = old_delaymagic;
5804 if (OP_GIMME(PL_op, 0) != G_VOID) {
5805 PUSHi( AvFILL(ary) + 1 );
5810 /* also used for: pp_pop()*/
5814 AV * const av = PL_op->op_flags & OPf_SPECIAL
5815 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5816 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5820 (void)sv_2mortal(sv);
5827 dSP; dMARK; dORIGMARK; dTARGET;
5828 AV *ary = MUTABLE_AV(*++MARK);
5829 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5832 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5835 ENTER_with_name("call_UNSHIFT");
5836 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5837 LEAVE_with_name("call_UNSHIFT");
5838 /* SPAGAIN; not needed: SP is assigned to immediately below */
5841 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5842 * only need to save locally, not on the save stack */
5843 U16 old_delaymagic = PL_delaymagic;
5846 av_unshift(ary, SP - MARK);
5847 PL_delaymagic = DM_DELAY;
5849 SV * const sv = newSVsv(*++MARK);
5850 (void)av_store(ary, i++, sv);
5852 if (PL_delaymagic & DM_ARRAY_ISA)
5853 mg_set(MUTABLE_SV(ary));
5854 PL_delaymagic = old_delaymagic;
5857 if (OP_GIMME(PL_op, 0) != G_VOID) {
5858 PUSHi( AvFILL(ary) + 1 );
5867 if (GIMME_V == G_LIST) {
5868 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5872 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5873 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5874 av = MUTABLE_AV((*SP));
5875 /* In-place reversing only happens in void context for the array
5876 * assignment. We don't need to push anything on the stack. */
5879 if (SvMAGICAL(av)) {
5881 SV *tmp = sv_newmortal();
5882 /* For SvCANEXISTDELETE */
5885 bool can_preserve = SvCANEXISTDELETE(av);
5887 for (i = 0, j = av_top_index(av); i < j; ++i, --j) {
5891 if (!av_exists(av, i)) {
5892 if (av_exists(av, j)) {
5893 SV *sv = av_delete(av, j, 0);
5894 begin = *av_fetch(av, i, TRUE);
5895 sv_setsv_mg(begin, sv);
5899 else if (!av_exists(av, j)) {
5900 SV *sv = av_delete(av, i, 0);
5901 end = *av_fetch(av, j, TRUE);
5902 sv_setsv_mg(end, sv);
5907 begin = *av_fetch(av, i, TRUE);
5908 end = *av_fetch(av, j, TRUE);
5909 sv_setsv(tmp, begin);
5910 sv_setsv_mg(begin, end);
5911 sv_setsv_mg(end, tmp);
5915 SV **begin = AvARRAY(av);
5918 SV **end = begin + AvFILLp(av);
5920 while (begin < end) {
5921 SV * const tmp = *begin;
5932 SV * const tmp = *MARK;
5936 /* safe as long as stack cannot get extended in the above */
5945 SvUTF8_off(TARG); /* decontaminate */
5946 if (SP - MARK > 1) {
5947 do_join(TARG, &PL_sv_no, MARK, SP);
5950 } else if (SP > MARK) {
5951 sv_setsv(TARG, *SP);
5954 sv_setsv(TARG, DEFSV);
5957 SvSETMAGIC(TARG); /* remove any utf8 length magic */
5959 up = SvPV_force(TARG, len);
5962 if (DO_UTF8(TARG)) { /* first reverse each character */
5963 U8* s = (U8*)SvPVX(TARG);
5964 const U8* send = (U8*)(s + len);
5966 if (UTF8_IS_INVARIANT(*s)) {
5971 if (!utf8_to_uvchr_buf(s, send, 0))
5975 down = (char*)(s - 1);
5976 /* reverse this character */
5978 const char tmp = *up;
5986 down = SvPVX(TARG) + len - 1;
5988 const char tmp = *up;
5992 (void)SvPOK_only_UTF8(TARG);
6001 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
6002 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
6003 ? (AV *)POPs : NULL;
6004 IV limit = POPi; /* note, negative is forever */
6005 SV * const sv = POPs;
6007 const char *s = SvPV_const(sv, len);
6008 const bool do_utf8 = DO_UTF8(sv);
6009 const bool in_uni_8_bit = IN_UNI_8_BIT;
6010 const char *strend = s + len;
6011 PMOP *pm = cPMOPx(PL_op);
6016 const STRLEN slen = do_utf8
6017 ? utf8_length((U8*)s, (U8*)strend)
6018 : (STRLEN)(strend - s);
6019 SSize_t maxiters = slen + 10;
6020 I32 trailing_empty = 0;
6022 const IV origlimit = limit;
6025 const U8 gimme = GIMME_V;
6027 I32 oldsave = PL_savestack_ix;
6028 U32 flags = (do_utf8 ? SVf_UTF8 : 0) |
6029 SVs_TEMP; /* Make mortal SVs by default */
6034 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
6035 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
6037 /* handle @ary = split(...) optimisation */
6038 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
6040 if (!(PL_op->op_flags & OPf_STACKED)) {
6041 if (PL_op->op_private & OPpSPLIT_LEX) {
6042 if (PL_op->op_private & OPpLVAL_INTRO)
6043 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6044 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
6049 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6051 pm->op_pmreplrootu.op_pmtargetgv;
6053 if (PL_op->op_private & OPpLVAL_INTRO)
6058 /* skip anything pushed by OPpLVAL_INTRO above */
6059 oldsave = PL_savestack_ix;
6062 /* Some defence against stack-not-refcounted bugs */
6063 (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary));
6065 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6067 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6069 flags &= ~SVs_TEMP; /* SVs will not be mortal */
6073 base = SP - PL_stack_base;
6075 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6077 while (s < strend && isSPACE_utf8_safe(s, strend))
6080 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6081 while (s < strend && isSPACE_LC(*s))
6084 else if (in_uni_8_bit) {
6085 while (s < strend && isSPACE_L1(*s))
6089 while (s < strend && isSPACE(*s))
6094 gimme_scalar = gimme == G_SCALAR && !ary;
6097 limit = maxiters + 2;
6098 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6101 /* this one uses 'm' and is a negative test */
6103 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6104 const int t = UTF8SKIP(m);
6105 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6112 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6114 while (m < strend && !isSPACE_LC(*m))
6117 else if (in_uni_8_bit) {
6118 while (m < strend && !isSPACE_L1(*m))
6121 while (m < strend && !isSPACE(*m))
6134 dstr = newSVpvn_flags(s, m-s, flags);
6138 /* skip the whitespace found last */
6140 s = m + UTF8SKIP(m);
6144 /* this one uses 's' and is a positive test */
6146 while (s < strend && isSPACE_utf8_safe(s, strend) )
6149 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6151 while (s < strend && isSPACE_LC(*s))
6154 else if (in_uni_8_bit) {
6155 while (s < strend && isSPACE_L1(*s))
6158 while (s < strend && isSPACE(*s))
6163 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6165 for (m = s; m < strend && *m != '\n'; m++)
6178 dstr = newSVpvn_flags(s, m-s, flags);
6184 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6185 /* This case boils down to deciding which is the smaller of:
6186 * limit - effectively a number of characters
6187 * slen - which already contains the number of characters in s
6189 * The resulting number is the number of iters (for gimme_scalar)
6190 * or the number of SVs to create (!gimme_scalar). */
6192 /* setting it to -1 will trigger a panic in EXTEND() */
6193 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
6194 const IV items = limit - 1;
6195 if (sslen < items || items < 0) {
6198 /* Note: The same result is returned if the following block
6199 * is removed, because of the "keep field after final delim?"
6200 * adjustment, but having the following makes the "correct"
6201 * behaviour more apparent. */
6209 if (!gimme_scalar) {
6211 Pre-extend the stack, either the number of bytes or
6212 characters in the string or a limited amount, triggered by:
6213 my ($x, $y) = split //, $str;
6222 dstr = newSVpvn_flags(m, s-m, flags);
6227 dstr = newSVpvn_flags(s, 1, flags);
6234 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6235 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6236 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6237 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6238 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6239 SV * const csv = CALLREG_INTUIT_STRING(rx);
6241 len = RX_MINLENRET(rx);
6242 if (len == 1 && !RX_UTF8(rx) && !tail) {
6243 const char c = *SvPV_nolen_const(csv);
6245 for (m = s; m < strend && *m != c; m++)
6256 dstr = newSVpvn_flags(s, m-s, flags);
6259 /* The rx->minlen is in characters but we want to step
6260 * s ahead by bytes. */
6262 s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend);
6264 s = m + len; /* Fake \n at the end */
6268 const bool multiline = (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) ? 1 : 0;
6270 while (s < strend && --limit &&
6271 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6272 csv, multiline ? FBMrf_MULTILINE : 0)) )
6281 dstr = newSVpvn_flags(s, m-s, flags);
6284 /* The rx->minlen is in characters but we want to step
6285 * s ahead by bytes. */
6287 s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend);
6289 s = m + len; /* Fake \n at the end */
6294 maxiters += slen * RX_NPARENS(rx);
6295 while (s < strend && --limit)
6299 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6302 if (rex_return == 0)
6304 TAINT_IF(RX_MATCH_TAINTED(rx));
6305 /* we never pass the REXEC_COPY_STR flag, so it should
6306 * never get copied */
6307 assert(!RX_MATCH_COPIED(rx));
6308 m = RX_OFFS(rx)[0].start + orig;
6317 dstr = newSVpvn_flags(s, m-s, flags);
6320 if (RX_NPARENS(rx)) {
6322 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6323 s = RX_OFFS(rx)[i].start + orig;
6324 m = RX_OFFS(rx)[i].end + orig;
6326 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6327 parens that didn't match -- they should be set to
6328 undef, not the empty string */
6336 if (m >= orig && s >= orig) {
6337 dstr = newSVpvn_flags(s, m-s, flags);
6340 dstr = &PL_sv_undef; /* undef, not "" */
6346 s = RX_OFFS(rx)[0].end + orig;
6350 if (!gimme_scalar) {
6351 iters = (SP - PL_stack_base) - base;
6353 if (iters > maxiters)
6354 DIE(aTHX_ "Split loop");
6356 /* keep field after final delim? */
6357 if (s < strend || (iters && origlimit)) {
6358 if (!gimme_scalar) {
6359 const STRLEN l = strend - s;
6360 dstr = newSVpvn_flags(s, l, flags);
6365 else if (!origlimit) {
6367 iters -= trailing_empty;
6369 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6370 if (TOPs && !(flags & SVs_TEMP))
6379 LEAVE_SCOPE(oldsave);
6385 if (av_count(ary) > 0)
6391 if (AvMAX(ary) > -1) {
6392 /* don't free mere refs */
6393 Zero(AvARRAY(ary), AvMAX(ary), SV*);
6396 if(AvMAX(ary) < iters)
6397 av_extend(ary,iters);
6400 /* Need to copy the SV*s from the stack into ary */
6401 Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*);
6402 AvFILLp(ary) = iters - 1;
6404 if (SvSMAGICAL(ary)) {
6406 mg_set(MUTABLE_SV(ary));
6410 if (gimme != G_LIST) {
6411 /* SP points to the final SV* pushed to the stack. But the SV* */
6412 /* are not going to be used from the stack. Point SP to below */
6413 /* the first of these SV*. */
6420 av_extend(ary,iters);
6423 ENTER_with_name("call_PUSH");
6424 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6425 LEAVE_with_name("call_PUSH");
6428 if (gimme == G_LIST) {
6430 /* EXTEND should not be needed - we just popped them */
6431 EXTEND_SKIP(SP, iters);
6432 for (i=0; i < iters; i++) {
6433 SV **svp = av_fetch(ary, i, FALSE);
6434 PUSHs((svp) ? *svp : &PL_sv_undef);
6441 if (gimme != G_LIST) {
6452 SV *const sv = PAD_SVl(PL_op->op_targ);
6454 if (SvPADSTALE(sv)) {
6457 RETURNOP(cLOGOP->op_other);
6459 RETURNOP(cLOGOP->op_next);
6468 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6469 || SvTYPE(retsv) == SVt_PVCV) {
6470 retsv = refto(retsv);
6477 /* used for: pp_padany(), pp_custom(); plus any system ops
6478 * that aren't implemented on a particular platform */
6480 PP(unimplemented_op)
6482 const Optype op_type = PL_op->op_type;
6483 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6484 with out of range op numbers - it only "special" cases op_custom.
6485 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6486 if we get here for a custom op then that means that the custom op didn't
6487 have an implementation. Given that OP_NAME() looks up the custom op
6488 by its op_ppaddr, likely it will return NULL, unless someone (unhelpfully)
6489 registers &Perl_unimplemented_op as the address of their custom op.
6490 NULL doesn't generate a useful error message. "custom" does. */
6491 const char *const name = op_type >= OP_max
6492 ? "[out of range]" : PL_op_name[op_type];
6493 if(OP_IS_SOCKET(op_type))
6494 DIE(aTHX_ PL_no_sock_func, name);
6495 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6499 S_maybe_unwind_defav(pTHX)
6501 if (CX_CUR()->cx_type & CXp_HASARGS) {
6502 PERL_CONTEXT *cx = CX_CUR();
6504 assert(CxHASARGS(cx));
6506 cx->cx_type &= ~CXp_HASARGS;
6510 /* For sorting out arguments passed to a &CORE:: subroutine */
6514 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6515 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6516 AV * const at_ = GvAV(PL_defgv);
6517 SV **svp = at_ ? AvARRAY(at_) : NULL;
6518 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6519 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6520 bool seen_question = 0;
6521 const char *err = NULL;
6522 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6524 /* Count how many args there are first, to get some idea how far to
6525 extend the stack. */
6527 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6529 if (oa & OA_OPTIONAL) seen_question = 1;
6530 if (!seen_question) minargs++;
6534 if(numargs < minargs) err = "Not enough";
6535 else if(numargs > maxargs) err = "Too many";
6537 /* diag_listed_as: Too many arguments for %s */
6539 "%s arguments for %s", err,
6540 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6543 /* Reset the stack pointer. Without this, we end up returning our own
6544 arguments in list context, in addition to the values we are supposed
6545 to return. nextstate usually does this on sub entry, but we need
6546 to run the next op with the caller's hints, so we cannot have a
6548 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6550 if(!maxargs) RETURN;
6552 /* We do this here, rather than with a separate pushmark op, as it has
6553 to come in between two things this function does (stack reset and
6554 arg pushing). This seems the easiest way to do it. */
6557 (void)Perl_pp_pushmark(aTHX);
6560 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6561 PUTBACK; /* The code below can die in various places. */
6563 oa = PL_opargs[opnum] >> OASHIFT;
6564 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6569 if (!numargs && defgv && whicharg == minargs + 1) {
6572 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6576 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6583 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6586 S_maybe_unwind_defav(aTHX);
6589 PUSHs((SV *)GvAVn(gv));
6592 if (!svp || !*svp || !SvROK(*svp)
6593 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6595 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6596 "Type of arg %d to &CORE::%s must be array reference",
6597 whicharg, PL_op_desc[opnum]
6602 if (!svp || !*svp || !SvROK(*svp)
6603 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6604 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6605 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6607 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6608 "Type of arg %d to &CORE::%s must be hash%s reference",
6609 whicharg, PL_op_desc[opnum],
6610 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6617 if (!numargs) PUSHs(NULL);
6618 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6619 /* no magic here, as the prototype will have added an extra
6620 refgen and we just want what was there before that */
6623 const bool constr = PL_op->op_private & whicharg;
6625 svp && *svp ? *svp : &PL_sv_undef,
6626 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6632 if (!numargs) goto try_defsv;
6634 const bool wantscalar =
6635 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6636 if (!svp || !*svp || !SvROK(*svp)
6637 /* We have to permit globrefs even for the \$ proto, as
6638 *foo is indistinguishable from ${\*foo}, and the proto-
6639 type permits the latter. */
6640 || SvTYPE(SvRV(*svp)) > (
6641 wantscalar ? SVt_PVLV
6642 : opnum == OP_LOCK || opnum == OP_UNDEF
6648 "Type of arg %d to &CORE::%s must be %s",
6649 whicharg, PL_op_name[opnum],
6651 ? "scalar reference"
6652 : opnum == OP_LOCK || opnum == OP_UNDEF
6653 ? "reference to one of [$@%&*]"
6654 : "reference to one of [$@%*]"
6657 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6658 /* Undo @_ localisation, so that sub exit does not undo
6659 part of our undeffing. */
6660 S_maybe_unwind_defav(aTHX);
6665 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6673 /* Implement CORE::keys(),values(),each().
6675 * We won't know until run-time whether the arg is an array or hash,
6678 * pp_keys/pp_values/pp_each
6680 * pp_akeys/pp_avalues/pp_aeach
6682 * as appropriate (or whatever pp function actually implements the OP_FOO
6683 * functionality for each FOO).
6690 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6691 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6699 if (PL_op->op_private & OPpOFFBYONE) {
6700 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6702 else cv = find_runcv(NULL);
6703 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6708 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6709 const bool can_preserve)
6711 const SSize_t ix = SvIV(keysv);
6712 if (can_preserve ? av_exists(av, ix) : TRUE) {
6713 SV ** const svp = av_fetch(av, ix, 1);
6715 Perl_croak(aTHX_ PL_no_aelem, ix);
6716 save_aelem(av, ix, svp);
6719 SAVEADELETE(av, ix);
6723 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6724 const bool can_preserve)
6726 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6727 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6728 SV ** const svp = he ? &HeVAL(he) : NULL;
6730 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6731 save_helem_flags(hv, keysv, svp, 0);
6734 SAVEHDELETE(hv, keysv);
6738 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6740 if (type == OPpLVREF_SV) {
6741 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6744 else if (type == OPpLVREF_AV)
6745 /* XXX Inefficient, as it creates a new AV, which we are
6746 about to clobber. */
6749 assert(type == OPpLVREF_HV);
6750 /* XXX Likewise inefficient. */
6759 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6760 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6762 const char *bad = NULL;
6763 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6764 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6767 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6771 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6775 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6779 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6783 /* diag_listed_as: Assigned value is not %s reference */
6784 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6788 switch (left ? SvTYPE(left) : 0) {
6791 SV * const old = PAD_SV(ARGTARG);
6792 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6794 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6796 SAVECLEARSV(PAD_SVl(ARGTARG));
6800 if (PL_op->op_private & OPpLVAL_INTRO) {
6801 S_localise_gv_slot(aTHX_ (GV *)left, type);
6803 gv_setref(left, sv);
6808 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6809 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6810 SvCANEXISTDELETE(left));
6812 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6815 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6817 S_localise_helem_lval(aTHX_ (HV *)left, key,
6818 SvCANEXISTDELETE(left));
6820 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6822 if (PL_op->op_flags & OPf_MOD)
6823 SETs(sv_2mortal(newSVsv(sv)));
6824 /* XXX else can weak references go stale before they are read, e.g.,
6833 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6834 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6835 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6836 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6837 &PL_vtbl_lvref, (char *)elem,
6838 elem ? HEf_SVKEY : (I32)ARGTARG);
6839 mg->mg_private = PL_op->op_private;
6840 if (PL_op->op_private & OPpLVREF_ITER)
6841 mg->mg_flags |= MGf_PERSIST;
6842 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6848 const bool can_preserve = SvCANEXISTDELETE(arg);
6849 if (SvTYPE(arg) == SVt_PVAV)
6850 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6852 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6856 S_localise_gv_slot(aTHX_ (GV *)arg,
6857 PL_op->op_private & OPpLVREF_TYPE);
6859 else if (!(PL_op->op_private & OPpPAD_STATE))
6860 SAVECLEARSV(PAD_SVl(ARGTARG));
6869 AV * const av = (AV *)POPs;
6870 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6871 bool can_preserve = FALSE;
6873 if (UNLIKELY(localizing)) {
6878 can_preserve = SvCANEXISTDELETE(av);
6880 if (SvTYPE(av) == SVt_PVAV) {
6883 for (svp = MARK + 1; svp <= SP; svp++) {
6884 const SSize_t elem = SvIV(*svp);
6888 if (max > AvMAX(av))
6893 while (++MARK <= SP) {
6894 SV * const elemsv = *MARK;
6895 if (UNLIKELY(localizing)) {
6896 if (SvTYPE(av) == SVt_PVAV)
6897 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6899 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6901 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6902 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6909 if (PL_op->op_flags & OPf_STACKED)
6910 Perl_pp_rv2av(aTHX);
6912 Perl_pp_padav(aTHX);
6916 SETs(0); /* special alias marker that aassign recognises */
6926 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6927 ? CopSTASH(PL_curcop)
6929 NULL, SvREFCNT_inc_simple_NN(sv))));
6934 /* process one subroutine argument - typically when the sub has a signature:
6935 * introduce PL_curpad[op_targ] and assign to it the value
6936 * for $: (OPf_STACKED ? *sp : $_[N])
6937 * for @/%: @_[N..$#_]
6939 * It's equivalent to
6942 * my $foo = (value-on-stack)
6944 * my @foo = @_[N..$#_]
6954 AV *defav = GvAV(PL_defgv); /* @_ */
6955 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6958 /* do 'my $var, @var or %var' action */
6959 padentry = &(PAD_SVl(o->op_targ));
6960 save_clearsv(padentry);
6963 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6964 if (o->op_flags & OPf_STACKED) {
6971 /* should already have been checked */
6973 #if IVSIZE > PTRSIZE
6974 assert(ix <= SSize_t_MAX);
6977 svp = av_fetch(defav, ix, FALSE);
6978 val = svp ? *svp : &PL_sv_undef;
6983 /* cargo-culted from pp_sassign */
6984 assert(TAINTING_get || !TAINT_get);
6985 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6988 SvSetMagicSV(targ, val);
6992 /* must be AV or HV */
6994 assert(!(o->op_flags & OPf_STACKED));
6995 argc = ((IV)AvFILL(defav) + 1) - ix;
6997 /* This is a copy of the relevant parts of pp_aassign().
6999 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
7002 if (AvFILL((AV*)targ) > -1) {
7003 /* target should usually be empty. If we get get
7004 * here, someone's been doing some weird closure tricks.
7005 * Make a copy of all args before clearing the array,
7006 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
7007 * elements. See similar code in pp_aassign.
7009 for (i = 0; i < argc; i++) {
7010 SV **svp = av_fetch(defav, ix + i, FALSE);
7011 SV *newsv = newSVsv_flags(svp ? *svp : &PL_sv_undef,
7012 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7013 if (!av_store(defav, ix + i, newsv))
7014 SvREFCNT_dec_NN(newsv);
7016 av_clear((AV*)targ);
7022 av_extend((AV*)targ, argc);
7027 SV **svp = av_fetch(defav, ix + i, FALSE);
7028 SV *val = svp ? *svp : &PL_sv_undef;
7030 sv_setsv(tmpsv, val);
7031 av_store((AV*)targ, i++, tmpsv);
7039 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
7041 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
7042 /* see "target should usually be empty" comment above */
7043 for (i = 0; i < argc; i++) {
7044 SV **svp = av_fetch(defav, ix + i, FALSE);
7045 SV *newsv = newSV(0);
7046 sv_setsv_flags(newsv,
7047 svp ? *svp : &PL_sv_undef,
7048 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7049 if (!av_store(defav, ix + i, newsv))
7050 SvREFCNT_dec_NN(newsv);
7052 hv_clear((HV*)targ);
7057 assert(argc % 2 == 0);
7066 svp = av_fetch(defav, ix + i++, FALSE);
7067 key = svp ? *svp : &PL_sv_undef;
7068 svp = av_fetch(defav, ix + i++, FALSE);
7069 val = svp ? *svp : &PL_sv_undef;
7072 if (UNLIKELY(SvGMAGICAL(key)))
7073 key = sv_mortalcopy(key);
7075 sv_setsv(tmpsv, val);
7076 hv_store_ent((HV*)targ, key, tmpsv, 0);
7084 /* Handle a default value for one subroutine argument (typically as part
7085 * of a subroutine signature).
7086 * It's equivalent to
7087 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
7089 * Intended to be used where op_next is an OP_ARGELEM
7091 * We abuse the op_targ field slightly: it's an index into @_ rather than
7097 OP * const o = PL_op;
7098 AV *defav = GvAV(PL_defgv); /* @_ */
7099 IV ix = (IV)o->op_targ;
7102 #if IVSIZE > PTRSIZE
7103 assert(ix <= SSize_t_MAX);
7106 if (AvFILL(defav) >= ix) {
7108 SV **svp = av_fetch(defav, ix, FALSE);
7109 SV *val = svp ? *svp : &PL_sv_undef;
7113 return cLOGOPo->op_other;
7118 S_find_runcv_name(void)
7133 sv = sv_newmortal();
7134 gv_fullname4(sv, gv, NULL, TRUE);
7138 /* Check a sub's arguments - i.e. that it has the correct number of args
7139 * (and anything else we might think of in future). Typically used with
7145 OP * const o = PL_op;
7146 struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux;
7147 UV params = aux->params;
7148 UV opt_params = aux->opt_params;
7149 char slurpy = aux->slurpy;
7150 AV *defav = GvAV(PL_defgv); /* @_ */
7154 assert(!SvMAGICAL(defav));
7155 argc = (UV)(AvFILLp(defav) + 1);
7156 too_few = (argc < (params - opt_params));
7158 if (UNLIKELY(too_few || (!slurpy && argc > params)))
7160 /* diag_listed_as: Too few arguments for subroutine '%s' (got %d; expected %d) */
7161 /* diag_listed_as: Too few arguments for subroutine '%s' (got %d; expected at least %d) */
7162 /* diag_listed_as: Too many arguments for subroutine '%s' (got %d; expected %d) */
7163 /* diag_listed_as: Too many arguments for subroutine '%s' (got %d; expected at most %d)*/
7164 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "' (got %" UVuf "; expected %s%" UVuf ")",
7165 too_few ? "few" : "many",
7166 S_find_runcv_name(),
7168 too_few ? (slurpy || opt_params ? "at least " : "") : (opt_params ? "at most " : ""),
7169 too_few ? (params - opt_params) : params);
7171 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7172 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7173 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7174 S_find_runcv_name());
7187 SETs(boolSV(sv_isa_sv(left, right)));
7196 if (SvTRUE_NN(result)) {
7197 return cLOGOP->op_other;
7223 sv_setbool_mg(TARG, SvIsBOOL(arg));
7236 sv_setbool_mg(TARG, SvROK(arg) && SvWEAKREF(arg));
7267 if(!SvROK(arg) || !SvOBJECT((rv = SvRV(arg)))) {
7272 if((PL_op->op_private & OPpTRUEBOOL) ||
7273 ((PL_op->op_private & OPpMAYBE_TRUEBOOL) && (block_gimme() == G_VOID))) {
7274 /* We only care about the boolean truth, not the specific string value.
7275 * We just have to check for the annoying cornercase of the package
7277 HV *stash = SvSTASH(rv);
7278 HEK *hek = HvNAME_HEK(stash);
7281 I32 len = HEK_LEN(hek);
7282 if(UNLIKELY(len == HEf_SVKEY || (len == 1 && HEK_KEY(hek)[0] == '0')))
7289 SETs(sv_ref(NULL, rv, TRUE));
7304 sv_setuv_mg(TARG, PTR2UV(SvRV(arg)));
7306 sv_setsv(TARG, &PL_sv_undef);
7321 sv_setpv_mg(TARG, sv_reftype(SvRV(arg), FALSE));
7323 sv_setsv(TARG, &PL_sv_undef);
7333 PUSHn(Perl_ceil(POPn));
7341 PUSHn(Perl_floor(POPn));
7346 * ex: set ts=8 sts=4 sw=4 et: