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 prepare_SV_for_RV(sv);
144 SvRV_set(sv, MUTABLE_SV(gv));
149 if (PL_op->op_flags & OPf_REF || strict) {
150 Perl_die(aTHX_ PL_no_usym, "a symbol");
152 if (ckWARN(WARN_UNINITIALIZED))
158 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
159 sv, GV_ADDMG, SVt_PVGV
168 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
172 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
173 == OPpDONT_INIT_GV) {
174 /* We are the target of a coderef assignment. Return
175 the scalar unchanged, and let pp_sasssign deal with
179 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
181 /* FAKE globs in the symbol table cause weird bugs (#77810) */
185 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
186 SV *newsv = sv_newmortal();
187 sv_setsv_flags(newsv, sv, 0);
199 sv, PL_op->op_private & OPpDEREF,
200 PL_op->op_private & HINT_STRICT_REFS,
201 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
202 || PL_op->op_type == OP_READLINE
204 if (PL_op->op_private & OPpLVAL_INTRO)
205 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
210 /* Helper function for pp_rv2sv and pp_rv2av */
212 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
213 const svtype type, SV ***spp)
217 PERL_ARGS_ASSERT_SOFTREF2XV;
219 if (PL_op->op_private & HINT_STRICT_REFS) {
221 Perl_die(aTHX_ PL_no_symref_sv, sv,
222 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
224 Perl_die(aTHX_ PL_no_usym, what);
228 PL_op->op_flags & OPf_REF
230 Perl_die(aTHX_ PL_no_usym, what);
231 if (ckWARN(WARN_UNINITIALIZED))
233 if (type != SVt_PV && GIMME_V == G_ARRAY) {
237 **spp = &PL_sv_undef;
240 if ((PL_op->op_flags & OPf_SPECIAL) &&
241 !(PL_op->op_flags & OPf_MOD))
243 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
245 **spp = &PL_sv_undef;
250 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
263 sv = amagic_deref_call(sv, to_sv_amg);
267 if (SvTYPE(sv) >= SVt_PVAV)
268 DIE(aTHX_ "Not a SCALAR reference");
273 if (!isGV_with_GP(gv)) {
274 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
280 if (PL_op->op_flags & OPf_MOD) {
281 if (PL_op->op_private & OPpLVAL_INTRO) {
282 if (cUNOP->op_first->op_type == OP_NULL)
283 sv = save_scalar(MUTABLE_GV(TOPs));
285 sv = save_scalar(gv);
287 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
289 else if (PL_op->op_private & OPpDEREF)
290 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
292 SPAGAIN; /* in case chasing soft refs reallocated the stack */
300 AV * const av = MUTABLE_AV(TOPs);
301 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
303 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
305 *svp = newSV_type(SVt_PVMG);
306 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
310 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
319 if (PL_op->op_flags & OPf_MOD || LVRET) {
320 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
321 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
323 LvTARG(ret) = SvREFCNT_inc_simple(sv);
324 SETs(ret); /* no SvSETMAGIC */
327 const MAGIC * const mg = mg_find_mglob(sv);
328 if (mg && mg->mg_len != -1) {
329 STRLEN i = mg->mg_len;
330 if (PL_op->op_private & OPpTRUEBOOL)
331 SETs(i ? &PL_sv_yes : &PL_sv_zero);
334 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
335 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
350 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
352 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
353 == OPpMAY_RETURN_CONSTANT)
356 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
357 /* (But not in defined().) */
359 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
361 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
362 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
363 ? MUTABLE_CV(SvRV(gv))
367 cv = MUTABLE_CV(&PL_sv_undef);
368 SETs(MUTABLE_SV(cv));
378 SV *ret = &PL_sv_undef;
380 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
381 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
382 const char * s = SvPVX_const(TOPs);
383 if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
384 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
386 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
387 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
389 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
395 cv = sv_2cv(TOPs, &stash, &gv, 0);
397 ret = newSVpvn_flags(
398 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
408 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
410 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
412 PUSHs(MUTABLE_SV(cv));
426 if (GIMME_V != G_ARRAY) {
432 *MARK = &PL_sv_undef;
434 *MARK = refto(*MARK);
438 EXTEND_MORTAL(SP - MARK);
440 *MARK = refto(*MARK);
445 S_refto(pTHX_ SV *sv)
449 PERL_ARGS_ASSERT_REFTO;
451 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
454 if (!(sv = LvTARG(sv)))
457 SvREFCNT_inc_void_NN(sv);
459 else if (SvTYPE(sv) == SVt_PVAV) {
460 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
461 av_reify(MUTABLE_AV(sv));
463 SvREFCNT_inc_void_NN(sv);
465 else if (SvPADTMP(sv)) {
468 else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
469 sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
472 SvREFCNT_inc_void_NN(sv);
475 sv_upgrade(rv, SVt_IV);
484 SV * const sv = TOPs;
492 /* op is in boolean context? */
493 if ( (PL_op->op_private & OPpTRUEBOOL)
494 || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL)
495 && block_gimme() == G_VOID))
497 /* refs are always true - unless it's to an object blessed into a
498 * class with a false name, i.e. "0". So we have to check for
499 * that remote possibility. The following is is basically an
500 * unrolled SvTRUE(sv_reftype(rv)) */
501 SV * const rv = SvRV(sv);
503 HV *stash = SvSTASH(rv);
504 HEK *hek = HvNAME_HEK(stash);
506 I32 len = HEK_LEN(hek);
507 /* bail out and do it the hard way? */
510 || (len == 1 && HEK_KEY(hek)[0] == '0')
523 sv_ref(TARG, SvRV(sv), TRUE);
539 stash = CopSTASH(PL_curcop);
540 if (SvTYPE(stash) != SVt_PVHV)
541 Perl_croak(aTHX_ "Attempt to bless into a freed package");
544 SV * const ssv = POPs;
548 if (!ssv) goto curstash;
551 if (!SvAMAGIC(ssv)) {
553 Perl_croak(aTHX_ "Attempt to bless into a reference");
555 /* SvAMAGIC is on here, but it only means potentially overloaded,
556 so after stringification: */
557 ptr = SvPV_nomg_const(ssv,len);
558 /* We need to check the flag again: */
559 if (!SvAMAGIC(ssv)) goto frog;
561 else ptr = SvPV_nomg_const(ssv,len);
563 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
564 "Explicit blessing to '' (assuming package main)");
565 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
568 (void)sv_bless(TOPs, stash);
578 const char * const elem = SvPV_const(sv, len);
579 GV * const gv = MUTABLE_GV(TOPs);
584 /* elem will always be NUL terminated. */
587 if (memEQs(elem, len, "ARRAY"))
589 tmpRef = MUTABLE_SV(GvAV(gv));
590 if (tmpRef && !AvREAL((const AV *)tmpRef)
591 && AvREIFY((const AV *)tmpRef))
592 av_reify(MUTABLE_AV(tmpRef));
596 if (memEQs(elem, len, "CODE"))
597 tmpRef = MUTABLE_SV(GvCVu(gv));
600 if (memEQs(elem, len, "FILEHANDLE")) {
601 tmpRef = MUTABLE_SV(GvIOp(gv));
604 if (memEQs(elem, len, "FORMAT"))
605 tmpRef = MUTABLE_SV(GvFORM(gv));
608 if (memEQs(elem, len, "GLOB"))
609 tmpRef = MUTABLE_SV(gv);
612 if (memEQs(elem, len, "HASH"))
613 tmpRef = MUTABLE_SV(GvHV(gv));
616 if (memEQs(elem, len, "IO"))
617 tmpRef = MUTABLE_SV(GvIOp(gv));
620 if (memEQs(elem, len, "NAME"))
621 sv = newSVhek(GvNAME_HEK(gv));
624 if (memEQs(elem, len, "PACKAGE")) {
625 const HV * const stash = GvSTASH(gv);
626 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
627 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
631 if (memEQs(elem, len, "SCALAR"))
646 /* Pattern matching */
654 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
655 /* Historically, study was skipped in these cases. */
660 /* Make study a no-op. It's no longer useful and its existence
661 complicates matters elsewhere. */
667 /* also used for: pp_transr() */
674 if (PL_op->op_flags & OPf_STACKED)
679 sv = PAD_SV(ARGTARG);
684 if(PL_op->op_type == OP_TRANSR) {
686 const char * const pv = SvPV(sv,len);
687 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
692 Size_t i = do_trans(sv);
698 /* Lvalue operators. */
701 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
707 PERL_ARGS_ASSERT_DO_CHOMP;
709 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
711 if (SvTYPE(sv) == SVt_PVAV) {
713 AV *const av = MUTABLE_AV(sv);
714 const I32 max = AvFILL(av);
716 for (i = 0; i <= max; i++) {
717 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
718 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
719 count += do_chomp(retval, sv, chomping);
723 else if (SvTYPE(sv) == SVt_PVHV) {
724 HV* const hv = MUTABLE_HV(sv);
726 (void)hv_iterinit(hv);
727 while ((entry = hv_iternext(hv)))
728 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
731 else if (SvREADONLY(sv)) {
732 Perl_croak_no_modify();
738 char *temp_buffer = NULL;
743 goto nope_free_nothing;
745 while (len && s[-1] == '\n') {
752 STRLEN rslen, rs_charlen;
753 const char *rsptr = SvPV_const(PL_rs, rslen);
755 rs_charlen = SvUTF8(PL_rs)
759 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
760 /* Assumption is that rs is shorter than the scalar. */
762 /* RS is utf8, scalar is 8 bit. */
764 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
767 /* Cannot downgrade, therefore cannot possibly match.
768 At this point, temp_buffer is not alloced, and
769 is the buffer inside PL_rs, so dont free it.
771 assert (temp_buffer == rsptr);
777 /* RS is 8 bit, scalar is utf8. */
778 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
792 if (memNE(s, rsptr, rslen))
797 SvPV_force_nomg_nolen(sv);
804 Safefree(temp_buffer);
806 SvREFCNT_dec(svrecode);
810 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
811 s = SvPV_force_nomg(sv, len);
814 char * const send = s + len;
815 char * const start = s;
817 while (s > start && UTF8_IS_CONTINUATION(*s))
819 if (is_utf8_string((U8*)s, send - s)) {
820 sv_setpvn(retval, s, send - s);
822 SvCUR_set(sv, s - start);
832 sv_setpvn(retval, s, 1);
846 /* also used for: pp_schomp() */
851 const bool chomping = PL_op->op_type == OP_SCHOMP;
853 const size_t count = do_chomp(TARG, TOPs, chomping);
855 sv_setiv(TARG, count);
861 /* also used for: pp_chomp() */
865 dSP; dMARK; dTARGET; dORIGMARK;
866 const bool chomping = PL_op->op_type == OP_CHOMP;
870 count += do_chomp(TARG, *++MARK, chomping);
872 sv_setiv(TARG, count);
883 if (!PL_op->op_private) {
895 if (SvTHINKFIRST(sv))
896 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
898 switch (SvTYPE(sv)) {
902 av_undef(MUTABLE_AV(sv));
905 hv_undef(MUTABLE_HV(sv));
908 if (cv_const_sv((const CV *)sv))
909 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
910 "Constant subroutine %" SVf " undefined",
911 SVfARG(CvANON((const CV *)sv)
912 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
913 : sv_2mortal(newSVhek(
915 ? CvNAME_HEK((CV *)sv)
916 : GvENAME_HEK(CvGV((const CV *)sv))
921 /* let user-undef'd sub keep its identity */
922 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
925 assert(isGV_with_GP(sv));
931 /* undef *Pkg::meth_name ... */
933 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
934 && HvENAME_get(stash);
936 if((stash = GvHV((const GV *)sv))) {
937 if(HvENAME_get(stash))
938 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
942 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
943 gp_free(MUTABLE_GV(sv));
945 GvGP_set(sv, gp_ref(gp));
946 #ifndef PERL_DONT_CREATE_GVSV
949 GvLINE(sv) = CopLINE(PL_curcop);
950 GvEGV(sv) = MUTABLE_GV(sv);
954 mro_package_moved(NULL, stash, (const GV *)sv, 0);
956 /* undef *Foo::ISA */
957 if( strEQ(GvNAME((const GV *)sv), "ISA")
958 && (stash = GvSTASH((const GV *)sv))
959 && (method_changed || HvENAME(stash)) )
960 mro_isa_changed_in(stash);
961 else if(method_changed)
962 mro_method_changed_in(
963 GvSTASH((const GV *)sv)
969 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
983 /* common "slow" code for pp_postinc and pp_postdec */
986 S_postincdec_common(pTHX_ SV *sv, SV *targ)
990 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
993 TARG = sv_newmortal();
1000 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1001 if (inc && !SvOK(TARG))
1008 /* also used for: pp_i_postinc() */
1015 /* special-case sv being a simple integer */
1016 if (LIKELY(((sv->sv_flags &
1017 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1018 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1020 && SvIVX(sv) != IV_MAX)
1023 SvIV_set(sv, iv + 1);
1024 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1029 return S_postincdec_common(aTHX_ sv, TARG);
1033 /* also used for: pp_i_postdec() */
1040 /* special-case sv being a simple integer */
1041 if (LIKELY(((sv->sv_flags &
1042 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1043 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1045 && SvIVX(sv) != IV_MIN)
1048 SvIV_set(sv, iv - 1);
1049 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1054 return S_postincdec_common(aTHX_ sv, TARG);
1058 /* Ordinary operators. */
1062 dSP; dATARGET; SV *svl, *svr;
1063 #ifdef PERL_PRESERVE_IVUV
1066 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1069 #ifdef PERL_PRESERVE_IVUV
1070 /* For integer to integer power, we do the calculation by hand wherever
1071 we're sure it is safe; otherwise we call pow() and try to convert to
1072 integer afterwards. */
1073 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1081 const IV iv = SvIVX(svr);
1085 goto float_it; /* Can't do negative powers this way. */
1089 baseuok = SvUOK(svl);
1091 baseuv = SvUVX(svl);
1093 const IV iv = SvIVX(svl);
1096 baseuok = TRUE; /* effectively it's a UV now */
1098 baseuv = -iv; /* abs, baseuok == false records sign */
1101 /* now we have integer ** positive integer. */
1104 /* foo & (foo - 1) is zero only for a power of 2. */
1105 if (!(baseuv & (baseuv - 1))) {
1106 /* We are raising power-of-2 to a positive integer.
1107 The logic here will work for any base (even non-integer
1108 bases) but it can be less accurate than
1109 pow (base,power) or exp (power * log (base)) when the
1110 intermediate values start to spill out of the mantissa.
1111 With powers of 2 we know this can't happen.
1112 And powers of 2 are the favourite thing for perl
1113 programmers to notice ** not doing what they mean. */
1115 NV base = baseuok ? baseuv : -(NV)baseuv;
1120 while (power >>= 1) {
1128 SvIV_please_nomg(svr);
1131 unsigned int highbit = 8 * sizeof(UV);
1132 unsigned int diff = 8 * sizeof(UV);
1133 while (diff >>= 1) {
1135 if (baseuv >> highbit) {
1139 /* we now have baseuv < 2 ** highbit */
1140 if (power * highbit <= 8 * sizeof(UV)) {
1141 /* result will definitely fit in UV, so use UV math
1142 on same algorithm as above */
1145 const bool odd_power = cBOOL(power & 1);
1149 while (power >>= 1) {
1156 if (baseuok || !odd_power)
1157 /* answer is positive */
1159 else if (result <= (UV)IV_MAX)
1160 /* answer negative, fits in IV */
1161 SETi( -(IV)result );
1162 else if (result == (UV)IV_MIN)
1163 /* 2's complement assumption: special case IV_MIN */
1166 /* answer negative, doesn't fit */
1167 SETn( -(NV)result );
1175 NV right = SvNV_nomg(svr);
1176 NV left = SvNV_nomg(svl);
1179 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1181 We are building perl with long double support and are on an AIX OS
1182 afflicted with a powl() function that wrongly returns NaNQ for any
1183 negative base. This was reported to IBM as PMR #23047-379 on
1184 03/06/2006. The problem exists in at least the following versions
1185 of AIX and the libm fileset, and no doubt others as well:
1187 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1188 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1189 AIX 5.2.0 bos.adt.libm 5.2.0.85
1191 So, until IBM fixes powl(), we provide the following workaround to
1192 handle the problem ourselves. Our logic is as follows: for
1193 negative bases (left), we use fmod(right, 2) to check if the
1194 exponent is an odd or even integer:
1196 - if odd, powl(left, right) == -powl(-left, right)
1197 - if even, powl(left, right) == powl(-left, right)
1199 If the exponent is not an integer, the result is rightly NaNQ, so
1200 we just return that (as NV_NAN).
1204 NV mod2 = Perl_fmod( right, 2.0 );
1205 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1206 SETn( -Perl_pow( -left, right) );
1207 } else if (mod2 == 0.0) { /* even integer */
1208 SETn( Perl_pow( -left, right) );
1209 } else { /* fractional power */
1213 SETn( Perl_pow( left, right) );
1216 SETn( Perl_pow( left, right) );
1217 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1219 #ifdef PERL_PRESERVE_IVUV
1221 SvIV_please_nomg(svr);
1229 dSP; dATARGET; SV *svl, *svr;
1230 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1234 #ifdef PERL_PRESERVE_IVUV
1236 /* special-case some simple common cases */
1237 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1239 U32 flags = (svl->sv_flags & svr->sv_flags);
1240 if (flags & SVf_IOK) {
1241 /* both args are simple IVs */
1246 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1247 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1249 /* if both are in a range that can't under/overflow, do a
1250 * simple integer multiply: if the top halves(*) of both numbers
1251 * are 00...00 or 11...11, then it's safe.
1252 * (*) for 32-bits, the "top half" is the top 17 bits,
1253 * for 64-bits, its 33 bits */
1255 ((topl+1) | (topr+1))
1256 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1259 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1265 else if (flags & SVf_NOK) {
1266 /* both args are NVs */
1271 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1272 /* nothing was lost by converting to IVs */
1277 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1278 if (Perl_isinf(result)) {
1279 Zero((U8*)&result + 8, 8, U8);
1282 TARGn(result, 0); /* args not GMG, so can't be tainted */
1290 if (SvIV_please_nomg(svr)) {
1291 /* Unless the left argument is integer in range we are going to have to
1292 use NV maths. Hence only attempt to coerce the right argument if
1293 we know the left is integer. */
1294 /* Left operand is defined, so is it IV? */
1295 if (SvIV_please_nomg(svl)) {
1296 bool auvok = SvUOK(svl);
1297 bool buvok = SvUOK(svr);
1298 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1299 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1308 const IV aiv = SvIVX(svl);
1311 auvok = TRUE; /* effectively it's a UV now */
1313 /* abs, auvok == false records sign; Using 0- here and
1314 * later to silence bogus warning from MS VC */
1315 alow = (UV) (0 - (UV) aiv);
1321 const IV biv = SvIVX(svr);
1324 buvok = TRUE; /* effectively it's a UV now */
1326 /* abs, buvok == false records sign */
1327 blow = (UV) (0 - (UV) biv);
1331 /* If this does sign extension on unsigned it's time for plan B */
1332 ahigh = alow >> (4 * sizeof (UV));
1334 bhigh = blow >> (4 * sizeof (UV));
1336 if (ahigh && bhigh) {
1338 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1339 which is overflow. Drop to NVs below. */
1340 } else if (!ahigh && !bhigh) {
1341 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1342 so the unsigned multiply cannot overflow. */
1343 const UV product = alow * blow;
1344 if (auvok == buvok) {
1345 /* -ve * -ve or +ve * +ve gives a +ve result. */
1349 } else if (product <= (UV)IV_MIN) {
1350 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1351 /* -ve result, which could overflow an IV */
1353 /* can't negate IV_MIN, but there are aren't two
1354 * integers such that !ahigh && !bhigh, where the
1355 * product equals 0x800....000 */
1356 assert(product != (UV)IV_MIN);
1357 SETi( -(IV)product );
1359 } /* else drop to NVs below. */
1361 /* One operand is large, 1 small */
1364 /* swap the operands */
1366 bhigh = blow; /* bhigh now the temp var for the swap */
1370 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1371 multiplies can't overflow. shift can, add can, -ve can. */
1372 product_middle = ahigh * blow;
1373 if (!(product_middle & topmask)) {
1374 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1376 product_middle <<= (4 * sizeof (UV));
1377 product_low = alow * blow;
1379 /* as for pp_add, UV + something mustn't get smaller.
1380 IIRC ANSI mandates this wrapping *behaviour* for
1381 unsigned whatever the actual representation*/
1382 product_low += product_middle;
1383 if (product_low >= product_middle) {
1384 /* didn't overflow */
1385 if (auvok == buvok) {
1386 /* -ve * -ve or +ve * +ve gives a +ve result. */
1388 SETu( product_low );
1390 } else if (product_low <= (UV)IV_MIN) {
1391 /* 2s complement assumption again */
1392 /* -ve result, which could overflow an IV */
1394 SETi(product_low == (UV)IV_MIN
1395 ? IV_MIN : -(IV)product_low);
1397 } /* else drop to NVs below. */
1399 } /* product_middle too large */
1400 } /* ahigh && bhigh */
1405 NV right = SvNV_nomg(svr);
1406 NV left = SvNV_nomg(svl);
1407 NV result = left * right;
1410 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1411 if (Perl_isinf(result)) {
1412 Zero((U8*)&result + 8, 8, U8);
1422 dSP; dATARGET; SV *svl, *svr;
1423 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1426 /* Only try to do UV divide first
1427 if ((SLOPPYDIVIDE is true) or
1428 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1430 The assumption is that it is better to use floating point divide
1431 whenever possible, only doing integer divide first if we can't be sure.
1432 If NV_PRESERVES_UV is true then we know at compile time that no UV
1433 can be too large to preserve, so don't need to compile the code to
1434 test the size of UVs. */
1436 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1437 # define PERL_TRY_UV_DIVIDE
1438 /* ensure that 20./5. == 4. */
1441 #ifdef PERL_TRY_UV_DIVIDE
1442 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1443 bool left_non_neg = SvUOK(svl);
1444 bool right_non_neg = SvUOK(svr);
1448 if (right_non_neg) {
1452 const IV biv = SvIVX(svr);
1455 right_non_neg = TRUE; /* effectively it's a UV now */
1461 /* historically undef()/0 gives a "Use of uninitialized value"
1462 warning before dieing, hence this test goes here.
1463 If it were immediately before the second SvIV_please, then
1464 DIE() would be invoked before left was even inspected, so
1465 no inspection would give no warning. */
1467 DIE(aTHX_ "Illegal division by zero");
1473 const IV aiv = SvIVX(svl);
1476 left_non_neg = TRUE; /* effectively it's a UV now */
1485 /* For sloppy divide we always attempt integer division. */
1487 /* Otherwise we only attempt it if either or both operands
1488 would not be preserved by an NV. If both fit in NVs
1489 we fall through to the NV divide code below. However,
1490 as left >= right to ensure integer result here, we know that
1491 we can skip the test on the right operand - right big
1492 enough not to be preserved can't get here unless left is
1495 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1498 /* Integer division can't overflow, but it can be imprecise. */
1500 /* Modern compilers optimize division followed by
1501 * modulo into a single div instruction */
1502 const UV result = left / right;
1503 if (left % right == 0) {
1504 SP--; /* result is valid */
1505 if (left_non_neg == right_non_neg) {
1506 /* signs identical, result is positive. */
1510 /* 2s complement assumption */
1511 if (result <= (UV)IV_MIN)
1512 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1514 /* It's exact but too negative for IV. */
1515 SETn( -(NV)result );
1518 } /* tried integer divide but it was not an integer result */
1519 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1520 } /* one operand wasn't SvIOK */
1521 #endif /* PERL_TRY_UV_DIVIDE */
1523 NV right = SvNV_nomg(svr);
1524 NV left = SvNV_nomg(svl);
1525 (void)POPs;(void)POPs;
1526 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1527 if (! Perl_isnan(right) && right == 0.0)
1531 DIE(aTHX_ "Illegal division by zero");
1532 PUSHn( left / right );
1540 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1544 bool left_neg = FALSE;
1545 bool right_neg = FALSE;
1546 bool use_double = FALSE;
1547 bool dright_valid = FALSE;
1550 SV * const svr = TOPs;
1551 SV * const svl = TOPm1s;
1552 if (SvIV_please_nomg(svr)) {
1553 right_neg = !SvUOK(svr);
1557 const IV biv = SvIVX(svr);
1560 right_neg = FALSE; /* effectively it's a UV now */
1562 right = (UV) (0 - (UV) biv);
1567 dright = SvNV_nomg(svr);
1568 right_neg = dright < 0;
1571 if (dright < UV_MAX_P1) {
1572 right = U_V(dright);
1573 dright_valid = TRUE; /* In case we need to use double below. */
1579 /* At this point use_double is only true if right is out of range for
1580 a UV. In range NV has been rounded down to nearest UV and
1581 use_double false. */
1582 if (!use_double && SvIV_please_nomg(svl)) {
1583 left_neg = !SvUOK(svl);
1587 const IV aiv = SvIVX(svl);
1590 left_neg = FALSE; /* effectively it's a UV now */
1592 left = (UV) (0 - (UV) aiv);
1597 dleft = SvNV_nomg(svl);
1598 left_neg = dleft < 0;
1602 /* This should be exactly the 5.6 behaviour - if left and right are
1603 both in range for UV then use U_V() rather than floor. */
1605 if (dleft < UV_MAX_P1) {
1606 /* right was in range, so is dleft, so use UVs not double.
1610 /* left is out of range for UV, right was in range, so promote
1611 right (back) to double. */
1613 /* The +0.5 is used in 5.6 even though it is not strictly
1614 consistent with the implicit +0 floor in the U_V()
1615 inside the #if 1. */
1616 dleft = Perl_floor(dleft + 0.5);
1619 dright = Perl_floor(dright + 0.5);
1630 DIE(aTHX_ "Illegal modulus zero");
1632 dans = Perl_fmod(dleft, dright);
1633 if ((left_neg != right_neg) && dans)
1634 dans = dright - dans;
1637 sv_setnv(TARG, dans);
1643 DIE(aTHX_ "Illegal modulus zero");
1646 if ((left_neg != right_neg) && ans)
1649 /* XXX may warn: unary minus operator applied to unsigned type */
1650 /* could change -foo to be (~foo)+1 instead */
1651 if (ans <= ~((UV)IV_MAX)+1)
1652 sv_setiv(TARG, ~ans+1);
1654 sv_setnv(TARG, -(NV)ans);
1657 sv_setuv(TARG, ans);
1669 bool infnan = FALSE;
1670 const U8 gimme = GIMME_V;
1672 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1673 /* TODO: think of some way of doing list-repeat overloading ??? */
1678 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1679 /* The parser saw this as a list repeat, and there
1680 are probably several items on the stack. But we're
1681 in scalar/void context, and there's no pp_list to save us
1682 now. So drop the rest of the items -- robin@kitsite.com
1685 if (MARK + 1 < SP) {
1691 ASSUME(MARK + 1 == SP);
1694 MARK[1] = &PL_sv_undef;
1698 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1704 const UV uv = SvUV_nomg(sv);
1706 count = IV_MAX; /* The best we can do? */
1710 count = SvIV_nomg(sv);
1713 else if (SvNOKp(sv)) {
1714 const NV nv = SvNV_nomg(sv);
1715 infnan = Perl_isinfnan(nv);
1716 if (UNLIKELY(infnan)) {
1720 count = -1; /* An arbitrary negative integer */
1726 count = SvIV_nomg(sv);
1729 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1730 "Non-finite repeat count does nothing");
1731 } else if (count < 0) {
1733 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1734 "Negative repeat count does nothing");
1737 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1739 const SSize_t items = SP - MARK;
1740 const U8 mod = PL_op->op_flags & OPf_MOD;
1745 if ( items > SSize_t_MAX / count /* max would overflow */
1746 /* repeatcpy would overflow */
1747 || items > I32_MAX / (I32)sizeof(SV *)
1749 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1750 max = items * count;
1755 if (mod && SvPADTMP(*SP)) {
1756 *SP = sv_mortalcopy(*SP);
1763 repeatcpy((char*)(MARK + items), (char*)MARK,
1764 items * sizeof(const SV *), count - 1);
1767 else if (count <= 0)
1770 else { /* Note: mark already snarfed by pp_list */
1771 SV * const tmpstr = POPs;
1776 sv_setsv_nomg(TARG, tmpstr);
1777 SvPV_force_nomg(TARG, len);
1778 isutf = DO_UTF8(TARG);
1785 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1786 || len > (U32)I32_MAX /* repeatcpy would overflow */
1788 Perl_croak(aTHX_ "%s",
1789 "Out of memory during string extend");
1790 max = (UV)count * len + 1;
1793 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1794 SvCUR_set(TARG, SvCUR(TARG) * count);
1796 *SvEND(TARG) = '\0';
1799 (void)SvPOK_only_UTF8(TARG);
1801 (void)SvPOK_only(TARG);
1810 dSP; dATARGET; bool useleft; SV *svl, *svr;
1811 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1815 #ifdef PERL_PRESERVE_IVUV
1817 /* special-case some simple common cases */
1818 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1820 U32 flags = (svl->sv_flags & svr->sv_flags);
1821 if (flags & SVf_IOK) {
1822 /* both args are simple IVs */
1827 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1828 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1830 /* if both are in a range that can't under/overflow, do a
1831 * simple integer subtract: if the top of both numbers
1832 * are 00 or 11, then it's safe */
1833 if (!( ((topl+1) | (topr+1)) & 2)) {
1835 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1841 else if (flags & SVf_NOK) {
1842 /* both args are NVs */
1846 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1847 /* nothing was lost by converting to IVs */
1851 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1859 useleft = USE_LEFT(svl);
1860 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1861 "bad things" happen if you rely on signed integers wrapping. */
1862 if (SvIV_please_nomg(svr)) {
1863 /* Unless the left argument is integer in range we are going to have to
1864 use NV maths. Hence only attempt to coerce the right argument if
1865 we know the left is integer. */
1872 a_valid = auvok = 1;
1873 /* left operand is undef, treat as zero. */
1875 /* Left operand is defined, so is it IV? */
1876 if (SvIV_please_nomg(svl)) {
1877 if ((auvok = SvUOK(svl)))
1880 const IV aiv = SvIVX(svl);
1883 auvok = 1; /* Now acting as a sign flag. */
1885 auv = (UV) (0 - (UV) aiv);
1892 bool result_good = 0;
1895 bool buvok = SvUOK(svr);
1900 const IV biv = SvIVX(svr);
1905 buv = (UV) (0 - (UV) biv);
1907 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1908 else "IV" now, independent of how it came in.
1909 if a, b represents positive, A, B negative, a maps to -A etc
1914 all UV maths. negate result if A negative.
1915 subtract if signs same, add if signs differ. */
1917 if (auvok ^ buvok) {
1926 /* Must get smaller */
1931 if (result <= buv) {
1932 /* result really should be -(auv-buv). as its negation
1933 of true value, need to swap our result flag */
1945 if (result <= (UV)IV_MIN)
1946 SETi(result == (UV)IV_MIN
1947 ? IV_MIN : -(IV)result);
1949 /* result valid, but out of range for IV. */
1950 SETn( -(NV)result );
1954 } /* Overflow, drop through to NVs. */
1958 useleft = USE_LEFT(svl);
1961 NV value = SvNV_nomg(svr);
1965 /* left operand is undef, treat as zero - value */
1969 SETn( SvNV_nomg(svl) - value );
1974 #define IV_BITS (IVSIZE * 8)
1976 static UV S_uv_shift(UV uv, int shift, bool left)
1982 if (UNLIKELY(shift >= IV_BITS)) {
1985 return left ? uv << shift : uv >> shift;
1988 static IV S_iv_shift(IV iv, int shift, bool left)
1995 if (UNLIKELY(shift >= IV_BITS)) {
1996 return iv < 0 && !left ? -1 : 0;
1999 /* For left shifts, perl 5 has chosen to treat the value as unsigned for
2000 * the * purposes of shifting, then cast back to signed. This is very
2001 * different from Raku:
2003 * $ raku -e 'say -2 +< 5'
2006 * $ ./perl -le 'print -2 << 5'
2007 * 18446744073709551552
2010 if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
2013 return (IV) (((UV) iv) << shift);
2016 /* Here is right shift */
2020 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2021 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2022 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2023 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2027 dSP; dATARGET; SV *svl, *svr;
2028 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2032 const IV shift = SvIV_nomg(svr);
2033 if (PL_op->op_private & HINT_INTEGER) {
2034 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2037 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2045 dSP; dATARGET; SV *svl, *svr;
2046 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2050 const IV shift = SvIV_nomg(svr);
2051 if (PL_op->op_private & HINT_INTEGER) {
2052 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2055 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2066 tryAMAGICbin_MG(lt_amg, AMGf_numeric);
2070 (SvIOK_notUV(left) && SvIOK_notUV(right))
2071 ? (SvIVX(left) < SvIVX(right))
2072 : (do_ncmp(left, right) == -1)
2082 tryAMAGICbin_MG(gt_amg, AMGf_numeric);
2086 (SvIOK_notUV(left) && SvIOK_notUV(right))
2087 ? (SvIVX(left) > SvIVX(right))
2088 : (do_ncmp(left, right) == 1)
2098 tryAMAGICbin_MG(le_amg, AMGf_numeric);
2102 (SvIOK_notUV(left) && SvIOK_notUV(right))
2103 ? (SvIVX(left) <= SvIVX(right))
2104 : (do_ncmp(left, right) <= 0)
2114 tryAMAGICbin_MG(ge_amg, AMGf_numeric);
2118 (SvIOK_notUV(left) && SvIOK_notUV(right))
2119 ? (SvIVX(left) >= SvIVX(right))
2120 : ( (do_ncmp(left, right) & 2) == 0)
2130 tryAMAGICbin_MG(ne_amg, AMGf_numeric);
2134 (SvIOK_notUV(left) && SvIOK_notUV(right))
2135 ? (SvIVX(left) != SvIVX(right))
2136 : (do_ncmp(left, right) != 0)
2141 /* compare left and right SVs. Returns:
2145 * 2: left or right was a NaN
2148 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2150 PERL_ARGS_ASSERT_DO_NCMP;
2151 #ifdef PERL_PRESERVE_IVUV
2152 /* Fortunately it seems NaN isn't IOK */
2153 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2155 const IV leftiv = SvIVX(left);
2156 if (!SvUOK(right)) {
2157 /* ## IV <=> IV ## */
2158 const IV rightiv = SvIVX(right);
2159 return (leftiv > rightiv) - (leftiv < rightiv);
2161 /* ## IV <=> UV ## */
2163 /* As (b) is a UV, it's >=0, so it must be < */
2166 const UV rightuv = SvUVX(right);
2167 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2172 /* ## UV <=> UV ## */
2173 const UV leftuv = SvUVX(left);
2174 const UV rightuv = SvUVX(right);
2175 return (leftuv > rightuv) - (leftuv < rightuv);
2177 /* ## UV <=> IV ## */
2179 const IV rightiv = SvIVX(right);
2181 /* As (a) is a UV, it's >=0, so it cannot be < */
2184 const UV leftuv = SvUVX(left);
2185 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2188 NOT_REACHED; /* NOTREACHED */
2192 NV const rnv = SvNV_nomg(right);
2193 NV const lnv = SvNV_nomg(left);
2195 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2196 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2199 return (lnv > rnv) - (lnv < rnv);
2218 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2221 value = do_ncmp(left, right);
2233 /* also used for: pp_sge() pp_sgt() pp_slt() */
2239 int amg_type = sle_amg;
2243 switch (PL_op->op_type) {
2262 tryAMAGICbin_MG(amg_type, 0);
2266 #ifdef USE_LOCALE_COLLATE
2267 (IN_LC_RUNTIME(LC_COLLATE))
2268 ? sv_cmp_locale_flags(left, right, 0)
2271 sv_cmp_flags(left, right, 0);
2272 SETs(boolSV(cmp * multiplier < rhs));
2280 tryAMAGICbin_MG(seq_amg, 0);
2283 SETs(boolSV(sv_eq_flags(left, right, 0)));
2291 tryAMAGICbin_MG(sne_amg, 0);
2294 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2302 tryAMAGICbin_MG(scmp_amg, 0);
2306 #ifdef USE_LOCALE_COLLATE
2307 (IN_LC_RUNTIME(LC_COLLATE))
2308 ? sv_cmp_locale_flags(left, right, 0)
2311 sv_cmp_flags(left, right, 0);
2320 tryAMAGICbin_MG(band_amg, AMGf_assign);
2323 if (SvNIOKp(left) || SvNIOKp(right)) {
2324 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2325 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2326 if (PL_op->op_private & HINT_INTEGER) {
2327 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2331 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2334 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2335 if (right_ro_nonnum) SvNIOK_off(right);
2338 do_vop(PL_op->op_type, TARG, left, right);
2348 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2350 dATARGET; dPOPTOPssrl;
2351 if (PL_op->op_private & HINT_INTEGER) {
2352 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2356 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2366 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2368 dATARGET; dPOPTOPssrl;
2369 do_vop(OP_BIT_AND, TARG, left, right);
2374 /* also used for: pp_bit_xor() */
2379 const int op_type = PL_op->op_type;
2381 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2384 if (SvNIOKp(left) || SvNIOKp(right)) {
2385 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2386 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2387 if (PL_op->op_private & HINT_INTEGER) {
2388 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2389 const IV r = SvIV_nomg(right);
2390 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2394 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2395 const UV r = SvUV_nomg(right);
2396 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2399 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2400 if (right_ro_nonnum) SvNIOK_off(right);
2403 do_vop(op_type, TARG, left, right);
2410 /* also used for: pp_nbit_xor() */
2415 const int op_type = PL_op->op_type;
2417 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2418 AMGf_assign|AMGf_numarg);
2420 dATARGET; dPOPTOPssrl;
2421 if (PL_op->op_private & HINT_INTEGER) {
2422 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2423 const IV r = SvIV_nomg(right);
2424 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2428 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2429 const UV r = SvUV_nomg(right);
2430 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2437 /* also used for: pp_sbit_xor() */
2442 const int op_type = PL_op->op_type;
2444 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2447 dATARGET; dPOPTOPssrl;
2448 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2454 PERL_STATIC_INLINE bool
2455 S_negate_string(pTHX)
2460 SV * const sv = TOPs;
2461 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2463 s = SvPV_nomg_const(sv, len);
2464 if (isIDFIRST(*s)) {
2465 sv_setpvs(TARG, "-");
2468 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2469 sv_setsv_nomg(TARG, sv);
2470 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2480 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2481 if (S_negate_string(aTHX)) return NORMAL;
2483 SV * const sv = TOPs;
2486 /* It's publicly an integer */
2489 if (SvIVX(sv) == IV_MIN) {
2490 /* 2s complement assumption. */
2491 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2495 else if (SvUVX(sv) <= IV_MAX) {
2500 else if (SvIVX(sv) != IV_MIN) {
2504 #ifdef PERL_PRESERVE_IVUV
2511 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2512 SETn(-SvNV_nomg(sv));
2513 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2514 goto oops_its_an_int;
2516 SETn(-SvNV_nomg(sv));
2526 tryAMAGICun_MG(not_amg, 0);
2528 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2533 S_scomplement(pTHX_ SV *targ, SV *sv)
2539 sv_copypv_nomg(TARG, sv);
2540 tmps = (U8*)SvPV_nomg(TARG, len);
2543 if (len && ! utf8_to_bytes(tmps, &len)) {
2544 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2546 SvCUR_set(TARG, len);
2554 for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++)
2557 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2562 for ( ; anum > 0; anum--, tmps++)
2569 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2573 if (PL_op->op_private & HINT_INTEGER) {
2574 const IV i = ~SvIV_nomg(sv);
2578 const UV u = ~SvUV_nomg(sv);
2583 S_scomplement(aTHX_ TARG, sv);
2593 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2596 if (PL_op->op_private & HINT_INTEGER) {
2597 const IV i = ~SvIV_nomg(sv);
2601 const UV u = ~SvUV_nomg(sv);
2611 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2614 S_scomplement(aTHX_ TARG, sv);
2620 /* integer versions of some of the above */
2625 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2628 SETi( left * right );
2637 tryAMAGICbin_MG(div_amg, AMGf_assign);
2640 IV value = SvIV_nomg(right);
2642 DIE(aTHX_ "Illegal division by zero");
2643 num = SvIV_nomg(left);
2645 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2649 value = num / value;
2658 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2662 DIE(aTHX_ "Illegal modulus zero");
2663 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2667 SETi( left % right );
2675 tryAMAGICbin_MG(add_amg, AMGf_assign);
2677 dPOPTOPiirl_ul_nomg;
2678 SETi( left + right );
2686 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2688 dPOPTOPiirl_ul_nomg;
2689 SETi( left - right );
2697 tryAMAGICbin_MG(lt_amg, 0);
2700 SETs(boolSV(left < right));
2708 tryAMAGICbin_MG(gt_amg, 0);
2711 SETs(boolSV(left > right));
2719 tryAMAGICbin_MG(le_amg, 0);
2722 SETs(boolSV(left <= right));
2730 tryAMAGICbin_MG(ge_amg, 0);
2733 SETs(boolSV(left >= right));
2741 tryAMAGICbin_MG(eq_amg, 0);
2744 SETs(boolSV(left == right));
2752 tryAMAGICbin_MG(ne_amg, 0);
2755 SETs(boolSV(left != right));
2763 tryAMAGICbin_MG(ncmp_amg, 0);
2770 else if (left < right)
2782 tryAMAGICun_MG(neg_amg, 0);
2783 if (S_negate_string(aTHX)) return NORMAL;
2785 SV * const sv = TOPs;
2786 IV const i = SvIV_nomg(sv);
2792 /* High falutin' math. */
2797 tryAMAGICbin_MG(atan2_amg, 0);
2800 SETn(Perl_atan2(left, right));
2806 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2811 int amg_type = fallback_amg;
2812 const char *neg_report = NULL;
2813 const int op_type = PL_op->op_type;
2816 case OP_SIN: amg_type = sin_amg; break;
2817 case OP_COS: amg_type = cos_amg; break;
2818 case OP_EXP: amg_type = exp_amg; break;
2819 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2820 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2823 assert(amg_type != fallback_amg);
2825 tryAMAGICun_MG(amg_type, 0);
2827 SV * const arg = TOPs;
2828 const NV value = SvNV_nomg(arg);
2834 if (neg_report) { /* log or sqrt */
2836 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2837 ! Perl_isnan(value) &&
2839 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2840 SET_NUMERIC_STANDARD();
2841 /* diag_listed_as: Can't take log of %g */
2842 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2847 case OP_SIN: result = Perl_sin(value); break;
2848 case OP_COS: result = Perl_cos(value); break;
2849 case OP_EXP: result = Perl_exp(value); break;
2850 case OP_LOG: result = Perl_log(value); break;
2851 case OP_SQRT: result = Perl_sqrt(value); break;
2858 /* Support Configure command-line overrides for rand() functions.
2859 After 5.005, perhaps we should replace this by Configure support
2860 for drand48(), random(), or rand(). For 5.005, though, maintain
2861 compatibility by calling rand() but allow the user to override it.
2862 See INSTALL for details. --Andy Dougherty 15 July 1998
2864 /* Now it's after 5.005, and Configure supports drand48() and random(),
2865 in addition to rand(). So the overrides should not be needed any more.
2866 --Jarkko Hietaniemi 27 September 1998
2871 if (!PL_srand_called) {
2872 (void)seedDrand01((Rand_seed_t)seed());
2873 PL_srand_called = TRUE;
2885 SV * const sv = POPs;
2891 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2892 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2893 if (! Perl_isnan(value) && value == 0.0)
2903 sv_setnv_mg(TARG, value);
2914 if (MAXARG >= 1 && (TOPs || POPs)) {
2921 pv = SvPV(top, len);
2922 flags = grok_number(pv, len, &anum);
2924 if (!(flags & IS_NUMBER_IN_UV)) {
2925 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2926 "Integer overflow in srand");
2934 (void)seedDrand01((Rand_seed_t)anum);
2935 PL_srand_called = TRUE;
2939 /* Historically srand always returned true. We can avoid breaking
2941 sv_setpvs(TARG, "0 but true");
2950 tryAMAGICun_MG(int_amg, AMGf_numeric);
2952 SV * const sv = TOPs;
2953 const IV iv = SvIV_nomg(sv);
2954 /* XXX it's arguable that compiler casting to IV might be subtly
2955 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2956 else preferring IV has introduced a subtle behaviour change bug. OTOH
2957 relying on floating point to be accurate is a bug. */
2962 else if (SvIOK(sv)) {
2964 SETu(SvUV_nomg(sv));
2969 const NV value = SvNV_nomg(sv);
2970 if (UNLIKELY(Perl_isinfnan(value)))
2972 else if (value >= 0.0) {
2973 if (value < (NV)UV_MAX + 0.5) {
2976 SETn(Perl_floor(value));
2980 if (value > (NV)IV_MIN - 0.5) {
2983 SETn(Perl_ceil(value));
2994 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2996 SV * const sv = TOPs;
2997 /* This will cache the NV value if string isn't actually integer */
2998 const IV iv = SvIV_nomg(sv);
3003 else if (SvIOK(sv)) {
3004 /* IVX is precise */
3006 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3014 /* 2s complement assumption. Also, not really needed as
3015 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3021 const NV value = SvNV_nomg(sv);
3032 /* also used for: pp_hex() */
3038 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3042 SV* const sv = TOPs;
3044 tmps = (SvPV_const(sv, len));
3046 /* If Unicode, try to downgrade
3047 * If not possible, croak. */
3048 SV* const tsv = sv_2mortal(newSVsv(sv));
3051 sv_utf8_downgrade(tsv, FALSE);
3052 tmps = SvPV_const(tsv, len);
3054 if (PL_op->op_type == OP_HEX)
3057 while (*tmps && len && isSPACE(*tmps))
3061 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3063 flags |= PERL_SCAN_DISALLOW_PREFIX;
3065 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3067 else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
3069 flags |= PERL_SCAN_DISALLOW_PREFIX;
3070 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3073 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3075 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3090 SV * const sv = TOPs;
3092 U32 in_bytes = IN_BYTES;
3093 /* Simplest case shortcut:
3094 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3095 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3098 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3100 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3103 if (LIKELY(svflags == SVf_POK))
3106 if (svflags & SVs_GMG)
3111 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3112 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3114 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3115 /* no need to convert from bytes to chars */
3119 len = sv_len_utf8_nomg(sv);
3122 /* unrolled SvPV_nomg_const(sv,len) */
3123 if (SvPOK_nog(sv)) {
3126 if (PL_op->op_private & OPpTRUEBOOL) {
3128 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3133 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3136 TARGi((IV)(len), 1);
3139 if (!SvPADTMP(TARG)) {
3140 /* OPpTARGET_MY: targ is var in '$lex = length()' */
3145 /* TARG is on stack at this point and is overwriten by SETs.
3146 * This branch is the odd one out, so put TARG by default on
3147 * stack earlier to let local SP go out of liveness sooner */
3150 return NORMAL; /* no putback, SP didn't move in this opcode */
3154 /* Returns false if substring is completely outside original string.
3155 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3156 always be true for an explicit 0.
3159 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3160 bool pos1_is_uv, IV len_iv,
3161 bool len_is_uv, STRLEN *posp,
3167 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3169 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3170 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3173 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3176 if (len_iv || len_is_uv) {
3177 if (!len_is_uv && len_iv < 0) {
3178 pos2_iv = curlen + len_iv;
3180 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3183 } else { /* len_iv >= 0 */
3184 if (!pos1_is_uv && pos1_iv < 0) {
3185 pos2_iv = pos1_iv + len_iv;
3186 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3188 if ((UV)len_iv > curlen-(UV)pos1_iv)
3191 pos2_iv = pos1_iv+len_iv;
3201 if (!pos2_is_uv && pos2_iv < 0) {
3202 if (!pos1_is_uv && pos1_iv < 0)
3206 else if (!pos1_is_uv && pos1_iv < 0)
3209 if ((UV)pos2_iv < (UV)pos1_iv)
3211 if ((UV)pos2_iv > curlen)
3214 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3215 *posp = (STRLEN)( (UV)pos1_iv );
3216 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3233 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3234 const bool rvalue = (GIMME_V != G_VOID);
3237 const char *repl = NULL;
3239 int num_args = PL_op->op_private & 7;
3240 bool repl_need_utf8_upgrade = FALSE;
3244 if(!(repl_sv = POPs)) num_args--;
3246 if ((len_sv = POPs)) {
3247 len_iv = SvIV(len_sv);
3248 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3253 pos1_iv = SvIV(pos_sv);
3254 pos1_is_uv = SvIOK_UV(pos_sv);
3256 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3260 if (lvalue && !repl_sv) {
3262 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3263 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3265 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3267 pos1_is_uv || pos1_iv >= 0
3268 ? (STRLEN)(UV)pos1_iv
3269 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3271 len_is_uv || len_iv > 0
3272 ? (STRLEN)(UV)len_iv
3273 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3275 PUSHs(ret); /* avoid SvSETMAGIC here */
3279 repl = SvPV_const(repl_sv, repl_len);
3282 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3283 "Attempt to use reference as lvalue in substr"
3285 tmps = SvPV_force_nomg(sv, curlen);
3286 if (DO_UTF8(repl_sv) && repl_len) {
3288 /* Upgrade the dest, and recalculate tmps in case the buffer
3289 * got reallocated; curlen may also have been changed */
3290 sv_utf8_upgrade_nomg(sv);
3291 tmps = SvPV_nomg(sv, curlen);
3294 else if (DO_UTF8(sv))
3295 repl_need_utf8_upgrade = TRUE;
3297 else tmps = SvPV_const(sv, curlen);
3299 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3300 if (utf8_curlen == curlen)
3303 curlen = utf8_curlen;
3309 STRLEN pos, len, byte_len, byte_pos;
3311 if (!translate_substr_offsets(
3312 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3316 byte_pos = utf8_curlen
3317 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3322 SvTAINTED_off(TARG); /* decontaminate */
3323 SvUTF8_off(TARG); /* decontaminate */
3324 sv_setpvn(TARG, tmps, byte_len);
3325 #ifdef USE_LOCALE_COLLATE
3326 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3333 SV* repl_sv_copy = NULL;
3335 if (repl_need_utf8_upgrade) {
3336 repl_sv_copy = newSVsv(repl_sv);
3337 sv_utf8_upgrade(repl_sv_copy);
3338 repl = SvPV_const(repl_sv_copy, repl_len);
3342 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3343 SvREFCNT_dec(repl_sv_copy);
3346 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3356 Perl_croak(aTHX_ "substr outside of string");
3357 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3364 const IV size = POPi;
3365 SV* offsetsv = POPs;
3366 SV * const src = POPs;
3367 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3373 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3374 * or flag that its out of range */
3376 IV iv = SvIV(offsetsv);
3378 /* avoid a large UV being wrapped to a negative value */
3379 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3380 errflags = LVf_OUT_OF_RANGE;
3382 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3383 #if PTRSIZE < IVSIZE
3384 else if (iv > Size_t_MAX)
3385 errflags = LVf_OUT_OF_RANGE;
3388 offset = (STRLEN)iv;
3391 retuv = errflags ? 0 : do_vecget(src, offset, size);
3393 if (lvalue) { /* it's an lvalue! */
3394 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3395 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3397 LvTARG(ret) = SvREFCNT_inc_simple(src);
3398 LvTARGOFF(ret) = offset;
3399 LvTARGLEN(ret) = size;
3400 LvFLAGS(ret) = errflags;
3404 SvTAINTED_off(TARG); /* decontaminate */
3408 sv_setuv(ret, retuv);
3416 /* also used for: pp_rindex() */
3429 const char *little_p;
3432 const bool is_index = PL_op->op_type == OP_INDEX;
3433 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3439 big_p = SvPV_const(big, biglen);
3440 little_p = SvPV_const(little, llen);
3442 big_utf8 = DO_UTF8(big);
3443 little_utf8 = DO_UTF8(little);
3444 if (big_utf8 ^ little_utf8) {
3445 /* One needs to be upgraded. */
3447 /* Well, maybe instead we might be able to downgrade the small
3449 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3452 /* If the large string is ISO-8859-1, and it's not possible to
3453 convert the small string to ISO-8859-1, then there is no
3454 way that it could be found anywhere by index. */
3459 /* At this point, pv is a malloc()ed string. So donate it to temp
3460 to ensure it will get free()d */
3461 little = temp = newSV(0);
3462 sv_usepvn(temp, pv, llen);
3463 little_p = SvPVX(little);
3465 temp = newSVpvn(little_p, llen);
3467 sv_utf8_upgrade(temp);
3469 little_p = SvPV_const(little, llen);
3472 if (SvGAMAGIC(big)) {
3473 /* Life just becomes a lot easier if I use a temporary here.
3474 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3475 will trigger magic and overloading again, as will fbm_instr()
3477 big = newSVpvn_flags(big_p, biglen,
3478 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3481 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3482 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3483 warn on undef, and we've already triggered a warning with the
3484 SvPV_const some lines above. We can't remove that, as we need to
3485 call some SvPV to trigger overloading early and find out if the
3487 This is all getting too messy. The API isn't quite clean enough,
3488 because data access has side effects.
3490 little = newSVpvn_flags(little_p, llen,
3491 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3492 little_p = SvPVX(little);
3496 offset = is_index ? 0 : biglen;
3498 if (big_utf8 && offset > 0)
3499 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3505 else if (offset > (SSize_t)biglen)
3507 if (!(little_p = is_index
3508 ? fbm_instr((unsigned char*)big_p + offset,
3509 (unsigned char*)big_p + biglen, little, 0)
3510 : rninstr(big_p, big_p + offset,
3511 little_p, little_p + llen)))
3514 retval = little_p - big_p;
3515 if (retval > 1 && big_utf8)
3516 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3521 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3522 if (PL_op->op_private & OPpTRUEBOOL) {
3523 SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3524 ? &PL_sv_yes : &PL_sv_no;
3525 if (PL_op->op_private & OPpTARGET_MY) {
3526 /* $lex = (index() == -1) */
3527 sv_setsv_mg(TARG, result);
3541 dSP; dMARK; dORIGMARK; dTARGET;
3542 SvTAINTED_off(TARG);
3543 do_sprintf(TARG, SP-MARK, MARK+1);
3544 TAINT_IF(SvTAINTED(TARG));
3556 const U8 *s = (U8*)SvPV_const(argsv, len);
3559 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3573 if (UNLIKELY(SvAMAGIC(top)))
3575 if (UNLIKELY(isinfnansv(top)))
3576 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3578 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3579 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3581 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3582 && SvNV_nomg(top) < 0.0)))
3584 if (ckWARN(WARN_UTF8)) {
3585 if (SvGMAGICAL(top)) {
3586 SV *top2 = sv_newmortal();
3587 sv_setsv_nomg(top2, top);
3590 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3591 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3593 value = UNICODE_REPLACEMENT;
3595 value = SvUV_nomg(top);
3599 SvUPGRADE(TARG,SVt_PV);
3601 if (value > 255 && !IN_BYTES) {
3602 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3603 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3604 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3606 (void)SvPOK_only(TARG);
3615 *tmps++ = (char)value;
3617 (void)SvPOK_only(TARG);
3629 const char *tmps = SvPV_const(left, len);
3631 if (DO_UTF8(left)) {
3632 /* If Unicode, try to downgrade.
3633 * If not possible, croak.
3634 * Yes, we made this up. */
3635 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3637 sv_utf8_downgrade(tsv, FALSE);
3638 tmps = SvPV_const(tsv, len);
3640 # ifdef USE_ITHREADS
3642 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3643 /* This should be threadsafe because in ithreads there is only
3644 * one thread per interpreter. If this would not be true,
3645 * we would need a mutex to protect this malloc. */
3646 PL_reentrant_buffer->_crypt_struct_buffer =
3647 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3648 # if defined(__GLIBC__) || defined(__EMX__)
3649 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3650 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3654 # endif /* HAS_CRYPT_R */
3655 # endif /* USE_ITHREADS */
3658 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3660 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3667 "The crypt() function is unimplemented due to excessive paranoia.");
3671 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3672 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3675 /* also used for: pp_lcfirst() */
3679 /* Actually is both lcfirst() and ucfirst(). Only the first character
3680 * changes. This means that possibly we can change in-place, ie., just
3681 * take the source and change that one character and store it back, but not
3682 * if read-only etc, or if the length changes */
3686 STRLEN slen; /* slen is the byte length of the whole SV. */
3689 bool inplace; /* ? Convert first char only, in-place */
3690 bool doing_utf8 = FALSE; /* ? using utf8 */
3691 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3692 const int op_type = PL_op->op_type;
3695 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3696 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3697 * stored as UTF-8 at s. */
3698 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3699 * lowercased) character stored in tmpbuf. May be either
3700 * UTF-8 or not, but in either case is the number of bytes */
3701 bool remove_dot_above = FALSE;
3703 s = (const U8*)SvPV_const(source, slen);
3705 /* We may be able to get away with changing only the first character, in
3706 * place, but not if read-only, etc. Later we may discover more reasons to
3707 * not convert in-place. */
3708 inplace = !SvREADONLY(source) && SvPADTMP(source);
3710 #ifdef USE_LOCALE_CTYPE
3712 if (IN_LC_RUNTIME(LC_CTYPE)) {
3713 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3718 /* First calculate what the changed first character should be. This affects
3719 * whether we can just swap it out, leaving the rest of the string unchanged,
3720 * or even if have to convert the dest to UTF-8 when the source isn't */
3722 if (! slen) { /* If empty */
3723 need = 1; /* still need a trailing NUL */
3727 else if (DO_UTF8(source)) { /* Is the source utf8? */
3731 if (op_type == OP_UCFIRST) {
3732 #ifdef USE_LOCALE_CTYPE
3733 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3735 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3740 #ifdef USE_LOCALE_CTYPE
3742 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3744 /* In turkic locales, lower casing an 'I' normally yields U+0131,
3745 * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3746 * contains a COMBINING DOT ABOVE. Instead it is treated like
3747 * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'. The
3748 * call to lowercase above has handled this. But SpecialCasing.txt
3749 * says we are supposed to remove the COMBINING DOT ABOVE. We can
3750 * tell if we have this situation if I ==> i in a turkic locale. */
3751 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3752 && IN_LC_RUNTIME(LC_CTYPE)
3753 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3755 /* Here, we know there was a COMBINING DOT ABOVE. We won't be
3756 * able to handle this in-place. */
3759 /* It seems likely that the DOT will immediately follow the
3760 * 'I'. If so, we can remove it simply by indicating to the
3761 * code below to start copying the source just beyond the DOT.
3762 * We know its length is 2 */
3763 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3766 else { /* But if it doesn't follow immediately, set a flag for
3768 remove_dot_above = TRUE;
3772 PERL_UNUSED_VAR(remove_dot_above);
3774 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3779 /* we can't do in-place if the length changes. */
3780 if (ulen != tculen) inplace = FALSE;
3781 need = slen + 1 - ulen + tculen;
3783 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3784 * latin1 is treated as caseless. Note that a locale takes
3786 ulen = 1; /* Original character is 1 byte */
3787 tculen = 1; /* Most characters will require one byte, but this will
3788 * need to be overridden for the tricky ones */
3792 #ifdef USE_LOCALE_CTYPE
3794 if (IN_LC_RUNTIME(LC_CTYPE)) {
3795 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3796 && ( (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3797 || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3799 if (*s == 'I') { /* lcfirst('I') */
3800 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3801 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3803 else { /* ucfirst('i') */
3804 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3805 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3810 convert_source_to_utf8 = TRUE;
3811 need += variant_under_utf8_count(s, s + slen);
3813 else if (op_type == OP_LCFIRST) {
3815 /* For lc, there are no gotchas for UTF-8 locales (other than
3816 * the turkish ones already handled above) */
3817 *tmpbuf = toLOWER_LC(*s);
3819 else { /* ucfirst */
3821 /* But for uc, some characters require special handling */
3822 if (IN_UTF8_CTYPE_LOCALE) {
3826 /* This would be a bug if any locales have upper and title case
3828 *tmpbuf = (U8) toUPPER_LC(*s);
3833 /* Here, not in locale. If not using Unicode rules, is a simple
3834 * lower/upper, depending */
3835 if (! IN_UNI_8_BIT) {
3836 *tmpbuf = (op_type == OP_LCFIRST)
3840 else if (op_type == OP_LCFIRST) {
3841 /* lower case the first letter: no trickiness for any character */
3842 *tmpbuf = toLOWER_LATIN1(*s);
3845 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3846 * non-turkic UTF-8, which we treat as not in locale), and cased
3849 #ifdef USE_LOCALE_CTYPE
3853 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3855 assert(tculen == 2);
3857 /* If the result is an upper Latin1-range character, it can
3858 * still be represented in one byte, which is its ordinal */
3859 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3860 *tmpbuf = (U8) title_ord;
3864 /* Otherwise it became more than one ASCII character (in
3865 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3866 * beyond Latin1, so the number of bytes changed, so can't
3867 * replace just the first character in place. */
3870 /* If the result won't fit in a byte, the entire result
3871 * will have to be in UTF-8. Allocate enough space for the
3872 * expanded first byte, and if UTF-8, the rest of the input
3873 * string, some or all of which may also expand to two
3874 * bytes, plus the terminating NUL. */
3875 if (title_ord > 255) {
3877 convert_source_to_utf8 = TRUE;
3879 + variant_under_utf8_count(s, s + slen)
3882 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3883 * characters whose title case is above 255 is
3887 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3888 need = slen + 1 + 1;
3892 } /* End of use Unicode (Latin1) semantics */
3893 } /* End of changing the case of the first character */
3895 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3896 * generate the result */
3899 /* We can convert in place. This means we change just the first
3900 * character without disturbing the rest; no need to grow */
3902 s = d = (U8*)SvPV_force_nomg(source, slen);
3908 /* Here, we can't convert in place; we earlier calculated how much
3909 * space we will need, so grow to accommodate that */
3910 SvUPGRADE(dest, SVt_PV);
3911 d = (U8*)SvGROW(dest, need);
3912 (void)SvPOK_only(dest);
3919 if (! convert_source_to_utf8) {
3921 /* Here both source and dest are in UTF-8, but have to create
3922 * the entire output. We initialize the result to be the
3923 * title/lower cased first character, and then append the rest
3925 sv_setpvn(dest, (char*)tmpbuf, tculen);
3928 /* But this boolean being set means we are in a turkic
3929 * locale, and there is a DOT character that needs to be
3930 * removed, and it isn't immediately after the current
3931 * character. Keep concatenating characters to the output
3932 * one at a time, until we find the DOT, which we simply
3934 if (UNLIKELY(remove_dot_above)) {
3936 Size_t this_len = UTF8SKIP(s + ulen);
3938 sv_catpvn(dest, (char*)(s + ulen), this_len);
3941 if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3945 } while (s + ulen < s + slen);
3948 /* The rest of the string can be concatenated unchanged,
3950 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3954 const U8 *const send = s + slen;
3956 /* Here the dest needs to be in UTF-8, but the source isn't,
3957 * except we earlier UTF-8'd the first character of the source
3958 * into tmpbuf. First put that into dest, and then append the
3959 * rest of the source, converting it to UTF-8 as we go. */
3961 /* Assert tculen is 2 here because the only characters that
3962 * get to this part of the code have 2-byte UTF-8 equivalents */
3963 assert(tculen == 2);
3965 *d++ = *(tmpbuf + 1);
3966 s++; /* We have just processed the 1st char */
3969 append_utf8_from_native_byte(*s, &d);
3974 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3978 else { /* in-place UTF-8. Just overwrite the first character */
3979 Copy(tmpbuf, d, tculen, U8);
3980 SvCUR_set(dest, need - 1);
3984 else { /* Neither source nor dest are, nor need to be UTF-8 */
3986 if (inplace) { /* in-place, only need to change the 1st char */
3989 else { /* Not in-place */
3991 /* Copy the case-changed character(s) from tmpbuf */
3992 Copy(tmpbuf, d, tculen, U8);
3993 d += tculen - 1; /* Code below expects d to point to final
3994 * character stored */
3997 else { /* empty source */
3998 /* See bug #39028: Don't taint if empty */
4002 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4003 * the destination to retain that flag */
4004 if (DO_UTF8(source))
4007 if (!inplace) { /* Finish the rest of the string, unchanged */
4008 /* This will copy the trailing NUL */
4009 Copy(s + 1, d + 1, slen, U8);
4010 SvCUR_set(dest, need - 1);
4013 #ifdef USE_LOCALE_CTYPE
4014 if (IN_LC_RUNTIME(LC_CTYPE)) {
4019 if (dest != source && SvTAINTED(source))
4038 if ( SvPADTMP(source)
4039 && !SvREADONLY(source) && SvPOK(source)
4042 #ifdef USE_LOCALE_CTYPE
4043 (IN_LC_RUNTIME(LC_CTYPE))
4044 ? ! IN_UTF8_CTYPE_LOCALE
4050 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4051 * make the loop tight, so we overwrite the source with the dest before
4052 * looking at it, and we need to look at the original source
4053 * afterwards. There would also need to be code added to handle
4054 * switching to not in-place in midstream if we run into characters
4055 * that change the length. Since being in locale overrides UNI_8_BIT,
4056 * that latter becomes irrelevant in the above test; instead for
4057 * locale, the size can't normally change, except if the locale is a
4060 s = d = (U8*)SvPV_force_nomg(source, len);
4067 s = (const U8*)SvPV_nomg_const(source, len);
4070 SvUPGRADE(dest, SVt_PV);
4071 d = (U8*)SvGROW(dest, min);
4072 (void)SvPOK_only(dest);
4077 #ifdef USE_LOCALE_CTYPE
4079 if (IN_LC_RUNTIME(LC_CTYPE)) {
4080 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4085 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4086 to check DO_UTF8 again here. */
4088 if (DO_UTF8(source)) {
4089 const U8 *const send = s + len;
4090 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4092 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4093 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4094 /* All occurrences of these are to be moved to follow any other marks.
4095 * This is context-dependent. We may not be passed enough context to
4096 * move the iota subscript beyond all of them, but we do the best we can
4097 * with what we're given. The result is always better than if we
4098 * hadn't done this. And, the problem would only arise if we are
4099 * passed a character without all its combining marks, which would be
4100 * the caller's mistake. The information this is based on comes from a
4101 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4102 * itself) and so can't be checked properly to see if it ever gets
4103 * revised. But the likelihood of it changing is remote */
4104 bool in_iota_subscript = FALSE;
4110 if (UNLIKELY(in_iota_subscript)) {
4111 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4113 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4115 /* A non-mark. Time to output the iota subscript */
4116 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4117 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4118 in_iota_subscript = FALSE;
4122 /* Then handle the current character. Get the changed case value
4123 * and copy it to the output buffer */
4126 #ifdef USE_LOCALE_CTYPE
4127 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4129 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4131 if (uv == GREEK_CAPITAL_LETTER_IOTA
4132 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4134 in_iota_subscript = TRUE;
4137 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4138 /* If the eventually required minimum size outgrows the
4139 * available space, we need to grow. */
4140 const UV o = d - (U8*)SvPVX_const(dest);
4142 /* If someone uppercases one million U+03B0s we SvGROW()
4143 * one million times. Or we could try guessing how much to
4144 * allocate without allocating too much. But we can't
4145 * really guess without examining the rest of the string.
4146 * Such is life. See corresponding comment in lc code for
4148 d = o + (U8*) SvGROW(dest, min);
4150 Copy(tmpbuf, d, ulen, U8);
4155 if (in_iota_subscript) {
4156 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4157 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4162 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4164 else { /* Not UTF-8 */
4166 const U8 *const send = s + len;
4168 /* Use locale casing if in locale; regular style if not treating
4169 * latin1 as having case; otherwise the latin1 casing. Do the
4170 * whole thing in a tight loop, for speed, */
4171 #ifdef USE_LOCALE_CTYPE
4172 if (IN_LC_RUNTIME(LC_CTYPE)) {
4173 if (IN_UTF8_CTYPE_LOCALE) {
4176 for (; s < send; d++, s++)
4177 *d = (U8) toUPPER_LC(*s);
4181 if (! IN_UNI_8_BIT) {
4182 for (; s < send; d++, s++) {
4187 #ifdef USE_LOCALE_CTYPE
4190 for (; s < send; d++, s++) {
4193 *d = toUPPER_LATIN1_MOD(*s);
4194 if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4196 #ifdef USE_LOCALE_CTYPE
4198 && (LIKELY( ! PL_in_utf8_turkic_locale
4199 || ! IN_LC_RUNTIME(LC_CTYPE))
4207 /* The mainstream case is the tight loop above. To avoid
4208 * extra tests in that, all three characters that always
4209 * require special handling are mapped by the MOD to the
4210 * one tested just above. Use the source to distinguish
4211 * between those cases */
4213 #if UNICODE_MAJOR_VERSION > 2 \
4214 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4215 && UNICODE_DOT_DOT_VERSION >= 8)
4216 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4218 /* uc() of this requires 2 characters, but they are
4219 * ASCII. If not enough room, grow the string */
4220 if (SvLEN(dest) < ++min) {
4221 const UV o = d - (U8*)SvPVX_const(dest);
4222 d = o + (U8*) SvGROW(dest, min);
4224 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4225 continue; /* Back to the tight loop; still in ASCII */
4229 /* The other special handling characters have their
4230 * upper cases outside the latin1 range, hence need to be
4231 * in UTF-8, so the whole result needs to be in UTF-8.
4233 * So, here we are somewhere in the middle of processing a
4234 * non-UTF-8 string, and realize that we will have to
4235 * convert the whole thing to UTF-8. What to do? There
4236 * are several possibilities. The simplest to code is to
4237 * convert what we have so far, set a flag, and continue on
4238 * in the loop. The flag would be tested each time through
4239 * the loop, and if set, the next character would be
4240 * converted to UTF-8 and stored. But, I (khw) didn't want
4241 * to slow down the mainstream case at all for this fairly
4242 * rare case, so I didn't want to add a test that didn't
4243 * absolutely have to be there in the loop, besides the
4244 * possibility that it would get too complicated for
4245 * optimizers to deal with. Another possibility is to just
4246 * give up, convert the source to UTF-8, and restart the
4247 * function that way. Another possibility is to convert
4248 * both what has already been processed and what is yet to
4249 * come separately to UTF-8, then jump into the loop that
4250 * handles UTF-8. But the most efficient time-wise of the
4251 * ones I could think of is what follows, and turned out to
4252 * not require much extra code.
4254 * First, calculate the extra space needed for the
4255 * remainder of the source needing to be in UTF-8. Except
4256 * for the 'i' in Turkic locales, in UTF-8 strings, the
4257 * uppercase of a character below 256 occupies the same
4258 * number of bytes as the original. Therefore, the space
4259 * needed is the that number plus the number of characters
4260 * that become two bytes when converted to UTF-8, plus, in
4261 * turkish locales, the number of 'i's. */
4263 extra = send - s + variant_under_utf8_count(s, send);
4265 #ifdef USE_LOCALE_CTYPE
4267 if (UNLIKELY(*s == 'i')) { /* We wouldn't get an 'i' here
4268 unless are in a Turkic
4270 const U8 * s_peek = s;
4275 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4276 send - (s_peek + 1));
4277 } while (s_peek != NULL);
4281 /* Convert what we have so far into UTF-8, telling the
4282 * function that we know it should be converted, and to
4283 * allow extra space for what we haven't processed yet.
4285 * This may cause the string pointer to move, so need to
4286 * save and re-find it. */
4288 len = d - (U8*)SvPVX_const(dest);
4289 SvCUR_set(dest, len);
4290 len = sv_utf8_upgrade_flags_grow(dest,
4291 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4293 + 1 /* trailing NUL */ );
4294 d = (U8*)SvPVX(dest) + len;
4296 /* Now process the remainder of the source, simultaneously
4297 * converting to upper and UTF-8.
4299 * To avoid extra tests in the loop body, and since the
4300 * loop is so simple, split out the rare Turkic case into
4303 #ifdef USE_LOCALE_CTYPE
4304 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4305 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4307 for (; s < send; s++) {
4309 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4310 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4313 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4320 for (; s < send; s++) {
4321 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4325 /* Here have processed the whole source; no need to
4326 * continue with the outer loop. Each character has been
4327 * converted to upper case and converted to UTF-8. */
4329 } /* End of processing all latin1-style chars */
4330 } /* End of processing all chars */
4331 } /* End of source is not empty */
4333 if (source != dest) {
4334 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4335 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4337 } /* End of isn't utf8 */
4338 #ifdef USE_LOCALE_CTYPE
4339 if (IN_LC_RUNTIME(LC_CTYPE)) {
4344 if (dest != source && SvTAINTED(source))
4359 bool has_turkic_I = FALSE;
4363 if ( SvPADTMP(source)
4364 && !SvREADONLY(source) && SvPOK(source)
4367 #ifdef USE_LOCALE_CTYPE
4369 && ( LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4370 || LIKELY(! PL_in_utf8_turkic_locale))
4376 /* We can convert in place, as, outside of Turkic UTF-8 locales,
4377 * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4378 * been on) doesn't lengthen it. */
4380 s = d = (U8*)SvPV_force_nomg(source, len);
4387 s = (const U8*)SvPV_nomg_const(source, len);
4390 SvUPGRADE(dest, SVt_PV);
4391 d = (U8*)SvGROW(dest, min);
4392 (void)SvPOK_only(dest);
4397 #ifdef USE_LOCALE_CTYPE
4399 if (IN_LC_RUNTIME(LC_CTYPE)) {
4402 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4404 /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4405 * UTF-8 for the single case of the character 'I' */
4406 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4407 && ! DO_UTF8(source)
4408 && (next_I = (U8 *) memchr(s, 'I', len)))
4411 const U8 *const send = s + len;
4416 next_I = (U8 *) memchr(next_I + 1, 'I',
4417 send - (next_I + 1));
4418 } while (next_I != NULL);
4420 /* Except for the 'I', in UTF-8 strings, the lower case of a
4421 * character below 256 occupies the same number of bytes as the
4422 * original. Therefore, the space needed is the original length
4423 * plus I_count plus the number of characters that become two bytes
4424 * when converted to UTF-8 */
4425 sv_utf8_upgrade_flags_grow(dest, 0, len
4427 + variant_under_utf8_count(s, send)
4428 + 1 /* Trailing NUL */ );
4429 d = (U8*)SvPVX(dest);
4430 has_turkic_I = TRUE;
4436 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4437 to check DO_UTF8 again here. */
4439 if (DO_UTF8(source)) {
4440 const U8 *const send = s + len;
4441 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4442 bool remove_dot_above = FALSE;
4445 const STRLEN u = UTF8SKIP(s);
4448 #ifdef USE_LOCALE_CTYPE
4450 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4452 /* If we are in a Turkic locale, we have to do more work. As noted
4453 * in the comments for lcfirst, there is a special case if a 'I'
4454 * is in a grapheme with COMBINING DOT ABOVE UTF8. It turns into a
4455 * 'i', and the DOT must be removed. We check for that situation,
4456 * and set a flag if the DOT is there. Then each time through the
4457 * loop, we have to see if we need to remove the next DOT above,
4458 * and if so, do it. We know that there is a DOT because
4459 * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4460 * was one in a proper position. */
4461 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4462 && IN_LC_RUNTIME(LC_CTYPE))
4464 if ( UNLIKELY(remove_dot_above)
4465 && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4468 remove_dot_above = FALSE;
4471 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4472 remove_dot_above = TRUE;
4476 PERL_UNUSED_VAR(remove_dot_above);
4478 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4481 /* Here is where we would do context-sensitive actions for the
4482 * Greek final sigma. See the commit message for 86510fb15 for why
4483 * there isn't any */
4485 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4487 /* If the eventually required minimum size outgrows the
4488 * available space, we need to grow. */
4489 const UV o = d - (U8*)SvPVX_const(dest);
4491 /* If someone lowercases one million U+0130s we SvGROW() one
4492 * million times. Or we could try guessing how much to
4493 * allocate without allocating too much. Such is life.
4494 * Another option would be to grow an extra byte or two more
4495 * each time we need to grow, which would cut down the million
4496 * to 500K, with little waste */
4497 d = o + (U8*) SvGROW(dest, min);
4500 /* Copy the newly lowercased letter to the output buffer we're
4502 Copy(tmpbuf, d, ulen, U8);
4505 } /* End of looping through the source string */
4508 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4509 } else { /* 'source' not utf8 */
4511 const U8 *const send = s + len;
4513 /* Use locale casing if in locale; regular style if not treating
4514 * latin1 as having case; otherwise the latin1 casing. Do the
4515 * whole thing in a tight loop, for speed, */
4516 #ifdef USE_LOCALE_CTYPE
4517 if (IN_LC_RUNTIME(LC_CTYPE)) {
4518 if (LIKELY( ! has_turkic_I)) {
4519 for (; s < send; d++, s++)
4520 *d = toLOWER_LC(*s);
4522 else { /* This is the only case where lc() converts 'dest'
4523 into UTF-8 from a non-UTF-8 'source' */
4524 for (; s < send; s++) {
4526 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4527 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4530 append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4537 if (! IN_UNI_8_BIT) {
4538 for (; s < send; d++, s++) {
4543 for (; s < send; d++, s++) {
4544 *d = toLOWER_LATIN1(*s);
4548 if (source != dest) {
4550 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4553 #ifdef USE_LOCALE_CTYPE
4554 if (IN_LC_RUNTIME(LC_CTYPE)) {
4559 if (dest != source && SvTAINTED(source))
4568 SV * const sv = TOPs;
4570 const char *s = SvPV_const(sv,len);
4572 SvUTF8_off(TARG); /* decontaminate */
4575 SvUPGRADE(TARG, SVt_PV);
4576 SvGROW(TARG, (len * 2) + 1);
4580 STRLEN ulen = UTF8SKIP(s);
4581 bool to_quote = FALSE;
4583 if (UTF8_IS_INVARIANT(*s)) {
4584 if (_isQUOTEMETA(*s)) {
4588 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4590 #ifdef USE_LOCALE_CTYPE
4591 /* In locale, we quote all non-ASCII Latin1 chars.
4592 * Otherwise use the quoting rules */
4594 IN_LC_RUNTIME(LC_CTYPE)
4597 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4602 else if (is_QUOTEMETA_high(s)) {
4617 else if (IN_UNI_8_BIT) {
4619 if (_isQUOTEMETA(*s))
4625 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4626 * including everything above ASCII */
4628 if (!isWORDCHAR_A(*s))
4634 SvCUR_set(TARG, d - SvPVX_const(TARG));
4635 (void)SvPOK_only_UTF8(TARG);
4638 sv_setpvn(TARG, s, len);
4654 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4655 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4656 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4657 || UNICODE_DOT_DOT_VERSION > 0)
4658 const bool full_folding = TRUE; /* This variable is here so we can easily
4659 move to more generality later */
4661 const bool full_folding = FALSE;
4663 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4664 #ifdef USE_LOCALE_CTYPE
4665 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4669 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4670 * You are welcome(?) -Hugmeir
4678 s = (const U8*)SvPV_nomg_const(source, len);
4680 if (ckWARN(WARN_UNINITIALIZED))
4681 report_uninit(source);
4688 SvUPGRADE(dest, SVt_PV);
4689 d = (U8*)SvGROW(dest, min);
4690 (void)SvPOK_only(dest);
4696 #ifdef USE_LOCALE_CTYPE
4698 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4699 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4704 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4706 const STRLEN u = UTF8SKIP(s);
4709 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4711 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4712 const UV o = d - (U8*)SvPVX_const(dest);
4713 d = o + (U8*) SvGROW(dest, min);
4716 Copy(tmpbuf, d, ulen, U8);
4721 } /* Unflagged string */
4723 #ifdef USE_LOCALE_CTYPE
4724 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4725 if (IN_UTF8_CTYPE_LOCALE) {
4726 goto do_uni_folding;
4728 for (; s < send; d++, s++)
4729 *d = (U8) toFOLD_LC(*s);
4733 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4734 for (; s < send; d++, s++)
4738 #ifdef USE_LOCALE_CTYPE
4741 /* For ASCII and the Latin-1 range, there's potentially three
4742 * troublesome folds:
4743 * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4744 * casefolding becomes 'ss';
4745 * \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4746 * \x{3BC} (\N{GREEK SMALL LETTER MU})
4747 * I only in Turkic locales, this folds to \x{131}
4748 * \N{LATIN SMALL LETTER DOTLESS I}
4749 * For the rest, the casefold is their lowercase. */
4750 for (; s < send; d++, s++) {
4751 if ( UNLIKELY(*s == MICRO_SIGN)
4752 #ifdef USE_LOCALE_CTYPE
4753 || ( UNLIKELY(PL_in_utf8_turkic_locale)
4754 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4755 && UNLIKELY(*s == 'I'))
4758 Size_t extra = send - s
4759 + variant_under_utf8_count(s, send);
4761 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4762 * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4763 * DOTLESS I} both of which are outside of the latin-1
4764 * range. There's a couple of ways to deal with this -- khw
4765 * discusses them in pp_lc/uc, so go there :) What we do
4766 * here is upgrade what we had already casefolded, then
4767 * enter an inner loop that appends the rest of the
4768 * characters as UTF-8.
4770 * First we calculate the needed size of the upgraded dest
4771 * beyond what's been processed already (the upgrade
4772 * function figures that out). Except for the 'I' in
4773 * Turkic locales, in UTF-8 strings, the fold case of a
4774 * character below 256 occupies the same number of bytes as
4775 * the original (even the Sharp S). Therefore, the space
4776 * needed is the number of bytes remaining plus the number
4777 * of characters that become two bytes when converted to
4778 * UTF-8 plus, in turkish locales, the number of 'I's */
4780 if (UNLIKELY(*s == 'I')) {
4781 const U8 * s_peek = s;
4786 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4787 send - (s_peek + 1));
4788 } while (s_peek != NULL);
4791 /* Growing may move things, so have to save and recalculate
4793 len = d - (U8*)SvPVX_const(dest);
4794 SvCUR_set(dest, len);
4795 len = sv_utf8_upgrade_flags_grow(dest,
4796 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4798 + 1 /* Trailing NUL */ );
4799 d = (U8*)SvPVX(dest) + len;
4801 *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4802 *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4805 for (; s < send; s++) {
4807 _to_uni_fold_flags(*s, d, &ulen, flags);
4812 else if ( UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4815 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4816 * becomes "ss", which may require growing the SV. */
4817 if (SvLEN(dest) < ++min) {
4818 const UV o = d - (U8*)SvPVX_const(dest);
4819 d = o + (U8*) SvGROW(dest, min);
4824 else { /* Else, the fold is the lower case */
4825 *d = toLOWER_LATIN1(*s);
4831 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4833 #ifdef USE_LOCALE_CTYPE
4834 if (IN_LC_RUNTIME(LC_CTYPE)) {
4839 if (SvTAINTED(source))
4849 dSP; dMARK; dORIGMARK;
4850 AV *const av = MUTABLE_AV(POPs);
4851 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4853 if (SvTYPE(av) == SVt_PVAV) {
4854 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4855 bool can_preserve = FALSE;
4861 can_preserve = SvCANEXISTDELETE(av);
4864 if (lval && localizing) {
4867 for (svp = MARK + 1; svp <= SP; svp++) {
4868 const SSize_t elem = SvIV(*svp);
4872 if (max > AvMAX(av))
4876 while (++MARK <= SP) {
4878 SSize_t elem = SvIV(*MARK);
4879 bool preeminent = TRUE;
4881 if (localizing && can_preserve) {
4882 /* If we can determine whether the element exist,
4883 * Try to preserve the existenceness of a tied array
4884 * element by using EXISTS and DELETE if possible.
4885 * Fallback to FETCH and STORE otherwise. */
4886 preeminent = av_exists(av, elem);
4889 svp = av_fetch(av, elem, lval);
4892 DIE(aTHX_ PL_no_aelem, elem);
4895 save_aelem(av, elem, svp);
4897 SAVEADELETE(av, elem);
4900 *MARK = svp ? *svp : &PL_sv_undef;
4903 if (GIMME_V != G_ARRAY) {
4905 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4914 AV *const av = MUTABLE_AV(POPs);
4915 I32 lval = (PL_op->op_flags & OPf_MOD);
4916 SSize_t items = SP - MARK;
4918 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4919 const I32 flags = is_lvalue_sub();
4921 if (!(flags & OPpENTERSUB_INARGS))
4922 /* diag_listed_as: Can't modify %s in %s */
4923 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4930 *(MARK+items*2-1) = *(MARK+items);
4936 while (++MARK <= SP) {
4939 svp = av_fetch(av, SvIV(*MARK), lval);
4941 if (!svp || !*svp || *svp == &PL_sv_undef) {
4942 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4944 *MARK = sv_mortalcopy(*MARK);
4946 *++MARK = svp ? *svp : &PL_sv_undef;
4948 if (GIMME_V != G_ARRAY) {
4949 MARK = SP - items*2;
4950 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4960 AV *array = MUTABLE_AV(POPs);
4961 const U8 gimme = GIMME_V;
4962 IV *iterp = Perl_av_iter_p(aTHX_ array);
4963 const IV current = (*iterp)++;
4965 if (current > av_tindex(array)) {
4967 if (gimme == G_SCALAR)
4975 if (gimme == G_ARRAY) {
4976 SV **const element = av_fetch(array, current, 0);
4977 PUSHs(element ? *element : &PL_sv_undef);
4982 /* also used for: pp_avalues()*/
4986 AV *array = MUTABLE_AV(POPs);
4987 const U8 gimme = GIMME_V;
4989 *Perl_av_iter_p(aTHX_ array) = 0;
4991 if (gimme == G_SCALAR) {
4993 PUSHi(av_tindex(array) + 1);
4995 else if (gimme == G_ARRAY) {
4996 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4997 const I32 flags = is_lvalue_sub();
4998 if (flags && !(flags & OPpENTERSUB_INARGS))
4999 /* diag_listed_as: Can't modify %s in %s */
5001 "Can't modify keys on array in list assignment");
5004 IV n = Perl_av_len(aTHX_ array);
5009 if ( PL_op->op_type == OP_AKEYS
5010 || ( PL_op->op_type == OP_AVHVSWITCH
5011 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
5013 for (i = 0; i <= n; i++) {
5018 for (i = 0; i <= n; i++) {
5019 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5020 PUSHs(elem ? *elem : &PL_sv_undef);
5028 /* Associative arrays. */
5033 HV * hash = MUTABLE_HV(POPs);
5035 const U8 gimme = GIMME_V;
5037 entry = hv_iternext(hash);
5041 SV* const sv = hv_iterkeysv(entry);
5043 if (gimme == G_ARRAY) {
5045 val = hv_iterval(hash, entry);
5049 else if (gimme == G_SCALAR)
5056 S_do_delete_local(pTHX)
5059 const U8 gimme = GIMME_V;
5062 const bool sliced = !!(PL_op->op_private & OPpSLICE);
5063 SV **unsliced_keysv = sliced ? NULL : sp--;
5064 SV * const osv = POPs;
5065 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5067 const bool tied = SvRMAGICAL(osv)
5068 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5069 const bool can_preserve = SvCANEXISTDELETE(osv);
5070 const U32 type = SvTYPE(osv);
5071 SV ** const end = sliced ? SP : unsliced_keysv;
5073 if (type == SVt_PVHV) { /* hash element */
5074 HV * const hv = MUTABLE_HV(osv);
5075 while (++MARK <= end) {
5076 SV * const keysv = *MARK;
5078 bool preeminent = TRUE;
5080 preeminent = hv_exists_ent(hv, keysv, 0);
5082 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5089 sv = hv_delete_ent(hv, keysv, 0, 0);
5091 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5094 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5095 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5097 *MARK = sv_mortalcopy(sv);
5103 SAVEHDELETE(hv, keysv);
5104 *MARK = &PL_sv_undef;
5108 else if (type == SVt_PVAV) { /* array element */
5109 if (PL_op->op_flags & OPf_SPECIAL) {
5110 AV * const av = MUTABLE_AV(osv);
5111 while (++MARK <= end) {
5112 SSize_t idx = SvIV(*MARK);
5114 bool preeminent = TRUE;
5116 preeminent = av_exists(av, idx);
5118 SV **svp = av_fetch(av, idx, 1);
5125 sv = av_delete(av, idx, 0);
5127 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5130 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5132 *MARK = sv_mortalcopy(sv);
5138 SAVEADELETE(av, idx);
5139 *MARK = &PL_sv_undef;
5144 DIE(aTHX_ "panic: avhv_delete no longer supported");
5147 DIE(aTHX_ "Not a HASH reference");
5149 if (gimme == G_VOID)
5151 else if (gimme == G_SCALAR) {
5156 *++MARK = &PL_sv_undef;
5160 else if (gimme != G_VOID)
5161 PUSHs(*unsliced_keysv);
5172 if (PL_op->op_private & OPpLVAL_INTRO)
5173 return do_delete_local();
5176 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5178 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5180 HV * const hv = MUTABLE_HV(POPs);
5181 const U32 hvtype = SvTYPE(hv);
5183 if (PL_op->op_private & OPpKVSLICE) {
5184 SSize_t items = SP - MARK;
5188 *(MARK+items*2-1) = *(MARK+items);
5195 if (hvtype == SVt_PVHV) { /* hash element */
5196 while ((MARK += (1+skip)) <= SP) {
5197 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5198 *MARK = sv ? sv : &PL_sv_undef;
5201 else if (hvtype == SVt_PVAV) { /* array element */
5202 if (PL_op->op_flags & OPf_SPECIAL) {
5203 while ((MARK += (1+skip)) <= SP) {
5204 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5205 *MARK = sv ? sv : &PL_sv_undef;
5210 DIE(aTHX_ "Not a HASH reference");
5213 else if (gimme == G_SCALAR) {
5218 *++MARK = &PL_sv_undef;
5224 HV * const hv = MUTABLE_HV(POPs);
5226 if (SvTYPE(hv) == SVt_PVHV)
5227 sv = hv_delete_ent(hv, keysv, discard, 0);
5228 else if (SvTYPE(hv) == SVt_PVAV) {
5229 if (PL_op->op_flags & OPf_SPECIAL)
5230 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5232 DIE(aTHX_ "panic: avhv_delete no longer supported");
5235 DIE(aTHX_ "Not a HASH reference");
5250 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5252 SV * const sv = POPs;
5253 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5256 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5261 hv = MUTABLE_HV(POPs);
5262 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5263 if (hv_exists_ent(hv, tmpsv, 0))
5266 else if (SvTYPE(hv) == SVt_PVAV) {
5267 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5268 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5273 DIE(aTHX_ "Not a HASH reference");
5280 dSP; dMARK; dORIGMARK;
5281 HV * const hv = MUTABLE_HV(POPs);
5282 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5283 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5284 bool can_preserve = FALSE;
5290 if (SvCANEXISTDELETE(hv))
5291 can_preserve = TRUE;
5294 while (++MARK <= SP) {
5295 SV * const keysv = *MARK;
5298 bool preeminent = TRUE;
5300 if (localizing && can_preserve) {
5301 /* If we can determine whether the element exist,
5302 * try to preserve the existenceness of a tied hash
5303 * element by using EXISTS and DELETE if possible.
5304 * Fallback to FETCH and STORE otherwise. */
5305 preeminent = hv_exists_ent(hv, keysv, 0);
5308 he = hv_fetch_ent(hv, keysv, lval, 0);
5309 svp = he ? &HeVAL(he) : NULL;
5312 if (!svp || !*svp || *svp == &PL_sv_undef) {
5313 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5316 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5317 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5318 else if (preeminent)
5319 save_helem_flags(hv, keysv, svp,
5320 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5322 SAVEHDELETE(hv, keysv);
5325 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5327 if (GIMME_V != G_ARRAY) {
5329 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5338 HV * const hv = MUTABLE_HV(POPs);
5339 I32 lval = (PL_op->op_flags & OPf_MOD);
5340 SSize_t items = SP - MARK;
5342 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5343 const I32 flags = is_lvalue_sub();
5345 if (!(flags & OPpENTERSUB_INARGS))
5346 /* diag_listed_as: Can't modify %s in %s */
5347 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5348 GIMME_V == G_ARRAY ? "list" : "scalar");
5355 *(MARK+items*2-1) = *(MARK+items);
5361 while (++MARK <= SP) {
5362 SV * const keysv = *MARK;
5366 he = hv_fetch_ent(hv, keysv, lval, 0);
5367 svp = he ? &HeVAL(he) : NULL;
5370 if (!svp || !*svp || *svp == &PL_sv_undef) {
5371 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5373 *MARK = sv_mortalcopy(*MARK);
5375 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5377 if (GIMME_V != G_ARRAY) {
5378 MARK = SP - items*2;
5379 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5385 /* List operators. */
5389 I32 markidx = POPMARK;
5390 if (GIMME_V != G_ARRAY) {
5391 /* don't initialize mark here, EXTEND() may move the stack */
5394 EXTEND(SP, 1); /* in case no arguments, as in @empty */
5395 mark = PL_stack_base + markidx;
5397 *MARK = *SP; /* unwanted list, return last item */
5399 *MARK = &PL_sv_undef;
5409 SV ** const lastrelem = PL_stack_sp;
5410 SV ** const lastlelem = PL_stack_base + POPMARK;
5411 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5412 SV ** const firstrelem = lastlelem + 1;
5413 const U8 mod = PL_op->op_flags & OPf_MOD;
5415 const I32 max = lastrelem - lastlelem;
5418 if (GIMME_V != G_ARRAY) {
5419 if (lastlelem < firstlelem) {
5421 *firstlelem = &PL_sv_undef;
5424 I32 ix = SvIV(*lastlelem);
5427 if (ix < 0 || ix >= max)
5428 *firstlelem = &PL_sv_undef;
5430 *firstlelem = firstrelem[ix];
5437 SP = firstlelem - 1;
5441 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5442 I32 ix = SvIV(*lelem);
5445 if (ix < 0 || ix >= max)
5446 *lelem = &PL_sv_undef;
5448 if (!(*lelem = firstrelem[ix]))
5449 *lelem = &PL_sv_undef;
5450 else if (mod && SvPADTMP(*lelem)) {
5451 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5462 const I32 items = SP - MARK;
5463 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5465 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5466 ? newRV_noinc(av) : av);
5472 dSP; dMARK; dORIGMARK;
5473 HV* const hv = newHV();
5474 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5475 ? newRV_noinc(MUTABLE_SV(hv))
5480 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5487 sv_setsv_nomg(val, *MARK);
5491 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5494 (void)hv_store_ent(hv,key,val,0);
5503 dSP; dMARK; dORIGMARK;
5504 int num_args = (SP - MARK);
5505 AV *ary = MUTABLE_AV(*++MARK);
5514 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5517 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5518 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5522 if (SvREADONLY(ary))
5523 Perl_croak_no_modify();
5528 offset = i = SvIV(*MARK);
5530 offset += AvFILLp(ary) + 1;
5532 DIE(aTHX_ PL_no_aelem, i);
5534 length = SvIVx(*MARK++);
5536 length += AvFILLp(ary) - offset + 1;
5542 length = AvMAX(ary) + 1; /* close enough to infinity */
5546 length = AvMAX(ary) + 1;
5548 if (offset > AvFILLp(ary) + 1) {
5550 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5551 offset = AvFILLp(ary) + 1;
5553 after = AvFILLp(ary) + 1 - (offset + length);
5554 if (after < 0) { /* not that much array */
5555 length += after; /* offset+length now in array */
5561 /* At this point, MARK .. SP-1 is our new LIST */
5564 diff = newlen - length;
5565 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5568 /* make new elements SVs now: avoid problems if they're from the array */
5569 for (dst = MARK, i = newlen; i; i--) {
5570 SV * const h = *dst;
5571 *dst++ = newSVsv(h);
5574 if (diff < 0) { /* shrinking the area */
5575 SV **tmparyval = NULL;
5577 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5578 Copy(MARK, tmparyval, newlen, SV*);
5581 MARK = ORIGMARK + 1;
5582 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5583 const bool real = cBOOL(AvREAL(ary));
5584 MEXTEND(MARK, length);
5586 EXTEND_MORTAL(length);
5587 for (i = 0, dst = MARK; i < length; i++) {
5588 if ((*dst = AvARRAY(ary)[i+offset])) {
5590 sv_2mortal(*dst); /* free them eventually */
5593 *dst = &PL_sv_undef;
5599 *MARK = AvARRAY(ary)[offset+length-1];
5602 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5603 SvREFCNT_dec(*dst++); /* free them now */
5606 *MARK = &PL_sv_undef;
5608 AvFILLp(ary) += diff;
5610 /* pull up or down? */
5612 if (offset < after) { /* easier to pull up */
5613 if (offset) { /* esp. if nothing to pull */
5614 src = &AvARRAY(ary)[offset-1];
5615 dst = src - diff; /* diff is negative */
5616 for (i = offset; i > 0; i--) /* can't trust Copy */
5620 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5624 if (after) { /* anything to pull down? */
5625 src = AvARRAY(ary) + offset + length;
5626 dst = src + diff; /* diff is negative */
5627 Move(src, dst, after, SV*);
5629 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5630 /* avoid later double free */
5637 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5638 Safefree(tmparyval);
5641 else { /* no, expanding (or same) */
5642 SV** tmparyval = NULL;
5644 Newx(tmparyval, length, SV*); /* so remember deletion */
5645 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5648 if (diff > 0) { /* expanding */
5649 /* push up or down? */
5650 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5654 Move(src, dst, offset, SV*);
5656 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5658 AvFILLp(ary) += diff;
5661 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5662 av_extend(ary, AvFILLp(ary) + diff);
5663 AvFILLp(ary) += diff;
5666 dst = AvARRAY(ary) + AvFILLp(ary);
5668 for (i = after; i; i--) {
5676 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5679 MARK = ORIGMARK + 1;
5680 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5682 const bool real = cBOOL(AvREAL(ary));
5684 EXTEND_MORTAL(length);
5685 for (i = 0, dst = MARK; i < length; i++) {
5686 if ((*dst = tmparyval[i])) {
5688 sv_2mortal(*dst); /* free them eventually */
5690 else *dst = &PL_sv_undef;
5696 else if (length--) {
5697 *MARK = tmparyval[length];
5700 while (length-- > 0)
5701 SvREFCNT_dec(tmparyval[length]);
5704 *MARK = &PL_sv_undef;
5707 *MARK = &PL_sv_undef;
5708 Safefree(tmparyval);
5712 mg_set(MUTABLE_SV(ary));
5720 dSP; dMARK; dORIGMARK; dTARGET;
5721 AV * const ary = MUTABLE_AV(*++MARK);
5722 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5725 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5728 ENTER_with_name("call_PUSH");
5729 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5730 LEAVE_with_name("call_PUSH");
5731 /* SPAGAIN; not needed: SP is assigned to immediately below */
5734 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5735 * only need to save locally, not on the save stack */
5736 U16 old_delaymagic = PL_delaymagic;
5738 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5739 PL_delaymagic = DM_DELAY;
5740 for (++MARK; MARK <= SP; MARK++) {
5742 if (*MARK) SvGETMAGIC(*MARK);
5745 sv_setsv_nomg(sv, *MARK);
5746 av_store(ary, AvFILLp(ary)+1, sv);
5748 if (PL_delaymagic & DM_ARRAY_ISA)
5749 mg_set(MUTABLE_SV(ary));
5750 PL_delaymagic = old_delaymagic;
5753 if (OP_GIMME(PL_op, 0) != G_VOID) {
5754 PUSHi( AvFILL(ary) + 1 );
5759 /* also used for: pp_pop()*/
5763 AV * const av = PL_op->op_flags & OPf_SPECIAL
5764 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5765 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5769 (void)sv_2mortal(sv);
5776 dSP; dMARK; dORIGMARK; dTARGET;
5777 AV *ary = MUTABLE_AV(*++MARK);
5778 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5781 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5784 ENTER_with_name("call_UNSHIFT");
5785 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5786 LEAVE_with_name("call_UNSHIFT");
5787 /* SPAGAIN; not needed: SP is assigned to immediately below */
5790 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5791 * only need to save locally, not on the save stack */
5792 U16 old_delaymagic = PL_delaymagic;
5795 av_unshift(ary, SP - MARK);
5796 PL_delaymagic = DM_DELAY;
5798 SV * const sv = newSVsv(*++MARK);
5799 (void)av_store(ary, i++, sv);
5801 if (PL_delaymagic & DM_ARRAY_ISA)
5802 mg_set(MUTABLE_SV(ary));
5803 PL_delaymagic = old_delaymagic;
5806 if (OP_GIMME(PL_op, 0) != G_VOID) {
5807 PUSHi( AvFILL(ary) + 1 );
5816 if (GIMME_V == G_ARRAY) {
5817 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5821 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5822 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5823 av = MUTABLE_AV((*SP));
5824 /* In-place reversing only happens in void context for the array
5825 * assignment. We don't need to push anything on the stack. */
5828 if (SvMAGICAL(av)) {
5830 SV *tmp = sv_newmortal();
5831 /* For SvCANEXISTDELETE */
5834 bool can_preserve = SvCANEXISTDELETE(av);
5836 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5840 if (!av_exists(av, i)) {
5841 if (av_exists(av, j)) {
5842 SV *sv = av_delete(av, j, 0);
5843 begin = *av_fetch(av, i, TRUE);
5844 sv_setsv_mg(begin, sv);
5848 else if (!av_exists(av, j)) {
5849 SV *sv = av_delete(av, i, 0);
5850 end = *av_fetch(av, j, TRUE);
5851 sv_setsv_mg(end, sv);
5856 begin = *av_fetch(av, i, TRUE);
5857 end = *av_fetch(av, j, TRUE);
5858 sv_setsv(tmp, begin);
5859 sv_setsv_mg(begin, end);
5860 sv_setsv_mg(end, tmp);
5864 SV **begin = AvARRAY(av);
5867 SV **end = begin + AvFILLp(av);
5869 while (begin < end) {
5870 SV * const tmp = *begin;
5881 SV * const tmp = *MARK;
5885 /* safe as long as stack cannot get extended in the above */
5894 SvUTF8_off(TARG); /* decontaminate */
5895 if (SP - MARK > 1) {
5896 do_join(TARG, &PL_sv_no, MARK, SP);
5899 } else if (SP > MARK) {
5900 sv_setsv(TARG, *SP);
5903 sv_setsv(TARG, DEFSV);
5906 SvSETMAGIC(TARG); /* remove any utf8 length magic */
5908 up = SvPV_force(TARG, len);
5911 if (DO_UTF8(TARG)) { /* first reverse each character */
5912 U8* s = (U8*)SvPVX(TARG);
5913 const U8* send = (U8*)(s + len);
5915 if (UTF8_IS_INVARIANT(*s)) {
5920 if (!utf8_to_uvchr_buf(s, send, 0))
5924 down = (char*)(s - 1);
5925 /* reverse this character */
5927 const char tmp = *up;
5935 down = SvPVX(TARG) + len - 1;
5937 const char tmp = *up;
5941 (void)SvPOK_only_UTF8(TARG);
5950 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5951 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
5952 ? (AV *)POPs : NULL;
5953 IV limit = POPi; /* note, negative is forever */
5954 SV * const sv = POPs;
5956 const char *s = SvPV_const(sv, len);
5957 const bool do_utf8 = DO_UTF8(sv);
5958 const bool in_uni_8_bit = IN_UNI_8_BIT;
5959 const char *strend = s + len;
5960 PMOP *pm = cPMOPx(PL_op);
5965 const STRLEN slen = do_utf8
5966 ? utf8_length((U8*)s, (U8*)strend)
5967 : (STRLEN)(strend - s);
5968 SSize_t maxiters = slen + 10;
5969 I32 trailing_empty = 0;
5971 const IV origlimit = limit;
5974 const U8 gimme = GIMME_V;
5976 I32 oldsave = PL_savestack_ix;
5977 U32 make_mortal = SVs_TEMP;
5983 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5984 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5986 /* handle @ary = split(...) optimisation */
5987 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5988 if (!(PL_op->op_flags & OPf_STACKED)) {
5989 if (PL_op->op_private & OPpSPLIT_LEX) {
5990 if (PL_op->op_private & OPpLVAL_INTRO)
5991 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5992 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5997 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5999 pm->op_pmreplrootu.op_pmtargetgv;
6001 if (PL_op->op_private & OPpLVAL_INTRO)
6006 /* skip anything pushed by OPpLVAL_INTRO above */
6007 oldsave = PL_savestack_ix;
6013 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
6016 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6018 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6025 for (i = AvFILLp(ary); i >= 0; i--)
6026 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
6028 /* temporarily switch stacks */
6029 SAVESWITCHSTACK(PL_curstack, ary);
6034 base = SP - PL_stack_base;
6036 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6038 while (s < strend && isSPACE_utf8_safe(s, strend))
6041 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6042 while (s < strend && isSPACE_LC(*s))
6045 else if (in_uni_8_bit) {
6046 while (s < strend && isSPACE_L1(*s))
6050 while (s < strend && isSPACE(*s))
6054 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
6058 gimme_scalar = gimme == G_SCALAR && !ary;
6061 limit = maxiters + 2;
6062 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6065 /* this one uses 'm' and is a negative test */
6067 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6068 const int t = UTF8SKIP(m);
6069 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6076 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6078 while (m < strend && !isSPACE_LC(*m))
6081 else if (in_uni_8_bit) {
6082 while (m < strend && !isSPACE_L1(*m))
6085 while (m < strend && !isSPACE(*m))
6098 dstr = newSVpvn_flags(s, m-s,
6099 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6103 /* skip the whitespace found last */
6105 s = m + UTF8SKIP(m);
6109 /* this one uses 's' and is a positive test */
6111 while (s < strend && isSPACE_utf8_safe(s, strend) )
6114 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6116 while (s < strend && isSPACE_LC(*s))
6119 else if (in_uni_8_bit) {
6120 while (s < strend && isSPACE_L1(*s))
6123 while (s < strend && isSPACE(*s))
6128 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6130 for (m = s; m < strend && *m != '\n'; m++)
6143 dstr = newSVpvn_flags(s, m-s,
6144 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6150 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6152 Pre-extend the stack, either the number of bytes or
6153 characters in the string or a limited amount, triggered by:
6155 my ($x, $y) = split //, $str;
6159 if (!gimme_scalar) {
6160 const IV items = limit - 1;
6161 /* setting it to -1 will trigger a panic in EXTEND() */
6162 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
6163 if (items >=0 && items < sslen)
6171 /* keep track of how many bytes we skip over */
6181 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6194 dstr = newSVpvn(s, 1);
6210 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6211 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6212 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6213 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6214 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6215 SV * const csv = CALLREG_INTUIT_STRING(rx);
6217 len = RX_MINLENRET(rx);
6218 if (len == 1 && !RX_UTF8(rx) && !tail) {
6219 const char c = *SvPV_nolen_const(csv);
6221 for (m = s; m < strend && *m != c; m++)
6232 dstr = newSVpvn_flags(s, m-s,
6233 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6236 /* The rx->minlen is in characters but we want to step
6237 * s ahead by bytes. */
6239 s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend);
6241 s = m + len; /* Fake \n at the end */
6245 while (s < strend && --limit &&
6246 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6247 csv, multiline ? FBMrf_MULTILINE : 0)) )
6256 dstr = newSVpvn_flags(s, m-s,
6257 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6260 /* The rx->minlen is in characters but we want to step
6261 * s ahead by bytes. */
6263 s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend);
6265 s = m + len; /* Fake \n at the end */
6270 maxiters += slen * RX_NPARENS(rx);
6271 while (s < strend && --limit)
6275 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6278 if (rex_return == 0)
6280 TAINT_IF(RX_MATCH_TAINTED(rx));
6281 /* we never pass the REXEC_COPY_STR flag, so it should
6282 * never get copied */
6283 assert(!RX_MATCH_COPIED(rx));
6284 m = RX_OFFS(rx)[0].start + orig;
6293 dstr = newSVpvn_flags(s, m-s,
6294 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6297 if (RX_NPARENS(rx)) {
6299 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6300 s = RX_OFFS(rx)[i].start + orig;
6301 m = RX_OFFS(rx)[i].end + orig;
6303 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6304 parens that didn't match -- they should be set to
6305 undef, not the empty string */
6313 if (m >= orig && s >= orig) {
6314 dstr = newSVpvn_flags(s, m-s,
6315 (do_utf8 ? SVf_UTF8 : 0)
6319 dstr = &PL_sv_undef; /* undef, not "" */
6325 s = RX_OFFS(rx)[0].end + orig;
6329 if (!gimme_scalar) {
6330 iters = (SP - PL_stack_base) - base;
6332 if (iters > maxiters)
6333 DIE(aTHX_ "Split loop");
6335 /* keep field after final delim? */
6336 if (s < strend || (iters && origlimit)) {
6337 if (!gimme_scalar) {
6338 const STRLEN l = strend - s;
6339 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6344 else if (!origlimit) {
6346 iters -= trailing_empty;
6348 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6349 if (TOPs && !make_mortal)
6358 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6362 if (SvSMAGICAL(ary)) {
6364 mg_set(MUTABLE_SV(ary));
6367 if (gimme == G_ARRAY) {
6369 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6376 ENTER_with_name("call_PUSH");
6377 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6378 LEAVE_with_name("call_PUSH");
6380 if (gimme == G_ARRAY) {
6382 /* EXTEND should not be needed - we just popped them */
6384 for (i=0; i < iters; i++) {
6385 SV **svp = av_fetch(ary, i, FALSE);
6386 PUSHs((svp) ? *svp : &PL_sv_undef);
6393 if (gimme == G_ARRAY)
6405 SV *const sv = PAD_SVl(PL_op->op_targ);
6407 if (SvPADSTALE(sv)) {
6410 RETURNOP(cLOGOP->op_other);
6412 RETURNOP(cLOGOP->op_next);
6421 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6422 || SvTYPE(retsv) == SVt_PVCV) {
6423 retsv = refto(retsv);
6430 /* used for: pp_padany(), pp_custom(); plus any system ops
6431 * that aren't implemented on a particular platform */
6433 PP(unimplemented_op)
6435 const Optype op_type = PL_op->op_type;
6436 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6437 with out of range op numbers - it only "special" cases op_custom.
6438 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6439 if we get here for a custom op then that means that the custom op didn't
6440 have an implementation. Given that OP_NAME() looks up the custom op
6441 by its op_ppaddr, likely it will return NULL, unless someone (unhelpfully)
6442 registers &Perl_unimplemented_op as the address of their custom op.
6443 NULL doesn't generate a useful error message. "custom" does. */
6444 const char *const name = op_type >= OP_max
6445 ? "[out of range]" : PL_op_name[op_type];
6446 if(OP_IS_SOCKET(op_type))
6447 DIE(aTHX_ PL_no_sock_func, name);
6448 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6452 S_maybe_unwind_defav(pTHX)
6454 if (CX_CUR()->cx_type & CXp_HASARGS) {
6455 PERL_CONTEXT *cx = CX_CUR();
6457 assert(CxHASARGS(cx));
6459 cx->cx_type &= ~CXp_HASARGS;
6463 /* For sorting out arguments passed to a &CORE:: subroutine */
6467 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6468 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6469 AV * const at_ = GvAV(PL_defgv);
6470 SV **svp = at_ ? AvARRAY(at_) : NULL;
6471 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6472 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6473 bool seen_question = 0;
6474 const char *err = NULL;
6475 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6477 /* Count how many args there are first, to get some idea how far to
6478 extend the stack. */
6480 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6482 if (oa & OA_OPTIONAL) seen_question = 1;
6483 if (!seen_question) minargs++;
6487 if(numargs < minargs) err = "Not enough";
6488 else if(numargs > maxargs) err = "Too many";
6490 /* diag_listed_as: Too many arguments for %s */
6492 "%s arguments for %s", err,
6493 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6496 /* Reset the stack pointer. Without this, we end up returning our own
6497 arguments in list context, in addition to the values we are supposed
6498 to return. nextstate usually does this on sub entry, but we need
6499 to run the next op with the caller's hints, so we cannot have a
6501 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6503 if(!maxargs) RETURN;
6505 /* We do this here, rather than with a separate pushmark op, as it has
6506 to come in between two things this function does (stack reset and
6507 arg pushing). This seems the easiest way to do it. */
6510 (void)Perl_pp_pushmark(aTHX);
6513 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6514 PUTBACK; /* The code below can die in various places. */
6516 oa = PL_opargs[opnum] >> OASHIFT;
6517 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6522 if (!numargs && defgv && whicharg == minargs + 1) {
6525 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6529 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6536 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6539 S_maybe_unwind_defav(aTHX);
6542 PUSHs((SV *)GvAVn(gv));
6545 if (!svp || !*svp || !SvROK(*svp)
6546 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6548 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6549 "Type of arg %d to &CORE::%s must be array reference",
6550 whicharg, PL_op_desc[opnum]
6555 if (!svp || !*svp || !SvROK(*svp)
6556 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6557 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6558 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6560 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6561 "Type of arg %d to &CORE::%s must be hash%s reference",
6562 whicharg, PL_op_desc[opnum],
6563 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6570 if (!numargs) PUSHs(NULL);
6571 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6572 /* no magic here, as the prototype will have added an extra
6573 refgen and we just want what was there before that */
6576 const bool constr = PL_op->op_private & whicharg;
6578 svp && *svp ? *svp : &PL_sv_undef,
6579 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6585 if (!numargs) goto try_defsv;
6587 const bool wantscalar =
6588 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6589 if (!svp || !*svp || !SvROK(*svp)
6590 /* We have to permit globrefs even for the \$ proto, as
6591 *foo is indistinguishable from ${\*foo}, and the proto-
6592 type permits the latter. */
6593 || SvTYPE(SvRV(*svp)) > (
6594 wantscalar ? SVt_PVLV
6595 : opnum == OP_LOCK || opnum == OP_UNDEF
6601 "Type of arg %d to &CORE::%s must be %s",
6602 whicharg, PL_op_name[opnum],
6604 ? "scalar reference"
6605 : opnum == OP_LOCK || opnum == OP_UNDEF
6606 ? "reference to one of [$@%&*]"
6607 : "reference to one of [$@%*]"
6610 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6611 /* Undo @_ localisation, so that sub exit does not undo
6612 part of our undeffing. */
6613 S_maybe_unwind_defav(aTHX);
6618 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6626 /* Implement CORE::keys(),values(),each().
6628 * We won't know until run-time whether the arg is an array or hash,
6631 * pp_keys/pp_values/pp_each
6633 * pp_akeys/pp_avalues/pp_aeach
6635 * as appropriate (or whatever pp function actually implements the OP_FOO
6636 * functionality for each FOO).
6643 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6644 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6652 if (PL_op->op_private & OPpOFFBYONE) {
6653 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6655 else cv = find_runcv(NULL);
6656 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6661 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6662 const bool can_preserve)
6664 const SSize_t ix = SvIV(keysv);
6665 if (can_preserve ? av_exists(av, ix) : TRUE) {
6666 SV ** const svp = av_fetch(av, ix, 1);
6668 Perl_croak(aTHX_ PL_no_aelem, ix);
6669 save_aelem(av, ix, svp);
6672 SAVEADELETE(av, ix);
6676 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6677 const bool can_preserve)
6679 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6680 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6681 SV ** const svp = he ? &HeVAL(he) : NULL;
6683 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6684 save_helem_flags(hv, keysv, svp, 0);
6687 SAVEHDELETE(hv, keysv);
6691 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6693 if (type == OPpLVREF_SV) {
6694 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6697 else if (type == OPpLVREF_AV)
6698 /* XXX Inefficient, as it creates a new AV, which we are
6699 about to clobber. */
6702 assert(type == OPpLVREF_HV);
6703 /* XXX Likewise inefficient. */
6712 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6713 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6715 const char *bad = NULL;
6716 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6717 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6720 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6724 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6728 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6732 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6736 /* diag_listed_as: Assigned value is not %s reference */
6737 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6741 switch (left ? SvTYPE(left) : 0) {
6744 SV * const old = PAD_SV(ARGTARG);
6745 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6747 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6749 SAVECLEARSV(PAD_SVl(ARGTARG));
6753 if (PL_op->op_private & OPpLVAL_INTRO) {
6754 S_localise_gv_slot(aTHX_ (GV *)left, type);
6756 gv_setref(left, sv);
6761 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6762 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6763 SvCANEXISTDELETE(left));
6765 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6768 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6770 S_localise_helem_lval(aTHX_ (HV *)left, key,
6771 SvCANEXISTDELETE(left));
6773 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6775 if (PL_op->op_flags & OPf_MOD)
6776 SETs(sv_2mortal(newSVsv(sv)));
6777 /* XXX else can weak references go stale before they are read, e.g.,
6786 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6787 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6788 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6789 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6790 &PL_vtbl_lvref, (char *)elem,
6791 elem ? HEf_SVKEY : (I32)ARGTARG);
6792 mg->mg_private = PL_op->op_private;
6793 if (PL_op->op_private & OPpLVREF_ITER)
6794 mg->mg_flags |= MGf_PERSIST;
6795 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6801 const bool can_preserve = SvCANEXISTDELETE(arg);
6802 if (SvTYPE(arg) == SVt_PVAV)
6803 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6805 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6809 S_localise_gv_slot(aTHX_ (GV *)arg,
6810 PL_op->op_private & OPpLVREF_TYPE);
6812 else if (!(PL_op->op_private & OPpPAD_STATE))
6813 SAVECLEARSV(PAD_SVl(ARGTARG));
6822 AV * const av = (AV *)POPs;
6823 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6824 bool can_preserve = FALSE;
6826 if (UNLIKELY(localizing)) {
6831 can_preserve = SvCANEXISTDELETE(av);
6833 if (SvTYPE(av) == SVt_PVAV) {
6836 for (svp = MARK + 1; svp <= SP; svp++) {
6837 const SSize_t elem = SvIV(*svp);
6841 if (max > AvMAX(av))
6846 while (++MARK <= SP) {
6847 SV * const elemsv = *MARK;
6848 if (UNLIKELY(localizing)) {
6849 if (SvTYPE(av) == SVt_PVAV)
6850 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6852 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6854 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6855 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6862 if (PL_op->op_flags & OPf_STACKED)
6863 Perl_pp_rv2av(aTHX);
6865 Perl_pp_padav(aTHX);
6869 SETs(0); /* special alias marker that aassign recognises */
6879 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6880 ? CopSTASH(PL_curcop)
6882 NULL, SvREFCNT_inc_simple_NN(sv))));
6887 /* process one subroutine argument - typically when the sub has a signature:
6888 * introduce PL_curpad[op_targ] and assign to it the value
6889 * for $: (OPf_STACKED ? *sp : $_[N])
6890 * for @/%: @_[N..$#_]
6892 * It's equivalent to
6895 * my $foo = (value-on-stack)
6897 * my @foo = @_[N..$#_]
6907 AV *defav = GvAV(PL_defgv); /* @_ */
6908 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6911 /* do 'my $var, @var or %var' action */
6912 padentry = &(PAD_SVl(o->op_targ));
6913 save_clearsv(padentry);
6916 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6917 if (o->op_flags & OPf_STACKED) {
6924 /* should already have been checked */
6926 #if IVSIZE > PTRSIZE
6927 assert(ix <= SSize_t_MAX);
6930 svp = av_fetch(defav, ix, FALSE);
6931 val = svp ? *svp : &PL_sv_undef;
6936 /* cargo-culted from pp_sassign */
6937 assert(TAINTING_get || !TAINT_get);
6938 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6941 SvSetMagicSV(targ, val);
6945 /* must be AV or HV */
6947 assert(!(o->op_flags & OPf_STACKED));
6948 argc = ((IV)AvFILL(defav) + 1) - ix;
6950 /* This is a copy of the relevant parts of pp_aassign().
6952 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6955 if (AvFILL((AV*)targ) > -1) {
6956 /* target should usually be empty. If we get get
6957 * here, someone's been doing some weird closure tricks.
6958 * Make a copy of all args before clearing the array,
6959 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6960 * elements. See similar code in pp_aassign.
6962 for (i = 0; i < argc; i++) {
6963 SV **svp = av_fetch(defav, ix + i, FALSE);
6964 SV *newsv = newSV(0);
6965 sv_setsv_flags(newsv,
6966 svp ? *svp : &PL_sv_undef,
6967 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6968 if (!av_store(defav, ix + i, newsv))
6969 SvREFCNT_dec_NN(newsv);
6971 av_clear((AV*)targ);
6977 av_extend((AV*)targ, argc);
6982 SV **svp = av_fetch(defav, ix + i, FALSE);
6983 SV *val = svp ? *svp : &PL_sv_undef;
6985 sv_setsv(tmpsv, val);
6986 av_store((AV*)targ, i++, tmpsv);
6994 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6996 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6997 /* see "target should usually be empty" comment above */
6998 for (i = 0; i < argc; i++) {
6999 SV **svp = av_fetch(defav, ix + i, FALSE);
7000 SV *newsv = newSV(0);
7001 sv_setsv_flags(newsv,
7002 svp ? *svp : &PL_sv_undef,
7003 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7004 if (!av_store(defav, ix + i, newsv))
7005 SvREFCNT_dec_NN(newsv);
7007 hv_clear((HV*)targ);
7012 assert(argc % 2 == 0);
7021 svp = av_fetch(defav, ix + i++, FALSE);
7022 key = svp ? *svp : &PL_sv_undef;
7023 svp = av_fetch(defav, ix + i++, FALSE);
7024 val = svp ? *svp : &PL_sv_undef;
7027 if (UNLIKELY(SvGMAGICAL(key)))
7028 key = sv_mortalcopy(key);
7030 sv_setsv(tmpsv, val);
7031 hv_store_ent((HV*)targ, key, tmpsv, 0);
7039 /* Handle a default value for one subroutine argument (typically as part
7040 * of a subroutine signature).
7041 * It's equivalent to
7042 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
7044 * Intended to be used where op_next is an OP_ARGELEM
7046 * We abuse the op_targ field slightly: it's an index into @_ rather than
7052 OP * const o = PL_op;
7053 AV *defav = GvAV(PL_defgv); /* @_ */
7054 IV ix = (IV)o->op_targ;
7057 #if IVSIZE > PTRSIZE
7058 assert(ix <= SSize_t_MAX);
7061 if (AvFILL(defav) >= ix) {
7063 SV **svp = av_fetch(defav, ix, FALSE);
7064 SV *val = svp ? *svp : &PL_sv_undef;
7068 return cLOGOPo->op_other;
7073 S_find_runcv_name(void)
7088 sv = sv_2mortal(newSV(0));
7089 gv_fullname4(sv, gv, NULL, TRUE);
7093 /* Check a sub's arguments - i.e. that it has the correct number of args
7094 * (and anything else we might think of in future). Typically used with
7100 OP * const o = PL_op;
7101 struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux;
7102 UV params = aux->params;
7103 UV opt_params = aux->opt_params;
7104 char slurpy = aux->slurpy;
7105 AV *defav = GvAV(PL_defgv); /* @_ */
7109 assert(!SvMAGICAL(defav));
7110 argc = (UV)(AvFILLp(defav) + 1);
7111 too_few = (argc < (params - opt_params));
7113 if (UNLIKELY(too_few || (!slurpy && argc > params)))
7114 /* diag_listed_as: Too few arguments for subroutine '%s' */
7115 /* diag_listed_as: Too many arguments for subroutine '%s' */
7116 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
7117 too_few ? "few" : "many", S_find_runcv_name());
7119 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7120 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7121 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7122 S_find_runcv_name());
7135 SETs(boolSV(sv_isa_sv(left, right)));
7144 if (SvTRUE_NN(result)) {
7145 return cLOGOP->op_other;
7164 * ex: set ts=8 sts=4 sw=4 et: