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 perl 6:
2003 * $ perl6 -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;
2657 /* This is the vanilla old i_modulo. */
2659 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2663 DIE(aTHX_ "Illegal modulus zero");
2664 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2668 SETi( left % right );
2673 #if defined(__GLIBC__) && IVSIZE == 8 \
2674 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2676 PP(pp_i_modulo_glibc_bugfix)
2678 /* This is the i_modulo with the workaround for the _moddi3 bug
2679 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2680 * See below for pp_i_modulo. */
2682 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2686 DIE(aTHX_ "Illegal modulus zero");
2687 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2691 SETi( left % PERL_ABS(right) );
2700 tryAMAGICbin_MG(add_amg, AMGf_assign);
2702 dPOPTOPiirl_ul_nomg;
2703 SETi( left + right );
2711 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2713 dPOPTOPiirl_ul_nomg;
2714 SETi( left - right );
2722 tryAMAGICbin_MG(lt_amg, 0);
2725 SETs(boolSV(left < right));
2733 tryAMAGICbin_MG(gt_amg, 0);
2736 SETs(boolSV(left > right));
2744 tryAMAGICbin_MG(le_amg, 0);
2747 SETs(boolSV(left <= right));
2755 tryAMAGICbin_MG(ge_amg, 0);
2758 SETs(boolSV(left >= right));
2766 tryAMAGICbin_MG(eq_amg, 0);
2769 SETs(boolSV(left == right));
2777 tryAMAGICbin_MG(ne_amg, 0);
2780 SETs(boolSV(left != right));
2788 tryAMAGICbin_MG(ncmp_amg, 0);
2795 else if (left < right)
2807 tryAMAGICun_MG(neg_amg, 0);
2808 if (S_negate_string(aTHX)) return NORMAL;
2810 SV * const sv = TOPs;
2811 IV const i = SvIV_nomg(sv);
2817 /* High falutin' math. */
2822 tryAMAGICbin_MG(atan2_amg, 0);
2825 SETn(Perl_atan2(left, right));
2831 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2836 int amg_type = fallback_amg;
2837 const char *neg_report = NULL;
2838 const int op_type = PL_op->op_type;
2841 case OP_SIN: amg_type = sin_amg; break;
2842 case OP_COS: amg_type = cos_amg; break;
2843 case OP_EXP: amg_type = exp_amg; break;
2844 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2845 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2848 assert(amg_type != fallback_amg);
2850 tryAMAGICun_MG(amg_type, 0);
2852 SV * const arg = TOPs;
2853 const NV value = SvNV_nomg(arg);
2859 if (neg_report) { /* log or sqrt */
2861 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2862 ! Perl_isnan(value) &&
2864 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2865 SET_NUMERIC_STANDARD();
2866 /* diag_listed_as: Can't take log of %g */
2867 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2872 case OP_SIN: result = Perl_sin(value); break;
2873 case OP_COS: result = Perl_cos(value); break;
2874 case OP_EXP: result = Perl_exp(value); break;
2875 case OP_LOG: result = Perl_log(value); break;
2876 case OP_SQRT: result = Perl_sqrt(value); break;
2883 /* Support Configure command-line overrides for rand() functions.
2884 After 5.005, perhaps we should replace this by Configure support
2885 for drand48(), random(), or rand(). For 5.005, though, maintain
2886 compatibility by calling rand() but allow the user to override it.
2887 See INSTALL for details. --Andy Dougherty 15 July 1998
2889 /* Now it's after 5.005, and Configure supports drand48() and random(),
2890 in addition to rand(). So the overrides should not be needed any more.
2891 --Jarkko Hietaniemi 27 September 1998
2896 if (!PL_srand_called) {
2897 (void)seedDrand01((Rand_seed_t)seed());
2898 PL_srand_called = TRUE;
2910 SV * const sv = POPs;
2916 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2917 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2918 if (! Perl_isnan(value) && value == 0.0)
2928 sv_setnv_mg(TARG, value);
2939 if (MAXARG >= 1 && (TOPs || POPs)) {
2946 pv = SvPV(top, len);
2947 flags = grok_number(pv, len, &anum);
2949 if (!(flags & IS_NUMBER_IN_UV)) {
2950 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2951 "Integer overflow in srand");
2959 (void)seedDrand01((Rand_seed_t)anum);
2960 PL_srand_called = TRUE;
2964 /* Historically srand always returned true. We can avoid breaking
2966 sv_setpvs(TARG, "0 but true");
2975 tryAMAGICun_MG(int_amg, AMGf_numeric);
2977 SV * const sv = TOPs;
2978 const IV iv = SvIV_nomg(sv);
2979 /* XXX it's arguable that compiler casting to IV might be subtly
2980 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2981 else preferring IV has introduced a subtle behaviour change bug. OTOH
2982 relying on floating point to be accurate is a bug. */
2987 else if (SvIOK(sv)) {
2989 SETu(SvUV_nomg(sv));
2994 const NV value = SvNV_nomg(sv);
2995 if (UNLIKELY(Perl_isinfnan(value)))
2997 else if (value >= 0.0) {
2998 if (value < (NV)UV_MAX + 0.5) {
3001 SETn(Perl_floor(value));
3005 if (value > (NV)IV_MIN - 0.5) {
3008 SETn(Perl_ceil(value));
3019 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3021 SV * const sv = TOPs;
3022 /* This will cache the NV value if string isn't actually integer */
3023 const IV iv = SvIV_nomg(sv);
3028 else if (SvIOK(sv)) {
3029 /* IVX is precise */
3031 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3039 /* 2s complement assumption. Also, not really needed as
3040 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3046 const NV value = SvNV_nomg(sv);
3057 /* also used for: pp_hex() */
3063 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3067 SV* const sv = TOPs;
3069 tmps = (SvPV_const(sv, len));
3071 /* If Unicode, try to downgrade
3072 * If not possible, croak. */
3073 SV* const tsv = sv_2mortal(newSVsv(sv));
3076 sv_utf8_downgrade(tsv, FALSE);
3077 tmps = SvPV_const(tsv, len);
3079 if (PL_op->op_type == OP_HEX)
3082 while (*tmps && len && isSPACE(*tmps))
3086 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3088 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3090 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3091 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3093 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3095 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3110 SV * const sv = TOPs;
3112 U32 in_bytes = IN_BYTES;
3113 /* Simplest case shortcut:
3114 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3115 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3118 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3120 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3123 if (LIKELY(svflags == SVf_POK))
3126 if (svflags & SVs_GMG)
3131 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3132 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3134 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3135 /* no need to convert from bytes to chars */
3139 len = sv_len_utf8_nomg(sv);
3142 /* unrolled SvPV_nomg_const(sv,len) */
3143 if (SvPOK_nog(sv)) {
3146 if (PL_op->op_private & OPpTRUEBOOL) {
3148 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3153 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3156 TARGi((IV)(len), 1);
3159 if (!SvPADTMP(TARG)) {
3160 /* OPpTARGET_MY: targ is var in '$lex = length()' */
3165 /* TARG is on stack at this point and is overwriten by SETs.
3166 * This branch is the odd one out, so put TARG by default on
3167 * stack earlier to let local SP go out of liveness sooner */
3170 return NORMAL; /* no putback, SP didn't move in this opcode */
3174 /* Returns false if substring is completely outside original string.
3175 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3176 always be true for an explicit 0.
3179 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3180 bool pos1_is_uv, IV len_iv,
3181 bool len_is_uv, STRLEN *posp,
3187 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3189 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3190 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3193 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3196 if (len_iv || len_is_uv) {
3197 if (!len_is_uv && len_iv < 0) {
3198 pos2_iv = curlen + len_iv;
3200 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3203 } else { /* len_iv >= 0 */
3204 if (!pos1_is_uv && pos1_iv < 0) {
3205 pos2_iv = pos1_iv + len_iv;
3206 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3208 if ((UV)len_iv > curlen-(UV)pos1_iv)
3211 pos2_iv = pos1_iv+len_iv;
3221 if (!pos2_is_uv && pos2_iv < 0) {
3222 if (!pos1_is_uv && pos1_iv < 0)
3226 else if (!pos1_is_uv && pos1_iv < 0)
3229 if ((UV)pos2_iv < (UV)pos1_iv)
3231 if ((UV)pos2_iv > curlen)
3234 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3235 *posp = (STRLEN)( (UV)pos1_iv );
3236 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3253 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3254 const bool rvalue = (GIMME_V != G_VOID);
3257 const char *repl = NULL;
3259 int num_args = PL_op->op_private & 7;
3260 bool repl_need_utf8_upgrade = FALSE;
3264 if(!(repl_sv = POPs)) num_args--;
3266 if ((len_sv = POPs)) {
3267 len_iv = SvIV(len_sv);
3268 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3273 pos1_iv = SvIV(pos_sv);
3274 pos1_is_uv = SvIOK_UV(pos_sv);
3276 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3280 if (lvalue && !repl_sv) {
3282 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3283 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3285 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3287 pos1_is_uv || pos1_iv >= 0
3288 ? (STRLEN)(UV)pos1_iv
3289 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3291 len_is_uv || len_iv > 0
3292 ? (STRLEN)(UV)len_iv
3293 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3295 PUSHs(ret); /* avoid SvSETMAGIC here */
3299 repl = SvPV_const(repl_sv, repl_len);
3302 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3303 "Attempt to use reference as lvalue in substr"
3305 tmps = SvPV_force_nomg(sv, curlen);
3306 if (DO_UTF8(repl_sv) && repl_len) {
3308 /* Upgrade the dest, and recalculate tmps in case the buffer
3309 * got reallocated; curlen may also have been changed */
3310 sv_utf8_upgrade_nomg(sv);
3311 tmps = SvPV_nomg(sv, curlen);
3314 else if (DO_UTF8(sv))
3315 repl_need_utf8_upgrade = TRUE;
3317 else tmps = SvPV_const(sv, curlen);
3319 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3320 if (utf8_curlen == curlen)
3323 curlen = utf8_curlen;
3329 STRLEN pos, len, byte_len, byte_pos;
3331 if (!translate_substr_offsets(
3332 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3336 byte_pos = utf8_curlen
3337 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3342 SvTAINTED_off(TARG); /* decontaminate */
3343 SvUTF8_off(TARG); /* decontaminate */
3344 sv_setpvn(TARG, tmps, byte_len);
3345 #ifdef USE_LOCALE_COLLATE
3346 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3353 SV* repl_sv_copy = NULL;
3355 if (repl_need_utf8_upgrade) {
3356 repl_sv_copy = newSVsv(repl_sv);
3357 sv_utf8_upgrade(repl_sv_copy);
3358 repl = SvPV_const(repl_sv_copy, repl_len);
3362 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3363 SvREFCNT_dec(repl_sv_copy);
3366 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3376 Perl_croak(aTHX_ "substr outside of string");
3377 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3384 const IV size = POPi;
3385 SV* offsetsv = POPs;
3386 SV * const src = POPs;
3387 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3393 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3394 * or flag that its out of range */
3396 IV iv = SvIV(offsetsv);
3398 /* avoid a large UV being wrapped to a negative value */
3399 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3400 errflags = LVf_OUT_OF_RANGE;
3402 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3403 #if PTRSIZE < IVSIZE
3404 else if (iv > Size_t_MAX)
3405 errflags = LVf_OUT_OF_RANGE;
3408 offset = (STRLEN)iv;
3411 retuv = errflags ? 0 : do_vecget(src, offset, size);
3413 if (lvalue) { /* it's an lvalue! */
3414 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3415 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3417 LvTARG(ret) = SvREFCNT_inc_simple(src);
3418 LvTARGOFF(ret) = offset;
3419 LvTARGLEN(ret) = size;
3420 LvFLAGS(ret) = errflags;
3424 SvTAINTED_off(TARG); /* decontaminate */
3428 sv_setuv(ret, retuv);
3436 /* also used for: pp_rindex() */
3449 const char *little_p;
3452 const bool is_index = PL_op->op_type == OP_INDEX;
3453 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3459 big_p = SvPV_const(big, biglen);
3460 little_p = SvPV_const(little, llen);
3462 big_utf8 = DO_UTF8(big);
3463 little_utf8 = DO_UTF8(little);
3464 if (big_utf8 ^ little_utf8) {
3465 /* One needs to be upgraded. */
3467 /* Well, maybe instead we might be able to downgrade the small
3469 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3472 /* If the large string is ISO-8859-1, and it's not possible to
3473 convert the small string to ISO-8859-1, then there is no
3474 way that it could be found anywhere by index. */
3479 /* At this point, pv is a malloc()ed string. So donate it to temp
3480 to ensure it will get free()d */
3481 little = temp = newSV(0);
3482 sv_usepvn(temp, pv, llen);
3483 little_p = SvPVX(little);
3485 temp = newSVpvn(little_p, llen);
3487 sv_utf8_upgrade(temp);
3489 little_p = SvPV_const(little, llen);
3492 if (SvGAMAGIC(big)) {
3493 /* Life just becomes a lot easier if I use a temporary here.
3494 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3495 will trigger magic and overloading again, as will fbm_instr()
3497 big = newSVpvn_flags(big_p, biglen,
3498 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3501 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3502 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3503 warn on undef, and we've already triggered a warning with the
3504 SvPV_const some lines above. We can't remove that, as we need to
3505 call some SvPV to trigger overloading early and find out if the
3507 This is all getting too messy. The API isn't quite clean enough,
3508 because data access has side effects.
3510 little = newSVpvn_flags(little_p, llen,
3511 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3512 little_p = SvPVX(little);
3516 offset = is_index ? 0 : biglen;
3518 if (big_utf8 && offset > 0)
3519 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3525 else if (offset > (SSize_t)biglen)
3527 if (!(little_p = is_index
3528 ? fbm_instr((unsigned char*)big_p + offset,
3529 (unsigned char*)big_p + biglen, little, 0)
3530 : rninstr(big_p, big_p + offset,
3531 little_p, little_p + llen)))
3534 retval = little_p - big_p;
3535 if (retval > 1 && big_utf8)
3536 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3541 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3542 if (PL_op->op_private & OPpTRUEBOOL) {
3543 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3544 ? &PL_sv_yes : &PL_sv_no);
3545 if (PL_op->op_private & OPpTARGET_MY)
3546 /* $lex = (index() == -1) */
3547 sv_setsv(TARG, TOPs);
3556 dSP; dMARK; dORIGMARK; dTARGET;
3557 SvTAINTED_off(TARG);
3558 do_sprintf(TARG, SP-MARK, MARK+1);
3559 TAINT_IF(SvTAINTED(TARG));
3571 const U8 *s = (U8*)SvPV_const(argsv, len);
3574 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3588 if (UNLIKELY(SvAMAGIC(top)))
3590 if (UNLIKELY(isinfnansv(top)))
3591 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3593 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3594 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3596 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3597 && SvNV_nomg(top) < 0.0)))
3599 if (ckWARN(WARN_UTF8)) {
3600 if (SvGMAGICAL(top)) {
3601 SV *top2 = sv_newmortal();
3602 sv_setsv_nomg(top2, top);
3605 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3606 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3608 value = UNICODE_REPLACEMENT;
3610 value = SvUV_nomg(top);
3614 SvUPGRADE(TARG,SVt_PV);
3616 if (value > 255 && !IN_BYTES) {
3617 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3618 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3619 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3621 (void)SvPOK_only(TARG);
3630 *tmps++ = (char)value;
3632 (void)SvPOK_only(TARG);
3644 const char *tmps = SvPV_const(left, len);
3646 if (DO_UTF8(left)) {
3647 /* If Unicode, try to downgrade.
3648 * If not possible, croak.
3649 * Yes, we made this up. */
3650 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3652 sv_utf8_downgrade(tsv, FALSE);
3653 tmps = SvPV_const(tsv, len);
3655 # ifdef USE_ITHREADS
3657 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3658 /* This should be threadsafe because in ithreads there is only
3659 * one thread per interpreter. If this would not be true,
3660 * we would need a mutex to protect this malloc. */
3661 PL_reentrant_buffer->_crypt_struct_buffer =
3662 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3663 #if defined(__GLIBC__) || defined(__EMX__)
3664 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3665 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3666 #if (defined(__GLIBC__) && __GLIBC__ == 2) && \
3667 (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
3668 /* work around glibc-2.2.5 bug, has been fixed at some
3669 * time in glibc-2.3.X */
3670 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3675 # endif /* HAS_CRYPT_R */
3676 # endif /* USE_ITHREADS */
3678 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3680 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3687 "The crypt() function is unimplemented due to excessive paranoia.");
3691 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3692 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3695 /* also used for: pp_lcfirst() */
3699 /* Actually is both lcfirst() and ucfirst(). Only the first character
3700 * changes. This means that possibly we can change in-place, ie., just
3701 * take the source and change that one character and store it back, but not
3702 * if read-only etc, or if the length changes */
3706 STRLEN slen; /* slen is the byte length of the whole SV. */
3709 bool inplace; /* ? Convert first char only, in-place */
3710 bool doing_utf8 = FALSE; /* ? using utf8 */
3711 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3712 const int op_type = PL_op->op_type;
3715 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3716 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3717 * stored as UTF-8 at s. */
3718 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3719 * lowercased) character stored in tmpbuf. May be either
3720 * UTF-8 or not, but in either case is the number of bytes */
3721 bool remove_dot_above = FALSE;
3723 s = (const U8*)SvPV_const(source, slen);
3725 /* We may be able to get away with changing only the first character, in
3726 * place, but not if read-only, etc. Later we may discover more reasons to
3727 * not convert in-place. */
3728 inplace = !SvREADONLY(source) && SvPADTMP(source);
3730 #ifdef USE_LOCALE_CTYPE
3732 if (IN_LC_RUNTIME(LC_CTYPE)) {
3733 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3738 /* First calculate what the changed first character should be. This affects
3739 * whether we can just swap it out, leaving the rest of the string unchanged,
3740 * or even if have to convert the dest to UTF-8 when the source isn't */
3742 if (! slen) { /* If empty */
3743 need = 1; /* still need a trailing NUL */
3747 else if (DO_UTF8(source)) { /* Is the source utf8? */
3751 if (op_type == OP_UCFIRST) {
3752 #ifdef USE_LOCALE_CTYPE
3753 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3755 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3760 #ifdef USE_LOCALE_CTYPE
3762 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3764 /* In turkic locales, lower casing an 'I' normally yields U+0131,
3765 * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3766 * contains a COMBINING DOT ABOVE. Instead it is treated like
3767 * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'. The
3768 * call to lowercase above has handled this. But SpecialCasing.txt
3769 * says we are supposed to remove the COMBINING DOT ABOVE. We can
3770 * tell if we have this situation if I ==> i in a turkic locale. */
3771 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3772 && IN_LC_RUNTIME(LC_CTYPE)
3773 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3775 /* Here, we know there was a COMBINING DOT ABOVE. We won't be
3776 * able to handle this in-place. */
3779 /* It seems likely that the DOT will immediately follow the
3780 * 'I'. If so, we can remove it simply by indicating to the
3781 * code below to start copying the source just beyond the DOT.
3782 * We know its length is 2 */
3783 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3786 else { /* But if it doesn't follow immediately, set a flag for
3788 remove_dot_above = TRUE;
3792 PERL_UNUSED_VAR(remove_dot_above);
3794 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3799 /* we can't do in-place if the length changes. */
3800 if (ulen != tculen) inplace = FALSE;
3801 need = slen + 1 - ulen + tculen;
3803 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3804 * latin1 is treated as caseless. Note that a locale takes
3806 ulen = 1; /* Original character is 1 byte */
3807 tculen = 1; /* Most characters will require one byte, but this will
3808 * need to be overridden for the tricky ones */
3812 #ifdef USE_LOCALE_CTYPE
3814 if (IN_LC_RUNTIME(LC_CTYPE)) {
3815 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3816 && ( (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3817 || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3819 if (*s == 'I') { /* lcfirst('I') */
3820 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3821 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3823 else { /* ucfirst('i') */
3824 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3825 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3830 convert_source_to_utf8 = TRUE;
3831 need += variant_under_utf8_count(s, s + slen);
3833 else if (op_type == OP_LCFIRST) {
3835 /* For lc, there are no gotchas for UTF-8 locales (other than
3836 * the turkish ones already handled above) */
3837 *tmpbuf = toLOWER_LC(*s);
3839 else { /* ucfirst */
3841 /* But for uc, some characters require special handling */
3842 if (IN_UTF8_CTYPE_LOCALE) {
3846 /* This would be a bug if any locales have upper and title case
3848 *tmpbuf = (U8) toUPPER_LC(*s);
3853 /* Here, not in locale. If not using Unicode rules, is a simple
3854 * lower/upper, depending */
3855 if (! IN_UNI_8_BIT) {
3856 *tmpbuf = (op_type == OP_LCFIRST)
3860 else if (op_type == OP_LCFIRST) {
3861 /* lower case the first letter: no trickiness for any character */
3862 *tmpbuf = toLOWER_LATIN1(*s);
3865 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3866 * non-turkic UTF-8, which we treat as not in locale), and cased
3869 #ifdef USE_LOCALE_CTYPE
3873 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3875 assert(tculen == 2);
3877 /* If the result is an upper Latin1-range character, it can
3878 * still be represented in one byte, which is its ordinal */
3879 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3880 *tmpbuf = (U8) title_ord;
3884 /* Otherwise it became more than one ASCII character (in
3885 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3886 * beyond Latin1, so the number of bytes changed, so can't
3887 * replace just the first character in place. */
3890 /* If the result won't fit in a byte, the entire result
3891 * will have to be in UTF-8. Allocate enough space for the
3892 * expanded first byte, and if UTF-8, the rest of the input
3893 * string, some or all of which may also expand to two
3894 * bytes, plus the terminating NUL. */
3895 if (title_ord > 255) {
3897 convert_source_to_utf8 = TRUE;
3899 + variant_under_utf8_count(s, s + slen)
3902 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3903 * characters whose title case is above 255 is
3907 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3908 need = slen + 1 + 1;
3912 } /* End of use Unicode (Latin1) semantics */
3913 } /* End of changing the case of the first character */
3915 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3916 * generate the result */
3919 /* We can convert in place. This means we change just the first
3920 * character without disturbing the rest; no need to grow */
3922 s = d = (U8*)SvPV_force_nomg(source, slen);
3928 /* Here, we can't convert in place; we earlier calculated how much
3929 * space we will need, so grow to accommodate that */
3930 SvUPGRADE(dest, SVt_PV);
3931 d = (U8*)SvGROW(dest, need);
3932 (void)SvPOK_only(dest);
3939 if (! convert_source_to_utf8) {
3941 /* Here both source and dest are in UTF-8, but have to create
3942 * the entire output. We initialize the result to be the
3943 * title/lower cased first character, and then append the rest
3945 sv_setpvn(dest, (char*)tmpbuf, tculen);
3948 /* But this boolean being set means we are in a turkic
3949 * locale, and there is a DOT character that needs to be
3950 * removed, and it isn't immediately after the current
3951 * character. Keep concatenating characters to the output
3952 * one at a time, until we find the DOT, which we simply
3954 if (UNLIKELY(remove_dot_above)) {
3956 Size_t this_len = UTF8SKIP(s + ulen);
3958 sv_catpvn(dest, (char*)(s + ulen), this_len);
3961 if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3965 } while (s + ulen < s + slen);
3968 /* The rest of the string can be concatenated unchanged,
3970 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3974 const U8 *const send = s + slen;
3976 /* Here the dest needs to be in UTF-8, but the source isn't,
3977 * except we earlier UTF-8'd the first character of the source
3978 * into tmpbuf. First put that into dest, and then append the
3979 * rest of the source, converting it to UTF-8 as we go. */
3981 /* Assert tculen is 2 here because the only characters that
3982 * get to this part of the code have 2-byte UTF-8 equivalents */
3983 assert(tculen == 2);
3985 *d++ = *(tmpbuf + 1);
3986 s++; /* We have just processed the 1st char */
3989 append_utf8_from_native_byte(*s, &d);
3994 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3998 else { /* in-place UTF-8. Just overwrite the first character */
3999 Copy(tmpbuf, d, tculen, U8);
4000 SvCUR_set(dest, need - 1);
4004 else { /* Neither source nor dest are, nor need to be UTF-8 */
4006 if (inplace) { /* in-place, only need to change the 1st char */
4009 else { /* Not in-place */
4011 /* Copy the case-changed character(s) from tmpbuf */
4012 Copy(tmpbuf, d, tculen, U8);
4013 d += tculen - 1; /* Code below expects d to point to final
4014 * character stored */
4017 else { /* empty source */
4018 /* See bug #39028: Don't taint if empty */
4022 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4023 * the destination to retain that flag */
4024 if (DO_UTF8(source))
4027 if (!inplace) { /* Finish the rest of the string, unchanged */
4028 /* This will copy the trailing NUL */
4029 Copy(s + 1, d + 1, slen, U8);
4030 SvCUR_set(dest, need - 1);
4033 #ifdef USE_LOCALE_CTYPE
4034 if (IN_LC_RUNTIME(LC_CTYPE)) {
4039 if (dest != source && SvTAINTED(source))
4058 if ( SvPADTMP(source)
4059 && !SvREADONLY(source) && SvPOK(source)
4062 #ifdef USE_LOCALE_CTYPE
4063 (IN_LC_RUNTIME(LC_CTYPE))
4064 ? ! IN_UTF8_CTYPE_LOCALE
4070 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4071 * make the loop tight, so we overwrite the source with the dest before
4072 * looking at it, and we need to look at the original source
4073 * afterwards. There would also need to be code added to handle
4074 * switching to not in-place in midstream if we run into characters
4075 * that change the length. Since being in locale overrides UNI_8_BIT,
4076 * that latter becomes irrelevant in the above test; instead for
4077 * locale, the size can't normally change, except if the locale is a
4080 s = d = (U8*)SvPV_force_nomg(source, len);
4087 s = (const U8*)SvPV_nomg_const(source, len);
4090 SvUPGRADE(dest, SVt_PV);
4091 d = (U8*)SvGROW(dest, min);
4092 (void)SvPOK_only(dest);
4097 #ifdef USE_LOCALE_CTYPE
4099 if (IN_LC_RUNTIME(LC_CTYPE)) {
4100 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4105 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4106 to check DO_UTF8 again here. */
4108 if (DO_UTF8(source)) {
4109 const U8 *const send = s + len;
4110 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4112 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4113 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4114 /* All occurrences of these are to be moved to follow any other marks.
4115 * This is context-dependent. We may not be passed enough context to
4116 * move the iota subscript beyond all of them, but we do the best we can
4117 * with what we're given. The result is always better than if we
4118 * hadn't done this. And, the problem would only arise if we are
4119 * passed a character without all its combining marks, which would be
4120 * the caller's mistake. The information this is based on comes from a
4121 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4122 * itself) and so can't be checked properly to see if it ever gets
4123 * revised. But the likelihood of it changing is remote */
4124 bool in_iota_subscript = FALSE;
4130 if (UNLIKELY(in_iota_subscript)) {
4131 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4133 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4135 /* A non-mark. Time to output the iota subscript */
4136 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4137 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4138 in_iota_subscript = FALSE;
4142 /* Then handle the current character. Get the changed case value
4143 * and copy it to the output buffer */
4146 #ifdef USE_LOCALE_CTYPE
4147 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4149 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4151 if (uv == GREEK_CAPITAL_LETTER_IOTA
4152 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4154 in_iota_subscript = TRUE;
4157 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4158 /* If the eventually required minimum size outgrows the
4159 * available space, we need to grow. */
4160 const UV o = d - (U8*)SvPVX_const(dest);
4162 /* If someone uppercases one million U+03B0s we SvGROW()
4163 * one million times. Or we could try guessing how much to
4164 * allocate without allocating too much. But we can't
4165 * really guess without examining the rest of the string.
4166 * Such is life. See corresponding comment in lc code for
4168 d = o + (U8*) SvGROW(dest, min);
4170 Copy(tmpbuf, d, ulen, U8);
4175 if (in_iota_subscript) {
4176 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4177 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4182 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4184 else { /* Not UTF-8 */
4186 const U8 *const send = s + len;
4188 /* Use locale casing if in locale; regular style if not treating
4189 * latin1 as having case; otherwise the latin1 casing. Do the
4190 * whole thing in a tight loop, for speed, */
4191 #ifdef USE_LOCALE_CTYPE
4192 if (IN_LC_RUNTIME(LC_CTYPE)) {
4193 if (IN_UTF8_CTYPE_LOCALE) {
4196 for (; s < send; d++, s++)
4197 *d = (U8) toUPPER_LC(*s);
4201 if (! IN_UNI_8_BIT) {
4202 for (; s < send; d++, s++) {
4207 #ifdef USE_LOCALE_CTYPE
4210 for (; s < send; d++, s++) {
4213 *d = toUPPER_LATIN1_MOD(*s);
4214 if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4216 #ifdef USE_LOCALE_CTYPE
4218 && (LIKELY( ! PL_in_utf8_turkic_locale
4219 || ! IN_LC_RUNTIME(LC_CTYPE))
4227 /* The mainstream case is the tight loop above. To avoid
4228 * extra tests in that, all three characters that always
4229 * require special handling are mapped by the MOD to the
4230 * one tested just above. Use the source to distinguish
4231 * between those cases */
4233 #if UNICODE_MAJOR_VERSION > 2 \
4234 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4235 && UNICODE_DOT_DOT_VERSION >= 8)
4236 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4238 /* uc() of this requires 2 characters, but they are
4239 * ASCII. If not enough room, grow the string */
4240 if (SvLEN(dest) < ++min) {
4241 const UV o = d - (U8*)SvPVX_const(dest);
4242 d = o + (U8*) SvGROW(dest, min);
4244 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4245 continue; /* Back to the tight loop; still in ASCII */
4249 /* The other special handling characters have their
4250 * upper cases outside the latin1 range, hence need to be
4251 * in UTF-8, so the whole result needs to be in UTF-8.
4253 * So, here we are somewhere in the middle of processing a
4254 * non-UTF-8 string, and realize that we will have to
4255 * convert the whole thing to UTF-8. What to do? There
4256 * are several possibilities. The simplest to code is to
4257 * convert what we have so far, set a flag, and continue on
4258 * in the loop. The flag would be tested each time through
4259 * the loop, and if set, the next character would be
4260 * converted to UTF-8 and stored. But, I (khw) didn't want
4261 * to slow down the mainstream case at all for this fairly
4262 * rare case, so I didn't want to add a test that didn't
4263 * absolutely have to be there in the loop, besides the
4264 * possibility that it would get too complicated for
4265 * optimizers to deal with. Another possibility is to just
4266 * give up, convert the source to UTF-8, and restart the
4267 * function that way. Another possibility is to convert
4268 * both what has already been processed and what is yet to
4269 * come separately to UTF-8, then jump into the loop that
4270 * handles UTF-8. But the most efficient time-wise of the
4271 * ones I could think of is what follows, and turned out to
4272 * not require much extra code.
4274 * First, calculate the extra space needed for the
4275 * remainder of the source needing to be in UTF-8. Except
4276 * for the 'i' in Turkic locales, in UTF-8 strings, the
4277 * uppercase of a character below 256 occupies the same
4278 * number of bytes as the original. Therefore, the space
4279 * needed is the that number plus the number of characters
4280 * that become two bytes when converted to UTF-8, plus, in
4281 * turkish locales, the number of 'i's. */
4283 extra = send - s + variant_under_utf8_count(s, send);
4285 #ifdef USE_LOCALE_CTYPE
4287 if (UNLIKELY(*s == 'i')) { /* We wouldn't get an 'i' here
4288 unless are in a Turkic
4290 const U8 * s_peek = s;
4295 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4296 send - (s_peek + 1));
4297 } while (s_peek != NULL);
4301 /* Convert what we have so far into UTF-8, telling the
4302 * function that we know it should be converted, and to
4303 * allow extra space for what we haven't processed yet.
4305 * This may cause the string pointer to move, so need to
4306 * save and re-find it. */
4308 len = d - (U8*)SvPVX_const(dest);
4309 SvCUR_set(dest, len);
4310 len = sv_utf8_upgrade_flags_grow(dest,
4311 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4313 + 1 /* trailing NUL */ );
4314 d = (U8*)SvPVX(dest) + len;
4316 /* Now process the remainder of the source, simultaneously
4317 * converting to upper and UTF-8.
4319 * To avoid extra tests in the loop body, and since the
4320 * loop is so simple, split out the rare Turkic case into
4323 #ifdef USE_LOCALE_CTYPE
4324 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4325 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4327 for (; s < send; s++) {
4329 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4330 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4333 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4340 for (; s < send; s++) {
4341 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4345 /* Here have processed the whole source; no need to
4346 * continue with the outer loop. Each character has been
4347 * converted to upper case and converted to UTF-8. */
4349 } /* End of processing all latin1-style chars */
4350 } /* End of processing all chars */
4351 } /* End of source is not empty */
4353 if (source != dest) {
4354 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4355 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4357 } /* End of isn't utf8 */
4358 #ifdef USE_LOCALE_CTYPE
4359 if (IN_LC_RUNTIME(LC_CTYPE)) {
4364 if (dest != source && SvTAINTED(source))
4379 bool has_turkic_I = FALSE;
4383 if ( SvPADTMP(source)
4384 && !SvREADONLY(source) && SvPOK(source)
4387 #ifdef USE_LOCALE_CTYPE
4389 && ( LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4390 || LIKELY(! PL_in_utf8_turkic_locale))
4396 /* We can convert in place, as, outside of Turkic UTF-8 locales,
4397 * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4398 * been on) doesn't lengthen it. */
4400 s = d = (U8*)SvPV_force_nomg(source, len);
4407 s = (const U8*)SvPV_nomg_const(source, len);
4410 SvUPGRADE(dest, SVt_PV);
4411 d = (U8*)SvGROW(dest, min);
4412 (void)SvPOK_only(dest);
4417 #ifdef USE_LOCALE_CTYPE
4419 if (IN_LC_RUNTIME(LC_CTYPE)) {
4422 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4424 /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4425 * UTF-8 for the single case of the character 'I' */
4426 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4427 && ! DO_UTF8(source)
4428 && (next_I = (U8 *) memchr(s, 'I', len)))
4431 const U8 *const send = s + len;
4436 next_I = (U8 *) memchr(next_I + 1, 'I',
4437 send - (next_I + 1));
4438 } while (next_I != NULL);
4440 /* Except for the 'I', in UTF-8 strings, the lower case of a
4441 * character below 256 occupies the same number of bytes as the
4442 * original. Therefore, the space needed is the original length
4443 * plus I_count plus the number of characters that become two bytes
4444 * when converted to UTF-8 */
4445 sv_utf8_upgrade_flags_grow(dest, 0, len
4447 + variant_under_utf8_count(s, send)
4448 + 1 /* Trailing NUL */ );
4449 d = (U8*)SvPVX(dest);
4450 has_turkic_I = TRUE;
4456 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4457 to check DO_UTF8 again here. */
4459 if (DO_UTF8(source)) {
4460 const U8 *const send = s + len;
4461 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4462 bool remove_dot_above = FALSE;
4465 const STRLEN u = UTF8SKIP(s);
4468 #ifdef USE_LOCALE_CTYPE
4470 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4472 /* If we are in a Turkic locale, we have to do more work. As noted
4473 * in the comments for lcfirst, there is a special case if a 'I'
4474 * is in a grapheme with COMBINING DOT ABOVE UTF8. It turns into a
4475 * 'i', and the DOT must be removed. We check for that situation,
4476 * and set a flag if the DOT is there. Then each time through the
4477 * loop, we have to see if we need to remove the next DOT above,
4478 * and if so, do it. We know that there is a DOT because
4479 * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4480 * was one in a proper position. */
4481 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4482 && IN_LC_RUNTIME(LC_CTYPE))
4484 if ( UNLIKELY(remove_dot_above)
4485 && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4488 remove_dot_above = FALSE;
4491 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4492 remove_dot_above = TRUE;
4496 PERL_UNUSED_VAR(remove_dot_above);
4498 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4501 /* Here is where we would do context-sensitive actions for the
4502 * Greek final sigma. See the commit message for 86510fb15 for why
4503 * there isn't any */
4505 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4507 /* If the eventually required minimum size outgrows the
4508 * available space, we need to grow. */
4509 const UV o = d - (U8*)SvPVX_const(dest);
4511 /* If someone lowercases one million U+0130s we SvGROW() one
4512 * million times. Or we could try guessing how much to
4513 * allocate without allocating too much. Such is life.
4514 * Another option would be to grow an extra byte or two more
4515 * each time we need to grow, which would cut down the million
4516 * to 500K, with little waste */
4517 d = o + (U8*) SvGROW(dest, min);
4520 /* Copy the newly lowercased letter to the output buffer we're
4522 Copy(tmpbuf, d, ulen, U8);
4525 } /* End of looping through the source string */
4528 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4529 } else { /* 'source' not utf8 */
4531 const U8 *const send = s + len;
4533 /* Use locale casing if in locale; regular style if not treating
4534 * latin1 as having case; otherwise the latin1 casing. Do the
4535 * whole thing in a tight loop, for speed, */
4536 #ifdef USE_LOCALE_CTYPE
4537 if (IN_LC_RUNTIME(LC_CTYPE)) {
4538 if (LIKELY( ! has_turkic_I)) {
4539 for (; s < send; d++, s++)
4540 *d = toLOWER_LC(*s);
4542 else { /* This is the only case where lc() converts 'dest'
4543 into UTF-8 from a non-UTF-8 'source' */
4544 for (; s < send; s++) {
4546 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4547 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4550 append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4557 if (! IN_UNI_8_BIT) {
4558 for (; s < send; d++, s++) {
4563 for (; s < send; d++, s++) {
4564 *d = toLOWER_LATIN1(*s);
4568 if (source != dest) {
4570 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4573 #ifdef USE_LOCALE_CTYPE
4574 if (IN_LC_RUNTIME(LC_CTYPE)) {
4579 if (dest != source && SvTAINTED(source))
4588 SV * const sv = TOPs;
4590 const char *s = SvPV_const(sv,len);
4592 SvUTF8_off(TARG); /* decontaminate */
4595 SvUPGRADE(TARG, SVt_PV);
4596 SvGROW(TARG, (len * 2) + 1);
4600 STRLEN ulen = UTF8SKIP(s);
4601 bool to_quote = FALSE;
4603 if (UTF8_IS_INVARIANT(*s)) {
4604 if (_isQUOTEMETA(*s)) {
4608 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4610 #ifdef USE_LOCALE_CTYPE
4611 /* In locale, we quote all non-ASCII Latin1 chars.
4612 * Otherwise use the quoting rules */
4614 IN_LC_RUNTIME(LC_CTYPE)
4617 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4622 else if (is_QUOTEMETA_high(s)) {
4637 else if (IN_UNI_8_BIT) {
4639 if (_isQUOTEMETA(*s))
4645 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4646 * including everything above ASCII */
4648 if (!isWORDCHAR_A(*s))
4654 SvCUR_set(TARG, d - SvPVX_const(TARG));
4655 (void)SvPOK_only_UTF8(TARG);
4658 sv_setpvn(TARG, s, len);
4674 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4675 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4676 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4677 || UNICODE_DOT_DOT_VERSION > 0)
4678 const bool full_folding = TRUE; /* This variable is here so we can easily
4679 move to more generality later */
4681 const bool full_folding = FALSE;
4683 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4684 #ifdef USE_LOCALE_CTYPE
4685 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4689 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4690 * You are welcome(?) -Hugmeir
4698 s = (const U8*)SvPV_nomg_const(source, len);
4700 if (ckWARN(WARN_UNINITIALIZED))
4701 report_uninit(source);
4708 SvUPGRADE(dest, SVt_PV);
4709 d = (U8*)SvGROW(dest, min);
4710 (void)SvPOK_only(dest);
4716 #ifdef USE_LOCALE_CTYPE
4718 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4719 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4724 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4726 const STRLEN u = UTF8SKIP(s);
4729 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4731 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4732 const UV o = d - (U8*)SvPVX_const(dest);
4733 d = o + (U8*) SvGROW(dest, min);
4736 Copy(tmpbuf, d, ulen, U8);
4741 } /* Unflagged string */
4743 #ifdef USE_LOCALE_CTYPE
4744 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4745 if (IN_UTF8_CTYPE_LOCALE) {
4746 goto do_uni_folding;
4748 for (; s < send; d++, s++)
4749 *d = (U8) toFOLD_LC(*s);
4753 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4754 for (; s < send; d++, s++)
4758 #ifdef USE_LOCALE_CTYPE
4761 /* For ASCII and the Latin-1 range, there's potentially three
4762 * troublesome folds:
4763 * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4764 * casefolding becomes 'ss';
4765 * \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4766 * \x{3BC} (\N{GREEK SMALL LETTER MU})
4767 * I only in Turkic locales, this folds to \x{131}
4768 * \N{LATIN SMALL LETTER DOTLESS I}
4769 * For the rest, the casefold is their lowercase. */
4770 for (; s < send; d++, s++) {
4771 if ( UNLIKELY(*s == MICRO_SIGN)
4772 #ifdef USE_LOCALE_CTYPE
4773 || ( UNLIKELY(PL_in_utf8_turkic_locale)
4774 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4775 && UNLIKELY(*s == 'I'))
4778 Size_t extra = send - s
4779 + variant_under_utf8_count(s, send);
4781 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4782 * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4783 * DOTLESS I} both of which are outside of the latin-1
4784 * range. There's a couple of ways to deal with this -- khw
4785 * discusses them in pp_lc/uc, so go there :) What we do
4786 * here is upgrade what we had already casefolded, then
4787 * enter an inner loop that appends the rest of the
4788 * characters as UTF-8.
4790 * First we calculate the needed size of the upgraded dest
4791 * beyond what's been processed already (the upgrade
4792 * function figures that out). Except for the 'I' in
4793 * Turkic locales, in UTF-8 strings, the fold case of a
4794 * character below 256 occupies the same number of bytes as
4795 * the original (even the Sharp S). Therefore, the space
4796 * needed is the number of bytes remaining plus the number
4797 * of characters that become two bytes when converted to
4798 * UTF-8 plus, in turkish locales, the number of 'I's */
4800 if (UNLIKELY(*s == 'I')) {
4801 const U8 * s_peek = s;
4806 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4807 send - (s_peek + 1));
4808 } while (s_peek != NULL);
4811 /* Growing may move things, so have to save and recalculate
4813 len = d - (U8*)SvPVX_const(dest);
4814 SvCUR_set(dest, len);
4815 len = sv_utf8_upgrade_flags_grow(dest,
4816 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4818 + 1 /* Trailing NUL */ );
4819 d = (U8*)SvPVX(dest) + len;
4821 *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4822 *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4825 for (; s < send; s++) {
4827 _to_uni_fold_flags(*s, d, &ulen, flags);
4832 else if ( UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4835 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4836 * becomes "ss", which may require growing the SV. */
4837 if (SvLEN(dest) < ++min) {
4838 const UV o = d - (U8*)SvPVX_const(dest);
4839 d = o + (U8*) SvGROW(dest, min);
4844 else { /* Else, the fold is the lower case */
4845 *d = toLOWER_LATIN1(*s);
4851 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4853 #ifdef USE_LOCALE_CTYPE
4854 if (IN_LC_RUNTIME(LC_CTYPE)) {
4859 if (SvTAINTED(source))
4869 dSP; dMARK; dORIGMARK;
4870 AV *const av = MUTABLE_AV(POPs);
4871 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4873 if (SvTYPE(av) == SVt_PVAV) {
4874 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4875 bool can_preserve = FALSE;
4881 can_preserve = SvCANEXISTDELETE(av);
4884 if (lval && localizing) {
4887 for (svp = MARK + 1; svp <= SP; svp++) {
4888 const SSize_t elem = SvIV(*svp);
4892 if (max > AvMAX(av))
4896 while (++MARK <= SP) {
4898 SSize_t elem = SvIV(*MARK);
4899 bool preeminent = TRUE;
4901 if (localizing && can_preserve) {
4902 /* If we can determine whether the element exist,
4903 * Try to preserve the existenceness of a tied array
4904 * element by using EXISTS and DELETE if possible.
4905 * Fallback to FETCH and STORE otherwise. */
4906 preeminent = av_exists(av, elem);
4909 svp = av_fetch(av, elem, lval);
4912 DIE(aTHX_ PL_no_aelem, elem);
4915 save_aelem(av, elem, svp);
4917 SAVEADELETE(av, elem);
4920 *MARK = svp ? *svp : &PL_sv_undef;
4923 if (GIMME_V != G_ARRAY) {
4925 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4934 AV *const av = MUTABLE_AV(POPs);
4935 I32 lval = (PL_op->op_flags & OPf_MOD);
4936 SSize_t items = SP - MARK;
4938 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4939 const I32 flags = is_lvalue_sub();
4941 if (!(flags & OPpENTERSUB_INARGS))
4942 /* diag_listed_as: Can't modify %s in %s */
4943 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4950 *(MARK+items*2-1) = *(MARK+items);
4956 while (++MARK <= SP) {
4959 svp = av_fetch(av, SvIV(*MARK), lval);
4961 if (!svp || !*svp || *svp == &PL_sv_undef) {
4962 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4964 *MARK = sv_mortalcopy(*MARK);
4966 *++MARK = svp ? *svp : &PL_sv_undef;
4968 if (GIMME_V != G_ARRAY) {
4969 MARK = SP - items*2;
4970 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4980 AV *array = MUTABLE_AV(POPs);
4981 const U8 gimme = GIMME_V;
4982 IV *iterp = Perl_av_iter_p(aTHX_ array);
4983 const IV current = (*iterp)++;
4985 if (current > av_tindex(array)) {
4987 if (gimme == G_SCALAR)
4995 if (gimme == G_ARRAY) {
4996 SV **const element = av_fetch(array, current, 0);
4997 PUSHs(element ? *element : &PL_sv_undef);
5002 /* also used for: pp_avalues()*/
5006 AV *array = MUTABLE_AV(POPs);
5007 const U8 gimme = GIMME_V;
5009 *Perl_av_iter_p(aTHX_ array) = 0;
5011 if (gimme == G_SCALAR) {
5013 PUSHi(av_tindex(array) + 1);
5015 else if (gimme == G_ARRAY) {
5016 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5017 const I32 flags = is_lvalue_sub();
5018 if (flags && !(flags & OPpENTERSUB_INARGS))
5019 /* diag_listed_as: Can't modify %s in %s */
5021 "Can't modify keys on array in list assignment");
5024 IV n = Perl_av_len(aTHX_ array);
5029 if ( PL_op->op_type == OP_AKEYS
5030 || ( PL_op->op_type == OP_AVHVSWITCH
5031 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
5033 for (i = 0; i <= n; i++) {
5038 for (i = 0; i <= n; i++) {
5039 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5040 PUSHs(elem ? *elem : &PL_sv_undef);
5048 /* Associative arrays. */
5053 HV * hash = MUTABLE_HV(POPs);
5055 const U8 gimme = GIMME_V;
5057 entry = hv_iternext(hash);
5061 SV* const sv = hv_iterkeysv(entry);
5063 if (gimme == G_ARRAY) {
5065 val = hv_iterval(hash, entry);
5069 else if (gimme == G_SCALAR)
5076 S_do_delete_local(pTHX)
5079 const U8 gimme = GIMME_V;
5082 const bool sliced = !!(PL_op->op_private & OPpSLICE);
5083 SV **unsliced_keysv = sliced ? NULL : sp--;
5084 SV * const osv = POPs;
5085 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5087 const bool tied = SvRMAGICAL(osv)
5088 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5089 const bool can_preserve = SvCANEXISTDELETE(osv);
5090 const U32 type = SvTYPE(osv);
5091 SV ** const end = sliced ? SP : unsliced_keysv;
5093 if (type == SVt_PVHV) { /* hash element */
5094 HV * const hv = MUTABLE_HV(osv);
5095 while (++MARK <= end) {
5096 SV * const keysv = *MARK;
5098 bool preeminent = TRUE;
5100 preeminent = hv_exists_ent(hv, keysv, 0);
5102 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5109 sv = hv_delete_ent(hv, keysv, 0, 0);
5111 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5114 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5115 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5117 *MARK = sv_mortalcopy(sv);
5123 SAVEHDELETE(hv, keysv);
5124 *MARK = &PL_sv_undef;
5128 else if (type == SVt_PVAV) { /* array element */
5129 if (PL_op->op_flags & OPf_SPECIAL) {
5130 AV * const av = MUTABLE_AV(osv);
5131 while (++MARK <= end) {
5132 SSize_t idx = SvIV(*MARK);
5134 bool preeminent = TRUE;
5136 preeminent = av_exists(av, idx);
5138 SV **svp = av_fetch(av, idx, 1);
5145 sv = av_delete(av, idx, 0);
5147 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5150 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5152 *MARK = sv_mortalcopy(sv);
5158 SAVEADELETE(av, idx);
5159 *MARK = &PL_sv_undef;
5164 DIE(aTHX_ "panic: avhv_delete no longer supported");
5167 DIE(aTHX_ "Not a HASH reference");
5169 if (gimme == G_VOID)
5171 else if (gimme == G_SCALAR) {
5176 *++MARK = &PL_sv_undef;
5180 else if (gimme != G_VOID)
5181 PUSHs(*unsliced_keysv);
5192 if (PL_op->op_private & OPpLVAL_INTRO)
5193 return do_delete_local();
5196 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5198 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5200 HV * const hv = MUTABLE_HV(POPs);
5201 const U32 hvtype = SvTYPE(hv);
5203 if (PL_op->op_private & OPpKVSLICE) {
5204 SSize_t items = SP - MARK;
5208 *(MARK+items*2-1) = *(MARK+items);
5215 if (hvtype == SVt_PVHV) { /* hash element */
5216 while ((MARK += (1+skip)) <= SP) {
5217 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5218 *MARK = sv ? sv : &PL_sv_undef;
5221 else if (hvtype == SVt_PVAV) { /* array element */
5222 if (PL_op->op_flags & OPf_SPECIAL) {
5223 while ((MARK += (1+skip)) <= SP) {
5224 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5225 *MARK = sv ? sv : &PL_sv_undef;
5230 DIE(aTHX_ "Not a HASH reference");
5233 else if (gimme == G_SCALAR) {
5238 *++MARK = &PL_sv_undef;
5244 HV * const hv = MUTABLE_HV(POPs);
5246 if (SvTYPE(hv) == SVt_PVHV)
5247 sv = hv_delete_ent(hv, keysv, discard, 0);
5248 else if (SvTYPE(hv) == SVt_PVAV) {
5249 if (PL_op->op_flags & OPf_SPECIAL)
5250 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5252 DIE(aTHX_ "panic: avhv_delete no longer supported");
5255 DIE(aTHX_ "Not a HASH reference");
5270 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5272 SV * const sv = POPs;
5273 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5276 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5281 hv = MUTABLE_HV(POPs);
5282 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5283 if (hv_exists_ent(hv, tmpsv, 0))
5286 else if (SvTYPE(hv) == SVt_PVAV) {
5287 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5288 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5293 DIE(aTHX_ "Not a HASH reference");
5300 dSP; dMARK; dORIGMARK;
5301 HV * const hv = MUTABLE_HV(POPs);
5302 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5303 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5304 bool can_preserve = FALSE;
5310 if (SvCANEXISTDELETE(hv))
5311 can_preserve = TRUE;
5314 while (++MARK <= SP) {
5315 SV * const keysv = *MARK;
5318 bool preeminent = TRUE;
5320 if (localizing && can_preserve) {
5321 /* If we can determine whether the element exist,
5322 * try to preserve the existenceness of a tied hash
5323 * element by using EXISTS and DELETE if possible.
5324 * Fallback to FETCH and STORE otherwise. */
5325 preeminent = hv_exists_ent(hv, keysv, 0);
5328 he = hv_fetch_ent(hv, keysv, lval, 0);
5329 svp = he ? &HeVAL(he) : NULL;
5332 if (!svp || !*svp || *svp == &PL_sv_undef) {
5333 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5336 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5337 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5338 else if (preeminent)
5339 save_helem_flags(hv, keysv, svp,
5340 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5342 SAVEHDELETE(hv, keysv);
5345 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5347 if (GIMME_V != G_ARRAY) {
5349 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5358 HV * const hv = MUTABLE_HV(POPs);
5359 I32 lval = (PL_op->op_flags & OPf_MOD);
5360 SSize_t items = SP - MARK;
5362 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5363 const I32 flags = is_lvalue_sub();
5365 if (!(flags & OPpENTERSUB_INARGS))
5366 /* diag_listed_as: Can't modify %s in %s */
5367 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5368 GIMME_V == G_ARRAY ? "list" : "scalar");
5375 *(MARK+items*2-1) = *(MARK+items);
5381 while (++MARK <= SP) {
5382 SV * const keysv = *MARK;
5386 he = hv_fetch_ent(hv, keysv, lval, 0);
5387 svp = he ? &HeVAL(he) : NULL;
5390 if (!svp || !*svp || *svp == &PL_sv_undef) {
5391 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5393 *MARK = sv_mortalcopy(*MARK);
5395 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5397 if (GIMME_V != G_ARRAY) {
5398 MARK = SP - items*2;
5399 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5405 /* List operators. */
5409 I32 markidx = POPMARK;
5410 if (GIMME_V != G_ARRAY) {
5411 /* don't initialize mark here, EXTEND() may move the stack */
5414 EXTEND(SP, 1); /* in case no arguments, as in @empty */
5415 mark = PL_stack_base + markidx;
5417 *MARK = *SP; /* unwanted list, return last item */
5419 *MARK = &PL_sv_undef;
5429 SV ** const lastrelem = PL_stack_sp;
5430 SV ** const lastlelem = PL_stack_base + POPMARK;
5431 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5432 SV ** const firstrelem = lastlelem + 1;
5433 const U8 mod = PL_op->op_flags & OPf_MOD;
5435 const I32 max = lastrelem - lastlelem;
5438 if (GIMME_V != G_ARRAY) {
5439 if (lastlelem < firstlelem) {
5441 *firstlelem = &PL_sv_undef;
5444 I32 ix = SvIV(*lastlelem);
5447 if (ix < 0 || ix >= max)
5448 *firstlelem = &PL_sv_undef;
5450 *firstlelem = firstrelem[ix];
5457 SP = firstlelem - 1;
5461 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5462 I32 ix = SvIV(*lelem);
5465 if (ix < 0 || ix >= max)
5466 *lelem = &PL_sv_undef;
5468 if (!(*lelem = firstrelem[ix]))
5469 *lelem = &PL_sv_undef;
5470 else if (mod && SvPADTMP(*lelem)) {
5471 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5482 const I32 items = SP - MARK;
5483 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5485 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5486 ? newRV_noinc(av) : av);
5492 dSP; dMARK; dORIGMARK;
5493 HV* const hv = newHV();
5494 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5495 ? newRV_noinc(MUTABLE_SV(hv))
5500 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5507 sv_setsv_nomg(val, *MARK);
5511 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5514 (void)hv_store_ent(hv,key,val,0);
5523 dSP; dMARK; dORIGMARK;
5524 int num_args = (SP - MARK);
5525 AV *ary = MUTABLE_AV(*++MARK);
5534 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5537 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5538 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5542 if (SvREADONLY(ary))
5543 Perl_croak_no_modify();
5548 offset = i = SvIV(*MARK);
5550 offset += AvFILLp(ary) + 1;
5552 DIE(aTHX_ PL_no_aelem, i);
5554 length = SvIVx(*MARK++);
5556 length += AvFILLp(ary) - offset + 1;
5562 length = AvMAX(ary) + 1; /* close enough to infinity */
5566 length = AvMAX(ary) + 1;
5568 if (offset > AvFILLp(ary) + 1) {
5570 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5571 offset = AvFILLp(ary) + 1;
5573 after = AvFILLp(ary) + 1 - (offset + length);
5574 if (after < 0) { /* not that much array */
5575 length += after; /* offset+length now in array */
5581 /* At this point, MARK .. SP-1 is our new LIST */
5584 diff = newlen - length;
5585 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5588 /* make new elements SVs now: avoid problems if they're from the array */
5589 for (dst = MARK, i = newlen; i; i--) {
5590 SV * const h = *dst;
5591 *dst++ = newSVsv(h);
5594 if (diff < 0) { /* shrinking the area */
5595 SV **tmparyval = NULL;
5597 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5598 Copy(MARK, tmparyval, newlen, SV*);
5601 MARK = ORIGMARK + 1;
5602 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5603 const bool real = cBOOL(AvREAL(ary));
5604 MEXTEND(MARK, length);
5606 EXTEND_MORTAL(length);
5607 for (i = 0, dst = MARK; i < length; i++) {
5608 if ((*dst = AvARRAY(ary)[i+offset])) {
5610 sv_2mortal(*dst); /* free them eventually */
5613 *dst = &PL_sv_undef;
5619 *MARK = AvARRAY(ary)[offset+length-1];
5622 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5623 SvREFCNT_dec(*dst++); /* free them now */
5626 *MARK = &PL_sv_undef;
5628 AvFILLp(ary) += diff;
5630 /* pull up or down? */
5632 if (offset < after) { /* easier to pull up */
5633 if (offset) { /* esp. if nothing to pull */
5634 src = &AvARRAY(ary)[offset-1];
5635 dst = src - diff; /* diff is negative */
5636 for (i = offset; i > 0; i--) /* can't trust Copy */
5640 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5644 if (after) { /* anything to pull down? */
5645 src = AvARRAY(ary) + offset + length;
5646 dst = src + diff; /* diff is negative */
5647 Move(src, dst, after, SV*);
5649 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5650 /* avoid later double free */
5657 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5658 Safefree(tmparyval);
5661 else { /* no, expanding (or same) */
5662 SV** tmparyval = NULL;
5664 Newx(tmparyval, length, SV*); /* so remember deletion */
5665 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5668 if (diff > 0) { /* expanding */
5669 /* push up or down? */
5670 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5674 Move(src, dst, offset, SV*);
5676 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5678 AvFILLp(ary) += diff;
5681 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5682 av_extend(ary, AvFILLp(ary) + diff);
5683 AvFILLp(ary) += diff;
5686 dst = AvARRAY(ary) + AvFILLp(ary);
5688 for (i = after; i; i--) {
5696 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5699 MARK = ORIGMARK + 1;
5700 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5702 const bool real = cBOOL(AvREAL(ary));
5704 EXTEND_MORTAL(length);
5705 for (i = 0, dst = MARK; i < length; i++) {
5706 if ((*dst = tmparyval[i])) {
5708 sv_2mortal(*dst); /* free them eventually */
5710 else *dst = &PL_sv_undef;
5716 else if (length--) {
5717 *MARK = tmparyval[length];
5720 while (length-- > 0)
5721 SvREFCNT_dec(tmparyval[length]);
5724 *MARK = &PL_sv_undef;
5727 *MARK = &PL_sv_undef;
5728 Safefree(tmparyval);
5732 mg_set(MUTABLE_SV(ary));
5740 dSP; dMARK; dORIGMARK; dTARGET;
5741 AV * const ary = MUTABLE_AV(*++MARK);
5742 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5745 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5748 ENTER_with_name("call_PUSH");
5749 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5750 LEAVE_with_name("call_PUSH");
5751 /* SPAGAIN; not needed: SP is assigned to immediately below */
5754 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5755 * only need to save locally, not on the save stack */
5756 U16 old_delaymagic = PL_delaymagic;
5758 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5759 PL_delaymagic = DM_DELAY;
5760 for (++MARK; MARK <= SP; MARK++) {
5762 if (*MARK) SvGETMAGIC(*MARK);
5765 sv_setsv_nomg(sv, *MARK);
5766 av_store(ary, AvFILLp(ary)+1, sv);
5768 if (PL_delaymagic & DM_ARRAY_ISA)
5769 mg_set(MUTABLE_SV(ary));
5770 PL_delaymagic = old_delaymagic;
5773 if (OP_GIMME(PL_op, 0) != G_VOID) {
5774 PUSHi( AvFILL(ary) + 1 );
5779 /* also used for: pp_pop()*/
5783 AV * const av = PL_op->op_flags & OPf_SPECIAL
5784 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5785 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5789 (void)sv_2mortal(sv);
5796 dSP; dMARK; dORIGMARK; dTARGET;
5797 AV *ary = MUTABLE_AV(*++MARK);
5798 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5801 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5804 ENTER_with_name("call_UNSHIFT");
5805 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5806 LEAVE_with_name("call_UNSHIFT");
5807 /* SPAGAIN; not needed: SP is assigned to immediately below */
5810 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5811 * only need to save locally, not on the save stack */
5812 U16 old_delaymagic = PL_delaymagic;
5815 av_unshift(ary, SP - MARK);
5816 PL_delaymagic = DM_DELAY;
5818 SV * const sv = newSVsv(*++MARK);
5819 (void)av_store(ary, i++, sv);
5821 if (PL_delaymagic & DM_ARRAY_ISA)
5822 mg_set(MUTABLE_SV(ary));
5823 PL_delaymagic = old_delaymagic;
5826 if (OP_GIMME(PL_op, 0) != G_VOID) {
5827 PUSHi( AvFILL(ary) + 1 );
5836 if (GIMME_V == G_ARRAY) {
5837 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5841 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5842 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5843 av = MUTABLE_AV((*SP));
5844 /* In-place reversing only happens in void context for the array
5845 * assignment. We don't need to push anything on the stack. */
5848 if (SvMAGICAL(av)) {
5850 SV *tmp = sv_newmortal();
5851 /* For SvCANEXISTDELETE */
5854 bool can_preserve = SvCANEXISTDELETE(av);
5856 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5860 if (!av_exists(av, i)) {
5861 if (av_exists(av, j)) {
5862 SV *sv = av_delete(av, j, 0);
5863 begin = *av_fetch(av, i, TRUE);
5864 sv_setsv_mg(begin, sv);
5868 else if (!av_exists(av, j)) {
5869 SV *sv = av_delete(av, i, 0);
5870 end = *av_fetch(av, j, TRUE);
5871 sv_setsv_mg(end, sv);
5876 begin = *av_fetch(av, i, TRUE);
5877 end = *av_fetch(av, j, TRUE);
5878 sv_setsv(tmp, begin);
5879 sv_setsv_mg(begin, end);
5880 sv_setsv_mg(end, tmp);
5884 SV **begin = AvARRAY(av);
5887 SV **end = begin + AvFILLp(av);
5889 while (begin < end) {
5890 SV * const tmp = *begin;
5901 SV * const tmp = *MARK;
5905 /* safe as long as stack cannot get extended in the above */
5914 SvUTF8_off(TARG); /* decontaminate */
5915 if (SP - MARK > 1) {
5916 do_join(TARG, &PL_sv_no, MARK, SP);
5919 } else if (SP > MARK) {
5920 sv_setsv(TARG, *SP);
5923 sv_setsv(TARG, DEFSV);
5927 up = SvPV_force(TARG, len);
5930 if (DO_UTF8(TARG)) { /* first reverse each character */
5931 U8* s = (U8*)SvPVX(TARG);
5932 const U8* send = (U8*)(s + len);
5934 if (UTF8_IS_INVARIANT(*s)) {
5939 if (!utf8_to_uvchr_buf(s, send, 0))
5943 down = (char*)(s - 1);
5944 /* reverse this character */
5946 const char tmp = *up;
5954 down = SvPVX(TARG) + len - 1;
5956 const char tmp = *up;
5960 (void)SvPOK_only_UTF8(TARG);
5969 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5970 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
5971 ? (AV *)POPs : NULL;
5972 IV limit = POPi; /* note, negative is forever */
5973 SV * const sv = POPs;
5975 const char *s = SvPV_const(sv, len);
5976 const bool do_utf8 = DO_UTF8(sv);
5977 const bool in_uni_8_bit = IN_UNI_8_BIT;
5978 const char *strend = s + len;
5979 PMOP *pm = cPMOPx(PL_op);
5984 const STRLEN slen = do_utf8
5985 ? utf8_length((U8*)s, (U8*)strend)
5986 : (STRLEN)(strend - s);
5987 SSize_t maxiters = slen + 10;
5988 I32 trailing_empty = 0;
5990 const IV origlimit = limit;
5993 const U8 gimme = GIMME_V;
5995 I32 oldsave = PL_savestack_ix;
5996 U32 make_mortal = SVs_TEMP;
6002 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
6003 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
6005 /* handle @ary = split(...) optimisation */
6006 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
6007 if (!(PL_op->op_flags & OPf_STACKED)) {
6008 if (PL_op->op_private & OPpSPLIT_LEX) {
6009 if (PL_op->op_private & OPpLVAL_INTRO)
6010 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6011 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
6016 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6018 pm->op_pmreplrootu.op_pmtargetgv;
6020 if (PL_op->op_private & OPpLVAL_INTRO)
6025 /* skip anything pushed by OPpLVAL_INTRO above */
6026 oldsave = PL_savestack_ix;
6032 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
6035 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6037 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6044 for (i = AvFILLp(ary); i >= 0; i--)
6045 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
6047 /* temporarily switch stacks */
6048 SAVESWITCHSTACK(PL_curstack, ary);
6053 base = SP - PL_stack_base;
6055 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6057 while (s < strend && isSPACE_utf8_safe(s, strend))
6060 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6061 while (s < strend && isSPACE_LC(*s))
6064 else if (in_uni_8_bit) {
6065 while (s < strend && isSPACE_L1(*s))
6069 while (s < strend && isSPACE(*s))
6073 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
6077 gimme_scalar = gimme == G_SCALAR && !ary;
6080 limit = maxiters + 2;
6081 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6084 /* this one uses 'm' and is a negative test */
6086 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6087 const int t = UTF8SKIP(m);
6088 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6095 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6097 while (m < strend && !isSPACE_LC(*m))
6100 else if (in_uni_8_bit) {
6101 while (m < strend && !isSPACE_L1(*m))
6104 while (m < strend && !isSPACE(*m))
6117 dstr = newSVpvn_flags(s, m-s,
6118 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6122 /* skip the whitespace found last */
6124 s = m + UTF8SKIP(m);
6128 /* this one uses 's' and is a positive test */
6130 while (s < strend && isSPACE_utf8_safe(s, strend) )
6133 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6135 while (s < strend && isSPACE_LC(*s))
6138 else if (in_uni_8_bit) {
6139 while (s < strend && isSPACE_L1(*s))
6142 while (s < strend && isSPACE(*s))
6147 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6149 for (m = s; m < strend && *m != '\n'; m++)
6162 dstr = newSVpvn_flags(s, m-s,
6163 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6169 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6171 Pre-extend the stack, either the number of bytes or
6172 characters in the string or a limited amount, triggered by:
6174 my ($x, $y) = split //, $str;
6178 if (!gimme_scalar) {
6179 const IV items = limit - 1;
6180 /* setting it to -1 will trigger a panic in EXTEND() */
6181 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
6182 if (items >=0 && items < sslen)
6190 /* keep track of how many bytes we skip over */
6200 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6213 dstr = newSVpvn(s, 1);
6229 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6230 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6231 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6232 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6233 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6234 SV * const csv = CALLREG_INTUIT_STRING(rx);
6236 len = RX_MINLENRET(rx);
6237 if (len == 1 && !RX_UTF8(rx) && !tail) {
6238 const char c = *SvPV_nolen_const(csv);
6240 for (m = s; m < strend && *m != c; m++)
6251 dstr = newSVpvn_flags(s, m-s,
6252 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6255 /* The rx->minlen is in characters but we want to step
6256 * s ahead by bytes. */
6258 s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend);
6260 s = m + len; /* Fake \n at the end */
6264 while (s < strend && --limit &&
6265 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6266 csv, multiline ? FBMrf_MULTILINE : 0)) )
6275 dstr = newSVpvn_flags(s, m-s,
6276 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6279 /* The rx->minlen is in characters but we want to step
6280 * s ahead by bytes. */
6282 s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend);
6284 s = m + len; /* Fake \n at the end */
6289 maxiters += slen * RX_NPARENS(rx);
6290 while (s < strend && --limit)
6294 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6297 if (rex_return == 0)
6299 TAINT_IF(RX_MATCH_TAINTED(rx));
6300 /* we never pass the REXEC_COPY_STR flag, so it should
6301 * never get copied */
6302 assert(!RX_MATCH_COPIED(rx));
6303 m = RX_OFFS(rx)[0].start + orig;
6312 dstr = newSVpvn_flags(s, m-s,
6313 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6316 if (RX_NPARENS(rx)) {
6318 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6319 s = RX_OFFS(rx)[i].start + orig;
6320 m = RX_OFFS(rx)[i].end + orig;
6322 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6323 parens that didn't match -- they should be set to
6324 undef, not the empty string */
6332 if (m >= orig && s >= orig) {
6333 dstr = newSVpvn_flags(s, m-s,
6334 (do_utf8 ? SVf_UTF8 : 0)
6338 dstr = &PL_sv_undef; /* undef, not "" */
6344 s = RX_OFFS(rx)[0].end + orig;
6348 if (!gimme_scalar) {
6349 iters = (SP - PL_stack_base) - base;
6351 if (iters > maxiters)
6352 DIE(aTHX_ "Split loop");
6354 /* keep field after final delim? */
6355 if (s < strend || (iters && origlimit)) {
6356 if (!gimme_scalar) {
6357 const STRLEN l = strend - s;
6358 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6363 else if (!origlimit) {
6365 iters -= trailing_empty;
6367 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6368 if (TOPs && !make_mortal)
6377 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6381 if (SvSMAGICAL(ary)) {
6383 mg_set(MUTABLE_SV(ary));
6386 if (gimme == G_ARRAY) {
6388 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6395 ENTER_with_name("call_PUSH");
6396 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6397 LEAVE_with_name("call_PUSH");
6399 if (gimme == G_ARRAY) {
6401 /* EXTEND should not be needed - we just popped them */
6403 for (i=0; i < iters; i++) {
6404 SV **svp = av_fetch(ary, i, FALSE);
6405 PUSHs((svp) ? *svp : &PL_sv_undef);
6412 if (gimme == G_ARRAY)
6424 SV *const sv = PAD_SVl(PL_op->op_targ);
6426 if (SvPADSTALE(sv)) {
6429 RETURNOP(cLOGOP->op_other);
6431 RETURNOP(cLOGOP->op_next);
6440 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6441 || SvTYPE(retsv) == SVt_PVCV) {
6442 retsv = refto(retsv);
6449 /* used for: pp_padany(), pp_custom(); plus any system ops
6450 * that aren't implemented on a particular platform */
6452 PP(unimplemented_op)
6454 const Optype op_type = PL_op->op_type;
6455 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6456 with out of range op numbers - it only "special" cases op_custom.
6457 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6458 if we get here for a custom op then that means that the custom op didn't
6459 have an implementation. Given that OP_NAME() looks up the custom op
6460 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6461 registers &PL_unimplemented_op as the address of their custom op.
6462 NULL doesn't generate a useful error message. "custom" does. */
6463 const char *const name = op_type >= OP_max
6464 ? "[out of range]" : PL_op_name[PL_op->op_type];
6465 if(OP_IS_SOCKET(op_type))
6466 DIE(aTHX_ PL_no_sock_func, name);
6467 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6471 S_maybe_unwind_defav(pTHX)
6473 if (CX_CUR()->cx_type & CXp_HASARGS) {
6474 PERL_CONTEXT *cx = CX_CUR();
6476 assert(CxHASARGS(cx));
6478 cx->cx_type &= ~CXp_HASARGS;
6482 /* For sorting out arguments passed to a &CORE:: subroutine */
6486 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6487 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6488 AV * const at_ = GvAV(PL_defgv);
6489 SV **svp = at_ ? AvARRAY(at_) : NULL;
6490 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6491 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6492 bool seen_question = 0;
6493 const char *err = NULL;
6494 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6496 /* Count how many args there are first, to get some idea how far to
6497 extend the stack. */
6499 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6501 if (oa & OA_OPTIONAL) seen_question = 1;
6502 if (!seen_question) minargs++;
6506 if(numargs < minargs) err = "Not enough";
6507 else if(numargs > maxargs) err = "Too many";
6509 /* diag_listed_as: Too many arguments for %s */
6511 "%s arguments for %s", err,
6512 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6515 /* Reset the stack pointer. Without this, we end up returning our own
6516 arguments in list context, in addition to the values we are supposed
6517 to return. nextstate usually does this on sub entry, but we need
6518 to run the next op with the caller's hints, so we cannot have a
6520 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6522 if(!maxargs) RETURN;
6524 /* We do this here, rather than with a separate pushmark op, as it has
6525 to come in between two things this function does (stack reset and
6526 arg pushing). This seems the easiest way to do it. */
6529 (void)Perl_pp_pushmark(aTHX);
6532 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6533 PUTBACK; /* The code below can die in various places. */
6535 oa = PL_opargs[opnum] >> OASHIFT;
6536 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6541 if (!numargs && defgv && whicharg == minargs + 1) {
6544 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6548 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6555 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6558 S_maybe_unwind_defav(aTHX);
6561 PUSHs((SV *)GvAVn(gv));
6564 if (!svp || !*svp || !SvROK(*svp)
6565 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6567 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6568 "Type of arg %d to &CORE::%s must be array reference",
6569 whicharg, PL_op_desc[opnum]
6574 if (!svp || !*svp || !SvROK(*svp)
6575 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6576 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6577 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6579 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6580 "Type of arg %d to &CORE::%s must be hash%s reference",
6581 whicharg, PL_op_desc[opnum],
6582 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6589 if (!numargs) PUSHs(NULL);
6590 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6591 /* no magic here, as the prototype will have added an extra
6592 refgen and we just want what was there before that */
6595 const bool constr = PL_op->op_private & whicharg;
6597 svp && *svp ? *svp : &PL_sv_undef,
6598 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6604 if (!numargs) goto try_defsv;
6606 const bool wantscalar =
6607 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6608 if (!svp || !*svp || !SvROK(*svp)
6609 /* We have to permit globrefs even for the \$ proto, as
6610 *foo is indistinguishable from ${\*foo}, and the proto-
6611 type permits the latter. */
6612 || SvTYPE(SvRV(*svp)) > (
6613 wantscalar ? SVt_PVLV
6614 : opnum == OP_LOCK || opnum == OP_UNDEF
6620 "Type of arg %d to &CORE::%s must be %s",
6621 whicharg, PL_op_name[opnum],
6623 ? "scalar reference"
6624 : opnum == OP_LOCK || opnum == OP_UNDEF
6625 ? "reference to one of [$@%&*]"
6626 : "reference to one of [$@%*]"
6629 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6630 /* Undo @_ localisation, so that sub exit does not undo
6631 part of our undeffing. */
6632 S_maybe_unwind_defav(aTHX);
6637 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6645 /* Implement CORE::keys(),values(),each().
6647 * We won't know until run-time whether the arg is an array or hash,
6650 * pp_keys/pp_values/pp_each
6652 * pp_akeys/pp_avalues/pp_aeach
6654 * as appropriate (or whatever pp function actually implements the OP_FOO
6655 * functionality for each FOO).
6662 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6663 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6671 if (PL_op->op_private & OPpOFFBYONE) {
6672 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6674 else cv = find_runcv(NULL);
6675 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6680 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6681 const bool can_preserve)
6683 const SSize_t ix = SvIV(keysv);
6684 if (can_preserve ? av_exists(av, ix) : TRUE) {
6685 SV ** const svp = av_fetch(av, ix, 1);
6687 Perl_croak(aTHX_ PL_no_aelem, ix);
6688 save_aelem(av, ix, svp);
6691 SAVEADELETE(av, ix);
6695 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6696 const bool can_preserve)
6698 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6699 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6700 SV ** const svp = he ? &HeVAL(he) : NULL;
6702 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6703 save_helem_flags(hv, keysv, svp, 0);
6706 SAVEHDELETE(hv, keysv);
6710 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6712 if (type == OPpLVREF_SV) {
6713 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6716 else if (type == OPpLVREF_AV)
6717 /* XXX Inefficient, as it creates a new AV, which we are
6718 about to clobber. */
6721 assert(type == OPpLVREF_HV);
6722 /* XXX Likewise inefficient. */
6731 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6732 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6734 const char *bad = NULL;
6735 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6736 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6739 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6743 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6747 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6751 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6755 /* diag_listed_as: Assigned value is not %s reference */
6756 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6760 switch (left ? SvTYPE(left) : 0) {
6763 SV * const old = PAD_SV(ARGTARG);
6764 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6766 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6768 SAVECLEARSV(PAD_SVl(ARGTARG));
6772 if (PL_op->op_private & OPpLVAL_INTRO) {
6773 S_localise_gv_slot(aTHX_ (GV *)left, type);
6775 gv_setref(left, sv);
6780 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6781 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6782 SvCANEXISTDELETE(left));
6784 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6787 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6789 S_localise_helem_lval(aTHX_ (HV *)left, key,
6790 SvCANEXISTDELETE(left));
6792 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6794 if (PL_op->op_flags & OPf_MOD)
6795 SETs(sv_2mortal(newSVsv(sv)));
6796 /* XXX else can weak references go stale before they are read, e.g.,
6805 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6806 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6807 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6808 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6809 &PL_vtbl_lvref, (char *)elem,
6810 elem ? HEf_SVKEY : (I32)ARGTARG);
6811 mg->mg_private = PL_op->op_private;
6812 if (PL_op->op_private & OPpLVREF_ITER)
6813 mg->mg_flags |= MGf_PERSIST;
6814 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6820 const bool can_preserve = SvCANEXISTDELETE(arg);
6821 if (SvTYPE(arg) == SVt_PVAV)
6822 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6824 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6828 S_localise_gv_slot(aTHX_ (GV *)arg,
6829 PL_op->op_private & OPpLVREF_TYPE);
6831 else if (!(PL_op->op_private & OPpPAD_STATE))
6832 SAVECLEARSV(PAD_SVl(ARGTARG));
6841 AV * const av = (AV *)POPs;
6842 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6843 bool can_preserve = FALSE;
6845 if (UNLIKELY(localizing)) {
6850 can_preserve = SvCANEXISTDELETE(av);
6852 if (SvTYPE(av) == SVt_PVAV) {
6855 for (svp = MARK + 1; svp <= SP; svp++) {
6856 const SSize_t elem = SvIV(*svp);
6860 if (max > AvMAX(av))
6865 while (++MARK <= SP) {
6866 SV * const elemsv = *MARK;
6867 if (UNLIKELY(localizing)) {
6868 if (SvTYPE(av) == SVt_PVAV)
6869 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6871 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6873 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6874 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6881 if (PL_op->op_flags & OPf_STACKED)
6882 Perl_pp_rv2av(aTHX);
6884 Perl_pp_padav(aTHX);
6888 SETs(0); /* special alias marker that aassign recognises */
6898 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6899 ? CopSTASH(PL_curcop)
6901 NULL, SvREFCNT_inc_simple_NN(sv))));
6906 /* process one subroutine argument - typically when the sub has a signature:
6907 * introduce PL_curpad[op_targ] and assign to it the value
6908 * for $: (OPf_STACKED ? *sp : $_[N])
6909 * for @/%: @_[N..$#_]
6911 * It's equivalent to
6914 * my $foo = (value-on-stack)
6916 * my @foo = @_[N..$#_]
6926 AV *defav = GvAV(PL_defgv); /* @_ */
6927 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6930 /* do 'my $var, @var or %var' action */
6931 padentry = &(PAD_SVl(o->op_targ));
6932 save_clearsv(padentry);
6935 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6936 if (o->op_flags & OPf_STACKED) {
6943 /* should already have been checked */
6945 #if IVSIZE > PTRSIZE
6946 assert(ix <= SSize_t_MAX);
6949 svp = av_fetch(defav, ix, FALSE);
6950 val = svp ? *svp : &PL_sv_undef;
6955 /* cargo-culted from pp_sassign */
6956 assert(TAINTING_get || !TAINT_get);
6957 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6960 SvSetMagicSV(targ, val);
6964 /* must be AV or HV */
6966 assert(!(o->op_flags & OPf_STACKED));
6967 argc = ((IV)AvFILL(defav) + 1) - ix;
6969 /* This is a copy of the relevant parts of pp_aassign().
6971 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6974 if (AvFILL((AV*)targ) > -1) {
6975 /* target should usually be empty. If we get get
6976 * here, someone's been doing some weird closure tricks.
6977 * Make a copy of all args before clearing the array,
6978 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6979 * elements. See similar code in pp_aassign.
6981 for (i = 0; i < argc; i++) {
6982 SV **svp = av_fetch(defav, ix + i, FALSE);
6983 SV *newsv = newSV(0);
6984 sv_setsv_flags(newsv,
6985 svp ? *svp : &PL_sv_undef,
6986 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6987 if (!av_store(defav, ix + i, newsv))
6988 SvREFCNT_dec_NN(newsv);
6990 av_clear((AV*)targ);
6996 av_extend((AV*)targ, argc);
7001 SV **svp = av_fetch(defav, ix + i, FALSE);
7002 SV *val = svp ? *svp : &PL_sv_undef;
7004 sv_setsv(tmpsv, val);
7005 av_store((AV*)targ, i++, tmpsv);
7013 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
7015 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
7016 /* see "target should usually be empty" comment above */
7017 for (i = 0; i < argc; i++) {
7018 SV **svp = av_fetch(defav, ix + i, FALSE);
7019 SV *newsv = newSV(0);
7020 sv_setsv_flags(newsv,
7021 svp ? *svp : &PL_sv_undef,
7022 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7023 if (!av_store(defav, ix + i, newsv))
7024 SvREFCNT_dec_NN(newsv);
7026 hv_clear((HV*)targ);
7031 assert(argc % 2 == 0);
7040 svp = av_fetch(defav, ix + i++, FALSE);
7041 key = svp ? *svp : &PL_sv_undef;
7042 svp = av_fetch(defav, ix + i++, FALSE);
7043 val = svp ? *svp : &PL_sv_undef;
7046 if (UNLIKELY(SvGMAGICAL(key)))
7047 key = sv_mortalcopy(key);
7049 sv_setsv(tmpsv, val);
7050 hv_store_ent((HV*)targ, key, tmpsv, 0);
7058 /* Handle a default value for one subroutine argument (typically as part
7059 * of a subroutine signature).
7060 * It's equivalent to
7061 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
7063 * Intended to be used where op_next is an OP_ARGELEM
7065 * We abuse the op_targ field slightly: it's an index into @_ rather than
7071 OP * const o = PL_op;
7072 AV *defav = GvAV(PL_defgv); /* @_ */
7073 IV ix = (IV)o->op_targ;
7076 #if IVSIZE > PTRSIZE
7077 assert(ix <= SSize_t_MAX);
7080 if (AvFILL(defav) >= ix) {
7082 SV **svp = av_fetch(defav, ix, FALSE);
7083 SV *val = svp ? *svp : &PL_sv_undef;
7087 return cLOGOPo->op_other;
7092 S_find_runcv_name(void)
7107 sv = sv_2mortal(newSV(0));
7108 gv_fullname4(sv, gv, NULL, TRUE);
7112 /* Check a sub's arguments - i.e. that it has the correct number of args
7113 * (and anything else we might think of in future). Typically used with
7119 OP * const o = PL_op;
7120 struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux;
7121 UV params = aux->params;
7122 UV opt_params = aux->opt_params;
7123 char slurpy = aux->slurpy;
7124 AV *defav = GvAV(PL_defgv); /* @_ */
7128 assert(!SvMAGICAL(defav));
7129 argc = (UV)(AvFILLp(defav) + 1);
7130 too_few = (argc < (params - opt_params));
7132 if (UNLIKELY(too_few || (!slurpy && argc > params)))
7133 /* diag_listed_as: Too few arguments for subroutine '%s' */
7134 /* diag_listed_as: Too many arguments for subroutine '%s' */
7135 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
7136 too_few ? "few" : "many", S_find_runcv_name());
7138 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7139 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7140 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7141 S_find_runcv_name());
7147 * ex: set ts=8 sts=4 sw=4 et: