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.
32 #include "regcharclass.h"
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
46 #if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
53 /* variations on pp_null */
58 if (GIMME_V == G_SCALAR)
65 /* This is also called directly by pp_lvavref. */
70 assert(SvTYPE(TARG) == SVt_PVAV);
71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
76 if (PL_op->op_flags & OPf_REF) {
80 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
81 const I32 flags = is_lvalue_sub();
82 if (flags && !(flags & OPpENTERSUB_INARGS)) {
83 if (GIMME_V == G_SCALAR)
84 /* diag_listed_as: Can't return %s to lvalue scalar context */
85 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
92 if (gimme == G_ARRAY) {
93 /* XXX see also S_pushav in pp_hot.c */
94 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
96 if (SvMAGICAL(TARG)) {
98 for (i=0; i < maxarg; i++) {
99 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
100 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
105 for (i=0; i < maxarg; i++) {
106 SV * const sv = AvARRAY((const AV *)TARG)[i];
107 SP[i+1] = sv ? sv : &PL_sv_undef;
112 else if (gimme == G_SCALAR) {
113 SV* const sv = sv_newmortal();
114 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
115 sv_setiv(sv, maxarg);
126 assert(SvTYPE(TARG) == SVt_PVHV);
128 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
129 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
130 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
132 if (PL_op->op_flags & OPf_REF)
134 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
135 const I32 flags = is_lvalue_sub();
136 if (flags && !(flags & OPpENTERSUB_INARGS)) {
137 if (GIMME_V == G_SCALAR)
138 /* diag_listed_as: Can't return %s to lvalue scalar context */
139 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
145 if (gimme == G_ARRAY) {
146 RETURNOP(Perl_do_kv(aTHX));
148 else if ((PL_op->op_private & OPpTRUEBOOL
149 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
150 && block_gimme() == G_VOID ))
151 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
153 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_no);
154 else if (gimme == G_SCALAR) {
155 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
164 assert(SvTYPE(TARG) == SVt_PVCV);
172 SvPADSTALE_off(TARG);
179 CV * const protocv = PadnamePROTOCV(
180 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
182 assert(SvTYPE(TARG) == SVt_PVCV);
184 if (CvISXSUB(protocv)) { /* constant */
185 /* XXX Should we clone it here? */
186 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
187 to introcv and remove the SvPADSTALE_off. */
188 SAVEPADSVANDMORTALIZE(ARGTARG);
189 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
192 if (CvROOT(protocv)) {
193 assert(CvCLONE(protocv));
194 assert(!CvCLONED(protocv));
196 cv_clone_into(protocv,(CV *)TARG);
197 SAVECLEARSV(PAD_SVl(ARGTARG));
204 /* In some cases this function inspects PL_op. If this function is called
205 for new op types, more bool parameters may need to be added in place of
208 When noinit is true, the absence of a gv will cause a retval of undef.
209 This is unrelated to the cv-to-gv assignment case.
213 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
216 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
219 sv = amagic_deref_call(sv, to_gv_amg);
223 if (SvTYPE(sv) == SVt_PVIO) {
224 GV * const gv = MUTABLE_GV(sv_newmortal());
225 gv_init(gv, 0, "__ANONIO__", 10, 0);
226 GvIOp(gv) = MUTABLE_IO(sv);
227 SvREFCNT_inc_void_NN(sv);
230 else if (!isGV_with_GP(sv)) {
231 Perl_die(aTHX_ "Not a GLOB reference");
235 if (!isGV_with_GP(sv)) {
237 /* If this is a 'my' scalar and flag is set then vivify
240 if (vivify_sv && sv != &PL_sv_undef) {
243 Perl_croak_no_modify();
244 if (cUNOP->op_targ) {
245 SV * const namesv = PAD_SV(cUNOP->op_targ);
246 HV *stash = CopSTASH(PL_curcop);
247 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
248 gv = MUTABLE_GV(newSV(0));
249 gv_init_sv(gv, stash, namesv, 0);
252 const char * const name = CopSTASHPV(PL_curcop);
253 gv = newGVgen_flags(name,
254 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
255 SvREFCNT_inc_simple_void_NN(gv);
257 prepare_SV_for_RV(sv);
258 SvRV_set(sv, MUTABLE_SV(gv));
263 if (PL_op->op_flags & OPf_REF || strict) {
264 Perl_die(aTHX_ PL_no_usym, "a symbol");
266 if (ckWARN(WARN_UNINITIALIZED))
272 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
273 sv, GV_ADDMG, SVt_PVGV
282 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
286 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
287 == OPpDONT_INIT_GV) {
288 /* We are the target of a coderef assignment. Return
289 the scalar unchanged, and let pp_sasssign deal with
293 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
295 /* FAKE globs in the symbol table cause weird bugs (#77810) */
299 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
300 SV *newsv = sv_newmortal();
301 sv_setsv_flags(newsv, sv, 0);
313 sv, PL_op->op_private & OPpDEREF,
314 PL_op->op_private & HINT_STRICT_REFS,
315 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
316 || PL_op->op_type == OP_READLINE
318 if (PL_op->op_private & OPpLVAL_INTRO)
319 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
324 /* Helper function for pp_rv2sv and pp_rv2av */
326 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
327 const svtype type, SV ***spp)
331 PERL_ARGS_ASSERT_SOFTREF2XV;
333 if (PL_op->op_private & HINT_STRICT_REFS) {
335 Perl_die(aTHX_ PL_no_symref_sv, sv,
336 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
338 Perl_die(aTHX_ PL_no_usym, what);
342 PL_op->op_flags & OPf_REF
344 Perl_die(aTHX_ PL_no_usym, what);
345 if (ckWARN(WARN_UNINITIALIZED))
347 if (type != SVt_PV && GIMME_V == G_ARRAY) {
351 **spp = &PL_sv_undef;
354 if ((PL_op->op_flags & OPf_SPECIAL) &&
355 !(PL_op->op_flags & OPf_MOD))
357 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
359 **spp = &PL_sv_undef;
364 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
377 sv = amagic_deref_call(sv, to_sv_amg);
381 if (SvTYPE(sv) >= SVt_PVAV)
382 DIE(aTHX_ "Not a SCALAR reference");
387 if (!isGV_with_GP(gv)) {
388 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
394 if (PL_op->op_flags & OPf_MOD) {
395 if (PL_op->op_private & OPpLVAL_INTRO) {
396 if (cUNOP->op_first->op_type == OP_NULL)
397 sv = save_scalar(MUTABLE_GV(TOPs));
399 sv = save_scalar(gv);
401 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
403 else if (PL_op->op_private & OPpDEREF)
404 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
406 SPAGAIN; /* in case chasing soft refs reallocated the stack */
414 AV * const av = MUTABLE_AV(TOPs);
415 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
417 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
419 *svp = newSV_type(SVt_PVMG);
420 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
424 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
433 if (PL_op->op_flags & OPf_MOD || LVRET) {
434 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
435 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
437 LvTARG(ret) = SvREFCNT_inc_simple(sv);
438 SETs(ret); /* no SvSETMAGIC */
441 const MAGIC * const mg = mg_find_mglob(sv);
442 if (mg && mg->mg_len != -1) {
444 STRLEN i = mg->mg_len;
445 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
446 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
460 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
462 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
463 == OPpMAY_RETURN_CONSTANT)
466 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
467 /* (But not in defined().) */
469 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
471 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
472 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
473 ? MUTABLE_CV(SvRV(gv))
477 cv = MUTABLE_CV(&PL_sv_undef);
478 SETs(MUTABLE_SV(cv));
488 SV *ret = &PL_sv_undef;
490 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
491 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
492 const char * s = SvPVX_const(TOPs);
493 if (strnEQ(s, "CORE::", 6)) {
494 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
496 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
497 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
499 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
505 cv = sv_2cv(TOPs, &stash, &gv, 0);
507 ret = newSVpvn_flags(
508 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
518 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
520 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
522 PUSHs(MUTABLE_SV(cv));
536 if (GIMME_V != G_ARRAY) {
542 *MARK = &PL_sv_undef;
544 *MARK = refto(*MARK);
548 EXTEND_MORTAL(SP - MARK);
550 *MARK = refto(*MARK);
555 S_refto(pTHX_ SV *sv)
559 PERL_ARGS_ASSERT_REFTO;
561 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
564 if (!(sv = LvTARG(sv)))
567 SvREFCNT_inc_void_NN(sv);
569 else if (SvTYPE(sv) == SVt_PVAV) {
570 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
571 av_reify(MUTABLE_AV(sv));
573 SvREFCNT_inc_void_NN(sv);
575 else if (SvPADTMP(sv)) {
580 SvREFCNT_inc_void_NN(sv);
583 sv_upgrade(rv, SVt_IV);
592 SV * const sv = TOPs;
600 /* op is in boolean context? */
601 if ( (PL_op->op_private & OPpTRUEBOOL)
602 || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL)
603 && block_gimme() == G_VOID))
605 /* refs are always true - unless it's to an object blessed into a
606 * class with a false name, i.e. "0". So we have to check for
607 * that remote possibility. The following is is basically an
608 * unrolled SvTRUE(sv_reftype(rv)) */
609 SV * const rv = SvRV(sv);
611 HV *stash = SvSTASH(rv);
612 HEK *hek = HvNAME_HEK(stash);
614 I32 len = HEK_LEN(hek);
615 /* bail out and do it the hard way? */
618 || (len == 1 && HEK_KEY(hek)[0] == '0')
631 sv_ref(TARG, SvRV(sv), TRUE);
632 assert(!SvSMAGICAL(TARG));
647 stash = CopSTASH(PL_curcop);
648 if (SvTYPE(stash) != SVt_PVHV)
649 Perl_croak(aTHX_ "Attempt to bless into a freed package");
652 SV * const ssv = POPs;
656 if (!ssv) goto curstash;
659 if (!SvAMAGIC(ssv)) {
661 Perl_croak(aTHX_ "Attempt to bless into a reference");
663 /* SvAMAGIC is on here, but it only means potentially overloaded,
664 so after stringification: */
665 ptr = SvPV_nomg_const(ssv,len);
666 /* We need to check the flag again: */
667 if (!SvAMAGIC(ssv)) goto frog;
669 else ptr = SvPV_nomg_const(ssv,len);
671 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
672 "Explicit blessing to '' (assuming package main)");
673 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
676 (void)sv_bless(TOPs, stash);
686 const char * const elem = SvPV_const(sv, len);
687 GV * const gv = MUTABLE_GV(TOPs);
692 /* elem will always be NUL terminated. */
695 if (memEQs(elem, len, "ARRAY"))
697 tmpRef = MUTABLE_SV(GvAV(gv));
698 if (tmpRef && !AvREAL((const AV *)tmpRef)
699 && AvREIFY((const AV *)tmpRef))
700 av_reify(MUTABLE_AV(tmpRef));
704 if (memEQs(elem, len, "CODE"))
705 tmpRef = MUTABLE_SV(GvCVu(gv));
708 if (memEQs(elem, len, "FILEHANDLE")) {
709 tmpRef = MUTABLE_SV(GvIOp(gv));
712 if (memEQs(elem, len, "FORMAT"))
713 tmpRef = MUTABLE_SV(GvFORM(gv));
716 if (memEQs(elem, len, "GLOB"))
717 tmpRef = MUTABLE_SV(gv);
720 if (memEQs(elem, len, "HASH"))
721 tmpRef = MUTABLE_SV(GvHV(gv));
724 if (memEQs(elem, len, "IO"))
725 tmpRef = MUTABLE_SV(GvIOp(gv));
728 if (memEQs(elem, len, "NAME"))
729 sv = newSVhek(GvNAME_HEK(gv));
732 if (memEQs(elem, len, "PACKAGE")) {
733 const HV * const stash = GvSTASH(gv);
734 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
735 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
739 if (memEQs(elem, len, "SCALAR"))
754 /* Pattern matching */
762 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
763 /* Historically, study was skipped in these cases. */
768 /* Make study a no-op. It's no longer useful and its existence
769 complicates matters elsewhere. */
775 /* also used for: pp_transr() */
782 if (PL_op->op_flags & OPf_STACKED)
787 sv = PAD_SV(ARGTARG);
792 if(PL_op->op_type == OP_TRANSR) {
794 const char * const pv = SvPV(sv,len);
795 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
800 I32 i = do_trans(sv);
806 /* Lvalue operators. */
809 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
815 PERL_ARGS_ASSERT_DO_CHOMP;
817 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
819 if (SvTYPE(sv) == SVt_PVAV) {
821 AV *const av = MUTABLE_AV(sv);
822 const I32 max = AvFILL(av);
824 for (i = 0; i <= max; i++) {
825 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
826 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
827 count += do_chomp(retval, sv, chomping);
831 else if (SvTYPE(sv) == SVt_PVHV) {
832 HV* const hv = MUTABLE_HV(sv);
834 (void)hv_iterinit(hv);
835 while ((entry = hv_iternext(hv)))
836 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
839 else if (SvREADONLY(sv)) {
840 Perl_croak_no_modify();
846 char *temp_buffer = NULL;
851 goto nope_free_nothing;
853 while (len && s[-1] == '\n') {
860 STRLEN rslen, rs_charlen;
861 const char *rsptr = SvPV_const(PL_rs, rslen);
863 rs_charlen = SvUTF8(PL_rs)
867 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
868 /* Assumption is that rs is shorter than the scalar. */
870 /* RS is utf8, scalar is 8 bit. */
872 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
875 /* Cannot downgrade, therefore cannot possibly match.
876 At this point, temp_buffer is not alloced, and
877 is the buffer inside PL_rs, so dont free it.
879 assert (temp_buffer == rsptr);
885 /* RS is 8 bit, scalar is utf8. */
886 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
900 if (memNE(s, rsptr, rslen))
905 SvPV_force_nomg_nolen(sv);
912 Safefree(temp_buffer);
914 SvREFCNT_dec(svrecode);
918 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
919 s = SvPV_force_nomg(sv, len);
922 char * const send = s + len;
923 char * const start = s;
925 while (s > start && UTF8_IS_CONTINUATION(*s))
927 if (is_utf8_string((U8*)s, send - s)) {
928 sv_setpvn(retval, s, send - s);
930 SvCUR_set(sv, s - start);
940 sv_setpvn(retval, s, 1);
954 /* also used for: pp_schomp() */
959 const bool chomping = PL_op->op_type == OP_SCHOMP;
961 const size_t count = do_chomp(TARG, TOPs, chomping);
963 sv_setiv(TARG, count);
969 /* also used for: pp_chomp() */
973 dSP; dMARK; dTARGET; dORIGMARK;
974 const bool chomping = PL_op->op_type == OP_CHOMP;
978 count += do_chomp(TARG, *++MARK, chomping);
980 sv_setiv(TARG, count);
991 if (!PL_op->op_private) {
1003 if (SvTHINKFIRST(sv))
1004 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
1006 switch (SvTYPE(sv)) {
1010 av_undef(MUTABLE_AV(sv));
1013 hv_undef(MUTABLE_HV(sv));
1016 if (cv_const_sv((const CV *)sv))
1017 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1018 "Constant subroutine %" SVf " undefined",
1019 SVfARG(CvANON((const CV *)sv)
1020 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1021 : sv_2mortal(newSVhek(
1023 ? CvNAME_HEK((CV *)sv)
1024 : GvENAME_HEK(CvGV((const CV *)sv))
1029 /* let user-undef'd sub keep its identity */
1030 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1033 assert(isGV_with_GP(sv));
1034 assert(!SvFAKE(sv));
1039 /* undef *Pkg::meth_name ... */
1041 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1042 && HvENAME_get(stash);
1044 if((stash = GvHV((const GV *)sv))) {
1045 if(HvENAME_get(stash))
1046 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1050 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1051 gp_free(MUTABLE_GV(sv));
1053 GvGP_set(sv, gp_ref(gp));
1054 #ifndef PERL_DONT_CREATE_GVSV
1055 GvSV(sv) = newSV(0);
1057 GvLINE(sv) = CopLINE(PL_curcop);
1058 GvEGV(sv) = MUTABLE_GV(sv);
1062 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1064 /* undef *Foo::ISA */
1065 if( strEQ(GvNAME((const GV *)sv), "ISA")
1066 && (stash = GvSTASH((const GV *)sv))
1067 && (method_changed || HvENAME(stash)) )
1068 mro_isa_changed_in(stash);
1069 else if(method_changed)
1070 mro_method_changed_in(
1071 GvSTASH((const GV *)sv)
1077 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1091 /* common "slow" code for pp_postinc and pp_postdec */
1094 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1098 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1101 TARG = sv_newmortal();
1108 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1109 if (inc && !SvOK(TARG))
1116 /* also used for: pp_i_postinc() */
1123 /* special-case sv being a simple integer */
1124 if (LIKELY(((sv->sv_flags &
1125 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1126 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1128 && SvIVX(sv) != IV_MAX)
1131 SvIV_set(sv, iv + 1);
1132 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1137 return S_postincdec_common(aTHX_ sv, TARG);
1141 /* also used for: pp_i_postdec() */
1148 /* special-case sv being a simple integer */
1149 if (LIKELY(((sv->sv_flags &
1150 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1151 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1153 && SvIVX(sv) != IV_MIN)
1156 SvIV_set(sv, iv - 1);
1157 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1162 return S_postincdec_common(aTHX_ sv, TARG);
1166 /* Ordinary operators. */
1170 dSP; dATARGET; SV *svl, *svr;
1171 #ifdef PERL_PRESERVE_IVUV
1174 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1177 #ifdef PERL_PRESERVE_IVUV
1178 /* For integer to integer power, we do the calculation by hand wherever
1179 we're sure it is safe; otherwise we call pow() and try to convert to
1180 integer afterwards. */
1181 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1189 const IV iv = SvIVX(svr);
1193 goto float_it; /* Can't do negative powers this way. */
1197 baseuok = SvUOK(svl);
1199 baseuv = SvUVX(svl);
1201 const IV iv = SvIVX(svl);
1204 baseuok = TRUE; /* effectively it's a UV now */
1206 baseuv = -iv; /* abs, baseuok == false records sign */
1209 /* now we have integer ** positive integer. */
1212 /* foo & (foo - 1) is zero only for a power of 2. */
1213 if (!(baseuv & (baseuv - 1))) {
1214 /* We are raising power-of-2 to a positive integer.
1215 The logic here will work for any base (even non-integer
1216 bases) but it can be less accurate than
1217 pow (base,power) or exp (power * log (base)) when the
1218 intermediate values start to spill out of the mantissa.
1219 With powers of 2 we know this can't happen.
1220 And powers of 2 are the favourite thing for perl
1221 programmers to notice ** not doing what they mean. */
1223 NV base = baseuok ? baseuv : -(NV)baseuv;
1228 while (power >>= 1) {
1236 SvIV_please_nomg(svr);
1239 unsigned int highbit = 8 * sizeof(UV);
1240 unsigned int diff = 8 * sizeof(UV);
1241 while (diff >>= 1) {
1243 if (baseuv >> highbit) {
1247 /* we now have baseuv < 2 ** highbit */
1248 if (power * highbit <= 8 * sizeof(UV)) {
1249 /* result will definitely fit in UV, so use UV math
1250 on same algorithm as above */
1253 const bool odd_power = cBOOL(power & 1);
1257 while (power >>= 1) {
1264 if (baseuok || !odd_power)
1265 /* answer is positive */
1267 else if (result <= (UV)IV_MAX)
1268 /* answer negative, fits in IV */
1269 SETi( -(IV)result );
1270 else if (result == (UV)IV_MIN)
1271 /* 2's complement assumption: special case IV_MIN */
1274 /* answer negative, doesn't fit */
1275 SETn( -(NV)result );
1283 NV right = SvNV_nomg(svr);
1284 NV left = SvNV_nomg(svl);
1287 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1289 We are building perl with long double support and are on an AIX OS
1290 afflicted with a powl() function that wrongly returns NaNQ for any
1291 negative base. This was reported to IBM as PMR #23047-379 on
1292 03/06/2006. The problem exists in at least the following versions
1293 of AIX and the libm fileset, and no doubt others as well:
1295 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1296 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1297 AIX 5.2.0 bos.adt.libm 5.2.0.85
1299 So, until IBM fixes powl(), we provide the following workaround to
1300 handle the problem ourselves. Our logic is as follows: for
1301 negative bases (left), we use fmod(right, 2) to check if the
1302 exponent is an odd or even integer:
1304 - if odd, powl(left, right) == -powl(-left, right)
1305 - if even, powl(left, right) == powl(-left, right)
1307 If the exponent is not an integer, the result is rightly NaNQ, so
1308 we just return that (as NV_NAN).
1312 NV mod2 = Perl_fmod( right, 2.0 );
1313 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1314 SETn( -Perl_pow( -left, right) );
1315 } else if (mod2 == 0.0) { /* even integer */
1316 SETn( Perl_pow( -left, right) );
1317 } else { /* fractional power */
1321 SETn( Perl_pow( left, right) );
1324 SETn( Perl_pow( left, right) );
1325 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1327 #ifdef PERL_PRESERVE_IVUV
1329 SvIV_please_nomg(svr);
1337 dSP; dATARGET; SV *svl, *svr;
1338 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1342 #ifdef PERL_PRESERVE_IVUV
1344 /* special-case some simple common cases */
1345 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1347 U32 flags = (svl->sv_flags & svr->sv_flags);
1348 if (flags & SVf_IOK) {
1349 /* both args are simple IVs */
1354 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1355 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1357 /* if both are in a range that can't under/overflow, do a
1358 * simple integer multiply: if the top halves(*) of both numbers
1359 * are 00...00 or 11...11, then it's safe.
1360 * (*) for 32-bits, the "top half" is the top 17 bits,
1361 * for 64-bits, its 33 bits */
1363 ((topl+1) | (topr+1))
1364 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1367 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1373 else if (flags & SVf_NOK) {
1374 /* both args are NVs */
1380 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1381 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1382 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1384 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1387 /* nothing was lost by converting to IVs */
1391 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1392 if (Perl_isinf(result)) {
1393 Zero((U8*)&result + 8, 8, U8);
1396 TARGn(result, 0); /* args not GMG, so can't be tainted */
1404 if (SvIV_please_nomg(svr)) {
1405 /* Unless the left argument is integer in range we are going to have to
1406 use NV maths. Hence only attempt to coerce the right argument if
1407 we know the left is integer. */
1408 /* Left operand is defined, so is it IV? */
1409 if (SvIV_please_nomg(svl)) {
1410 bool auvok = SvUOK(svl);
1411 bool buvok = SvUOK(svr);
1412 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1413 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1422 const IV aiv = SvIVX(svl);
1425 auvok = TRUE; /* effectively it's a UV now */
1427 /* abs, auvok == false records sign */
1428 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1434 const IV biv = SvIVX(svr);
1437 buvok = TRUE; /* effectively it's a UV now */
1439 /* abs, buvok == false records sign */
1440 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1444 /* If this does sign extension on unsigned it's time for plan B */
1445 ahigh = alow >> (4 * sizeof (UV));
1447 bhigh = blow >> (4 * sizeof (UV));
1449 if (ahigh && bhigh) {
1451 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1452 which is overflow. Drop to NVs below. */
1453 } else if (!ahigh && !bhigh) {
1454 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1455 so the unsigned multiply cannot overflow. */
1456 const UV product = alow * blow;
1457 if (auvok == buvok) {
1458 /* -ve * -ve or +ve * +ve gives a +ve result. */
1462 } else if (product <= (UV)IV_MIN) {
1463 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1464 /* -ve result, which could overflow an IV */
1466 /* can't negate IV_MIN, but there are aren't two
1467 * integers such that !ahigh && !bhigh, where the
1468 * product equals 0x800....000 */
1469 assert(product != (UV)IV_MIN);
1470 SETi( -(IV)product );
1472 } /* else drop to NVs below. */
1474 /* One operand is large, 1 small */
1477 /* swap the operands */
1479 bhigh = blow; /* bhigh now the temp var for the swap */
1483 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1484 multiplies can't overflow. shift can, add can, -ve can. */
1485 product_middle = ahigh * blow;
1486 if (!(product_middle & topmask)) {
1487 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1489 product_middle <<= (4 * sizeof (UV));
1490 product_low = alow * blow;
1492 /* as for pp_add, UV + something mustn't get smaller.
1493 IIRC ANSI mandates this wrapping *behaviour* for
1494 unsigned whatever the actual representation*/
1495 product_low += product_middle;
1496 if (product_low >= product_middle) {
1497 /* didn't overflow */
1498 if (auvok == buvok) {
1499 /* -ve * -ve or +ve * +ve gives a +ve result. */
1501 SETu( product_low );
1503 } else if (product_low <= (UV)IV_MIN) {
1504 /* 2s complement assumption again */
1505 /* -ve result, which could overflow an IV */
1507 SETi(product_low == (UV)IV_MIN
1508 ? IV_MIN : -(IV)product_low);
1510 } /* else drop to NVs below. */
1512 } /* product_middle too large */
1513 } /* ahigh && bhigh */
1518 NV right = SvNV_nomg(svr);
1519 NV left = SvNV_nomg(svl);
1520 NV result = left * right;
1523 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1524 if (Perl_isinf(result)) {
1525 Zero((U8*)&result + 8, 8, U8);
1535 dSP; dATARGET; SV *svl, *svr;
1536 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1539 /* Only try to do UV divide first
1540 if ((SLOPPYDIVIDE is true) or
1541 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1543 The assumption is that it is better to use floating point divide
1544 whenever possible, only doing integer divide first if we can't be sure.
1545 If NV_PRESERVES_UV is true then we know at compile time that no UV
1546 can be too large to preserve, so don't need to compile the code to
1547 test the size of UVs. */
1550 # define PERL_TRY_UV_DIVIDE
1551 /* ensure that 20./5. == 4. */
1553 # ifdef PERL_PRESERVE_IVUV
1554 # ifndef NV_PRESERVES_UV
1555 # define PERL_TRY_UV_DIVIDE
1560 #ifdef PERL_TRY_UV_DIVIDE
1561 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1562 bool left_non_neg = SvUOK(svl);
1563 bool right_non_neg = SvUOK(svr);
1567 if (right_non_neg) {
1571 const IV biv = SvIVX(svr);
1574 right_non_neg = TRUE; /* effectively it's a UV now */
1577 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1580 /* historically undef()/0 gives a "Use of uninitialized value"
1581 warning before dieing, hence this test goes here.
1582 If it were immediately before the second SvIV_please, then
1583 DIE() would be invoked before left was even inspected, so
1584 no inspection would give no warning. */
1586 DIE(aTHX_ "Illegal division by zero");
1592 const IV aiv = SvIVX(svl);
1595 left_non_neg = TRUE; /* effectively it's a UV now */
1598 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1604 /* For sloppy divide we always attempt integer division. */
1606 /* Otherwise we only attempt it if either or both operands
1607 would not be preserved by an NV. If both fit in NVs
1608 we fall through to the NV divide code below. However,
1609 as left >= right to ensure integer result here, we know that
1610 we can skip the test on the right operand - right big
1611 enough not to be preserved can't get here unless left is
1614 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1617 /* Integer division can't overflow, but it can be imprecise. */
1618 const UV result = left / right;
1619 if (result * right == left) {
1620 SP--; /* result is valid */
1621 if (left_non_neg == right_non_neg) {
1622 /* signs identical, result is positive. */
1626 /* 2s complement assumption */
1627 if (result <= (UV)IV_MIN)
1628 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1630 /* It's exact but too negative for IV. */
1631 SETn( -(NV)result );
1634 } /* tried integer divide but it was not an integer result */
1635 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1636 } /* one operand wasn't SvIOK */
1637 #endif /* PERL_TRY_UV_DIVIDE */
1639 NV right = SvNV_nomg(svr);
1640 NV left = SvNV_nomg(svl);
1641 (void)POPs;(void)POPs;
1642 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1643 if (! Perl_isnan(right) && right == 0.0)
1647 DIE(aTHX_ "Illegal division by zero");
1648 PUSHn( left / right );
1656 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1660 bool left_neg = FALSE;
1661 bool right_neg = FALSE;
1662 bool use_double = FALSE;
1663 bool dright_valid = FALSE;
1666 SV * const svr = TOPs;
1667 SV * const svl = TOPm1s;
1668 if (SvIV_please_nomg(svr)) {
1669 right_neg = !SvUOK(svr);
1673 const IV biv = SvIVX(svr);
1676 right_neg = FALSE; /* effectively it's a UV now */
1678 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1683 dright = SvNV_nomg(svr);
1684 right_neg = dright < 0;
1687 if (dright < UV_MAX_P1) {
1688 right = U_V(dright);
1689 dright_valid = TRUE; /* In case we need to use double below. */
1695 /* At this point use_double is only true if right is out of range for
1696 a UV. In range NV has been rounded down to nearest UV and
1697 use_double false. */
1698 if (!use_double && SvIV_please_nomg(svl)) {
1699 left_neg = !SvUOK(svl);
1703 const IV aiv = SvIVX(svl);
1706 left_neg = FALSE; /* effectively it's a UV now */
1708 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1713 dleft = SvNV_nomg(svl);
1714 left_neg = dleft < 0;
1718 /* This should be exactly the 5.6 behaviour - if left and right are
1719 both in range for UV then use U_V() rather than floor. */
1721 if (dleft < UV_MAX_P1) {
1722 /* right was in range, so is dleft, so use UVs not double.
1726 /* left is out of range for UV, right was in range, so promote
1727 right (back) to double. */
1729 /* The +0.5 is used in 5.6 even though it is not strictly
1730 consistent with the implicit +0 floor in the U_V()
1731 inside the #if 1. */
1732 dleft = Perl_floor(dleft + 0.5);
1735 dright = Perl_floor(dright + 0.5);
1746 DIE(aTHX_ "Illegal modulus zero");
1748 dans = Perl_fmod(dleft, dright);
1749 if ((left_neg != right_neg) && dans)
1750 dans = dright - dans;
1753 sv_setnv(TARG, dans);
1759 DIE(aTHX_ "Illegal modulus zero");
1762 if ((left_neg != right_neg) && ans)
1765 /* XXX may warn: unary minus operator applied to unsigned type */
1766 /* could change -foo to be (~foo)+1 instead */
1767 if (ans <= ~((UV)IV_MAX)+1)
1768 sv_setiv(TARG, ~ans+1);
1770 sv_setnv(TARG, -(NV)ans);
1773 sv_setuv(TARG, ans);
1785 bool infnan = FALSE;
1787 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1788 /* TODO: think of some way of doing list-repeat overloading ??? */
1793 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1794 /* The parser saw this as a list repeat, and there
1795 are probably several items on the stack. But we're
1796 in scalar/void context, and there's no pp_list to save us
1797 now. So drop the rest of the items -- robin@kitsite.com
1800 if (MARK + 1 < SP) {
1806 ASSUME(MARK + 1 == SP);
1808 MARK[1] = &PL_sv_undef;
1812 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1818 const UV uv = SvUV_nomg(sv);
1820 count = IV_MAX; /* The best we can do? */
1824 count = SvIV_nomg(sv);
1827 else if (SvNOKp(sv)) {
1828 const NV nv = SvNV_nomg(sv);
1829 infnan = Perl_isinfnan(nv);
1830 if (UNLIKELY(infnan)) {
1834 count = -1; /* An arbitrary negative integer */
1840 count = SvIV_nomg(sv);
1843 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1844 "Non-finite repeat count does nothing");
1845 } else if (count < 0) {
1847 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1848 "Negative repeat count does nothing");
1851 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1853 const SSize_t items = SP - MARK;
1854 const U8 mod = PL_op->op_flags & OPf_MOD;
1859 if ( items > SSize_t_MAX / count /* max would overflow */
1860 /* repeatcpy would overflow */
1861 || items > I32_MAX / (I32)sizeof(SV *)
1863 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1864 max = items * count;
1869 if (mod && SvPADTMP(*SP)) {
1870 *SP = sv_mortalcopy(*SP);
1877 repeatcpy((char*)(MARK + items), (char*)MARK,
1878 items * sizeof(const SV *), count - 1);
1881 else if (count <= 0)
1884 else { /* Note: mark already snarfed by pp_list */
1885 SV * const tmpstr = POPs;
1890 sv_setsv_nomg(TARG, tmpstr);
1891 SvPV_force_nomg(TARG, len);
1892 isutf = DO_UTF8(TARG);
1899 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1900 || len > (U32)I32_MAX /* repeatcpy would overflow */
1902 Perl_croak(aTHX_ "%s",
1903 "Out of memory during string extend");
1904 max = (UV)count * len + 1;
1907 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1908 SvCUR_set(TARG, SvCUR(TARG) * count);
1910 *SvEND(TARG) = '\0';
1913 (void)SvPOK_only_UTF8(TARG);
1915 (void)SvPOK_only(TARG);
1924 dSP; dATARGET; bool useleft; SV *svl, *svr;
1925 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1929 #ifdef PERL_PRESERVE_IVUV
1931 /* special-case some simple common cases */
1932 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1934 U32 flags = (svl->sv_flags & svr->sv_flags);
1935 if (flags & SVf_IOK) {
1936 /* both args are simple IVs */
1941 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1942 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1944 /* if both are in a range that can't under/overflow, do a
1945 * simple integer subtract: if the top of both numbers
1946 * are 00 or 11, then it's safe */
1947 if (!( ((topl+1) | (topr+1)) & 2)) {
1949 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1955 else if (flags & SVf_NOK) {
1956 /* both args are NVs */
1961 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1962 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1963 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1965 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1968 /* nothing was lost by converting to IVs */
1971 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1979 useleft = USE_LEFT(svl);
1980 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1981 "bad things" happen if you rely on signed integers wrapping. */
1982 if (SvIV_please_nomg(svr)) {
1983 /* Unless the left argument is integer in range we are going to have to
1984 use NV maths. Hence only attempt to coerce the right argument if
1985 we know the left is integer. */
1992 a_valid = auvok = 1;
1993 /* left operand is undef, treat as zero. */
1995 /* Left operand is defined, so is it IV? */
1996 if (SvIV_please_nomg(svl)) {
1997 if ((auvok = SvUOK(svl)))
2000 const IV aiv = SvIVX(svl);
2003 auvok = 1; /* Now acting as a sign flag. */
2004 } else { /* 2s complement assumption for IV_MIN */
2005 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
2012 bool result_good = 0;
2015 bool buvok = SvUOK(svr);
2020 const IV biv = SvIVX(svr);
2025 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
2027 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
2028 else "IV" now, independent of how it came in.
2029 if a, b represents positive, A, B negative, a maps to -A etc
2034 all UV maths. negate result if A negative.
2035 subtract if signs same, add if signs differ. */
2037 if (auvok ^ buvok) {
2046 /* Must get smaller */
2051 if (result <= buv) {
2052 /* result really should be -(auv-buv). as its negation
2053 of true value, need to swap our result flag */
2065 if (result <= (UV)IV_MIN)
2066 SETi(result == (UV)IV_MIN
2067 ? IV_MIN : -(IV)result);
2069 /* result valid, but out of range for IV. */
2070 SETn( -(NV)result );
2074 } /* Overflow, drop through to NVs. */
2078 useleft = USE_LEFT(svl);
2081 NV value = SvNV_nomg(svr);
2085 /* left operand is undef, treat as zero - value */
2089 SETn( SvNV_nomg(svl) - value );
2094 #define IV_BITS (IVSIZE * 8)
2096 static UV S_uv_shift(UV uv, int shift, bool left)
2102 if (shift >= IV_BITS) {
2105 return left ? uv << shift : uv >> shift;
2108 static IV S_iv_shift(IV iv, int shift, bool left)
2114 if (shift >= IV_BITS) {
2115 return iv < 0 && !left ? -1 : 0;
2117 return left ? iv << shift : iv >> shift;
2120 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2121 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2122 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2123 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2127 dSP; dATARGET; SV *svl, *svr;
2128 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2132 const IV shift = SvIV_nomg(svr);
2133 if (PL_op->op_private & HINT_INTEGER) {
2134 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2137 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2145 dSP; dATARGET; SV *svl, *svr;
2146 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2150 const IV shift = SvIV_nomg(svr);
2151 if (PL_op->op_private & HINT_INTEGER) {
2152 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2155 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2166 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2170 (SvIOK_notUV(left) && SvIOK_notUV(right))
2171 ? (SvIVX(left) < SvIVX(right))
2172 : (do_ncmp(left, right) == -1)
2182 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2186 (SvIOK_notUV(left) && SvIOK_notUV(right))
2187 ? (SvIVX(left) > SvIVX(right))
2188 : (do_ncmp(left, right) == 1)
2198 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2202 (SvIOK_notUV(left) && SvIOK_notUV(right))
2203 ? (SvIVX(left) <= SvIVX(right))
2204 : (do_ncmp(left, right) <= 0)
2214 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2218 (SvIOK_notUV(left) && SvIOK_notUV(right))
2219 ? (SvIVX(left) >= SvIVX(right))
2220 : ( (do_ncmp(left, right) & 2) == 0)
2230 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2234 (SvIOK_notUV(left) && SvIOK_notUV(right))
2235 ? (SvIVX(left) != SvIVX(right))
2236 : (do_ncmp(left, right) != 0)
2241 /* compare left and right SVs. Returns:
2245 * 2: left or right was a NaN
2248 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2250 PERL_ARGS_ASSERT_DO_NCMP;
2251 #ifdef PERL_PRESERVE_IVUV
2252 /* Fortunately it seems NaN isn't IOK */
2253 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2255 const IV leftiv = SvIVX(left);
2256 if (!SvUOK(right)) {
2257 /* ## IV <=> IV ## */
2258 const IV rightiv = SvIVX(right);
2259 return (leftiv > rightiv) - (leftiv < rightiv);
2261 /* ## IV <=> UV ## */
2263 /* As (b) is a UV, it's >=0, so it must be < */
2266 const UV rightuv = SvUVX(right);
2267 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2272 /* ## UV <=> UV ## */
2273 const UV leftuv = SvUVX(left);
2274 const UV rightuv = SvUVX(right);
2275 return (leftuv > rightuv) - (leftuv < rightuv);
2277 /* ## UV <=> IV ## */
2279 const IV rightiv = SvIVX(right);
2281 /* As (a) is a UV, it's >=0, so it cannot be < */
2284 const UV leftuv = SvUVX(left);
2285 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2288 NOT_REACHED; /* NOTREACHED */
2292 NV const rnv = SvNV_nomg(right);
2293 NV const lnv = SvNV_nomg(left);
2295 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2296 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2299 return (lnv > rnv) - (lnv < rnv);
2318 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2321 value = do_ncmp(left, right);
2333 /* also used for: pp_sge() pp_sgt() pp_slt() */
2339 int amg_type = sle_amg;
2343 switch (PL_op->op_type) {
2362 tryAMAGICbin_MG(amg_type, AMGf_set);
2366 #ifdef USE_LOCALE_COLLATE
2367 (IN_LC_RUNTIME(LC_COLLATE))
2368 ? sv_cmp_locale_flags(left, right, 0)
2371 sv_cmp_flags(left, right, 0);
2372 SETs(boolSV(cmp * multiplier < rhs));
2380 tryAMAGICbin_MG(seq_amg, AMGf_set);
2383 SETs(boolSV(sv_eq_flags(left, right, 0)));
2391 tryAMAGICbin_MG(sne_amg, AMGf_set);
2394 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2402 tryAMAGICbin_MG(scmp_amg, 0);
2406 #ifdef USE_LOCALE_COLLATE
2407 (IN_LC_RUNTIME(LC_COLLATE))
2408 ? sv_cmp_locale_flags(left, right, 0)
2411 sv_cmp_flags(left, right, 0);
2420 tryAMAGICbin_MG(band_amg, AMGf_assign);
2423 if (SvNIOKp(left) || SvNIOKp(right)) {
2424 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2425 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2426 if (PL_op->op_private & HINT_INTEGER) {
2427 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2431 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2434 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2435 if (right_ro_nonnum) SvNIOK_off(right);
2438 do_vop(PL_op->op_type, TARG, left, right);
2448 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2450 dATARGET; dPOPTOPssrl;
2451 if (PL_op->op_private & HINT_INTEGER) {
2452 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2456 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2466 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2468 dATARGET; dPOPTOPssrl;
2469 do_vop(OP_BIT_AND, TARG, left, right);
2474 /* also used for: pp_bit_xor() */
2479 const int op_type = PL_op->op_type;
2481 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2484 if (SvNIOKp(left) || SvNIOKp(right)) {
2485 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2486 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2487 if (PL_op->op_private & HINT_INTEGER) {
2488 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2489 const IV r = SvIV_nomg(right);
2490 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2494 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2495 const UV r = SvUV_nomg(right);
2496 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2499 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2500 if (right_ro_nonnum) SvNIOK_off(right);
2503 do_vop(op_type, TARG, left, right);
2510 /* also used for: pp_nbit_xor() */
2515 const int op_type = PL_op->op_type;
2517 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2518 AMGf_assign|AMGf_numarg);
2520 dATARGET; dPOPTOPssrl;
2521 if (PL_op->op_private & HINT_INTEGER) {
2522 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2523 const IV r = SvIV_nomg(right);
2524 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2528 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2529 const UV r = SvUV_nomg(right);
2530 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2537 /* also used for: pp_sbit_xor() */
2542 const int op_type = PL_op->op_type;
2544 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2547 dATARGET; dPOPTOPssrl;
2548 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2554 PERL_STATIC_INLINE bool
2555 S_negate_string(pTHX)
2560 SV * const sv = TOPs;
2561 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2563 s = SvPV_nomg_const(sv, len);
2564 if (isIDFIRST(*s)) {
2565 sv_setpvs(TARG, "-");
2568 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2569 sv_setsv_nomg(TARG, sv);
2570 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2580 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2581 if (S_negate_string(aTHX)) return NORMAL;
2583 SV * const sv = TOPs;
2586 /* It's publicly an integer */
2589 if (SvIVX(sv) == IV_MIN) {
2590 /* 2s complement assumption. */
2591 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2595 else if (SvUVX(sv) <= IV_MAX) {
2600 else if (SvIVX(sv) != IV_MIN) {
2604 #ifdef PERL_PRESERVE_IVUV
2611 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2612 SETn(-SvNV_nomg(sv));
2613 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2614 goto oops_its_an_int;
2616 SETn(-SvNV_nomg(sv));
2624 tryAMAGICun_MG(not_amg, AMGf_set);
2625 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2630 S_scomplement(pTHX_ SV *targ, SV *sv)
2636 sv_copypv_nomg(TARG, sv);
2637 tmps = (U8*)SvPV_nomg(TARG, len);
2640 /* Calculate exact length, let's not estimate. */
2644 U8 * const send = tmps + len;
2645 U8 * const origtmps = tmps;
2646 const UV utf8flags = UTF8_ALLOW_ANYUV;
2650 while (tmps < send) {
2651 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2653 targlen += UVCHR_SKIP(~c);
2657 fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
2660 /* Now rewind strings and write them. */
2663 Newx(result, nchar + 1, U8);
2665 while (tmps < send) {
2666 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2671 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2678 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2681 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2686 for ( ; anum > 0; anum--, tmps++)
2693 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2697 if (PL_op->op_private & HINT_INTEGER) {
2698 const IV i = ~SvIV_nomg(sv);
2702 const UV u = ~SvUV_nomg(sv);
2707 S_scomplement(aTHX_ TARG, sv);
2717 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2720 if (PL_op->op_private & HINT_INTEGER) {
2721 const IV i = ~SvIV_nomg(sv);
2725 const UV u = ~SvUV_nomg(sv);
2735 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2738 S_scomplement(aTHX_ TARG, sv);
2744 /* integer versions of some of the above */
2749 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2752 SETi( left * right );
2761 tryAMAGICbin_MG(div_amg, AMGf_assign);
2764 IV value = SvIV_nomg(right);
2766 DIE(aTHX_ "Illegal division by zero");
2767 num = SvIV_nomg(left);
2769 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2773 value = num / value;
2781 /* This is the vanilla old i_modulo. */
2783 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2787 DIE(aTHX_ "Illegal modulus zero");
2788 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2792 SETi( left % right );
2797 #if defined(__GLIBC__) && IVSIZE == 8 \
2798 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2800 PP(pp_i_modulo_glibc_bugfix)
2802 /* This is the i_modulo with the workaround for the _moddi3 bug
2803 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2804 * See below for pp_i_modulo. */
2806 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2810 DIE(aTHX_ "Illegal modulus zero");
2811 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2815 SETi( left % PERL_ABS(right) );
2824 tryAMAGICbin_MG(add_amg, AMGf_assign);
2826 dPOPTOPiirl_ul_nomg;
2827 SETi( left + right );
2835 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2837 dPOPTOPiirl_ul_nomg;
2838 SETi( left - right );
2846 tryAMAGICbin_MG(lt_amg, AMGf_set);
2849 SETs(boolSV(left < right));
2857 tryAMAGICbin_MG(gt_amg, AMGf_set);
2860 SETs(boolSV(left > right));
2868 tryAMAGICbin_MG(le_amg, AMGf_set);
2871 SETs(boolSV(left <= right));
2879 tryAMAGICbin_MG(ge_amg, AMGf_set);
2882 SETs(boolSV(left >= right));
2890 tryAMAGICbin_MG(eq_amg, AMGf_set);
2893 SETs(boolSV(left == right));
2901 tryAMAGICbin_MG(ne_amg, AMGf_set);
2904 SETs(boolSV(left != right));
2912 tryAMAGICbin_MG(ncmp_amg, 0);
2919 else if (left < right)
2931 tryAMAGICun_MG(neg_amg, 0);
2932 if (S_negate_string(aTHX)) return NORMAL;
2934 SV * const sv = TOPs;
2935 IV const i = SvIV_nomg(sv);
2941 /* High falutin' math. */
2946 tryAMAGICbin_MG(atan2_amg, 0);
2949 SETn(Perl_atan2(left, right));
2955 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2960 int amg_type = fallback_amg;
2961 const char *neg_report = NULL;
2962 const int op_type = PL_op->op_type;
2965 case OP_SIN: amg_type = sin_amg; break;
2966 case OP_COS: amg_type = cos_amg; break;
2967 case OP_EXP: amg_type = exp_amg; break;
2968 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2969 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2972 assert(amg_type != fallback_amg);
2974 tryAMAGICun_MG(amg_type, 0);
2976 SV * const arg = TOPs;
2977 const NV value = SvNV_nomg(arg);
2983 if (neg_report) { /* log or sqrt */
2985 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2986 ! Perl_isnan(value) &&
2988 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2989 SET_NUMERIC_STANDARD();
2990 /* diag_listed_as: Can't take log of %g */
2991 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2996 case OP_SIN: result = Perl_sin(value); break;
2997 case OP_COS: result = Perl_cos(value); break;
2998 case OP_EXP: result = Perl_exp(value); break;
2999 case OP_LOG: result = Perl_log(value); break;
3000 case OP_SQRT: result = Perl_sqrt(value); break;
3007 /* Support Configure command-line overrides for rand() functions.
3008 After 5.005, perhaps we should replace this by Configure support
3009 for drand48(), random(), or rand(). For 5.005, though, maintain
3010 compatibility by calling rand() but allow the user to override it.
3011 See INSTALL for details. --Andy Dougherty 15 July 1998
3013 /* Now it's after 5.005, and Configure supports drand48() and random(),
3014 in addition to rand(). So the overrides should not be needed any more.
3015 --Jarkko Hietaniemi 27 September 1998
3020 if (!PL_srand_called) {
3021 (void)seedDrand01((Rand_seed_t)seed());
3022 PL_srand_called = TRUE;
3034 SV * const sv = POPs;
3040 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3041 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3042 if (! Perl_isnan(value) && value == 0.0)
3052 sv_setnv_mg(TARG, value);
3063 if (MAXARG >= 1 && (TOPs || POPs)) {
3070 pv = SvPV(top, len);
3071 flags = grok_number(pv, len, &anum);
3073 if (!(flags & IS_NUMBER_IN_UV)) {
3074 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3075 "Integer overflow in srand");
3083 (void)seedDrand01((Rand_seed_t)anum);
3084 PL_srand_called = TRUE;
3088 /* Historically srand always returned true. We can avoid breaking
3090 sv_setpvs(TARG, "0 but true");
3099 tryAMAGICun_MG(int_amg, AMGf_numeric);
3101 SV * const sv = TOPs;
3102 const IV iv = SvIV_nomg(sv);
3103 /* XXX it's arguable that compiler casting to IV might be subtly
3104 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3105 else preferring IV has introduced a subtle behaviour change bug. OTOH
3106 relying on floating point to be accurate is a bug. */
3111 else if (SvIOK(sv)) {
3113 SETu(SvUV_nomg(sv));
3118 const NV value = SvNV_nomg(sv);
3119 if (UNLIKELY(Perl_isinfnan(value)))
3121 else if (value >= 0.0) {
3122 if (value < (NV)UV_MAX + 0.5) {
3125 SETn(Perl_floor(value));
3129 if (value > (NV)IV_MIN - 0.5) {
3132 SETn(Perl_ceil(value));
3143 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3145 SV * const sv = TOPs;
3146 /* This will cache the NV value if string isn't actually integer */
3147 const IV iv = SvIV_nomg(sv);
3152 else if (SvIOK(sv)) {
3153 /* IVX is precise */
3155 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3163 /* 2s complement assumption. Also, not really needed as
3164 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3170 const NV value = SvNV_nomg(sv);
3181 /* also used for: pp_hex() */
3187 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3191 SV* const sv = TOPs;
3193 tmps = (SvPV_const(sv, len));
3195 /* If Unicode, try to downgrade
3196 * If not possible, croak. */
3197 SV* const tsv = sv_2mortal(newSVsv(sv));
3200 sv_utf8_downgrade(tsv, FALSE);
3201 tmps = SvPV_const(tsv, len);
3203 if (PL_op->op_type == OP_HEX)
3206 while (*tmps && len && isSPACE(*tmps))
3210 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3212 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3214 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3215 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3217 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3219 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3233 SV * const sv = TOPs;
3235 U32 in_bytes = IN_BYTES;
3236 /* simplest case shortcut */
3237 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3238 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3239 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3242 if(LIKELY(svflags == SVf_POK))
3244 if(svflags & SVs_GMG)
3247 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3248 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3252 /* unrolled SvPV_nomg_const(sv,len) */
3257 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3259 sv_setiv(TARG, (IV)(len));
3262 if (!SvPADTMP(TARG)) {
3264 } else { /* TARG is on stack at this point and is overwriten by SETs.
3265 This branch is the odd one out, so put TARG by default on
3266 stack earlier to let local SP go out of liveness sooner */
3273 return NORMAL; /* no putback, SP didn't move in this opcode */
3276 /* Returns false if substring is completely outside original string.
3277 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3278 always be true for an explicit 0.
3281 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3282 bool pos1_is_uv, IV len_iv,
3283 bool len_is_uv, STRLEN *posp,
3289 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3291 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3292 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3295 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3298 if (len_iv || len_is_uv) {
3299 if (!len_is_uv && len_iv < 0) {
3300 pos2_iv = curlen + len_iv;
3302 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3305 } else { /* len_iv >= 0 */
3306 if (!pos1_is_uv && pos1_iv < 0) {
3307 pos2_iv = pos1_iv + len_iv;
3308 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3310 if ((UV)len_iv > curlen-(UV)pos1_iv)
3313 pos2_iv = pos1_iv+len_iv;
3323 if (!pos2_is_uv && pos2_iv < 0) {
3324 if (!pos1_is_uv && pos1_iv < 0)
3328 else if (!pos1_is_uv && pos1_iv < 0)
3331 if ((UV)pos2_iv < (UV)pos1_iv)
3333 if ((UV)pos2_iv > curlen)
3336 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3337 *posp = (STRLEN)( (UV)pos1_iv );
3338 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3355 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3356 const bool rvalue = (GIMME_V != G_VOID);
3359 const char *repl = NULL;
3361 int num_args = PL_op->op_private & 7;
3362 bool repl_need_utf8_upgrade = FALSE;
3366 if(!(repl_sv = POPs)) num_args--;
3368 if ((len_sv = POPs)) {
3369 len_iv = SvIV(len_sv);
3370 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3375 pos1_iv = SvIV(pos_sv);
3376 pos1_is_uv = SvIOK_UV(pos_sv);
3378 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3382 if (lvalue && !repl_sv) {
3384 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3385 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3387 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3389 pos1_is_uv || pos1_iv >= 0
3390 ? (STRLEN)(UV)pos1_iv
3391 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3393 len_is_uv || len_iv > 0
3394 ? (STRLEN)(UV)len_iv
3395 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3397 PUSHs(ret); /* avoid SvSETMAGIC here */
3401 repl = SvPV_const(repl_sv, repl_len);
3404 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3405 "Attempt to use reference as lvalue in substr"
3407 tmps = SvPV_force_nomg(sv, curlen);
3408 if (DO_UTF8(repl_sv) && repl_len) {
3410 /* Upgrade the dest, and recalculate tmps in case the buffer
3411 * got reallocated; curlen may also have been changed */
3412 sv_utf8_upgrade_nomg(sv);
3413 tmps = SvPV_nomg(sv, curlen);
3416 else if (DO_UTF8(sv))
3417 repl_need_utf8_upgrade = TRUE;
3419 else tmps = SvPV_const(sv, curlen);
3421 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3422 if (utf8_curlen == curlen)
3425 curlen = utf8_curlen;
3431 STRLEN pos, len, byte_len, byte_pos;
3433 if (!translate_substr_offsets(
3434 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3438 byte_pos = utf8_curlen
3439 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3444 SvTAINTED_off(TARG); /* decontaminate */
3445 SvUTF8_off(TARG); /* decontaminate */
3446 sv_setpvn(TARG, tmps, byte_len);
3447 #ifdef USE_LOCALE_COLLATE
3448 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3455 SV* repl_sv_copy = NULL;
3457 if (repl_need_utf8_upgrade) {
3458 repl_sv_copy = newSVsv(repl_sv);
3459 sv_utf8_upgrade(repl_sv_copy);
3460 repl = SvPV_const(repl_sv_copy, repl_len);
3464 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3465 SvREFCNT_dec(repl_sv_copy);
3468 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3478 Perl_croak(aTHX_ "substr outside of string");
3479 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3486 const IV size = POPi;
3487 SV* offsetsv = POPs;
3488 SV * const src = POPs;
3489 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3495 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3496 * or flag that its out of range */
3498 IV iv = SvIV(offsetsv);
3500 /* avoid a large UV being wrapped to a negative value */
3501 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3502 errflags = LVf_OUT_OF_RANGE;
3504 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3505 #if PTRSIZE < IVSIZE
3506 else if (iv > Size_t_MAX)
3507 errflags = LVf_OUT_OF_RANGE;
3510 offset = (STRLEN)iv;
3513 retuv = errflags ? 0 : do_vecget(src, offset, size);
3515 if (lvalue) { /* it's an lvalue! */
3516 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3517 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3519 LvTARG(ret) = SvREFCNT_inc_simple(src);
3520 LvTARGOFF(ret) = offset;
3521 LvTARGLEN(ret) = size;
3522 LvFLAGS(ret) = errflags;
3526 SvTAINTED_off(TARG); /* decontaminate */
3530 sv_setuv(ret, retuv);
3538 /* also used for: pp_rindex() */
3551 const char *little_p;
3554 const bool is_index = PL_op->op_type == OP_INDEX;
3555 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3561 big_p = SvPV_const(big, biglen);
3562 little_p = SvPV_const(little, llen);
3564 big_utf8 = DO_UTF8(big);
3565 little_utf8 = DO_UTF8(little);
3566 if (big_utf8 ^ little_utf8) {
3567 /* One needs to be upgraded. */
3569 /* Well, maybe instead we might be able to downgrade the small
3571 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3574 /* If the large string is ISO-8859-1, and it's not possible to
3575 convert the small string to ISO-8859-1, then there is no
3576 way that it could be found anywhere by index. */
3581 /* At this point, pv is a malloc()ed string. So donate it to temp
3582 to ensure it will get free()d */
3583 little = temp = newSV(0);
3584 sv_usepvn(temp, pv, llen);
3585 little_p = SvPVX(little);
3587 temp = newSVpvn(little_p, llen);
3589 sv_utf8_upgrade(temp);
3591 little_p = SvPV_const(little, llen);
3594 if (SvGAMAGIC(big)) {
3595 /* Life just becomes a lot easier if I use a temporary here.
3596 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3597 will trigger magic and overloading again, as will fbm_instr()
3599 big = newSVpvn_flags(big_p, biglen,
3600 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3603 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3604 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3605 warn on undef, and we've already triggered a warning with the
3606 SvPV_const some lines above. We can't remove that, as we need to
3607 call some SvPV to trigger overloading early and find out if the
3609 This is all getting too messy. The API isn't quite clean enough,
3610 because data access has side effects.
3612 little = newSVpvn_flags(little_p, llen,
3613 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3614 little_p = SvPVX(little);
3618 offset = is_index ? 0 : biglen;
3620 if (big_utf8 && offset > 0)
3621 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3627 else if (offset > (SSize_t)biglen)
3629 if (!(little_p = is_index
3630 ? fbm_instr((unsigned char*)big_p + offset,
3631 (unsigned char*)big_p + biglen, little, 0)
3632 : rninstr(big_p, big_p + offset,
3633 little_p, little_p + llen)))
3636 retval = little_p - big_p;
3637 if (retval > 1 && big_utf8)
3638 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3648 dSP; dMARK; dORIGMARK; dTARGET;
3649 SvTAINTED_off(TARG);
3650 do_sprintf(TARG, SP-MARK, MARK+1);
3651 TAINT_IF(SvTAINTED(TARG));
3663 const U8 *s = (U8*)SvPV_const(argsv, len);
3666 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3680 if (UNLIKELY(SvAMAGIC(top)))
3682 if (UNLIKELY(isinfnansv(top)))
3683 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3685 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3686 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3688 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3689 && SvNV_nomg(top) < 0.0)))
3691 if (ckWARN(WARN_UTF8)) {
3692 if (SvGMAGICAL(top)) {
3693 SV *top2 = sv_newmortal();
3694 sv_setsv_nomg(top2, top);
3697 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3698 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3700 value = UNICODE_REPLACEMENT;
3702 value = SvUV_nomg(top);
3706 SvUPGRADE(TARG,SVt_PV);
3708 if (value > 255 && !IN_BYTES) {
3709 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3710 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3711 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3713 (void)SvPOK_only(TARG);
3722 *tmps++ = (char)value;
3724 (void)SvPOK_only(TARG);
3736 const char *tmps = SvPV_const(left, len);
3738 if (DO_UTF8(left)) {
3739 /* If Unicode, try to downgrade.
3740 * If not possible, croak.
3741 * Yes, we made this up. */
3742 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3744 sv_utf8_downgrade(tsv, FALSE);
3745 tmps = SvPV_const(tsv, len);
3747 # ifdef USE_ITHREADS
3749 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3750 /* This should be threadsafe because in ithreads there is only
3751 * one thread per interpreter. If this would not be true,
3752 * we would need a mutex to protect this malloc. */
3753 PL_reentrant_buffer->_crypt_struct_buffer =
3754 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3755 #if defined(__GLIBC__) || defined(__EMX__)
3756 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3757 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3758 /* work around glibc-2.2.5 bug */
3759 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3763 # endif /* HAS_CRYPT_R */
3764 # endif /* USE_ITHREADS */
3766 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3768 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3775 "The crypt() function is unimplemented due to excessive paranoia.");
3779 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3780 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3783 /* also used for: pp_lcfirst() */
3787 /* Actually is both lcfirst() and ucfirst(). Only the first character
3788 * changes. This means that possibly we can change in-place, ie., just
3789 * take the source and change that one character and store it back, but not
3790 * if read-only etc, or if the length changes */
3794 STRLEN slen; /* slen is the byte length of the whole SV. */
3797 bool inplace; /* ? Convert first char only, in-place */
3798 bool doing_utf8 = FALSE; /* ? using utf8 */
3799 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3800 const int op_type = PL_op->op_type;
3803 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3804 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3805 * stored as UTF-8 at s. */
3806 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3807 * lowercased) character stored in tmpbuf. May be either
3808 * UTF-8 or not, but in either case is the number of bytes */
3810 s = (const U8*)SvPV_const(source, slen);
3812 /* We may be able to get away with changing only the first character, in
3813 * place, but not if read-only, etc. Later we may discover more reasons to
3814 * not convert in-place. */
3815 inplace = !SvREADONLY(source) && SvPADTMP(source);
3817 /* First calculate what the changed first character should be. This affects
3818 * whether we can just swap it out, leaving the rest of the string unchanged,
3819 * or even if have to convert the dest to UTF-8 when the source isn't */
3821 if (! slen) { /* If empty */
3822 need = 1; /* still need a trailing NUL */
3825 else if (DO_UTF8(source)) { /* Is the source utf8? */
3828 if (op_type == OP_UCFIRST) {
3829 #ifdef USE_LOCALE_CTYPE
3830 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3832 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3836 #ifdef USE_LOCALE_CTYPE
3837 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3839 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3843 /* we can't do in-place if the length changes. */
3844 if (ulen != tculen) inplace = FALSE;
3845 need = slen + 1 - ulen + tculen;
3847 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3848 * latin1 is treated as caseless. Note that a locale takes
3850 ulen = 1; /* Original character is 1 byte */
3851 tculen = 1; /* Most characters will require one byte, but this will
3852 * need to be overridden for the tricky ones */
3855 if (op_type == OP_LCFIRST) {
3857 /* lower case the first letter: no trickiness for any character */
3858 #ifdef USE_LOCALE_CTYPE
3859 if (IN_LC_RUNTIME(LC_CTYPE)) {
3860 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3861 *tmpbuf = toLOWER_LC(*s);
3866 *tmpbuf = (IN_UNI_8_BIT)
3867 ? toLOWER_LATIN1(*s)
3871 #ifdef USE_LOCALE_CTYPE
3873 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3874 if (IN_UTF8_CTYPE_LOCALE) {
3878 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3879 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3880 locales have upper and title case
3884 else if (! IN_UNI_8_BIT) {
3885 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3886 * on EBCDIC machines whatever the
3887 * native function does */
3890 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3891 * UTF-8, which we treat as not in locale), and cased latin1 */
3893 #ifdef USE_LOCALE_CTYPE
3897 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3899 assert(tculen == 2);
3901 /* If the result is an upper Latin1-range character, it can
3902 * still be represented in one byte, which is its ordinal */
3903 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3904 *tmpbuf = (U8) title_ord;
3908 /* Otherwise it became more than one ASCII character (in
3909 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3910 * beyond Latin1, so the number of bytes changed, so can't
3911 * replace just the first character in place. */
3914 /* If the result won't fit in a byte, the entire result
3915 * will have to be in UTF-8. Assume worst case sizing in
3916 * conversion. (all latin1 characters occupy at most two
3918 if (title_ord > 255) {
3920 convert_source_to_utf8 = TRUE;
3921 need = slen * 2 + 1;
3923 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3924 * (both) characters whose title case is above 255 is
3928 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3929 need = slen + 1 + 1;
3933 } /* End of use Unicode (Latin1) semantics */
3934 } /* End of changing the case of the first character */
3936 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3937 * generate the result */
3940 /* We can convert in place. This means we change just the first
3941 * character without disturbing the rest; no need to grow */
3943 s = d = (U8*)SvPV_force_nomg(source, slen);
3949 /* Here, we can't convert in place; we earlier calculated how much
3950 * space we will need, so grow to accommodate that */
3951 SvUPGRADE(dest, SVt_PV);
3952 d = (U8*)SvGROW(dest, need);
3953 (void)SvPOK_only(dest);
3960 if (! convert_source_to_utf8) {
3962 /* Here both source and dest are in UTF-8, but have to create
3963 * the entire output. We initialize the result to be the
3964 * title/lower cased first character, and then append the rest
3966 sv_setpvn(dest, (char*)tmpbuf, tculen);
3968 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3972 const U8 *const send = s + slen;
3974 /* Here the dest needs to be in UTF-8, but the source isn't,
3975 * except we earlier UTF-8'd the first character of the source
3976 * into tmpbuf. First put that into dest, and then append the
3977 * rest of the source, converting it to UTF-8 as we go. */
3979 /* Assert tculen is 2 here because the only two characters that
3980 * get to this part of the code have 2-byte UTF-8 equivalents */
3982 *d++ = *(tmpbuf + 1);
3983 s++; /* We have just processed the 1st char */
3985 for (; s < send; s++) {
3986 d = uvchr_to_utf8(d, *s);
3989 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3993 else { /* in-place UTF-8. Just overwrite the first character */
3994 Copy(tmpbuf, d, tculen, U8);
3995 SvCUR_set(dest, need - 1);
3999 else { /* Neither source nor dest are in or need to be UTF-8 */
4001 if (inplace) { /* in-place, only need to change the 1st char */
4004 else { /* Not in-place */
4006 /* Copy the case-changed character(s) from tmpbuf */
4007 Copy(tmpbuf, d, tculen, U8);
4008 d += tculen - 1; /* Code below expects d to point to final
4009 * character stored */
4012 else { /* empty source */
4013 /* See bug #39028: Don't taint if empty */
4017 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4018 * the destination to retain that flag */
4019 if (SvUTF8(source) && ! IN_BYTES)
4022 if (!inplace) { /* Finish the rest of the string, unchanged */
4023 /* This will copy the trailing NUL */
4024 Copy(s + 1, d + 1, slen, U8);
4025 SvCUR_set(dest, need - 1);
4028 #ifdef USE_LOCALE_CTYPE
4029 if (IN_LC_RUNTIME(LC_CTYPE)) {
4034 if (dest != source && SvTAINTED(source))
4040 /* There's so much setup/teardown code common between uc and lc, I wonder if
4041 it would be worth merging the two, and just having a switch outside each
4042 of the three tight loops. There is less and less commonality though */
4055 if ( SvPADTMP(source)
4056 && !SvREADONLY(source) && SvPOK(source)
4059 #ifdef USE_LOCALE_CTYPE
4060 (IN_LC_RUNTIME(LC_CTYPE))
4061 ? ! IN_UTF8_CTYPE_LOCALE
4067 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4068 * make the loop tight, so we overwrite the source with the dest before
4069 * looking at it, and we need to look at the original source
4070 * afterwards. There would also need to be code added to handle
4071 * switching to not in-place in midstream if we run into characters
4072 * that change the length. Since being in locale overrides UNI_8_BIT,
4073 * that latter becomes irrelevant in the above test; instead for
4074 * locale, the size can't normally change, except if the locale is a
4077 s = d = (U8*)SvPV_force_nomg(source, len);
4084 s = (const U8*)SvPV_nomg_const(source, len);
4087 SvUPGRADE(dest, SVt_PV);
4088 d = (U8*)SvGROW(dest, min);
4089 (void)SvPOK_only(dest);
4094 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4095 to check DO_UTF8 again here. */
4097 if (DO_UTF8(source)) {
4098 const U8 *const send = s + len;
4099 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4101 /* All occurrences of these are to be moved to follow any other marks.
4102 * This is context-dependent. We may not be passed enough context to
4103 * move the iota subscript beyond all of them, but we do the best we can
4104 * with what we're given. The result is always better than if we
4105 * hadn't done this. And, the problem would only arise if we are
4106 * passed a character without all its combining marks, which would be
4107 * the caller's mistake. The information this is based on comes from a
4108 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4109 * itself) and so can't be checked properly to see if it ever gets
4110 * revised. But the likelihood of it changing is remote */
4111 bool in_iota_subscript = FALSE;
4117 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4119 /* A non-mark. Time to output the iota subscript */
4120 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4121 d += capital_iota_len;
4122 in_iota_subscript = FALSE;
4125 /* Then handle the current character. Get the changed case value
4126 * and copy it to the output buffer */
4129 #ifdef USE_LOCALE_CTYPE
4130 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4132 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4134 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4135 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4136 if (uv == GREEK_CAPITAL_LETTER_IOTA
4137 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4139 in_iota_subscript = TRUE;
4142 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4143 /* If the eventually required minimum size outgrows the
4144 * available space, we need to grow. */
4145 const UV o = d - (U8*)SvPVX_const(dest);
4147 /* If someone uppercases one million U+03B0s we SvGROW()
4148 * one million times. Or we could try guessing how much to
4149 * allocate without allocating too much. Such is life.
4150 * See corresponding comment in lc code for another option
4152 d = o + (U8*) SvGROW(dest, min);
4154 Copy(tmpbuf, d, ulen, U8);
4159 if (in_iota_subscript) {
4160 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4161 d += capital_iota_len;
4166 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4168 else { /* Not UTF-8 */
4170 const U8 *const send = s + len;
4172 /* Use locale casing if in locale; regular style if not treating
4173 * latin1 as having case; otherwise the latin1 casing. Do the
4174 * whole thing in a tight loop, for speed, */
4175 #ifdef USE_LOCALE_CTYPE
4176 if (IN_LC_RUNTIME(LC_CTYPE)) {
4177 if (IN_UTF8_CTYPE_LOCALE) {
4180 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4181 for (; s < send; d++, s++)
4182 *d = (U8) toUPPER_LC(*s);
4186 if (! IN_UNI_8_BIT) {
4187 for (; s < send; d++, s++) {
4192 #ifdef USE_LOCALE_CTYPE
4195 for (; s < send; d++, s++) {
4196 *d = toUPPER_LATIN1_MOD(*s);
4197 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4201 /* The mainstream case is the tight loop above. To avoid
4202 * extra tests in that, all three characters that require
4203 * special handling are mapped by the MOD to the one tested
4205 * Use the source to distinguish between the three cases */
4207 #if UNICODE_MAJOR_VERSION > 2 \
4208 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4209 && UNICODE_DOT_DOT_VERSION >= 8)
4210 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4212 /* uc() of this requires 2 characters, but they are
4213 * ASCII. If not enough room, grow the string */
4214 if (SvLEN(dest) < ++min) {
4215 const UV o = d - (U8*)SvPVX_const(dest);
4216 d = o + (U8*) SvGROW(dest, min);
4218 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4219 continue; /* Back to the tight loop; still in ASCII */
4223 /* The other two special handling characters have their
4224 * upper cases outside the latin1 range, hence need to be
4225 * in UTF-8, so the whole result needs to be in UTF-8. So,
4226 * here we are somewhere in the middle of processing a
4227 * non-UTF-8 string, and realize that we will have to convert
4228 * the whole thing to UTF-8. What to do? There are
4229 * several possibilities. The simplest to code is to
4230 * convert what we have so far, set a flag, and continue on
4231 * in the loop. The flag would be tested each time through
4232 * the loop, and if set, the next character would be
4233 * converted to UTF-8 and stored. But, I (khw) didn't want
4234 * to slow down the mainstream case at all for this fairly
4235 * rare case, so I didn't want to add a test that didn't
4236 * absolutely have to be there in the loop, besides the
4237 * possibility that it would get too complicated for
4238 * optimizers to deal with. Another possibility is to just
4239 * give up, convert the source to UTF-8, and restart the
4240 * function that way. Another possibility is to convert
4241 * both what has already been processed and what is yet to
4242 * come separately to UTF-8, then jump into the loop that
4243 * handles UTF-8. But the most efficient time-wise of the
4244 * ones I could think of is what follows, and turned out to
4245 * not require much extra code. */
4247 /* Convert what we have so far into UTF-8, telling the
4248 * function that we know it should be converted, and to
4249 * allow extra space for what we haven't processed yet.
4250 * Assume the worst case space requirements for converting
4251 * what we haven't processed so far: that it will require
4252 * two bytes for each remaining source character, plus the
4253 * NUL at the end. This may cause the string pointer to
4254 * move, so re-find it. */
4256 len = d - (U8*)SvPVX_const(dest);
4257 SvCUR_set(dest, len);
4258 len = sv_utf8_upgrade_flags_grow(dest,
4259 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4261 d = (U8*)SvPVX(dest) + len;
4263 /* Now process the remainder of the source, converting to
4264 * upper and UTF-8. If a resulting byte is invariant in
4265 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4266 * append it to the output. */
4267 for (; s < send; s++) {
4268 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4272 /* Here have processed the whole source; no need to continue
4273 * with the outer loop. Each character has been converted
4274 * to upper case and converted to UTF-8 */
4277 } /* End of processing all latin1-style chars */
4278 } /* End of processing all chars */
4279 } /* End of source is not empty */
4281 if (source != dest) {
4282 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4283 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4285 } /* End of isn't utf8 */
4286 #ifdef USE_LOCALE_CTYPE
4287 if (IN_LC_RUNTIME(LC_CTYPE)) {
4292 if (dest != source && SvTAINTED(source))
4310 if ( SvPADTMP(source)
4311 && !SvREADONLY(source) && SvPOK(source)
4312 && !DO_UTF8(source)) {
4314 /* We can convert in place, as lowercasing anything in the latin1 range
4315 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4317 s = d = (U8*)SvPV_force_nomg(source, len);
4324 s = (const U8*)SvPV_nomg_const(source, len);
4327 SvUPGRADE(dest, SVt_PV);
4328 d = (U8*)SvGROW(dest, min);
4329 (void)SvPOK_only(dest);
4334 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4335 to check DO_UTF8 again here. */
4337 if (DO_UTF8(source)) {
4338 const U8 *const send = s + len;
4339 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4342 const STRLEN u = UTF8SKIP(s);
4345 #ifdef USE_LOCALE_CTYPE
4346 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4348 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4351 /* Here is where we would do context-sensitive actions. See the
4352 * commit message for 86510fb15 for why there isn't any */
4354 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4356 /* If the eventually required minimum size outgrows the
4357 * available space, we need to grow. */
4358 const UV o = d - (U8*)SvPVX_const(dest);
4360 /* If someone lowercases one million U+0130s we SvGROW() one
4361 * million times. Or we could try guessing how much to
4362 * allocate without allocating too much. Such is life.
4363 * Another option would be to grow an extra byte or two more
4364 * each time we need to grow, which would cut down the million
4365 * to 500K, with little waste */
4366 d = o + (U8*) SvGROW(dest, min);
4369 /* Copy the newly lowercased letter to the output buffer we're
4371 Copy(tmpbuf, d, ulen, U8);
4374 } /* End of looping through the source string */
4377 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4378 } else { /* Not utf8 */
4380 const U8 *const send = s + len;
4382 /* Use locale casing if in locale; regular style if not treating
4383 * latin1 as having case; otherwise the latin1 casing. Do the
4384 * whole thing in a tight loop, for speed, */
4385 #ifdef USE_LOCALE_CTYPE
4386 if (IN_LC_RUNTIME(LC_CTYPE)) {
4387 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4388 for (; s < send; d++, s++)
4389 *d = toLOWER_LC(*s);
4393 if (! IN_UNI_8_BIT) {
4394 for (; s < send; d++, s++) {
4399 for (; s < send; d++, s++) {
4400 *d = toLOWER_LATIN1(*s);
4404 if (source != dest) {
4406 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4409 #ifdef USE_LOCALE_CTYPE
4410 if (IN_LC_RUNTIME(LC_CTYPE)) {
4415 if (dest != source && SvTAINTED(source))
4424 SV * const sv = TOPs;
4426 const char *s = SvPV_const(sv,len);
4428 SvUTF8_off(TARG); /* decontaminate */
4431 SvUPGRADE(TARG, SVt_PV);
4432 SvGROW(TARG, (len * 2) + 1);
4436 STRLEN ulen = UTF8SKIP(s);
4437 bool to_quote = FALSE;
4439 if (UTF8_IS_INVARIANT(*s)) {
4440 if (_isQUOTEMETA(*s)) {
4444 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4446 #ifdef USE_LOCALE_CTYPE
4447 /* In locale, we quote all non-ASCII Latin1 chars.
4448 * Otherwise use the quoting rules */
4450 IN_LC_RUNTIME(LC_CTYPE)
4453 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4458 else if (is_QUOTEMETA_high(s)) {
4473 else if (IN_UNI_8_BIT) {
4475 if (_isQUOTEMETA(*s))
4481 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4482 * including everything above ASCII */
4484 if (!isWORDCHAR_A(*s))
4490 SvCUR_set(TARG, d - SvPVX_const(TARG));
4491 (void)SvPOK_only_UTF8(TARG);
4494 sv_setpvn(TARG, s, len);
4510 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4511 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4512 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4513 || UNICODE_DOT_DOT_VERSION > 0)
4514 const bool full_folding = TRUE; /* This variable is here so we can easily
4515 move to more generality later */
4517 const bool full_folding = FALSE;
4519 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4520 #ifdef USE_LOCALE_CTYPE
4521 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4525 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4526 * You are welcome(?) -Hugmeir
4534 s = (const U8*)SvPV_nomg_const(source, len);
4536 if (ckWARN(WARN_UNINITIALIZED))
4537 report_uninit(source);
4544 SvUPGRADE(dest, SVt_PV);
4545 d = (U8*)SvGROW(dest, min);
4546 (void)SvPOK_only(dest);
4551 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4553 const STRLEN u = UTF8SKIP(s);
4556 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4558 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4559 const UV o = d - (U8*)SvPVX_const(dest);
4560 d = o + (U8*) SvGROW(dest, min);
4563 Copy(tmpbuf, d, ulen, U8);
4568 } /* Unflagged string */
4570 #ifdef USE_LOCALE_CTYPE
4571 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4572 if (IN_UTF8_CTYPE_LOCALE) {
4573 goto do_uni_folding;
4575 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4576 for (; s < send; d++, s++)
4577 *d = (U8) toFOLD_LC(*s);
4581 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4582 for (; s < send; d++, s++)
4586 #ifdef USE_LOCALE_CTYPE
4589 /* For ASCII and the Latin-1 range, there's only two troublesome
4590 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4591 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4592 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4593 * For the rest, the casefold is their lowercase. */
4594 for (; s < send; d++, s++) {
4595 if (*s == MICRO_SIGN) {
4596 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4597 * which is outside of the latin-1 range. There's a couple
4598 * of ways to deal with this -- khw discusses them in
4599 * pp_lc/uc, so go there :) What we do here is upgrade what
4600 * we had already casefolded, then enter an inner loop that
4601 * appends the rest of the characters as UTF-8. */
4602 len = d - (U8*)SvPVX_const(dest);
4603 SvCUR_set(dest, len);
4604 len = sv_utf8_upgrade_flags_grow(dest,
4605 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4606 /* The max expansion for latin1
4607 * chars is 1 byte becomes 2 */
4609 d = (U8*)SvPVX(dest) + len;
4611 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4614 for (; s < send; s++) {
4616 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4617 if UVCHR_IS_INVARIANT(fc) {
4619 && *s == LATIN_SMALL_LETTER_SHARP_S)
4628 Copy(tmpbuf, d, ulen, U8);
4634 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4635 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4636 * becomes "ss", which may require growing the SV. */
4637 if (SvLEN(dest) < ++min) {
4638 const UV o = d - (U8*)SvPVX_const(dest);
4639 d = o + (U8*) SvGROW(dest, min);
4644 else { /* If it's not one of those two, the fold is their lower
4646 *d = toLOWER_LATIN1(*s);
4652 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4654 #ifdef USE_LOCALE_CTYPE
4655 if (IN_LC_RUNTIME(LC_CTYPE)) {
4660 if (SvTAINTED(source))
4670 dSP; dMARK; dORIGMARK;
4671 AV *const av = MUTABLE_AV(POPs);
4672 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4674 if (SvTYPE(av) == SVt_PVAV) {
4675 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4676 bool can_preserve = FALSE;
4682 can_preserve = SvCANEXISTDELETE(av);
4685 if (lval && localizing) {
4688 for (svp = MARK + 1; svp <= SP; svp++) {
4689 const SSize_t elem = SvIV(*svp);
4693 if (max > AvMAX(av))
4697 while (++MARK <= SP) {
4699 SSize_t elem = SvIV(*MARK);
4700 bool preeminent = TRUE;
4702 if (localizing && can_preserve) {
4703 /* If we can determine whether the element exist,
4704 * Try to preserve the existenceness of a tied array
4705 * element by using EXISTS and DELETE if possible.
4706 * Fallback to FETCH and STORE otherwise. */
4707 preeminent = av_exists(av, elem);
4710 svp = av_fetch(av, elem, lval);
4713 DIE(aTHX_ PL_no_aelem, elem);
4716 save_aelem(av, elem, svp);
4718 SAVEADELETE(av, elem);
4721 *MARK = svp ? *svp : &PL_sv_undef;
4724 if (GIMME_V != G_ARRAY) {
4726 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4735 AV *const av = MUTABLE_AV(POPs);
4736 I32 lval = (PL_op->op_flags & OPf_MOD);
4737 SSize_t items = SP - MARK;
4739 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4740 const I32 flags = is_lvalue_sub();
4742 if (!(flags & OPpENTERSUB_INARGS))
4743 /* diag_listed_as: Can't modify %s in %s */
4744 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4751 *(MARK+items*2-1) = *(MARK+items);
4757 while (++MARK <= SP) {
4760 svp = av_fetch(av, SvIV(*MARK), lval);
4762 if (!svp || !*svp || *svp == &PL_sv_undef) {
4763 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4765 *MARK = sv_mortalcopy(*MARK);
4767 *++MARK = svp ? *svp : &PL_sv_undef;
4769 if (GIMME_V != G_ARRAY) {
4770 MARK = SP - items*2;
4771 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4781 AV *array = MUTABLE_AV(POPs);
4782 const U8 gimme = GIMME_V;
4783 IV *iterp = Perl_av_iter_p(aTHX_ array);
4784 const IV current = (*iterp)++;
4786 if (current > av_tindex(array)) {
4788 if (gimme == G_SCALAR)
4796 if (gimme == G_ARRAY) {
4797 SV **const element = av_fetch(array, current, 0);
4798 PUSHs(element ? *element : &PL_sv_undef);
4803 /* also used for: pp_avalues()*/
4807 AV *array = MUTABLE_AV(POPs);
4808 const U8 gimme = GIMME_V;
4810 *Perl_av_iter_p(aTHX_ array) = 0;
4812 if (gimme == G_SCALAR) {
4814 PUSHi(av_tindex(array) + 1);
4816 else if (gimme == G_ARRAY) {
4817 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4818 const I32 flags = is_lvalue_sub();
4819 if (flags && !(flags & OPpENTERSUB_INARGS))
4820 /* diag_listed_as: Can't modify %s in %s */
4822 "Can't modify keys on array in list assignment");
4825 IV n = Perl_av_len(aTHX_ array);
4830 if ( PL_op->op_type == OP_AKEYS
4831 || ( PL_op->op_type == OP_AVHVSWITCH
4832 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
4834 for (i = 0; i <= n; i++) {
4839 for (i = 0; i <= n; i++) {
4840 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4841 PUSHs(elem ? *elem : &PL_sv_undef);
4849 /* Associative arrays. */
4854 HV * hash = MUTABLE_HV(POPs);
4856 const U8 gimme = GIMME_V;
4858 entry = hv_iternext(hash);
4862 SV* const sv = hv_iterkeysv(entry);
4864 if (gimme == G_ARRAY) {
4866 val = hv_iterval(hash, entry);
4870 else if (gimme == G_SCALAR)
4877 S_do_delete_local(pTHX)
4880 const U8 gimme = GIMME_V;
4883 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4884 SV **unsliced_keysv = sliced ? NULL : sp--;
4885 SV * const osv = POPs;
4886 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4888 const bool tied = SvRMAGICAL(osv)
4889 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4890 const bool can_preserve = SvCANEXISTDELETE(osv);
4891 const U32 type = SvTYPE(osv);
4892 SV ** const end = sliced ? SP : unsliced_keysv;
4894 if (type == SVt_PVHV) { /* hash element */
4895 HV * const hv = MUTABLE_HV(osv);
4896 while (++MARK <= end) {
4897 SV * const keysv = *MARK;
4899 bool preeminent = TRUE;
4901 preeminent = hv_exists_ent(hv, keysv, 0);
4903 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4910 sv = hv_delete_ent(hv, keysv, 0, 0);
4912 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4915 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4916 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4918 *MARK = sv_mortalcopy(sv);
4924 SAVEHDELETE(hv, keysv);
4925 *MARK = &PL_sv_undef;
4929 else if (type == SVt_PVAV) { /* array element */
4930 if (PL_op->op_flags & OPf_SPECIAL) {
4931 AV * const av = MUTABLE_AV(osv);
4932 while (++MARK <= end) {
4933 SSize_t idx = SvIV(*MARK);
4935 bool preeminent = TRUE;
4937 preeminent = av_exists(av, idx);
4939 SV **svp = av_fetch(av, idx, 1);
4946 sv = av_delete(av, idx, 0);
4948 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4951 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4953 *MARK = sv_mortalcopy(sv);
4959 SAVEADELETE(av, idx);
4960 *MARK = &PL_sv_undef;
4965 DIE(aTHX_ "panic: avhv_delete no longer supported");
4968 DIE(aTHX_ "Not a HASH reference");
4970 if (gimme == G_VOID)
4972 else if (gimme == G_SCALAR) {
4977 *++MARK = &PL_sv_undef;
4981 else if (gimme != G_VOID)
4982 PUSHs(*unsliced_keysv);
4993 if (PL_op->op_private & OPpLVAL_INTRO)
4994 return do_delete_local();
4997 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4999 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5001 HV * const hv = MUTABLE_HV(POPs);
5002 const U32 hvtype = SvTYPE(hv);
5004 if (PL_op->op_private & OPpKVSLICE) {
5005 SSize_t items = SP - MARK;
5009 *(MARK+items*2-1) = *(MARK+items);
5016 if (hvtype == SVt_PVHV) { /* hash element */
5017 while ((MARK += (1+skip)) <= SP) {
5018 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5019 *MARK = sv ? sv : &PL_sv_undef;
5022 else if (hvtype == SVt_PVAV) { /* array element */
5023 if (PL_op->op_flags & OPf_SPECIAL) {
5024 while ((MARK += (1+skip)) <= SP) {
5025 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5026 *MARK = sv ? sv : &PL_sv_undef;
5031 DIE(aTHX_ "Not a HASH reference");
5034 else if (gimme == G_SCALAR) {
5039 *++MARK = &PL_sv_undef;
5045 HV * const hv = MUTABLE_HV(POPs);
5047 if (SvTYPE(hv) == SVt_PVHV)
5048 sv = hv_delete_ent(hv, keysv, discard, 0);
5049 else if (SvTYPE(hv) == SVt_PVAV) {
5050 if (PL_op->op_flags & OPf_SPECIAL)
5051 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5053 DIE(aTHX_ "panic: avhv_delete no longer supported");
5056 DIE(aTHX_ "Not a HASH reference");
5071 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5073 SV * const sv = POPs;
5074 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5077 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5082 hv = MUTABLE_HV(POPs);
5083 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5084 if (hv_exists_ent(hv, tmpsv, 0))
5087 else if (SvTYPE(hv) == SVt_PVAV) {
5088 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5089 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5094 DIE(aTHX_ "Not a HASH reference");
5101 dSP; dMARK; dORIGMARK;
5102 HV * const hv = MUTABLE_HV(POPs);
5103 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5104 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5105 bool can_preserve = FALSE;
5111 if (SvCANEXISTDELETE(hv))
5112 can_preserve = TRUE;
5115 while (++MARK <= SP) {
5116 SV * const keysv = *MARK;
5119 bool preeminent = TRUE;
5121 if (localizing && can_preserve) {
5122 /* If we can determine whether the element exist,
5123 * try to preserve the existenceness of a tied hash
5124 * element by using EXISTS and DELETE if possible.
5125 * Fallback to FETCH and STORE otherwise. */
5126 preeminent = hv_exists_ent(hv, keysv, 0);
5129 he = hv_fetch_ent(hv, keysv, lval, 0);
5130 svp = he ? &HeVAL(he) : NULL;
5133 if (!svp || !*svp || *svp == &PL_sv_undef) {
5134 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5137 if (HvNAME_get(hv) && isGV(*svp))
5138 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5139 else if (preeminent)
5140 save_helem_flags(hv, keysv, svp,
5141 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5143 SAVEHDELETE(hv, keysv);
5146 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5148 if (GIMME_V != G_ARRAY) {
5150 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5159 HV * const hv = MUTABLE_HV(POPs);
5160 I32 lval = (PL_op->op_flags & OPf_MOD);
5161 SSize_t items = SP - MARK;
5163 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5164 const I32 flags = is_lvalue_sub();
5166 if (!(flags & OPpENTERSUB_INARGS))
5167 /* diag_listed_as: Can't modify %s in %s */
5168 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5169 GIMME_V == G_ARRAY ? "list" : "scalar");
5176 *(MARK+items*2-1) = *(MARK+items);
5182 while (++MARK <= SP) {
5183 SV * const keysv = *MARK;
5187 he = hv_fetch_ent(hv, keysv, lval, 0);
5188 svp = he ? &HeVAL(he) : NULL;
5191 if (!svp || !*svp || *svp == &PL_sv_undef) {
5192 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5194 *MARK = sv_mortalcopy(*MARK);
5196 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5198 if (GIMME_V != G_ARRAY) {
5199 MARK = SP - items*2;
5200 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5206 /* List operators. */
5210 I32 markidx = POPMARK;
5211 if (GIMME_V != G_ARRAY) {
5212 SV **mark = PL_stack_base + markidx;
5215 *MARK = *SP; /* unwanted list, return last item */
5217 *MARK = &PL_sv_undef;
5227 SV ** const lastrelem = PL_stack_sp;
5228 SV ** const lastlelem = PL_stack_base + POPMARK;
5229 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5230 SV ** const firstrelem = lastlelem + 1;
5231 const U8 mod = PL_op->op_flags & OPf_MOD;
5233 const I32 max = lastrelem - lastlelem;
5236 if (GIMME_V != G_ARRAY) {
5237 if (lastlelem < firstlelem) {
5238 *firstlelem = &PL_sv_undef;
5241 I32 ix = SvIV(*lastlelem);
5244 if (ix < 0 || ix >= max)
5245 *firstlelem = &PL_sv_undef;
5247 *firstlelem = firstrelem[ix];
5254 SP = firstlelem - 1;
5258 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5259 I32 ix = SvIV(*lelem);
5262 if (ix < 0 || ix >= max)
5263 *lelem = &PL_sv_undef;
5265 if (!(*lelem = firstrelem[ix]))
5266 *lelem = &PL_sv_undef;
5267 else if (mod && SvPADTMP(*lelem)) {
5268 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5279 const I32 items = SP - MARK;
5280 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5282 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5283 ? newRV_noinc(av) : av);
5289 dSP; dMARK; dORIGMARK;
5290 HV* const hv = newHV();
5291 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5292 ? newRV_noinc(MUTABLE_SV(hv))
5297 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5304 sv_setsv_nomg(val, *MARK);
5308 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5311 (void)hv_store_ent(hv,key,val,0);
5320 dSP; dMARK; dORIGMARK;
5321 int num_args = (SP - MARK);
5322 AV *ary = MUTABLE_AV(*++MARK);
5331 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5334 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5335 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5342 offset = i = SvIV(*MARK);
5344 offset += AvFILLp(ary) + 1;
5346 DIE(aTHX_ PL_no_aelem, i);
5348 length = SvIVx(*MARK++);
5350 length += AvFILLp(ary) - offset + 1;
5356 length = AvMAX(ary) + 1; /* close enough to infinity */
5360 length = AvMAX(ary) + 1;
5362 if (offset > AvFILLp(ary) + 1) {
5364 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5365 offset = AvFILLp(ary) + 1;
5367 after = AvFILLp(ary) + 1 - (offset + length);
5368 if (after < 0) { /* not that much array */
5369 length += after; /* offset+length now in array */
5375 /* At this point, MARK .. SP-1 is our new LIST */
5378 diff = newlen - length;
5379 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5382 /* make new elements SVs now: avoid problems if they're from the array */
5383 for (dst = MARK, i = newlen; i; i--) {
5384 SV * const h = *dst;
5385 *dst++ = newSVsv(h);
5388 if (diff < 0) { /* shrinking the area */
5389 SV **tmparyval = NULL;
5391 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5392 Copy(MARK, tmparyval, newlen, SV*);
5395 MARK = ORIGMARK + 1;
5396 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5397 const bool real = cBOOL(AvREAL(ary));
5398 MEXTEND(MARK, length);
5400 EXTEND_MORTAL(length);
5401 for (i = 0, dst = MARK; i < length; i++) {
5402 if ((*dst = AvARRAY(ary)[i+offset])) {
5404 sv_2mortal(*dst); /* free them eventually */
5407 *dst = &PL_sv_undef;
5413 *MARK = AvARRAY(ary)[offset+length-1];
5416 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5417 SvREFCNT_dec(*dst++); /* free them now */
5420 *MARK = &PL_sv_undef;
5422 AvFILLp(ary) += diff;
5424 /* pull up or down? */
5426 if (offset < after) { /* easier to pull up */
5427 if (offset) { /* esp. if nothing to pull */
5428 src = &AvARRAY(ary)[offset-1];
5429 dst = src - diff; /* diff is negative */
5430 for (i = offset; i > 0; i--) /* can't trust Copy */
5434 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5438 if (after) { /* anything to pull down? */
5439 src = AvARRAY(ary) + offset + length;
5440 dst = src + diff; /* diff is negative */
5441 Move(src, dst, after, SV*);
5443 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5444 /* avoid later double free */
5451 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5452 Safefree(tmparyval);
5455 else { /* no, expanding (or same) */
5456 SV** tmparyval = NULL;
5458 Newx(tmparyval, length, SV*); /* so remember deletion */
5459 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5462 if (diff > 0) { /* expanding */
5463 /* push up or down? */
5464 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5468 Move(src, dst, offset, SV*);
5470 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5472 AvFILLp(ary) += diff;
5475 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5476 av_extend(ary, AvFILLp(ary) + diff);
5477 AvFILLp(ary) += diff;
5480 dst = AvARRAY(ary) + AvFILLp(ary);
5482 for (i = after; i; i--) {
5490 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5493 MARK = ORIGMARK + 1;
5494 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5496 const bool real = cBOOL(AvREAL(ary));
5498 EXTEND_MORTAL(length);
5499 for (i = 0, dst = MARK; i < length; i++) {
5500 if ((*dst = tmparyval[i])) {
5502 sv_2mortal(*dst); /* free them eventually */
5504 else *dst = &PL_sv_undef;
5510 else if (length--) {
5511 *MARK = tmparyval[length];
5514 while (length-- > 0)
5515 SvREFCNT_dec(tmparyval[length]);
5518 *MARK = &PL_sv_undef;
5521 *MARK = &PL_sv_undef;
5522 Safefree(tmparyval);
5526 mg_set(MUTABLE_SV(ary));
5534 dSP; dMARK; dORIGMARK; dTARGET;
5535 AV * const ary = MUTABLE_AV(*++MARK);
5536 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5539 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5542 ENTER_with_name("call_PUSH");
5543 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5544 LEAVE_with_name("call_PUSH");
5545 /* SPAGAIN; not needed: SP is assigned to immediately below */
5548 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5549 * only need to save locally, not on the save stack */
5550 U16 old_delaymagic = PL_delaymagic;
5552 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5553 PL_delaymagic = DM_DELAY;
5554 for (++MARK; MARK <= SP; MARK++) {
5556 if (*MARK) SvGETMAGIC(*MARK);
5559 sv_setsv_nomg(sv, *MARK);
5560 av_store(ary, AvFILLp(ary)+1, sv);
5562 if (PL_delaymagic & DM_ARRAY_ISA)
5563 mg_set(MUTABLE_SV(ary));
5564 PL_delaymagic = old_delaymagic;
5567 if (OP_GIMME(PL_op, 0) != G_VOID) {
5568 PUSHi( AvFILL(ary) + 1 );
5573 /* also used for: pp_pop()*/
5577 AV * const av = PL_op->op_flags & OPf_SPECIAL
5578 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5579 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5583 (void)sv_2mortal(sv);
5590 dSP; dMARK; dORIGMARK; dTARGET;
5591 AV *ary = MUTABLE_AV(*++MARK);
5592 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5595 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5598 ENTER_with_name("call_UNSHIFT");
5599 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5600 LEAVE_with_name("call_UNSHIFT");
5601 /* SPAGAIN; not needed: SP is assigned to immediately below */
5604 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5605 * only need to save locally, not on the save stack */
5606 U16 old_delaymagic = PL_delaymagic;
5609 av_unshift(ary, SP - MARK);
5610 PL_delaymagic = DM_DELAY;
5612 SV * const sv = newSVsv(*++MARK);
5613 (void)av_store(ary, i++, sv);
5615 if (PL_delaymagic & DM_ARRAY_ISA)
5616 mg_set(MUTABLE_SV(ary));
5617 PL_delaymagic = old_delaymagic;
5620 if (OP_GIMME(PL_op, 0) != G_VOID) {
5621 PUSHi( AvFILL(ary) + 1 );
5630 if (GIMME_V == G_ARRAY) {
5631 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5635 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5636 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5637 av = MUTABLE_AV((*SP));
5638 /* In-place reversing only happens in void context for the array
5639 * assignment. We don't need to push anything on the stack. */
5642 if (SvMAGICAL(av)) {
5644 SV *tmp = sv_newmortal();
5645 /* For SvCANEXISTDELETE */
5648 bool can_preserve = SvCANEXISTDELETE(av);
5650 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5654 if (!av_exists(av, i)) {
5655 if (av_exists(av, j)) {
5656 SV *sv = av_delete(av, j, 0);
5657 begin = *av_fetch(av, i, TRUE);
5658 sv_setsv_mg(begin, sv);
5662 else if (!av_exists(av, j)) {
5663 SV *sv = av_delete(av, i, 0);
5664 end = *av_fetch(av, j, TRUE);
5665 sv_setsv_mg(end, sv);
5670 begin = *av_fetch(av, i, TRUE);
5671 end = *av_fetch(av, j, TRUE);
5672 sv_setsv(tmp, begin);
5673 sv_setsv_mg(begin, end);
5674 sv_setsv_mg(end, tmp);
5678 SV **begin = AvARRAY(av);
5681 SV **end = begin + AvFILLp(av);
5683 while (begin < end) {
5684 SV * const tmp = *begin;
5695 SV * const tmp = *MARK;
5699 /* safe as long as stack cannot get extended in the above */
5708 SvUTF8_off(TARG); /* decontaminate */
5710 do_join(TARG, &PL_sv_no, MARK, SP);
5712 sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5715 up = SvPV_force(TARG, len);
5718 if (DO_UTF8(TARG)) { /* first reverse each character */
5719 U8* s = (U8*)SvPVX(TARG);
5720 const U8* send = (U8*)(s + len);
5722 if (UTF8_IS_INVARIANT(*s)) {
5727 if (!utf8_to_uvchr_buf(s, send, 0))
5731 down = (char*)(s - 1);
5732 /* reverse this character */
5734 const char tmp = *up;
5742 down = SvPVX(TARG) + len - 1;
5744 const char tmp = *up;
5748 (void)SvPOK_only_UTF8(TARG);
5759 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5760 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
5761 ? (AV *)POPs : NULL;
5762 IV limit = POPi; /* note, negative is forever */
5763 SV * const sv = POPs;
5765 const char *s = SvPV_const(sv, len);
5766 const bool do_utf8 = DO_UTF8(sv);
5767 const char *strend = s + len;
5768 PMOP *pm = cPMOPx(PL_op);
5773 const STRLEN slen = do_utf8
5774 ? utf8_length((U8*)s, (U8*)strend)
5775 : (STRLEN)(strend - s);
5776 SSize_t maxiters = slen + 10;
5777 I32 trailing_empty = 0;
5779 const IV origlimit = limit;
5782 const U8 gimme = GIMME_V;
5784 I32 oldsave = PL_savestack_ix;
5785 U32 make_mortal = SVs_TEMP;
5791 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5792 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5794 /* handle @ary = split(...) optimisation */
5795 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5796 if (!(PL_op->op_flags & OPf_STACKED)) {
5797 if (PL_op->op_private & OPpSPLIT_LEX) {
5798 if (PL_op->op_private & OPpLVAL_INTRO)
5799 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5800 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5805 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5807 pm->op_pmreplrootu.op_pmtargetgv;
5809 if (PL_op->op_private & OPpLVAL_INTRO)
5814 /* skip anything pushed by OPpLVAL_INTRO above */
5815 oldsave = PL_savestack_ix;
5821 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5824 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5826 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5833 for (i = AvFILLp(ary); i >= 0; i--)
5834 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5836 /* temporarily switch stacks */
5837 SAVESWITCHSTACK(PL_curstack, ary);
5842 base = SP - PL_stack_base;
5844 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5846 while (s < strend && isSPACE_utf8_safe(s, strend))
5849 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5850 while (s < strend && isSPACE_LC(*s))
5854 while (s < strend && isSPACE(*s))
5858 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5862 gimme_scalar = gimme == G_SCALAR && !ary;
5865 limit = maxiters + 2;
5866 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5869 /* this one uses 'm' and is a negative test */
5871 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
5872 const int t = UTF8SKIP(m);
5873 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
5880 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5882 while (m < strend && !isSPACE_LC(*m))
5885 while (m < strend && !isSPACE(*m))
5898 dstr = newSVpvn_flags(s, m-s,
5899 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5903 /* skip the whitespace found last */
5905 s = m + UTF8SKIP(m);
5909 /* this one uses 's' and is a positive test */
5911 while (s < strend && isSPACE_utf8_safe(s, strend) )
5914 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5916 while (s < strend && isSPACE_LC(*s))
5919 while (s < strend && isSPACE(*s))
5924 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5926 for (m = s; m < strend && *m != '\n'; m++)
5939 dstr = newSVpvn_flags(s, m-s,
5940 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5946 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5948 Pre-extend the stack, either the number of bytes or
5949 characters in the string or a limited amount, triggered by:
5951 my ($x, $y) = split //, $str;
5955 if (!gimme_scalar) {
5956 const IV items = limit - 1;
5957 /* setting it to -1 will trigger a panic in EXTEND() */
5958 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
5959 if (items >=0 && items < sslen)
5967 /* keep track of how many bytes we skip over */
5977 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5990 dstr = newSVpvn(s, 1);
6006 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6007 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6008 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6009 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6010 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6011 SV * const csv = CALLREG_INTUIT_STRING(rx);
6013 len = RX_MINLENRET(rx);
6014 if (len == 1 && !RX_UTF8(rx) && !tail) {
6015 const char c = *SvPV_nolen_const(csv);
6017 for (m = s; m < strend && *m != c; m++)
6028 dstr = newSVpvn_flags(s, m-s,
6029 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6032 /* The rx->minlen is in characters but we want to step
6033 * s ahead by bytes. */
6035 s = (char*)utf8_hop((U8*)m, len);
6037 s = m + len; /* Fake \n at the end */
6041 while (s < strend && --limit &&
6042 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6043 csv, multiline ? FBMrf_MULTILINE : 0)) )
6052 dstr = newSVpvn_flags(s, m-s,
6053 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6056 /* The rx->minlen is in characters but we want to step
6057 * s ahead by bytes. */
6059 s = (char*)utf8_hop((U8*)m, len);
6061 s = m + len; /* Fake \n at the end */
6066 maxiters += slen * RX_NPARENS(rx);
6067 while (s < strend && --limit)
6071 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6074 if (rex_return == 0)
6076 TAINT_IF(RX_MATCH_TAINTED(rx));
6077 /* we never pass the REXEC_COPY_STR flag, so it should
6078 * never get copied */
6079 assert(!RX_MATCH_COPIED(rx));
6080 m = RX_OFFS(rx)[0].start + orig;
6089 dstr = newSVpvn_flags(s, m-s,
6090 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6093 if (RX_NPARENS(rx)) {
6095 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6096 s = RX_OFFS(rx)[i].start + orig;
6097 m = RX_OFFS(rx)[i].end + orig;
6099 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6100 parens that didn't match -- they should be set to
6101 undef, not the empty string */
6109 if (m >= orig && s >= orig) {
6110 dstr = newSVpvn_flags(s, m-s,
6111 (do_utf8 ? SVf_UTF8 : 0)
6115 dstr = &PL_sv_undef; /* undef, not "" */
6121 s = RX_OFFS(rx)[0].end + orig;
6125 if (!gimme_scalar) {
6126 iters = (SP - PL_stack_base) - base;
6128 if (iters > maxiters)
6129 DIE(aTHX_ "Split loop");
6131 /* keep field after final delim? */
6132 if (s < strend || (iters && origlimit)) {
6133 if (!gimme_scalar) {
6134 const STRLEN l = strend - s;
6135 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6140 else if (!origlimit) {
6142 iters -= trailing_empty;
6144 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6145 if (TOPs && !make_mortal)
6154 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6158 if (SvSMAGICAL(ary)) {
6160 mg_set(MUTABLE_SV(ary));
6163 if (gimme == G_ARRAY) {
6165 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6172 ENTER_with_name("call_PUSH");
6173 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6174 LEAVE_with_name("call_PUSH");
6176 if (gimme == G_ARRAY) {
6178 /* EXTEND should not be needed - we just popped them */
6180 for (i=0; i < iters; i++) {
6181 SV **svp = av_fetch(ary, i, FALSE);
6182 PUSHs((svp) ? *svp : &PL_sv_undef);
6189 if (gimme == G_ARRAY)
6201 SV *const sv = PAD_SVl(PL_op->op_targ);
6203 if (SvPADSTALE(sv)) {
6206 RETURNOP(cLOGOP->op_other);
6208 RETURNOP(cLOGOP->op_next);
6217 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6218 || SvTYPE(retsv) == SVt_PVCV) {
6219 retsv = refto(retsv);
6226 /* used for: pp_padany(), pp_custom(); plus any system ops
6227 * that aren't implemented on a particular platform */
6229 PP(unimplemented_op)
6231 const Optype op_type = PL_op->op_type;
6232 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6233 with out of range op numbers - it only "special" cases op_custom.
6234 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6235 if we get here for a custom op then that means that the custom op didn't
6236 have an implementation. Given that OP_NAME() looks up the custom op
6237 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6238 registers &PL_unimplemented_op as the address of their custom op.
6239 NULL doesn't generate a useful error message. "custom" does. */
6240 const char *const name = op_type >= OP_max
6241 ? "[out of range]" : PL_op_name[PL_op->op_type];
6242 if(OP_IS_SOCKET(op_type))
6243 DIE(aTHX_ PL_no_sock_func, name);
6244 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6248 S_maybe_unwind_defav(pTHX)
6250 if (CX_CUR()->cx_type & CXp_HASARGS) {
6251 PERL_CONTEXT *cx = CX_CUR();
6253 assert(CxHASARGS(cx));
6255 cx->cx_type &= ~CXp_HASARGS;
6259 /* For sorting out arguments passed to a &CORE:: subroutine */
6263 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6264 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6265 AV * const at_ = GvAV(PL_defgv);
6266 SV **svp = at_ ? AvARRAY(at_) : NULL;
6267 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6268 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6269 bool seen_question = 0;
6270 const char *err = NULL;
6271 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6273 /* Count how many args there are first, to get some idea how far to
6274 extend the stack. */
6276 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6278 if (oa & OA_OPTIONAL) seen_question = 1;
6279 if (!seen_question) minargs++;
6283 if(numargs < minargs) err = "Not enough";
6284 else if(numargs > maxargs) err = "Too many";
6286 /* diag_listed_as: Too many arguments for %s */
6288 "%s arguments for %s", err,
6289 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6292 /* Reset the stack pointer. Without this, we end up returning our own
6293 arguments in list context, in addition to the values we are supposed
6294 to return. nextstate usually does this on sub entry, but we need
6295 to run the next op with the caller's hints, so we cannot have a
6297 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6299 if(!maxargs) RETURN;
6301 /* We do this here, rather than with a separate pushmark op, as it has
6302 to come in between two things this function does (stack reset and
6303 arg pushing). This seems the easiest way to do it. */
6306 (void)Perl_pp_pushmark(aTHX);
6309 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6310 PUTBACK; /* The code below can die in various places. */
6312 oa = PL_opargs[opnum] >> OASHIFT;
6313 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6318 if (!numargs && defgv && whicharg == minargs + 1) {
6321 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6325 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6332 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6335 S_maybe_unwind_defav(aTHX);
6338 PUSHs((SV *)GvAVn(gv));
6341 if (!svp || !*svp || !SvROK(*svp)
6342 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6344 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6345 "Type of arg %d to &CORE::%s must be array reference",
6346 whicharg, PL_op_desc[opnum]
6351 if (!svp || !*svp || !SvROK(*svp)
6352 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6353 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6354 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6356 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6357 "Type of arg %d to &CORE::%s must be hash%s reference",
6358 whicharg, PL_op_desc[opnum],
6359 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6366 if (!numargs) PUSHs(NULL);
6367 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6368 /* no magic here, as the prototype will have added an extra
6369 refgen and we just want what was there before that */
6372 const bool constr = PL_op->op_private & whicharg;
6374 svp && *svp ? *svp : &PL_sv_undef,
6375 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6381 if (!numargs) goto try_defsv;
6383 const bool wantscalar =
6384 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6385 if (!svp || !*svp || !SvROK(*svp)
6386 /* We have to permit globrefs even for the \$ proto, as
6387 *foo is indistinguishable from ${\*foo}, and the proto-
6388 type permits the latter. */
6389 || SvTYPE(SvRV(*svp)) > (
6390 wantscalar ? SVt_PVLV
6391 : opnum == OP_LOCK || opnum == OP_UNDEF
6397 "Type of arg %d to &CORE::%s must be %s",
6398 whicharg, PL_op_name[opnum],
6400 ? "scalar reference"
6401 : opnum == OP_LOCK || opnum == OP_UNDEF
6402 ? "reference to one of [$@%&*]"
6403 : "reference to one of [$@%*]"
6406 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6407 /* Undo @_ localisation, so that sub exit does not undo
6408 part of our undeffing. */
6409 S_maybe_unwind_defav(aTHX);
6414 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6426 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6427 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6435 if (PL_op->op_private & OPpOFFBYONE) {
6436 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6438 else cv = find_runcv(NULL);
6439 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6444 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6445 const bool can_preserve)
6447 const SSize_t ix = SvIV(keysv);
6448 if (can_preserve ? av_exists(av, ix) : TRUE) {
6449 SV ** const svp = av_fetch(av, ix, 1);
6451 Perl_croak(aTHX_ PL_no_aelem, ix);
6452 save_aelem(av, ix, svp);
6455 SAVEADELETE(av, ix);
6459 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6460 const bool can_preserve)
6462 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6463 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6464 SV ** const svp = he ? &HeVAL(he) : NULL;
6466 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6467 save_helem_flags(hv, keysv, svp, 0);
6470 SAVEHDELETE(hv, keysv);
6474 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6476 if (type == OPpLVREF_SV) {
6477 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6480 else if (type == OPpLVREF_AV)
6481 /* XXX Inefficient, as it creates a new AV, which we are
6482 about to clobber. */
6485 assert(type == OPpLVREF_HV);
6486 /* XXX Likewise inefficient. */
6495 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6496 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6498 const char *bad = NULL;
6499 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6500 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6503 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6507 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6511 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6515 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6519 /* diag_listed_as: Assigned value is not %s reference */
6520 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6524 switch (left ? SvTYPE(left) : 0) {
6527 SV * const old = PAD_SV(ARGTARG);
6528 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6530 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6532 SAVECLEARSV(PAD_SVl(ARGTARG));
6536 if (PL_op->op_private & OPpLVAL_INTRO) {
6537 S_localise_gv_slot(aTHX_ (GV *)left, type);
6539 gv_setref(left, sv);
6544 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6545 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6546 SvCANEXISTDELETE(left));
6548 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6551 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6553 S_localise_helem_lval(aTHX_ (HV *)left, key,
6554 SvCANEXISTDELETE(left));
6556 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6558 if (PL_op->op_flags & OPf_MOD)
6559 SETs(sv_2mortal(newSVsv(sv)));
6560 /* XXX else can weak references go stale before they are read, e.g.,
6569 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6570 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6571 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6572 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6573 &PL_vtbl_lvref, (char *)elem,
6574 elem ? HEf_SVKEY : (I32)ARGTARG);
6575 mg->mg_private = PL_op->op_private;
6576 if (PL_op->op_private & OPpLVREF_ITER)
6577 mg->mg_flags |= MGf_PERSIST;
6578 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6584 const bool can_preserve = SvCANEXISTDELETE(arg);
6585 if (SvTYPE(arg) == SVt_PVAV)
6586 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6588 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6592 S_localise_gv_slot(aTHX_ (GV *)arg,
6593 PL_op->op_private & OPpLVREF_TYPE);
6595 else if (!(PL_op->op_private & OPpPAD_STATE))
6596 SAVECLEARSV(PAD_SVl(ARGTARG));
6605 AV * const av = (AV *)POPs;
6606 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6607 bool can_preserve = FALSE;
6609 if (UNLIKELY(localizing)) {
6614 can_preserve = SvCANEXISTDELETE(av);
6616 if (SvTYPE(av) == SVt_PVAV) {
6619 for (svp = MARK + 1; svp <= SP; svp++) {
6620 const SSize_t elem = SvIV(*svp);
6624 if (max > AvMAX(av))
6629 while (++MARK <= SP) {
6630 SV * const elemsv = *MARK;
6631 if (SvTYPE(av) == SVt_PVAV)
6632 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6634 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6635 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6636 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6643 if (PL_op->op_flags & OPf_STACKED)
6644 Perl_pp_rv2av(aTHX);
6646 Perl_pp_padav(aTHX);
6650 SETs(0); /* special alias marker that aassign recognises */
6660 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6661 ? CopSTASH(PL_curcop)
6663 NULL, SvREFCNT_inc_simple_NN(sv))));
6668 /* process one subroutine argument - typically when the sub has a signature:
6669 * introduce PL_curpad[op_targ] and assign to it the value
6670 * for $: (OPf_STACKED ? *sp : $_[N])
6671 * for @/%: @_[N..$#_]
6673 * It's equivalent to
6676 * my $foo = (value-on-stack)
6678 * my @foo = @_[N..$#_]
6688 AV *defav = GvAV(PL_defgv); /* @_ */
6689 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6692 /* do 'my $var, @var or %var' action */
6693 padentry = &(PAD_SVl(o->op_targ));
6694 save_clearsv(padentry);
6697 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6698 if (o->op_flags & OPf_STACKED) {
6705 /* should already have been checked */
6707 #if IVSIZE > PTRSIZE
6708 assert(ix <= SSize_t_MAX);
6711 svp = av_fetch(defav, ix, FALSE);
6712 val = svp ? *svp : &PL_sv_undef;
6717 /* cargo-culted from pp_sassign */
6718 assert(TAINTING_get || !TAINT_get);
6719 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6722 SvSetMagicSV(targ, val);
6726 /* must be AV or HV */
6728 assert(!(o->op_flags & OPf_STACKED));
6729 argc = ((IV)AvFILL(defav) + 1) - ix;
6731 /* This is a copy of the relevant parts of pp_aassign().
6733 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6736 if (AvFILL((AV*)targ) > -1) {
6737 /* target should usually be empty. If we get get
6738 * here, someone's been doing some weird closure tricks.
6739 * Make a copy of all args before clearing the array,
6740 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6741 * elements. See similar code in pp_aassign.
6743 for (i = 0; i < argc; i++) {
6744 SV **svp = av_fetch(defav, ix + i, FALSE);
6745 SV *newsv = newSV(0);
6746 sv_setsv_flags(newsv,
6747 svp ? *svp : &PL_sv_undef,
6748 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6749 if (!av_store(defav, ix + i, newsv))
6750 SvREFCNT_dec_NN(newsv);
6752 av_clear((AV*)targ);
6758 av_extend((AV*)targ, argc);
6763 SV **svp = av_fetch(defav, ix + i, FALSE);
6764 SV *val = svp ? *svp : &PL_sv_undef;
6766 sv_setsv(tmpsv, val);
6767 av_store((AV*)targ, i++, tmpsv);
6775 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6777 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6778 /* see "target should usually be empty" comment above */
6779 for (i = 0; i < argc; i++) {
6780 SV **svp = av_fetch(defav, ix + i, FALSE);
6781 SV *newsv = newSV(0);
6782 sv_setsv_flags(newsv,
6783 svp ? *svp : &PL_sv_undef,
6784 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6785 if (!av_store(defav, ix + i, newsv))
6786 SvREFCNT_dec_NN(newsv);
6788 hv_clear((HV*)targ);
6793 assert(argc % 2 == 0);
6802 svp = av_fetch(defav, ix + i++, FALSE);
6803 key = svp ? *svp : &PL_sv_undef;
6804 svp = av_fetch(defav, ix + i++, FALSE);
6805 val = svp ? *svp : &PL_sv_undef;
6808 if (UNLIKELY(SvGMAGICAL(key)))
6809 key = sv_mortalcopy(key);
6811 sv_setsv(tmpsv, val);
6812 hv_store_ent((HV*)targ, key, tmpsv, 0);
6820 /* Handle a default value for one subroutine argument (typically as part
6821 * of a subroutine signature).
6822 * It's equivalent to
6823 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
6825 * Intended to be used where op_next is an OP_ARGELEM
6827 * We abuse the op_targ field slightly: it's an index into @_ rather than
6833 OP * const o = PL_op;
6834 AV *defav = GvAV(PL_defgv); /* @_ */
6835 IV ix = (IV)o->op_targ;
6838 #if IVSIZE > PTRSIZE
6839 assert(ix <= SSize_t_MAX);
6842 if (AvFILL(defav) >= ix) {
6844 SV **svp = av_fetch(defav, ix, FALSE);
6845 SV *val = svp ? *svp : &PL_sv_undef;
6849 return cLOGOPo->op_other;
6854 S_find_runcv_name(void)
6869 sv = sv_2mortal(newSV(0));
6870 gv_fullname4(sv, gv, NULL, TRUE);
6874 /* Check a a subs arguments - i.e. that it has the correct number of args
6875 * (and anything else we might think of in future). Typically used with
6881 OP * const o = PL_op;
6882 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6883 IV params = aux[0].iv;
6884 IV opt_params = aux[1].iv;
6885 char slurpy = (char)(aux[2].iv);
6886 AV *defav = GvAV(PL_defgv); /* @_ */
6890 assert(!SvMAGICAL(defav));
6891 argc = (AvFILLp(defav) + 1);
6892 too_few = (argc < (params - opt_params));
6894 if (UNLIKELY(too_few || (!slurpy && argc > params)))
6895 /* diag_listed_as: Too few arguments for subroutine '%s' */
6896 /* diag_listed_as: Too many arguments for subroutine '%s' */
6897 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
6898 too_few ? "few" : "many", S_find_runcv_name());
6900 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6901 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
6902 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
6903 S_find_runcv_name());
6909 * ex: set ts=8 sts=4 sw=4 et: