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);
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 if (len && ! utf8_to_bytes(tmps, &len)) {
2641 Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
2652 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2655 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2660 for ( ; anum > 0; anum--, tmps++)
2667 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2671 if (PL_op->op_private & HINT_INTEGER) {
2672 const IV i = ~SvIV_nomg(sv);
2676 const UV u = ~SvUV_nomg(sv);
2681 S_scomplement(aTHX_ TARG, sv);
2691 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2694 if (PL_op->op_private & HINT_INTEGER) {
2695 const IV i = ~SvIV_nomg(sv);
2699 const UV u = ~SvUV_nomg(sv);
2709 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2712 S_scomplement(aTHX_ TARG, sv);
2718 /* integer versions of some of the above */
2723 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2726 SETi( left * right );
2735 tryAMAGICbin_MG(div_amg, AMGf_assign);
2738 IV value = SvIV_nomg(right);
2740 DIE(aTHX_ "Illegal division by zero");
2741 num = SvIV_nomg(left);
2743 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2747 value = num / value;
2755 /* This is the vanilla old i_modulo. */
2757 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2761 DIE(aTHX_ "Illegal modulus zero");
2762 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2766 SETi( left % right );
2771 #if defined(__GLIBC__) && IVSIZE == 8 \
2772 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2774 PP(pp_i_modulo_glibc_bugfix)
2776 /* This is the i_modulo with the workaround for the _moddi3 bug
2777 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2778 * See below for pp_i_modulo. */
2780 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2784 DIE(aTHX_ "Illegal modulus zero");
2785 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2789 SETi( left % PERL_ABS(right) );
2798 tryAMAGICbin_MG(add_amg, AMGf_assign);
2800 dPOPTOPiirl_ul_nomg;
2801 SETi( left + right );
2809 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2811 dPOPTOPiirl_ul_nomg;
2812 SETi( left - right );
2820 tryAMAGICbin_MG(lt_amg, AMGf_set);
2823 SETs(boolSV(left < right));
2831 tryAMAGICbin_MG(gt_amg, AMGf_set);
2834 SETs(boolSV(left > right));
2842 tryAMAGICbin_MG(le_amg, AMGf_set);
2845 SETs(boolSV(left <= right));
2853 tryAMAGICbin_MG(ge_amg, AMGf_set);
2856 SETs(boolSV(left >= right));
2864 tryAMAGICbin_MG(eq_amg, AMGf_set);
2867 SETs(boolSV(left == right));
2875 tryAMAGICbin_MG(ne_amg, AMGf_set);
2878 SETs(boolSV(left != right));
2886 tryAMAGICbin_MG(ncmp_amg, 0);
2893 else if (left < right)
2905 tryAMAGICun_MG(neg_amg, 0);
2906 if (S_negate_string(aTHX)) return NORMAL;
2908 SV * const sv = TOPs;
2909 IV const i = SvIV_nomg(sv);
2915 /* High falutin' math. */
2920 tryAMAGICbin_MG(atan2_amg, 0);
2923 SETn(Perl_atan2(left, right));
2929 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2934 int amg_type = fallback_amg;
2935 const char *neg_report = NULL;
2936 const int op_type = PL_op->op_type;
2939 case OP_SIN: amg_type = sin_amg; break;
2940 case OP_COS: amg_type = cos_amg; break;
2941 case OP_EXP: amg_type = exp_amg; break;
2942 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2943 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2946 assert(amg_type != fallback_amg);
2948 tryAMAGICun_MG(amg_type, 0);
2950 SV * const arg = TOPs;
2951 const NV value = SvNV_nomg(arg);
2957 if (neg_report) { /* log or sqrt */
2959 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2960 ! Perl_isnan(value) &&
2962 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2963 SET_NUMERIC_STANDARD();
2964 /* diag_listed_as: Can't take log of %g */
2965 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2970 case OP_SIN: result = Perl_sin(value); break;
2971 case OP_COS: result = Perl_cos(value); break;
2972 case OP_EXP: result = Perl_exp(value); break;
2973 case OP_LOG: result = Perl_log(value); break;
2974 case OP_SQRT: result = Perl_sqrt(value); break;
2981 /* Support Configure command-line overrides for rand() functions.
2982 After 5.005, perhaps we should replace this by Configure support
2983 for drand48(), random(), or rand(). For 5.005, though, maintain
2984 compatibility by calling rand() but allow the user to override it.
2985 See INSTALL for details. --Andy Dougherty 15 July 1998
2987 /* Now it's after 5.005, and Configure supports drand48() and random(),
2988 in addition to rand(). So the overrides should not be needed any more.
2989 --Jarkko Hietaniemi 27 September 1998
2994 if (!PL_srand_called) {
2995 (void)seedDrand01((Rand_seed_t)seed());
2996 PL_srand_called = TRUE;
3008 SV * const sv = POPs;
3014 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3015 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3016 if (! Perl_isnan(value) && value == 0.0)
3026 sv_setnv_mg(TARG, value);
3037 if (MAXARG >= 1 && (TOPs || POPs)) {
3044 pv = SvPV(top, len);
3045 flags = grok_number(pv, len, &anum);
3047 if (!(flags & IS_NUMBER_IN_UV)) {
3048 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3049 "Integer overflow in srand");
3057 (void)seedDrand01((Rand_seed_t)anum);
3058 PL_srand_called = TRUE;
3062 /* Historically srand always returned true. We can avoid breaking
3064 sv_setpvs(TARG, "0 but true");
3073 tryAMAGICun_MG(int_amg, AMGf_numeric);
3075 SV * const sv = TOPs;
3076 const IV iv = SvIV_nomg(sv);
3077 /* XXX it's arguable that compiler casting to IV might be subtly
3078 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3079 else preferring IV has introduced a subtle behaviour change bug. OTOH
3080 relying on floating point to be accurate is a bug. */
3085 else if (SvIOK(sv)) {
3087 SETu(SvUV_nomg(sv));
3092 const NV value = SvNV_nomg(sv);
3093 if (UNLIKELY(Perl_isinfnan(value)))
3095 else if (value >= 0.0) {
3096 if (value < (NV)UV_MAX + 0.5) {
3099 SETn(Perl_floor(value));
3103 if (value > (NV)IV_MIN - 0.5) {
3106 SETn(Perl_ceil(value));
3117 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3119 SV * const sv = TOPs;
3120 /* This will cache the NV value if string isn't actually integer */
3121 const IV iv = SvIV_nomg(sv);
3126 else if (SvIOK(sv)) {
3127 /* IVX is precise */
3129 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3137 /* 2s complement assumption. Also, not really needed as
3138 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3144 const NV value = SvNV_nomg(sv);
3155 /* also used for: pp_hex() */
3161 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3165 SV* const sv = TOPs;
3167 tmps = (SvPV_const(sv, len));
3169 /* If Unicode, try to downgrade
3170 * If not possible, croak. */
3171 SV* const tsv = sv_2mortal(newSVsv(sv));
3174 sv_utf8_downgrade(tsv, FALSE);
3175 tmps = SvPV_const(tsv, len);
3177 if (PL_op->op_type == OP_HEX)
3180 while (*tmps && len && isSPACE(*tmps))
3184 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3186 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3188 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3189 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3191 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3193 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3207 SV * const sv = TOPs;
3209 U32 in_bytes = IN_BYTES;
3210 /* simplest case shortcut */
3211 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3212 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3213 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3216 if(LIKELY(svflags == SVf_POK))
3218 if(svflags & SVs_GMG)
3221 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3222 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3226 /* unrolled SvPV_nomg_const(sv,len) */
3231 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3233 sv_setiv(TARG, (IV)(len));
3236 if (!SvPADTMP(TARG)) {
3238 } else { /* TARG is on stack at this point and is overwriten by SETs.
3239 This branch is the odd one out, so put TARG by default on
3240 stack earlier to let local SP go out of liveness sooner */
3247 return NORMAL; /* no putback, SP didn't move in this opcode */
3250 /* Returns false if substring is completely outside original string.
3251 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3252 always be true for an explicit 0.
3255 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3256 bool pos1_is_uv, IV len_iv,
3257 bool len_is_uv, STRLEN *posp,
3263 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3265 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3266 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3269 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3272 if (len_iv || len_is_uv) {
3273 if (!len_is_uv && len_iv < 0) {
3274 pos2_iv = curlen + len_iv;
3276 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3279 } else { /* len_iv >= 0 */
3280 if (!pos1_is_uv && pos1_iv < 0) {
3281 pos2_iv = pos1_iv + len_iv;
3282 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3284 if ((UV)len_iv > curlen-(UV)pos1_iv)
3287 pos2_iv = pos1_iv+len_iv;
3297 if (!pos2_is_uv && pos2_iv < 0) {
3298 if (!pos1_is_uv && pos1_iv < 0)
3302 else if (!pos1_is_uv && pos1_iv < 0)
3305 if ((UV)pos2_iv < (UV)pos1_iv)
3307 if ((UV)pos2_iv > curlen)
3310 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3311 *posp = (STRLEN)( (UV)pos1_iv );
3312 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3329 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3330 const bool rvalue = (GIMME_V != G_VOID);
3333 const char *repl = NULL;
3335 int num_args = PL_op->op_private & 7;
3336 bool repl_need_utf8_upgrade = FALSE;
3340 if(!(repl_sv = POPs)) num_args--;
3342 if ((len_sv = POPs)) {
3343 len_iv = SvIV(len_sv);
3344 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3349 pos1_iv = SvIV(pos_sv);
3350 pos1_is_uv = SvIOK_UV(pos_sv);
3352 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3356 if (lvalue && !repl_sv) {
3358 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3359 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3361 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3363 pos1_is_uv || pos1_iv >= 0
3364 ? (STRLEN)(UV)pos1_iv
3365 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3367 len_is_uv || len_iv > 0
3368 ? (STRLEN)(UV)len_iv
3369 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3371 PUSHs(ret); /* avoid SvSETMAGIC here */
3375 repl = SvPV_const(repl_sv, repl_len);
3378 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3379 "Attempt to use reference as lvalue in substr"
3381 tmps = SvPV_force_nomg(sv, curlen);
3382 if (DO_UTF8(repl_sv) && repl_len) {
3384 /* Upgrade the dest, and recalculate tmps in case the buffer
3385 * got reallocated; curlen may also have been changed */
3386 sv_utf8_upgrade_nomg(sv);
3387 tmps = SvPV_nomg(sv, curlen);
3390 else if (DO_UTF8(sv))
3391 repl_need_utf8_upgrade = TRUE;
3393 else tmps = SvPV_const(sv, curlen);
3395 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3396 if (utf8_curlen == curlen)
3399 curlen = utf8_curlen;
3405 STRLEN pos, len, byte_len, byte_pos;
3407 if (!translate_substr_offsets(
3408 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3412 byte_pos = utf8_curlen
3413 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3418 SvTAINTED_off(TARG); /* decontaminate */
3419 SvUTF8_off(TARG); /* decontaminate */
3420 sv_setpvn(TARG, tmps, byte_len);
3421 #ifdef USE_LOCALE_COLLATE
3422 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3429 SV* repl_sv_copy = NULL;
3431 if (repl_need_utf8_upgrade) {
3432 repl_sv_copy = newSVsv(repl_sv);
3433 sv_utf8_upgrade(repl_sv_copy);
3434 repl = SvPV_const(repl_sv_copy, repl_len);
3438 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3439 SvREFCNT_dec(repl_sv_copy);
3442 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3452 Perl_croak(aTHX_ "substr outside of string");
3453 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3460 const IV size = POPi;
3461 SV* offsetsv = POPs;
3462 SV * const src = POPs;
3463 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3469 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3470 * or flag that its out of range */
3472 IV iv = SvIV(offsetsv);
3474 /* avoid a large UV being wrapped to a negative value */
3475 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3476 errflags = LVf_OUT_OF_RANGE;
3478 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3479 #if PTRSIZE < IVSIZE
3480 else if (iv > Size_t_MAX)
3481 errflags = LVf_OUT_OF_RANGE;
3484 offset = (STRLEN)iv;
3487 retuv = errflags ? 0 : do_vecget(src, offset, size);
3489 if (lvalue) { /* it's an lvalue! */
3490 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3491 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3493 LvTARG(ret) = SvREFCNT_inc_simple(src);
3494 LvTARGOFF(ret) = offset;
3495 LvTARGLEN(ret) = size;
3496 LvFLAGS(ret) = errflags;
3500 SvTAINTED_off(TARG); /* decontaminate */
3504 sv_setuv(ret, retuv);
3512 /* also used for: pp_rindex() */
3525 const char *little_p;
3528 const bool is_index = PL_op->op_type == OP_INDEX;
3529 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3535 big_p = SvPV_const(big, biglen);
3536 little_p = SvPV_const(little, llen);
3538 big_utf8 = DO_UTF8(big);
3539 little_utf8 = DO_UTF8(little);
3540 if (big_utf8 ^ little_utf8) {
3541 /* One needs to be upgraded. */
3543 /* Well, maybe instead we might be able to downgrade the small
3545 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3548 /* If the large string is ISO-8859-1, and it's not possible to
3549 convert the small string to ISO-8859-1, then there is no
3550 way that it could be found anywhere by index. */
3555 /* At this point, pv is a malloc()ed string. So donate it to temp
3556 to ensure it will get free()d */
3557 little = temp = newSV(0);
3558 sv_usepvn(temp, pv, llen);
3559 little_p = SvPVX(little);
3561 temp = newSVpvn(little_p, llen);
3563 sv_utf8_upgrade(temp);
3565 little_p = SvPV_const(little, llen);
3568 if (SvGAMAGIC(big)) {
3569 /* Life just becomes a lot easier if I use a temporary here.
3570 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3571 will trigger magic and overloading again, as will fbm_instr()
3573 big = newSVpvn_flags(big_p, biglen,
3574 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3577 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3578 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3579 warn on undef, and we've already triggered a warning with the
3580 SvPV_const some lines above. We can't remove that, as we need to
3581 call some SvPV to trigger overloading early and find out if the
3583 This is all getting too messy. The API isn't quite clean enough,
3584 because data access has side effects.
3586 little = newSVpvn_flags(little_p, llen,
3587 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3588 little_p = SvPVX(little);
3592 offset = is_index ? 0 : biglen;
3594 if (big_utf8 && offset > 0)
3595 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3601 else if (offset > (SSize_t)biglen)
3603 if (!(little_p = is_index
3604 ? fbm_instr((unsigned char*)big_p + offset,
3605 (unsigned char*)big_p + biglen, little, 0)
3606 : rninstr(big_p, big_p + offset,
3607 little_p, little_p + llen)))
3610 retval = little_p - big_p;
3611 if (retval > 1 && big_utf8)
3612 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3622 dSP; dMARK; dORIGMARK; dTARGET;
3623 SvTAINTED_off(TARG);
3624 do_sprintf(TARG, SP-MARK, MARK+1);
3625 TAINT_IF(SvTAINTED(TARG));
3637 const U8 *s = (U8*)SvPV_const(argsv, len);
3640 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3654 if (UNLIKELY(SvAMAGIC(top)))
3656 if (UNLIKELY(isinfnansv(top)))
3657 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3659 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3660 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3662 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3663 && SvNV_nomg(top) < 0.0)))
3665 if (ckWARN(WARN_UTF8)) {
3666 if (SvGMAGICAL(top)) {
3667 SV *top2 = sv_newmortal();
3668 sv_setsv_nomg(top2, top);
3671 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3672 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3674 value = UNICODE_REPLACEMENT;
3676 value = SvUV_nomg(top);
3680 SvUPGRADE(TARG,SVt_PV);
3682 if (value > 255 && !IN_BYTES) {
3683 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3684 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3685 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3687 (void)SvPOK_only(TARG);
3696 *tmps++ = (char)value;
3698 (void)SvPOK_only(TARG);
3710 const char *tmps = SvPV_const(left, len);
3712 if (DO_UTF8(left)) {
3713 /* If Unicode, try to downgrade.
3714 * If not possible, croak.
3715 * Yes, we made this up. */
3716 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3718 sv_utf8_downgrade(tsv, FALSE);
3719 tmps = SvPV_const(tsv, len);
3721 # ifdef USE_ITHREADS
3723 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3724 /* This should be threadsafe because in ithreads there is only
3725 * one thread per interpreter. If this would not be true,
3726 * we would need a mutex to protect this malloc. */
3727 PL_reentrant_buffer->_crypt_struct_buffer =
3728 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3729 #if defined(__GLIBC__) || defined(__EMX__)
3730 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3731 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3732 /* work around glibc-2.2.5 bug */
3733 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3737 # endif /* HAS_CRYPT_R */
3738 # endif /* USE_ITHREADS */
3740 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3742 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3749 "The crypt() function is unimplemented due to excessive paranoia.");
3753 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3754 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3757 /* also used for: pp_lcfirst() */
3761 /* Actually is both lcfirst() and ucfirst(). Only the first character
3762 * changes. This means that possibly we can change in-place, ie., just
3763 * take the source and change that one character and store it back, but not
3764 * if read-only etc, or if the length changes */
3768 STRLEN slen; /* slen is the byte length of the whole SV. */
3771 bool inplace; /* ? Convert first char only, in-place */
3772 bool doing_utf8 = FALSE; /* ? using utf8 */
3773 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3774 const int op_type = PL_op->op_type;
3777 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3778 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3779 * stored as UTF-8 at s. */
3780 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3781 * lowercased) character stored in tmpbuf. May be either
3782 * UTF-8 or not, but in either case is the number of bytes */
3784 s = (const U8*)SvPV_const(source, slen);
3786 /* We may be able to get away with changing only the first character, in
3787 * place, but not if read-only, etc. Later we may discover more reasons to
3788 * not convert in-place. */
3789 inplace = !SvREADONLY(source) && SvPADTMP(source);
3791 /* First calculate what the changed first character should be. This affects
3792 * whether we can just swap it out, leaving the rest of the string unchanged,
3793 * or even if have to convert the dest to UTF-8 when the source isn't */
3795 if (! slen) { /* If empty */
3796 need = 1; /* still need a trailing NUL */
3799 else if (DO_UTF8(source)) { /* Is the source utf8? */
3802 if (op_type == OP_UCFIRST) {
3803 #ifdef USE_LOCALE_CTYPE
3804 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3806 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3810 #ifdef USE_LOCALE_CTYPE
3811 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3813 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3817 /* we can't do in-place if the length changes. */
3818 if (ulen != tculen) inplace = FALSE;
3819 need = slen + 1 - ulen + tculen;
3821 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3822 * latin1 is treated as caseless. Note that a locale takes
3824 ulen = 1; /* Original character is 1 byte */
3825 tculen = 1; /* Most characters will require one byte, but this will
3826 * need to be overridden for the tricky ones */
3829 if (op_type == OP_LCFIRST) {
3831 /* lower case the first letter: no trickiness for any character */
3832 #ifdef USE_LOCALE_CTYPE
3833 if (IN_LC_RUNTIME(LC_CTYPE)) {
3834 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3835 *tmpbuf = toLOWER_LC(*s);
3840 *tmpbuf = (IN_UNI_8_BIT)
3841 ? toLOWER_LATIN1(*s)
3845 #ifdef USE_LOCALE_CTYPE
3847 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3848 if (IN_UTF8_CTYPE_LOCALE) {
3852 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3853 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3854 locales have upper and title case
3858 else if (! IN_UNI_8_BIT) {
3859 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3860 * on EBCDIC machines whatever the
3861 * native function does */
3864 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3865 * UTF-8, which we treat as not in locale), and cased latin1 */
3867 #ifdef USE_LOCALE_CTYPE
3871 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3873 assert(tculen == 2);
3875 /* If the result is an upper Latin1-range character, it can
3876 * still be represented in one byte, which is its ordinal */
3877 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3878 *tmpbuf = (U8) title_ord;
3882 /* Otherwise it became more than one ASCII character (in
3883 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3884 * beyond Latin1, so the number of bytes changed, so can't
3885 * replace just the first character in place. */
3888 /* If the result won't fit in a byte, the entire result
3889 * will have to be in UTF-8. Assume worst case sizing in
3890 * conversion. (all latin1 characters occupy at most two
3892 if (title_ord > 255) {
3894 convert_source_to_utf8 = TRUE;
3895 need = slen * 2 + 1;
3897 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3898 * (both) characters whose title case is above 255 is
3902 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3903 need = slen + 1 + 1;
3907 } /* End of use Unicode (Latin1) semantics */
3908 } /* End of changing the case of the first character */
3910 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3911 * generate the result */
3914 /* We can convert in place. This means we change just the first
3915 * character without disturbing the rest; no need to grow */
3917 s = d = (U8*)SvPV_force_nomg(source, slen);
3923 /* Here, we can't convert in place; we earlier calculated how much
3924 * space we will need, so grow to accommodate that */
3925 SvUPGRADE(dest, SVt_PV);
3926 d = (U8*)SvGROW(dest, need);
3927 (void)SvPOK_only(dest);
3934 if (! convert_source_to_utf8) {
3936 /* Here both source and dest are in UTF-8, but have to create
3937 * the entire output. We initialize the result to be the
3938 * title/lower cased first character, and then append the rest
3940 sv_setpvn(dest, (char*)tmpbuf, tculen);
3942 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3946 const U8 *const send = s + slen;
3948 /* Here the dest needs to be in UTF-8, but the source isn't,
3949 * except we earlier UTF-8'd the first character of the source
3950 * into tmpbuf. First put that into dest, and then append the
3951 * rest of the source, converting it to UTF-8 as we go. */
3953 /* Assert tculen is 2 here because the only two characters that
3954 * get to this part of the code have 2-byte UTF-8 equivalents */
3956 *d++ = *(tmpbuf + 1);
3957 s++; /* We have just processed the 1st char */
3959 for (; s < send; s++) {
3960 d = uvchr_to_utf8(d, *s);
3963 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3967 else { /* in-place UTF-8. Just overwrite the first character */
3968 Copy(tmpbuf, d, tculen, U8);
3969 SvCUR_set(dest, need - 1);
3973 else { /* Neither source nor dest are in or need to be UTF-8 */
3975 if (inplace) { /* in-place, only need to change the 1st char */
3978 else { /* Not in-place */
3980 /* Copy the case-changed character(s) from tmpbuf */
3981 Copy(tmpbuf, d, tculen, U8);
3982 d += tculen - 1; /* Code below expects d to point to final
3983 * character stored */
3986 else { /* empty source */
3987 /* See bug #39028: Don't taint if empty */
3991 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3992 * the destination to retain that flag */
3993 if (SvUTF8(source) && ! IN_BYTES)
3996 if (!inplace) { /* Finish the rest of the string, unchanged */
3997 /* This will copy the trailing NUL */
3998 Copy(s + 1, d + 1, slen, U8);
3999 SvCUR_set(dest, need - 1);
4002 #ifdef USE_LOCALE_CTYPE
4003 if (IN_LC_RUNTIME(LC_CTYPE)) {
4008 if (dest != source && SvTAINTED(source))
4014 /* There's so much setup/teardown code common between uc and lc, I wonder if
4015 it would be worth merging the two, and just having a switch outside each
4016 of the three tight loops. There is less and less commonality though */
4029 if ( SvPADTMP(source)
4030 && !SvREADONLY(source) && SvPOK(source)
4033 #ifdef USE_LOCALE_CTYPE
4034 (IN_LC_RUNTIME(LC_CTYPE))
4035 ? ! IN_UTF8_CTYPE_LOCALE
4041 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4042 * make the loop tight, so we overwrite the source with the dest before
4043 * looking at it, and we need to look at the original source
4044 * afterwards. There would also need to be code added to handle
4045 * switching to not in-place in midstream if we run into characters
4046 * that change the length. Since being in locale overrides UNI_8_BIT,
4047 * that latter becomes irrelevant in the above test; instead for
4048 * locale, the size can't normally change, except if the locale is a
4051 s = d = (U8*)SvPV_force_nomg(source, len);
4058 s = (const U8*)SvPV_nomg_const(source, len);
4061 SvUPGRADE(dest, SVt_PV);
4062 d = (U8*)SvGROW(dest, min);
4063 (void)SvPOK_only(dest);
4068 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4069 to check DO_UTF8 again here. */
4071 if (DO_UTF8(source)) {
4072 const U8 *const send = s + len;
4073 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4075 /* All occurrences of these are to be moved to follow any other marks.
4076 * This is context-dependent. We may not be passed enough context to
4077 * move the iota subscript beyond all of them, but we do the best we can
4078 * with what we're given. The result is always better than if we
4079 * hadn't done this. And, the problem would only arise if we are
4080 * passed a character without all its combining marks, which would be
4081 * the caller's mistake. The information this is based on comes from a
4082 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4083 * itself) and so can't be checked properly to see if it ever gets
4084 * revised. But the likelihood of it changing is remote */
4085 bool in_iota_subscript = FALSE;
4091 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4093 /* A non-mark. Time to output the iota subscript */
4094 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4095 d += capital_iota_len;
4096 in_iota_subscript = FALSE;
4099 /* Then handle the current character. Get the changed case value
4100 * and copy it to the output buffer */
4103 #ifdef USE_LOCALE_CTYPE
4104 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4106 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4108 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4109 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4110 if (uv == GREEK_CAPITAL_LETTER_IOTA
4111 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4113 in_iota_subscript = TRUE;
4116 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4117 /* If the eventually required minimum size outgrows the
4118 * available space, we need to grow. */
4119 const UV o = d - (U8*)SvPVX_const(dest);
4121 /* If someone uppercases one million U+03B0s we SvGROW()
4122 * one million times. Or we could try guessing how much to
4123 * allocate without allocating too much. Such is life.
4124 * See corresponding comment in lc code for another option
4126 d = o + (U8*) SvGROW(dest, min);
4128 Copy(tmpbuf, d, ulen, U8);
4133 if (in_iota_subscript) {
4134 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4135 d += capital_iota_len;
4140 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4142 else { /* Not UTF-8 */
4144 const U8 *const send = s + len;
4146 /* Use locale casing if in locale; regular style if not treating
4147 * latin1 as having case; otherwise the latin1 casing. Do the
4148 * whole thing in a tight loop, for speed, */
4149 #ifdef USE_LOCALE_CTYPE
4150 if (IN_LC_RUNTIME(LC_CTYPE)) {
4151 if (IN_UTF8_CTYPE_LOCALE) {
4154 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4155 for (; s < send; d++, s++)
4156 *d = (U8) toUPPER_LC(*s);
4160 if (! IN_UNI_8_BIT) {
4161 for (; s < send; d++, s++) {
4166 #ifdef USE_LOCALE_CTYPE
4169 for (; s < send; d++, s++) {
4170 *d = toUPPER_LATIN1_MOD(*s);
4171 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4175 /* The mainstream case is the tight loop above. To avoid
4176 * extra tests in that, all three characters that require
4177 * special handling are mapped by the MOD to the one tested
4179 * Use the source to distinguish between the three cases */
4181 #if UNICODE_MAJOR_VERSION > 2 \
4182 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4183 && UNICODE_DOT_DOT_VERSION >= 8)
4184 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4186 /* uc() of this requires 2 characters, but they are
4187 * ASCII. If not enough room, grow the string */
4188 if (SvLEN(dest) < ++min) {
4189 const UV o = d - (U8*)SvPVX_const(dest);
4190 d = o + (U8*) SvGROW(dest, min);
4192 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4193 continue; /* Back to the tight loop; still in ASCII */
4197 /* The other two special handling characters have their
4198 * upper cases outside the latin1 range, hence need to be
4199 * in UTF-8, so the whole result needs to be in UTF-8. So,
4200 * here we are somewhere in the middle of processing a
4201 * non-UTF-8 string, and realize that we will have to convert
4202 * the whole thing to UTF-8. What to do? There are
4203 * several possibilities. The simplest to code is to
4204 * convert what we have so far, set a flag, and continue on
4205 * in the loop. The flag would be tested each time through
4206 * the loop, and if set, the next character would be
4207 * converted to UTF-8 and stored. But, I (khw) didn't want
4208 * to slow down the mainstream case at all for this fairly
4209 * rare case, so I didn't want to add a test that didn't
4210 * absolutely have to be there in the loop, besides the
4211 * possibility that it would get too complicated for
4212 * optimizers to deal with. Another possibility is to just
4213 * give up, convert the source to UTF-8, and restart the
4214 * function that way. Another possibility is to convert
4215 * both what has already been processed and what is yet to
4216 * come separately to UTF-8, then jump into the loop that
4217 * handles UTF-8. But the most efficient time-wise of the
4218 * ones I could think of is what follows, and turned out to
4219 * not require much extra code. */
4221 /* Convert what we have so far into UTF-8, telling the
4222 * function that we know it should be converted, and to
4223 * allow extra space for what we haven't processed yet.
4224 * Assume the worst case space requirements for converting
4225 * what we haven't processed so far: that it will require
4226 * two bytes for each remaining source character, plus the
4227 * NUL at the end. This may cause the string pointer to
4228 * move, so re-find it. */
4230 len = d - (U8*)SvPVX_const(dest);
4231 SvCUR_set(dest, len);
4232 len = sv_utf8_upgrade_flags_grow(dest,
4233 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4235 d = (U8*)SvPVX(dest) + len;
4237 /* Now process the remainder of the source, converting to
4238 * upper and UTF-8. If a resulting byte is invariant in
4239 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4240 * append it to the output. */
4241 for (; s < send; s++) {
4242 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4246 /* Here have processed the whole source; no need to continue
4247 * with the outer loop. Each character has been converted
4248 * to upper case and converted to UTF-8 */
4251 } /* End of processing all latin1-style chars */
4252 } /* End of processing all chars */
4253 } /* End of source is not empty */
4255 if (source != dest) {
4256 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4257 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4259 } /* End of isn't utf8 */
4260 #ifdef USE_LOCALE_CTYPE
4261 if (IN_LC_RUNTIME(LC_CTYPE)) {
4266 if (dest != source && SvTAINTED(source))
4284 if ( SvPADTMP(source)
4285 && !SvREADONLY(source) && SvPOK(source)
4286 && !DO_UTF8(source)) {
4288 /* We can convert in place, as lowercasing anything in the latin1 range
4289 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4291 s = d = (U8*)SvPV_force_nomg(source, len);
4298 s = (const U8*)SvPV_nomg_const(source, len);
4301 SvUPGRADE(dest, SVt_PV);
4302 d = (U8*)SvGROW(dest, min);
4303 (void)SvPOK_only(dest);
4308 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4309 to check DO_UTF8 again here. */
4311 if (DO_UTF8(source)) {
4312 const U8 *const send = s + len;
4313 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4316 const STRLEN u = UTF8SKIP(s);
4319 #ifdef USE_LOCALE_CTYPE
4320 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4322 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4325 /* Here is where we would do context-sensitive actions. See the
4326 * commit message for 86510fb15 for why there isn't any */
4328 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4330 /* If the eventually required minimum size outgrows the
4331 * available space, we need to grow. */
4332 const UV o = d - (U8*)SvPVX_const(dest);
4334 /* If someone lowercases one million U+0130s we SvGROW() one
4335 * million times. Or we could try guessing how much to
4336 * allocate without allocating too much. Such is life.
4337 * Another option would be to grow an extra byte or two more
4338 * each time we need to grow, which would cut down the million
4339 * to 500K, with little waste */
4340 d = o + (U8*) SvGROW(dest, min);
4343 /* Copy the newly lowercased letter to the output buffer we're
4345 Copy(tmpbuf, d, ulen, U8);
4348 } /* End of looping through the source string */
4351 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4352 } else { /* Not utf8 */
4354 const U8 *const send = s + len;
4356 /* Use locale casing if in locale; regular style if not treating
4357 * latin1 as having case; otherwise the latin1 casing. Do the
4358 * whole thing in a tight loop, for speed, */
4359 #ifdef USE_LOCALE_CTYPE
4360 if (IN_LC_RUNTIME(LC_CTYPE)) {
4361 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4362 for (; s < send; d++, s++)
4363 *d = toLOWER_LC(*s);
4367 if (! IN_UNI_8_BIT) {
4368 for (; s < send; d++, s++) {
4373 for (; s < send; d++, s++) {
4374 *d = toLOWER_LATIN1(*s);
4378 if (source != dest) {
4380 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4383 #ifdef USE_LOCALE_CTYPE
4384 if (IN_LC_RUNTIME(LC_CTYPE)) {
4389 if (dest != source && SvTAINTED(source))
4398 SV * const sv = TOPs;
4400 const char *s = SvPV_const(sv,len);
4402 SvUTF8_off(TARG); /* decontaminate */
4405 SvUPGRADE(TARG, SVt_PV);
4406 SvGROW(TARG, (len * 2) + 1);
4410 STRLEN ulen = UTF8SKIP(s);
4411 bool to_quote = FALSE;
4413 if (UTF8_IS_INVARIANT(*s)) {
4414 if (_isQUOTEMETA(*s)) {
4418 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4420 #ifdef USE_LOCALE_CTYPE
4421 /* In locale, we quote all non-ASCII Latin1 chars.
4422 * Otherwise use the quoting rules */
4424 IN_LC_RUNTIME(LC_CTYPE)
4427 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4432 else if (is_QUOTEMETA_high(s)) {
4447 else if (IN_UNI_8_BIT) {
4449 if (_isQUOTEMETA(*s))
4455 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4456 * including everything above ASCII */
4458 if (!isWORDCHAR_A(*s))
4464 SvCUR_set(TARG, d - SvPVX_const(TARG));
4465 (void)SvPOK_only_UTF8(TARG);
4468 sv_setpvn(TARG, s, len);
4484 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4485 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4486 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4487 || UNICODE_DOT_DOT_VERSION > 0)
4488 const bool full_folding = TRUE; /* This variable is here so we can easily
4489 move to more generality later */
4491 const bool full_folding = FALSE;
4493 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4494 #ifdef USE_LOCALE_CTYPE
4495 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4499 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4500 * You are welcome(?) -Hugmeir
4508 s = (const U8*)SvPV_nomg_const(source, len);
4510 if (ckWARN(WARN_UNINITIALIZED))
4511 report_uninit(source);
4518 SvUPGRADE(dest, SVt_PV);
4519 d = (U8*)SvGROW(dest, min);
4520 (void)SvPOK_only(dest);
4525 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4527 const STRLEN u = UTF8SKIP(s);
4530 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4532 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4533 const UV o = d - (U8*)SvPVX_const(dest);
4534 d = o + (U8*) SvGROW(dest, min);
4537 Copy(tmpbuf, d, ulen, U8);
4542 } /* Unflagged string */
4544 #ifdef USE_LOCALE_CTYPE
4545 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4546 if (IN_UTF8_CTYPE_LOCALE) {
4547 goto do_uni_folding;
4549 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4550 for (; s < send; d++, s++)
4551 *d = (U8) toFOLD_LC(*s);
4555 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4556 for (; s < send; d++, s++)
4560 #ifdef USE_LOCALE_CTYPE
4563 /* For ASCII and the Latin-1 range, there's only two troublesome
4564 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4565 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4566 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4567 * For the rest, the casefold is their lowercase. */
4568 for (; s < send; d++, s++) {
4569 if (*s == MICRO_SIGN) {
4570 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4571 * which is outside of the latin-1 range. There's a couple
4572 * of ways to deal with this -- khw discusses them in
4573 * pp_lc/uc, so go there :) What we do here is upgrade what
4574 * we had already casefolded, then enter an inner loop that
4575 * appends the rest of the characters as UTF-8. */
4576 len = d - (U8*)SvPVX_const(dest);
4577 SvCUR_set(dest, len);
4578 len = sv_utf8_upgrade_flags_grow(dest,
4579 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4580 /* The max expansion for latin1
4581 * chars is 1 byte becomes 2 */
4583 d = (U8*)SvPVX(dest) + len;
4585 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4588 for (; s < send; s++) {
4590 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4591 if UVCHR_IS_INVARIANT(fc) {
4593 && *s == LATIN_SMALL_LETTER_SHARP_S)
4602 Copy(tmpbuf, d, ulen, U8);
4608 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4609 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4610 * becomes "ss", which may require growing the SV. */
4611 if (SvLEN(dest) < ++min) {
4612 const UV o = d - (U8*)SvPVX_const(dest);
4613 d = o + (U8*) SvGROW(dest, min);
4618 else { /* If it's not one of those two, the fold is their lower
4620 *d = toLOWER_LATIN1(*s);
4626 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4628 #ifdef USE_LOCALE_CTYPE
4629 if (IN_LC_RUNTIME(LC_CTYPE)) {
4634 if (SvTAINTED(source))
4644 dSP; dMARK; dORIGMARK;
4645 AV *const av = MUTABLE_AV(POPs);
4646 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4648 if (SvTYPE(av) == SVt_PVAV) {
4649 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4650 bool can_preserve = FALSE;
4656 can_preserve = SvCANEXISTDELETE(av);
4659 if (lval && localizing) {
4662 for (svp = MARK + 1; svp <= SP; svp++) {
4663 const SSize_t elem = SvIV(*svp);
4667 if (max > AvMAX(av))
4671 while (++MARK <= SP) {
4673 SSize_t elem = SvIV(*MARK);
4674 bool preeminent = TRUE;
4676 if (localizing && can_preserve) {
4677 /* If we can determine whether the element exist,
4678 * Try to preserve the existenceness of a tied array
4679 * element by using EXISTS and DELETE if possible.
4680 * Fallback to FETCH and STORE otherwise. */
4681 preeminent = av_exists(av, elem);
4684 svp = av_fetch(av, elem, lval);
4687 DIE(aTHX_ PL_no_aelem, elem);
4690 save_aelem(av, elem, svp);
4692 SAVEADELETE(av, elem);
4695 *MARK = svp ? *svp : &PL_sv_undef;
4698 if (GIMME_V != G_ARRAY) {
4700 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4709 AV *const av = MUTABLE_AV(POPs);
4710 I32 lval = (PL_op->op_flags & OPf_MOD);
4711 SSize_t items = SP - MARK;
4713 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4714 const I32 flags = is_lvalue_sub();
4716 if (!(flags & OPpENTERSUB_INARGS))
4717 /* diag_listed_as: Can't modify %s in %s */
4718 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4725 *(MARK+items*2-1) = *(MARK+items);
4731 while (++MARK <= SP) {
4734 svp = av_fetch(av, SvIV(*MARK), lval);
4736 if (!svp || !*svp || *svp == &PL_sv_undef) {
4737 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4739 *MARK = sv_mortalcopy(*MARK);
4741 *++MARK = svp ? *svp : &PL_sv_undef;
4743 if (GIMME_V != G_ARRAY) {
4744 MARK = SP - items*2;
4745 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4755 AV *array = MUTABLE_AV(POPs);
4756 const U8 gimme = GIMME_V;
4757 IV *iterp = Perl_av_iter_p(aTHX_ array);
4758 const IV current = (*iterp)++;
4760 if (current > av_tindex(array)) {
4762 if (gimme == G_SCALAR)
4770 if (gimme == G_ARRAY) {
4771 SV **const element = av_fetch(array, current, 0);
4772 PUSHs(element ? *element : &PL_sv_undef);
4777 /* also used for: pp_avalues()*/
4781 AV *array = MUTABLE_AV(POPs);
4782 const U8 gimme = GIMME_V;
4784 *Perl_av_iter_p(aTHX_ array) = 0;
4786 if (gimme == G_SCALAR) {
4788 PUSHi(av_tindex(array) + 1);
4790 else if (gimme == G_ARRAY) {
4791 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4792 const I32 flags = is_lvalue_sub();
4793 if (flags && !(flags & OPpENTERSUB_INARGS))
4794 /* diag_listed_as: Can't modify %s in %s */
4796 "Can't modify keys on array in list assignment");
4799 IV n = Perl_av_len(aTHX_ array);
4804 if ( PL_op->op_type == OP_AKEYS
4805 || ( PL_op->op_type == OP_AVHVSWITCH
4806 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
4808 for (i = 0; i <= n; i++) {
4813 for (i = 0; i <= n; i++) {
4814 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4815 PUSHs(elem ? *elem : &PL_sv_undef);
4823 /* Associative arrays. */
4828 HV * hash = MUTABLE_HV(POPs);
4830 const U8 gimme = GIMME_V;
4832 entry = hv_iternext(hash);
4836 SV* const sv = hv_iterkeysv(entry);
4838 if (gimme == G_ARRAY) {
4840 val = hv_iterval(hash, entry);
4844 else if (gimme == G_SCALAR)
4851 S_do_delete_local(pTHX)
4854 const U8 gimme = GIMME_V;
4857 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4858 SV **unsliced_keysv = sliced ? NULL : sp--;
4859 SV * const osv = POPs;
4860 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4862 const bool tied = SvRMAGICAL(osv)
4863 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4864 const bool can_preserve = SvCANEXISTDELETE(osv);
4865 const U32 type = SvTYPE(osv);
4866 SV ** const end = sliced ? SP : unsliced_keysv;
4868 if (type == SVt_PVHV) { /* hash element */
4869 HV * const hv = MUTABLE_HV(osv);
4870 while (++MARK <= end) {
4871 SV * const keysv = *MARK;
4873 bool preeminent = TRUE;
4875 preeminent = hv_exists_ent(hv, keysv, 0);
4877 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4884 sv = hv_delete_ent(hv, keysv, 0, 0);
4886 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4889 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4890 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4892 *MARK = sv_mortalcopy(sv);
4898 SAVEHDELETE(hv, keysv);
4899 *MARK = &PL_sv_undef;
4903 else if (type == SVt_PVAV) { /* array element */
4904 if (PL_op->op_flags & OPf_SPECIAL) {
4905 AV * const av = MUTABLE_AV(osv);
4906 while (++MARK <= end) {
4907 SSize_t idx = SvIV(*MARK);
4909 bool preeminent = TRUE;
4911 preeminent = av_exists(av, idx);
4913 SV **svp = av_fetch(av, idx, 1);
4920 sv = av_delete(av, idx, 0);
4922 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4925 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4927 *MARK = sv_mortalcopy(sv);
4933 SAVEADELETE(av, idx);
4934 *MARK = &PL_sv_undef;
4939 DIE(aTHX_ "panic: avhv_delete no longer supported");
4942 DIE(aTHX_ "Not a HASH reference");
4944 if (gimme == G_VOID)
4946 else if (gimme == G_SCALAR) {
4951 *++MARK = &PL_sv_undef;
4955 else if (gimme != G_VOID)
4956 PUSHs(*unsliced_keysv);
4967 if (PL_op->op_private & OPpLVAL_INTRO)
4968 return do_delete_local();
4971 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4973 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
4975 HV * const hv = MUTABLE_HV(POPs);
4976 const U32 hvtype = SvTYPE(hv);
4978 if (PL_op->op_private & OPpKVSLICE) {
4979 SSize_t items = SP - MARK;
4983 *(MARK+items*2-1) = *(MARK+items);
4990 if (hvtype == SVt_PVHV) { /* hash element */
4991 while ((MARK += (1+skip)) <= SP) {
4992 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
4993 *MARK = sv ? sv : &PL_sv_undef;
4996 else if (hvtype == SVt_PVAV) { /* array element */
4997 if (PL_op->op_flags & OPf_SPECIAL) {
4998 while ((MARK += (1+skip)) <= SP) {
4999 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5000 *MARK = sv ? sv : &PL_sv_undef;
5005 DIE(aTHX_ "Not a HASH reference");
5008 else if (gimme == G_SCALAR) {
5013 *++MARK = &PL_sv_undef;
5019 HV * const hv = MUTABLE_HV(POPs);
5021 if (SvTYPE(hv) == SVt_PVHV)
5022 sv = hv_delete_ent(hv, keysv, discard, 0);
5023 else if (SvTYPE(hv) == SVt_PVAV) {
5024 if (PL_op->op_flags & OPf_SPECIAL)
5025 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5027 DIE(aTHX_ "panic: avhv_delete no longer supported");
5030 DIE(aTHX_ "Not a HASH reference");
5045 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5047 SV * const sv = POPs;
5048 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5051 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5056 hv = MUTABLE_HV(POPs);
5057 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5058 if (hv_exists_ent(hv, tmpsv, 0))
5061 else if (SvTYPE(hv) == SVt_PVAV) {
5062 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5063 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5068 DIE(aTHX_ "Not a HASH reference");
5075 dSP; dMARK; dORIGMARK;
5076 HV * const hv = MUTABLE_HV(POPs);
5077 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5078 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5079 bool can_preserve = FALSE;
5085 if (SvCANEXISTDELETE(hv))
5086 can_preserve = TRUE;
5089 while (++MARK <= SP) {
5090 SV * const keysv = *MARK;
5093 bool preeminent = TRUE;
5095 if (localizing && can_preserve) {
5096 /* If we can determine whether the element exist,
5097 * try to preserve the existenceness of a tied hash
5098 * element by using EXISTS and DELETE if possible.
5099 * Fallback to FETCH and STORE otherwise. */
5100 preeminent = hv_exists_ent(hv, keysv, 0);
5103 he = hv_fetch_ent(hv, keysv, lval, 0);
5104 svp = he ? &HeVAL(he) : NULL;
5107 if (!svp || !*svp || *svp == &PL_sv_undef) {
5108 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5111 if (HvNAME_get(hv) && isGV(*svp))
5112 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5113 else if (preeminent)
5114 save_helem_flags(hv, keysv, svp,
5115 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5117 SAVEHDELETE(hv, keysv);
5120 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5122 if (GIMME_V != G_ARRAY) {
5124 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5133 HV * const hv = MUTABLE_HV(POPs);
5134 I32 lval = (PL_op->op_flags & OPf_MOD);
5135 SSize_t items = SP - MARK;
5137 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5138 const I32 flags = is_lvalue_sub();
5140 if (!(flags & OPpENTERSUB_INARGS))
5141 /* diag_listed_as: Can't modify %s in %s */
5142 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5143 GIMME_V == G_ARRAY ? "list" : "scalar");
5150 *(MARK+items*2-1) = *(MARK+items);
5156 while (++MARK <= SP) {
5157 SV * const keysv = *MARK;
5161 he = hv_fetch_ent(hv, keysv, lval, 0);
5162 svp = he ? &HeVAL(he) : NULL;
5165 if (!svp || !*svp || *svp == &PL_sv_undef) {
5166 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5168 *MARK = sv_mortalcopy(*MARK);
5170 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5172 if (GIMME_V != G_ARRAY) {
5173 MARK = SP - items*2;
5174 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5180 /* List operators. */
5184 I32 markidx = POPMARK;
5185 if (GIMME_V != G_ARRAY) {
5186 SV **mark = PL_stack_base + markidx;
5189 *MARK = *SP; /* unwanted list, return last item */
5191 *MARK = &PL_sv_undef;
5201 SV ** const lastrelem = PL_stack_sp;
5202 SV ** const lastlelem = PL_stack_base + POPMARK;
5203 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5204 SV ** const firstrelem = lastlelem + 1;
5205 const U8 mod = PL_op->op_flags & OPf_MOD;
5207 const I32 max = lastrelem - lastlelem;
5210 if (GIMME_V != G_ARRAY) {
5211 if (lastlelem < firstlelem) {
5213 *firstlelem = &PL_sv_undef;
5216 I32 ix = SvIV(*lastlelem);
5219 if (ix < 0 || ix >= max)
5220 *firstlelem = &PL_sv_undef;
5222 *firstlelem = firstrelem[ix];
5229 SP = firstlelem - 1;
5233 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5234 I32 ix = SvIV(*lelem);
5237 if (ix < 0 || ix >= max)
5238 *lelem = &PL_sv_undef;
5240 if (!(*lelem = firstrelem[ix]))
5241 *lelem = &PL_sv_undef;
5242 else if (mod && SvPADTMP(*lelem)) {
5243 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5254 const I32 items = SP - MARK;
5255 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5257 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5258 ? newRV_noinc(av) : av);
5264 dSP; dMARK; dORIGMARK;
5265 HV* const hv = newHV();
5266 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5267 ? newRV_noinc(MUTABLE_SV(hv))
5272 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5279 sv_setsv_nomg(val, *MARK);
5283 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5286 (void)hv_store_ent(hv,key,val,0);
5295 dSP; dMARK; dORIGMARK;
5296 int num_args = (SP - MARK);
5297 AV *ary = MUTABLE_AV(*++MARK);
5306 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5309 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5310 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5317 offset = i = SvIV(*MARK);
5319 offset += AvFILLp(ary) + 1;
5321 DIE(aTHX_ PL_no_aelem, i);
5323 length = SvIVx(*MARK++);
5325 length += AvFILLp(ary) - offset + 1;
5331 length = AvMAX(ary) + 1; /* close enough to infinity */
5335 length = AvMAX(ary) + 1;
5337 if (offset > AvFILLp(ary) + 1) {
5339 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5340 offset = AvFILLp(ary) + 1;
5342 after = AvFILLp(ary) + 1 - (offset + length);
5343 if (after < 0) { /* not that much array */
5344 length += after; /* offset+length now in array */
5350 /* At this point, MARK .. SP-1 is our new LIST */
5353 diff = newlen - length;
5354 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5357 /* make new elements SVs now: avoid problems if they're from the array */
5358 for (dst = MARK, i = newlen; i; i--) {
5359 SV * const h = *dst;
5360 *dst++ = newSVsv(h);
5363 if (diff < 0) { /* shrinking the area */
5364 SV **tmparyval = NULL;
5366 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5367 Copy(MARK, tmparyval, newlen, SV*);
5370 MARK = ORIGMARK + 1;
5371 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5372 const bool real = cBOOL(AvREAL(ary));
5373 MEXTEND(MARK, length);
5375 EXTEND_MORTAL(length);
5376 for (i = 0, dst = MARK; i < length; i++) {
5377 if ((*dst = AvARRAY(ary)[i+offset])) {
5379 sv_2mortal(*dst); /* free them eventually */
5382 *dst = &PL_sv_undef;
5388 *MARK = AvARRAY(ary)[offset+length-1];
5391 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5392 SvREFCNT_dec(*dst++); /* free them now */
5395 *MARK = &PL_sv_undef;
5397 AvFILLp(ary) += diff;
5399 /* pull up or down? */
5401 if (offset < after) { /* easier to pull up */
5402 if (offset) { /* esp. if nothing to pull */
5403 src = &AvARRAY(ary)[offset-1];
5404 dst = src - diff; /* diff is negative */
5405 for (i = offset; i > 0; i--) /* can't trust Copy */
5409 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5413 if (after) { /* anything to pull down? */
5414 src = AvARRAY(ary) + offset + length;
5415 dst = src + diff; /* diff is negative */
5416 Move(src, dst, after, SV*);
5418 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5419 /* avoid later double free */
5426 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5427 Safefree(tmparyval);
5430 else { /* no, expanding (or same) */
5431 SV** tmparyval = NULL;
5433 Newx(tmparyval, length, SV*); /* so remember deletion */
5434 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5437 if (diff > 0) { /* expanding */
5438 /* push up or down? */
5439 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5443 Move(src, dst, offset, SV*);
5445 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5447 AvFILLp(ary) += diff;
5450 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5451 av_extend(ary, AvFILLp(ary) + diff);
5452 AvFILLp(ary) += diff;
5455 dst = AvARRAY(ary) + AvFILLp(ary);
5457 for (i = after; i; i--) {
5465 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5468 MARK = ORIGMARK + 1;
5469 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5471 const bool real = cBOOL(AvREAL(ary));
5473 EXTEND_MORTAL(length);
5474 for (i = 0, dst = MARK; i < length; i++) {
5475 if ((*dst = tmparyval[i])) {
5477 sv_2mortal(*dst); /* free them eventually */
5479 else *dst = &PL_sv_undef;
5485 else if (length--) {
5486 *MARK = tmparyval[length];
5489 while (length-- > 0)
5490 SvREFCNT_dec(tmparyval[length]);
5493 *MARK = &PL_sv_undef;
5496 *MARK = &PL_sv_undef;
5497 Safefree(tmparyval);
5501 mg_set(MUTABLE_SV(ary));
5509 dSP; dMARK; dORIGMARK; dTARGET;
5510 AV * const ary = MUTABLE_AV(*++MARK);
5511 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5514 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5517 ENTER_with_name("call_PUSH");
5518 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5519 LEAVE_with_name("call_PUSH");
5520 /* SPAGAIN; not needed: SP is assigned to immediately below */
5523 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5524 * only need to save locally, not on the save stack */
5525 U16 old_delaymagic = PL_delaymagic;
5527 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5528 PL_delaymagic = DM_DELAY;
5529 for (++MARK; MARK <= SP; MARK++) {
5531 if (*MARK) SvGETMAGIC(*MARK);
5534 sv_setsv_nomg(sv, *MARK);
5535 av_store(ary, AvFILLp(ary)+1, sv);
5537 if (PL_delaymagic & DM_ARRAY_ISA)
5538 mg_set(MUTABLE_SV(ary));
5539 PL_delaymagic = old_delaymagic;
5542 if (OP_GIMME(PL_op, 0) != G_VOID) {
5543 PUSHi( AvFILL(ary) + 1 );
5548 /* also used for: pp_pop()*/
5552 AV * const av = PL_op->op_flags & OPf_SPECIAL
5553 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5554 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5558 (void)sv_2mortal(sv);
5565 dSP; dMARK; dORIGMARK; dTARGET;
5566 AV *ary = MUTABLE_AV(*++MARK);
5567 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5570 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5573 ENTER_with_name("call_UNSHIFT");
5574 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5575 LEAVE_with_name("call_UNSHIFT");
5576 /* SPAGAIN; not needed: SP is assigned to immediately below */
5579 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5580 * only need to save locally, not on the save stack */
5581 U16 old_delaymagic = PL_delaymagic;
5584 av_unshift(ary, SP - MARK);
5585 PL_delaymagic = DM_DELAY;
5587 SV * const sv = newSVsv(*++MARK);
5588 (void)av_store(ary, i++, sv);
5590 if (PL_delaymagic & DM_ARRAY_ISA)
5591 mg_set(MUTABLE_SV(ary));
5592 PL_delaymagic = old_delaymagic;
5595 if (OP_GIMME(PL_op, 0) != G_VOID) {
5596 PUSHi( AvFILL(ary) + 1 );
5605 if (GIMME_V == G_ARRAY) {
5606 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5610 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5611 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5612 av = MUTABLE_AV((*SP));
5613 /* In-place reversing only happens in void context for the array
5614 * assignment. We don't need to push anything on the stack. */
5617 if (SvMAGICAL(av)) {
5619 SV *tmp = sv_newmortal();
5620 /* For SvCANEXISTDELETE */
5623 bool can_preserve = SvCANEXISTDELETE(av);
5625 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5629 if (!av_exists(av, i)) {
5630 if (av_exists(av, j)) {
5631 SV *sv = av_delete(av, j, 0);
5632 begin = *av_fetch(av, i, TRUE);
5633 sv_setsv_mg(begin, sv);
5637 else if (!av_exists(av, j)) {
5638 SV *sv = av_delete(av, i, 0);
5639 end = *av_fetch(av, j, TRUE);
5640 sv_setsv_mg(end, sv);
5645 begin = *av_fetch(av, i, TRUE);
5646 end = *av_fetch(av, j, TRUE);
5647 sv_setsv(tmp, begin);
5648 sv_setsv_mg(begin, end);
5649 sv_setsv_mg(end, tmp);
5653 SV **begin = AvARRAY(av);
5656 SV **end = begin + AvFILLp(av);
5658 while (begin < end) {
5659 SV * const tmp = *begin;
5670 SV * const tmp = *MARK;
5674 /* safe as long as stack cannot get extended in the above */
5683 SvUTF8_off(TARG); /* decontaminate */
5685 do_join(TARG, &PL_sv_no, MARK, SP);
5687 sv_setsv(TARG, *SP);
5689 sv_setsv(TARG, DEFSV);
5693 up = SvPV_force(TARG, len);
5696 if (DO_UTF8(TARG)) { /* first reverse each character */
5697 U8* s = (U8*)SvPVX(TARG);
5698 const U8* send = (U8*)(s + len);
5700 if (UTF8_IS_INVARIANT(*s)) {
5705 if (!utf8_to_uvchr_buf(s, send, 0))
5709 down = (char*)(s - 1);
5710 /* reverse this character */
5712 const char tmp = *up;
5720 down = SvPVX(TARG) + len - 1;
5722 const char tmp = *up;
5726 (void)SvPOK_only_UTF8(TARG);
5737 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5738 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
5739 ? (AV *)POPs : NULL;
5740 IV limit = POPi; /* note, negative is forever */
5741 SV * const sv = POPs;
5743 const char *s = SvPV_const(sv, len);
5744 const bool do_utf8 = DO_UTF8(sv);
5745 const char *strend = s + len;
5746 PMOP *pm = cPMOPx(PL_op);
5751 const STRLEN slen = do_utf8
5752 ? utf8_length((U8*)s, (U8*)strend)
5753 : (STRLEN)(strend - s);
5754 SSize_t maxiters = slen + 10;
5755 I32 trailing_empty = 0;
5757 const IV origlimit = limit;
5760 const U8 gimme = GIMME_V;
5762 I32 oldsave = PL_savestack_ix;
5763 U32 make_mortal = SVs_TEMP;
5769 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5770 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5772 /* handle @ary = split(...) optimisation */
5773 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5774 if (!(PL_op->op_flags & OPf_STACKED)) {
5775 if (PL_op->op_private & OPpSPLIT_LEX) {
5776 if (PL_op->op_private & OPpLVAL_INTRO)
5777 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5778 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5783 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5785 pm->op_pmreplrootu.op_pmtargetgv;
5787 if (PL_op->op_private & OPpLVAL_INTRO)
5792 /* skip anything pushed by OPpLVAL_INTRO above */
5793 oldsave = PL_savestack_ix;
5799 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5802 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5804 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5811 for (i = AvFILLp(ary); i >= 0; i--)
5812 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5814 /* temporarily switch stacks */
5815 SAVESWITCHSTACK(PL_curstack, ary);
5820 base = SP - PL_stack_base;
5822 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5824 while (s < strend && isSPACE_utf8_safe(s, strend))
5827 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5828 while (s < strend && isSPACE_LC(*s))
5832 while (s < strend && isSPACE(*s))
5836 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5840 gimme_scalar = gimme == G_SCALAR && !ary;
5843 limit = maxiters + 2;
5844 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5847 /* this one uses 'm' and is a negative test */
5849 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
5850 const int t = UTF8SKIP(m);
5851 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
5858 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5860 while (m < strend && !isSPACE_LC(*m))
5863 while (m < strend && !isSPACE(*m))
5876 dstr = newSVpvn_flags(s, m-s,
5877 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5881 /* skip the whitespace found last */
5883 s = m + UTF8SKIP(m);
5887 /* this one uses 's' and is a positive test */
5889 while (s < strend && isSPACE_utf8_safe(s, strend) )
5892 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5894 while (s < strend && isSPACE_LC(*s))
5897 while (s < strend && isSPACE(*s))
5902 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5904 for (m = s; m < strend && *m != '\n'; m++)
5917 dstr = newSVpvn_flags(s, m-s,
5918 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5924 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5926 Pre-extend the stack, either the number of bytes or
5927 characters in the string or a limited amount, triggered by:
5929 my ($x, $y) = split //, $str;
5933 if (!gimme_scalar) {
5934 const IV items = limit - 1;
5935 /* setting it to -1 will trigger a panic in EXTEND() */
5936 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
5937 if (items >=0 && items < sslen)
5945 /* keep track of how many bytes we skip over */
5955 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5968 dstr = newSVpvn(s, 1);
5984 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5985 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5986 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5987 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5988 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5989 SV * const csv = CALLREG_INTUIT_STRING(rx);
5991 len = RX_MINLENRET(rx);
5992 if (len == 1 && !RX_UTF8(rx) && !tail) {
5993 const char c = *SvPV_nolen_const(csv);
5995 for (m = s; m < strend && *m != c; m++)
6006 dstr = newSVpvn_flags(s, m-s,
6007 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6010 /* The rx->minlen is in characters but we want to step
6011 * s ahead by bytes. */
6013 s = (char*)utf8_hop((U8*)m, len);
6015 s = m + len; /* Fake \n at the end */
6019 while (s < strend && --limit &&
6020 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6021 csv, multiline ? FBMrf_MULTILINE : 0)) )
6030 dstr = newSVpvn_flags(s, m-s,
6031 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6034 /* The rx->minlen is in characters but we want to step
6035 * s ahead by bytes. */
6037 s = (char*)utf8_hop((U8*)m, len);
6039 s = m + len; /* Fake \n at the end */
6044 maxiters += slen * RX_NPARENS(rx);
6045 while (s < strend && --limit)
6049 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6052 if (rex_return == 0)
6054 TAINT_IF(RX_MATCH_TAINTED(rx));
6055 /* we never pass the REXEC_COPY_STR flag, so it should
6056 * never get copied */
6057 assert(!RX_MATCH_COPIED(rx));
6058 m = RX_OFFS(rx)[0].start + orig;
6067 dstr = newSVpvn_flags(s, m-s,
6068 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6071 if (RX_NPARENS(rx)) {
6073 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6074 s = RX_OFFS(rx)[i].start + orig;
6075 m = RX_OFFS(rx)[i].end + orig;
6077 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6078 parens that didn't match -- they should be set to
6079 undef, not the empty string */
6087 if (m >= orig && s >= orig) {
6088 dstr = newSVpvn_flags(s, m-s,
6089 (do_utf8 ? SVf_UTF8 : 0)
6093 dstr = &PL_sv_undef; /* undef, not "" */
6099 s = RX_OFFS(rx)[0].end + orig;
6103 if (!gimme_scalar) {
6104 iters = (SP - PL_stack_base) - base;
6106 if (iters > maxiters)
6107 DIE(aTHX_ "Split loop");
6109 /* keep field after final delim? */
6110 if (s < strend || (iters && origlimit)) {
6111 if (!gimme_scalar) {
6112 const STRLEN l = strend - s;
6113 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6118 else if (!origlimit) {
6120 iters -= trailing_empty;
6122 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6123 if (TOPs && !make_mortal)
6132 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6136 if (SvSMAGICAL(ary)) {
6138 mg_set(MUTABLE_SV(ary));
6141 if (gimme == G_ARRAY) {
6143 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6150 ENTER_with_name("call_PUSH");
6151 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6152 LEAVE_with_name("call_PUSH");
6154 if (gimme == G_ARRAY) {
6156 /* EXTEND should not be needed - we just popped them */
6158 for (i=0; i < iters; i++) {
6159 SV **svp = av_fetch(ary, i, FALSE);
6160 PUSHs((svp) ? *svp : &PL_sv_undef);
6167 if (gimme == G_ARRAY)
6179 SV *const sv = PAD_SVl(PL_op->op_targ);
6181 if (SvPADSTALE(sv)) {
6184 RETURNOP(cLOGOP->op_other);
6186 RETURNOP(cLOGOP->op_next);
6195 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6196 || SvTYPE(retsv) == SVt_PVCV) {
6197 retsv = refto(retsv);
6204 /* used for: pp_padany(), pp_custom(); plus any system ops
6205 * that aren't implemented on a particular platform */
6207 PP(unimplemented_op)
6209 const Optype op_type = PL_op->op_type;
6210 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6211 with out of range op numbers - it only "special" cases op_custom.
6212 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6213 if we get here for a custom op then that means that the custom op didn't
6214 have an implementation. Given that OP_NAME() looks up the custom op
6215 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6216 registers &PL_unimplemented_op as the address of their custom op.
6217 NULL doesn't generate a useful error message. "custom" does. */
6218 const char *const name = op_type >= OP_max
6219 ? "[out of range]" : PL_op_name[PL_op->op_type];
6220 if(OP_IS_SOCKET(op_type))
6221 DIE(aTHX_ PL_no_sock_func, name);
6222 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6226 S_maybe_unwind_defav(pTHX)
6228 if (CX_CUR()->cx_type & CXp_HASARGS) {
6229 PERL_CONTEXT *cx = CX_CUR();
6231 assert(CxHASARGS(cx));
6233 cx->cx_type &= ~CXp_HASARGS;
6237 /* For sorting out arguments passed to a &CORE:: subroutine */
6241 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6242 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6243 AV * const at_ = GvAV(PL_defgv);
6244 SV **svp = at_ ? AvARRAY(at_) : NULL;
6245 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6246 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6247 bool seen_question = 0;
6248 const char *err = NULL;
6249 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6251 /* Count how many args there are first, to get some idea how far to
6252 extend the stack. */
6254 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6256 if (oa & OA_OPTIONAL) seen_question = 1;
6257 if (!seen_question) minargs++;
6261 if(numargs < minargs) err = "Not enough";
6262 else if(numargs > maxargs) err = "Too many";
6264 /* diag_listed_as: Too many arguments for %s */
6266 "%s arguments for %s", err,
6267 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6270 /* Reset the stack pointer. Without this, we end up returning our own
6271 arguments in list context, in addition to the values we are supposed
6272 to return. nextstate usually does this on sub entry, but we need
6273 to run the next op with the caller's hints, so we cannot have a
6275 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6277 if(!maxargs) RETURN;
6279 /* We do this here, rather than with a separate pushmark op, as it has
6280 to come in between two things this function does (stack reset and
6281 arg pushing). This seems the easiest way to do it. */
6284 (void)Perl_pp_pushmark(aTHX);
6287 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6288 PUTBACK; /* The code below can die in various places. */
6290 oa = PL_opargs[opnum] >> OASHIFT;
6291 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6296 if (!numargs && defgv && whicharg == minargs + 1) {
6299 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6303 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6310 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6313 S_maybe_unwind_defav(aTHX);
6316 PUSHs((SV *)GvAVn(gv));
6319 if (!svp || !*svp || !SvROK(*svp)
6320 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6322 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6323 "Type of arg %d to &CORE::%s must be array reference",
6324 whicharg, PL_op_desc[opnum]
6329 if (!svp || !*svp || !SvROK(*svp)
6330 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6331 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6332 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6334 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6335 "Type of arg %d to &CORE::%s must be hash%s reference",
6336 whicharg, PL_op_desc[opnum],
6337 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6344 if (!numargs) PUSHs(NULL);
6345 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6346 /* no magic here, as the prototype will have added an extra
6347 refgen and we just want what was there before that */
6350 const bool constr = PL_op->op_private & whicharg;
6352 svp && *svp ? *svp : &PL_sv_undef,
6353 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6359 if (!numargs) goto try_defsv;
6361 const bool wantscalar =
6362 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6363 if (!svp || !*svp || !SvROK(*svp)
6364 /* We have to permit globrefs even for the \$ proto, as
6365 *foo is indistinguishable from ${\*foo}, and the proto-
6366 type permits the latter. */
6367 || SvTYPE(SvRV(*svp)) > (
6368 wantscalar ? SVt_PVLV
6369 : opnum == OP_LOCK || opnum == OP_UNDEF
6375 "Type of arg %d to &CORE::%s must be %s",
6376 whicharg, PL_op_name[opnum],
6378 ? "scalar reference"
6379 : opnum == OP_LOCK || opnum == OP_UNDEF
6380 ? "reference to one of [$@%&*]"
6381 : "reference to one of [$@%*]"
6384 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6385 /* Undo @_ localisation, so that sub exit does not undo
6386 part of our undeffing. */
6387 S_maybe_unwind_defav(aTHX);
6392 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6404 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6405 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6413 if (PL_op->op_private & OPpOFFBYONE) {
6414 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6416 else cv = find_runcv(NULL);
6417 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6422 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6423 const bool can_preserve)
6425 const SSize_t ix = SvIV(keysv);
6426 if (can_preserve ? av_exists(av, ix) : TRUE) {
6427 SV ** const svp = av_fetch(av, ix, 1);
6429 Perl_croak(aTHX_ PL_no_aelem, ix);
6430 save_aelem(av, ix, svp);
6433 SAVEADELETE(av, ix);
6437 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6438 const bool can_preserve)
6440 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6441 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6442 SV ** const svp = he ? &HeVAL(he) : NULL;
6444 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6445 save_helem_flags(hv, keysv, svp, 0);
6448 SAVEHDELETE(hv, keysv);
6452 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6454 if (type == OPpLVREF_SV) {
6455 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6458 else if (type == OPpLVREF_AV)
6459 /* XXX Inefficient, as it creates a new AV, which we are
6460 about to clobber. */
6463 assert(type == OPpLVREF_HV);
6464 /* XXX Likewise inefficient. */
6473 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6474 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6476 const char *bad = NULL;
6477 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6478 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6481 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6485 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6489 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6493 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6497 /* diag_listed_as: Assigned value is not %s reference */
6498 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6502 switch (left ? SvTYPE(left) : 0) {
6505 SV * const old = PAD_SV(ARGTARG);
6506 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6508 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6510 SAVECLEARSV(PAD_SVl(ARGTARG));
6514 if (PL_op->op_private & OPpLVAL_INTRO) {
6515 S_localise_gv_slot(aTHX_ (GV *)left, type);
6517 gv_setref(left, sv);
6522 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6523 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6524 SvCANEXISTDELETE(left));
6526 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6529 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6531 S_localise_helem_lval(aTHX_ (HV *)left, key,
6532 SvCANEXISTDELETE(left));
6534 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6536 if (PL_op->op_flags & OPf_MOD)
6537 SETs(sv_2mortal(newSVsv(sv)));
6538 /* XXX else can weak references go stale before they are read, e.g.,
6547 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6548 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6549 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6550 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6551 &PL_vtbl_lvref, (char *)elem,
6552 elem ? HEf_SVKEY : (I32)ARGTARG);
6553 mg->mg_private = PL_op->op_private;
6554 if (PL_op->op_private & OPpLVREF_ITER)
6555 mg->mg_flags |= MGf_PERSIST;
6556 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6562 const bool can_preserve = SvCANEXISTDELETE(arg);
6563 if (SvTYPE(arg) == SVt_PVAV)
6564 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6566 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6570 S_localise_gv_slot(aTHX_ (GV *)arg,
6571 PL_op->op_private & OPpLVREF_TYPE);
6573 else if (!(PL_op->op_private & OPpPAD_STATE))
6574 SAVECLEARSV(PAD_SVl(ARGTARG));
6583 AV * const av = (AV *)POPs;
6584 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6585 bool can_preserve = FALSE;
6587 if (UNLIKELY(localizing)) {
6592 can_preserve = SvCANEXISTDELETE(av);
6594 if (SvTYPE(av) == SVt_PVAV) {
6597 for (svp = MARK + 1; svp <= SP; svp++) {
6598 const SSize_t elem = SvIV(*svp);
6602 if (max > AvMAX(av))
6607 while (++MARK <= SP) {
6608 SV * const elemsv = *MARK;
6609 if (SvTYPE(av) == SVt_PVAV)
6610 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6612 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6613 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6614 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6621 if (PL_op->op_flags & OPf_STACKED)
6622 Perl_pp_rv2av(aTHX);
6624 Perl_pp_padav(aTHX);
6628 SETs(0); /* special alias marker that aassign recognises */
6638 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6639 ? CopSTASH(PL_curcop)
6641 NULL, SvREFCNT_inc_simple_NN(sv))));
6646 /* process one subroutine argument - typically when the sub has a signature:
6647 * introduce PL_curpad[op_targ] and assign to it the value
6648 * for $: (OPf_STACKED ? *sp : $_[N])
6649 * for @/%: @_[N..$#_]
6651 * It's equivalent to
6654 * my $foo = (value-on-stack)
6656 * my @foo = @_[N..$#_]
6666 AV *defav = GvAV(PL_defgv); /* @_ */
6667 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6670 /* do 'my $var, @var or %var' action */
6671 padentry = &(PAD_SVl(o->op_targ));
6672 save_clearsv(padentry);
6675 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6676 if (o->op_flags & OPf_STACKED) {
6683 /* should already have been checked */
6685 #if IVSIZE > PTRSIZE
6686 assert(ix <= SSize_t_MAX);
6689 svp = av_fetch(defav, ix, FALSE);
6690 val = svp ? *svp : &PL_sv_undef;
6695 /* cargo-culted from pp_sassign */
6696 assert(TAINTING_get || !TAINT_get);
6697 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6700 SvSetMagicSV(targ, val);
6704 /* must be AV or HV */
6706 assert(!(o->op_flags & OPf_STACKED));
6707 argc = ((IV)AvFILL(defav) + 1) - ix;
6709 /* This is a copy of the relevant parts of pp_aassign().
6711 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6714 if (AvFILL((AV*)targ) > -1) {
6715 /* target should usually be empty. If we get get
6716 * here, someone's been doing some weird closure tricks.
6717 * Make a copy of all args before clearing the array,
6718 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6719 * elements. See similar code in pp_aassign.
6721 for (i = 0; i < argc; i++) {
6722 SV **svp = av_fetch(defav, ix + i, FALSE);
6723 SV *newsv = newSV(0);
6724 sv_setsv_flags(newsv,
6725 svp ? *svp : &PL_sv_undef,
6726 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6727 if (!av_store(defav, ix + i, newsv))
6728 SvREFCNT_dec_NN(newsv);
6730 av_clear((AV*)targ);
6736 av_extend((AV*)targ, argc);
6741 SV **svp = av_fetch(defav, ix + i, FALSE);
6742 SV *val = svp ? *svp : &PL_sv_undef;
6744 sv_setsv(tmpsv, val);
6745 av_store((AV*)targ, i++, tmpsv);
6753 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6755 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6756 /* see "target should usually be empty" comment above */
6757 for (i = 0; i < argc; i++) {
6758 SV **svp = av_fetch(defav, ix + i, FALSE);
6759 SV *newsv = newSV(0);
6760 sv_setsv_flags(newsv,
6761 svp ? *svp : &PL_sv_undef,
6762 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6763 if (!av_store(defav, ix + i, newsv))
6764 SvREFCNT_dec_NN(newsv);
6766 hv_clear((HV*)targ);
6771 assert(argc % 2 == 0);
6780 svp = av_fetch(defav, ix + i++, FALSE);
6781 key = svp ? *svp : &PL_sv_undef;
6782 svp = av_fetch(defav, ix + i++, FALSE);
6783 val = svp ? *svp : &PL_sv_undef;
6786 if (UNLIKELY(SvGMAGICAL(key)))
6787 key = sv_mortalcopy(key);
6789 sv_setsv(tmpsv, val);
6790 hv_store_ent((HV*)targ, key, tmpsv, 0);
6798 /* Handle a default value for one subroutine argument (typically as part
6799 * of a subroutine signature).
6800 * It's equivalent to
6801 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
6803 * Intended to be used where op_next is an OP_ARGELEM
6805 * We abuse the op_targ field slightly: it's an index into @_ rather than
6811 OP * const o = PL_op;
6812 AV *defav = GvAV(PL_defgv); /* @_ */
6813 IV ix = (IV)o->op_targ;
6816 #if IVSIZE > PTRSIZE
6817 assert(ix <= SSize_t_MAX);
6820 if (AvFILL(defav) >= ix) {
6822 SV **svp = av_fetch(defav, ix, FALSE);
6823 SV *val = svp ? *svp : &PL_sv_undef;
6827 return cLOGOPo->op_other;
6832 S_find_runcv_name(void)
6847 sv = sv_2mortal(newSV(0));
6848 gv_fullname4(sv, gv, NULL, TRUE);
6852 /* Check a a subs arguments - i.e. that it has the correct number of args
6853 * (and anything else we might think of in future). Typically used with
6859 OP * const o = PL_op;
6860 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6861 IV params = aux[0].iv;
6862 IV opt_params = aux[1].iv;
6863 char slurpy = (char)(aux[2].iv);
6864 AV *defav = GvAV(PL_defgv); /* @_ */
6868 assert(!SvMAGICAL(defav));
6869 argc = (AvFILLp(defav) + 1);
6870 too_few = (argc < (params - opt_params));
6872 if (UNLIKELY(too_few || (!slurpy && argc > params)))
6873 /* diag_listed_as: Too few arguments for subroutine '%s' */
6874 /* diag_listed_as: Too many arguments for subroutine '%s' */
6875 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
6876 too_few ? "few" : "many", S_find_runcv_name());
6878 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6879 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
6880 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
6881 S_find_runcv_name());
6887 * ex: set ts=8 sts=4 sw=4 et: