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 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
35 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
37 /* variations on pp_null */
42 if (GIMME_V == G_SCALAR)
54 assert(SvTYPE(TARG) == SVt_PVCV);
69 CV * const protocv = PadnamePROTOCV(
70 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
72 assert(SvTYPE(TARG) == SVt_PVCV);
74 if (CvISXSUB(protocv)) { /* constant */
75 /* XXX Should we clone it here? */
76 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
77 to introcv and remove the SvPADSTALE_off. */
78 SAVEPADSVANDMORTALIZE(ARGTARG);
79 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
82 if (CvROOT(protocv)) {
83 assert(CvCLONE(protocv));
84 assert(!CvCLONED(protocv));
86 cv_clone_into(protocv,(CV *)TARG);
87 SAVECLEARSV(PAD_SVl(ARGTARG));
94 /* In some cases this function inspects PL_op. If this function is called
95 for new op types, more bool parameters may need to be added in place of
98 When noinit is true, the absence of a gv will cause a retval of undef.
99 This is unrelated to the cv-to-gv assignment case.
103 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
106 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
109 sv = amagic_deref_call(sv, to_gv_amg);
113 if (SvTYPE(sv) == SVt_PVIO) {
114 GV * const gv = MUTABLE_GV(sv_newmortal());
115 gv_init(gv, 0, "__ANONIO__", 10, 0);
116 GvIOp(gv) = MUTABLE_IO(sv);
117 SvREFCNT_inc_void_NN(sv);
120 else if (!isGV_with_GP(sv)) {
121 Perl_die(aTHX_ "Not a GLOB reference");
125 if (!isGV_with_GP(sv)) {
127 /* If this is a 'my' scalar and flag is set then vivify
130 if (vivify_sv && sv != &PL_sv_undef) {
134 Perl_croak_no_modify();
135 gv = MUTABLE_GV(newSV(0));
136 stash = CopSTASH(PL_curcop);
137 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
138 if (cUNOP->op_targ) {
139 SV * const namesv = PAD_SV(cUNOP->op_targ);
140 gv_init_sv(gv, stash, namesv, 0);
143 gv_init_pv(gv, stash, "__ANONIO__", 0);
145 prepare_SV_for_RV(sv);
146 SvRV_set(sv, MUTABLE_SV(gv));
151 if (PL_op->op_flags & OPf_REF || strict) {
152 Perl_die(aTHX_ PL_no_usym, "a symbol");
154 if (ckWARN(WARN_UNINITIALIZED))
160 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
161 sv, GV_ADDMG, SVt_PVGV
170 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
174 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
175 == OPpDONT_INIT_GV) {
176 /* We are the target of a coderef assignment. Return
177 the scalar unchanged, and let pp_sasssign deal with
181 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
183 /* FAKE globs in the symbol table cause weird bugs (#77810) */
187 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
188 SV *newsv = sv_newmortal();
189 sv_setsv_flags(newsv, sv, 0);
201 sv, PL_op->op_private & OPpDEREF,
202 PL_op->op_private & HINT_STRICT_REFS,
203 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
204 || PL_op->op_type == OP_READLINE
206 if (PL_op->op_private & OPpLVAL_INTRO)
207 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
212 /* Helper function for pp_rv2sv and pp_rv2av */
214 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
215 const svtype type, SV ***spp)
219 PERL_ARGS_ASSERT_SOFTREF2XV;
221 if (PL_op->op_private & HINT_STRICT_REFS) {
223 Perl_die(aTHX_ PL_no_symref_sv, sv,
224 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
226 Perl_die(aTHX_ PL_no_usym, what);
230 PL_op->op_flags & OPf_REF
232 Perl_die(aTHX_ PL_no_usym, what);
233 if (ckWARN(WARN_UNINITIALIZED))
235 if (type != SVt_PV && GIMME_V == G_ARRAY) {
239 **spp = &PL_sv_undef;
242 if ((PL_op->op_flags & OPf_SPECIAL) &&
243 !(PL_op->op_flags & OPf_MOD))
245 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
247 **spp = &PL_sv_undef;
252 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
265 sv = amagic_deref_call(sv, to_sv_amg);
269 if (SvTYPE(sv) >= SVt_PVAV)
270 DIE(aTHX_ "Not a SCALAR reference");
275 if (!isGV_with_GP(gv)) {
276 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
282 if (PL_op->op_flags & OPf_MOD) {
283 if (PL_op->op_private & OPpLVAL_INTRO) {
284 if (cUNOP->op_first->op_type == OP_NULL)
285 sv = save_scalar(MUTABLE_GV(TOPs));
287 sv = save_scalar(gv);
289 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
291 else if (PL_op->op_private & OPpDEREF)
292 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
294 SPAGAIN; /* in case chasing soft refs reallocated the stack */
302 AV * const av = MUTABLE_AV(TOPs);
303 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
305 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
307 *svp = newSV_type(SVt_PVMG);
308 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
312 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
321 if (PL_op->op_flags & OPf_MOD || LVRET) {
322 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
323 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
325 LvTARG(ret) = SvREFCNT_inc_simple(sv);
326 SETs(ret); /* no SvSETMAGIC */
329 const MAGIC * const mg = mg_find_mglob(sv);
330 if (mg && mg->mg_len != -1) {
331 STRLEN i = mg->mg_len;
332 if (PL_op->op_private & OPpTRUEBOOL)
333 SETs(i ? &PL_sv_yes : &PL_sv_zero);
336 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
337 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
352 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
354 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
355 == OPpMAY_RETURN_CONSTANT)
358 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
359 /* (But not in defined().) */
361 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
363 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
364 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
365 ? MUTABLE_CV(SvRV(gv))
369 cv = MUTABLE_CV(&PL_sv_undef);
370 SETs(MUTABLE_SV(cv));
380 SV *ret = &PL_sv_undef;
382 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
383 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
384 const char * s = SvPVX_const(TOPs);
385 if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
386 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
388 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
389 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
391 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
397 cv = sv_2cv(TOPs, &stash, &gv, 0);
399 ret = newSVpvn_flags(
400 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
410 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
412 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
414 PUSHs(MUTABLE_SV(cv));
428 if (GIMME_V != G_ARRAY) {
434 *MARK = &PL_sv_undef;
436 *MARK = refto(*MARK);
440 EXTEND_MORTAL(SP - MARK);
442 *MARK = refto(*MARK);
447 S_refto(pTHX_ SV *sv)
451 PERL_ARGS_ASSERT_REFTO;
453 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
456 if (!(sv = LvTARG(sv)))
459 SvREFCNT_inc_void_NN(sv);
461 else if (SvTYPE(sv) == SVt_PVAV) {
462 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
463 av_reify(MUTABLE_AV(sv));
465 SvREFCNT_inc_void_NN(sv);
467 else if (SvPADTMP(sv)) {
470 else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
471 sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
474 SvREFCNT_inc_void_NN(sv);
477 sv_upgrade(rv, SVt_IV);
486 SV * const sv = TOPs;
494 /* op is in boolean context? */
495 if ( (PL_op->op_private & OPpTRUEBOOL)
496 || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL)
497 && block_gimme() == G_VOID))
499 /* refs are always true - unless it's to an object blessed into a
500 * class with a false name, i.e. "0". So we have to check for
501 * that remote possibility. The following is is basically an
502 * unrolled SvTRUE(sv_reftype(rv)) */
503 SV * const rv = SvRV(sv);
505 HV *stash = SvSTASH(rv);
506 HEK *hek = HvNAME_HEK(stash);
508 I32 len = HEK_LEN(hek);
509 /* bail out and do it the hard way? */
512 || (len == 1 && HEK_KEY(hek)[0] == '0')
525 sv_ref(TARG, SvRV(sv), TRUE);
541 stash = CopSTASH(PL_curcop);
542 if (SvTYPE(stash) != SVt_PVHV)
543 Perl_croak(aTHX_ "Attempt to bless into a freed package");
546 SV * const ssv = POPs;
550 if (!ssv) goto curstash;
553 if (!SvAMAGIC(ssv)) {
555 Perl_croak(aTHX_ "Attempt to bless into a reference");
557 /* SvAMAGIC is on here, but it only means potentially overloaded,
558 so after stringification: */
559 ptr = SvPV_nomg_const(ssv,len);
560 /* We need to check the flag again: */
561 if (!SvAMAGIC(ssv)) goto frog;
563 else ptr = SvPV_nomg_const(ssv,len);
565 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
566 "Explicit blessing to '' (assuming package main)");
567 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
570 (void)sv_bless(TOPs, stash);
580 const char * const elem = SvPV_const(sv, len);
581 GV * const gv = MUTABLE_GV(TOPs);
586 /* elem will always be NUL terminated. */
589 if (memEQs(elem, len, "ARRAY"))
591 tmpRef = MUTABLE_SV(GvAV(gv));
592 if (tmpRef && !AvREAL((const AV *)tmpRef)
593 && AvREIFY((const AV *)tmpRef))
594 av_reify(MUTABLE_AV(tmpRef));
598 if (memEQs(elem, len, "CODE"))
599 tmpRef = MUTABLE_SV(GvCVu(gv));
602 if (memEQs(elem, len, "FILEHANDLE")) {
603 tmpRef = MUTABLE_SV(GvIOp(gv));
606 if (memEQs(elem, len, "FORMAT"))
607 tmpRef = MUTABLE_SV(GvFORM(gv));
610 if (memEQs(elem, len, "GLOB"))
611 tmpRef = MUTABLE_SV(gv);
614 if (memEQs(elem, len, "HASH"))
615 tmpRef = MUTABLE_SV(GvHV(gv));
618 if (memEQs(elem, len, "IO"))
619 tmpRef = MUTABLE_SV(GvIOp(gv));
622 if (memEQs(elem, len, "NAME"))
623 sv = newSVhek(GvNAME_HEK(gv));
626 if (memEQs(elem, len, "PACKAGE")) {
627 const HV * const stash = GvSTASH(gv);
628 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
629 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
633 if (memEQs(elem, len, "SCALAR"))
648 /* Pattern matching */
656 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
657 /* Historically, study was skipped in these cases. */
662 /* Make study a no-op. It's no longer useful and its existence
663 complicates matters elsewhere. */
669 /* also used for: pp_transr() */
676 if (PL_op->op_flags & OPf_STACKED)
681 sv = PAD_SV(ARGTARG);
686 if(PL_op->op_type == OP_TRANSR) {
688 const char * const pv = SvPV(sv,len);
689 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
694 Size_t i = do_trans(sv);
700 /* Lvalue operators. */
703 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
709 PERL_ARGS_ASSERT_DO_CHOMP;
711 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
713 if (SvTYPE(sv) == SVt_PVAV) {
715 AV *const av = MUTABLE_AV(sv);
716 const I32 max = AvFILL(av);
718 for (i = 0; i <= max; i++) {
719 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
720 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
721 count += do_chomp(retval, sv, chomping);
725 else if (SvTYPE(sv) == SVt_PVHV) {
726 HV* const hv = MUTABLE_HV(sv);
728 (void)hv_iterinit(hv);
729 while ((entry = hv_iternext(hv)))
730 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
733 else if (SvREADONLY(sv)) {
734 Perl_croak_no_modify();
740 char *temp_buffer = NULL;
745 goto nope_free_nothing;
747 while (len && s[-1] == '\n') {
754 STRLEN rslen, rs_charlen;
755 const char *rsptr = SvPV_const(PL_rs, rslen);
757 rs_charlen = SvUTF8(PL_rs)
761 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
762 /* Assumption is that rs is shorter than the scalar. */
764 /* RS is utf8, scalar is 8 bit. */
766 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
769 /* Cannot downgrade, therefore cannot possibly match.
770 At this point, temp_buffer is not alloced, and
771 is the buffer inside PL_rs, so dont free it.
773 assert (temp_buffer == rsptr);
779 /* RS is 8 bit, scalar is utf8. */
780 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
794 if (memNE(s, rsptr, rslen))
799 SvPV_force_nomg_nolen(sv);
806 Safefree(temp_buffer);
808 SvREFCNT_dec(svrecode);
812 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
813 s = SvPV_force_nomg(sv, len);
816 char * const send = s + len;
817 char * const start = s;
819 while (s > start && UTF8_IS_CONTINUATION(*s))
821 if (is_utf8_string((U8*)s, send - s)) {
822 sv_setpvn(retval, s, send - s);
824 SvCUR_set(sv, s - start);
834 sv_setpvn(retval, s, 1);
848 /* also used for: pp_schomp() */
853 const bool chomping = PL_op->op_type == OP_SCHOMP;
855 const size_t count = do_chomp(TARG, TOPs, chomping);
857 sv_setiv(TARG, count);
863 /* also used for: pp_chomp() */
867 dSP; dMARK; dTARGET; dORIGMARK;
868 const bool chomping = PL_op->op_type == OP_CHOMP;
872 count += do_chomp(TARG, *++MARK, chomping);
874 sv_setiv(TARG, count);
885 if (!PL_op->op_private) {
897 if (SvTHINKFIRST(sv))
898 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
900 switch (SvTYPE(sv)) {
904 av_undef(MUTABLE_AV(sv));
907 hv_undef(MUTABLE_HV(sv));
910 if (cv_const_sv((const CV *)sv))
911 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
912 "Constant subroutine %" SVf " undefined",
913 SVfARG(CvANON((const CV *)sv)
914 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
915 : sv_2mortal(newSVhek(
917 ? CvNAME_HEK((CV *)sv)
918 : GvENAME_HEK(CvGV((const CV *)sv))
923 /* let user-undef'd sub keep its identity */
924 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
927 assert(isGV_with_GP(sv));
933 /* undef *Pkg::meth_name ... */
935 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
936 && HvENAME_get(stash);
938 if((stash = GvHV((const GV *)sv))) {
939 if(HvENAME_get(stash))
940 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
944 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
945 gp_free(MUTABLE_GV(sv));
947 GvGP_set(sv, gp_ref(gp));
948 #ifndef PERL_DONT_CREATE_GVSV
951 GvLINE(sv) = CopLINE(PL_curcop);
952 GvEGV(sv) = MUTABLE_GV(sv);
956 mro_package_moved(NULL, stash, (const GV *)sv, 0);
958 /* undef *Foo::ISA */
959 if( strEQ(GvNAME((const GV *)sv), "ISA")
960 && (stash = GvSTASH((const GV *)sv))
961 && (method_changed || HvENAME(stash)) )
962 mro_isa_changed_in(stash);
963 else if(method_changed)
964 mro_method_changed_in(
965 GvSTASH((const GV *)sv)
971 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
985 /* common "slow" code for pp_postinc and pp_postdec */
988 S_postincdec_common(pTHX_ SV *sv, SV *targ)
992 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
995 TARG = sv_newmortal();
1002 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1003 if (inc && !SvOK(TARG))
1010 /* also used for: pp_i_postinc() */
1017 /* special-case sv being a simple integer */
1018 if (LIKELY(((sv->sv_flags &
1019 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1020 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1022 && SvIVX(sv) != IV_MAX)
1025 SvIV_set(sv, iv + 1);
1026 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1031 return S_postincdec_common(aTHX_ sv, TARG);
1035 /* also used for: pp_i_postdec() */
1042 /* special-case sv being a simple integer */
1043 if (LIKELY(((sv->sv_flags &
1044 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1045 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1047 && SvIVX(sv) != IV_MIN)
1050 SvIV_set(sv, iv - 1);
1051 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1056 return S_postincdec_common(aTHX_ sv, TARG);
1060 /* Ordinary operators. */
1064 dSP; dATARGET; SV *svl, *svr;
1065 #ifdef PERL_PRESERVE_IVUV
1068 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1071 #ifdef PERL_PRESERVE_IVUV
1072 /* For integer to integer power, we do the calculation by hand wherever
1073 we're sure it is safe; otherwise we call pow() and try to convert to
1074 integer afterwards. */
1075 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1083 const IV iv = SvIVX(svr);
1087 goto float_it; /* Can't do negative powers this way. */
1091 baseuok = SvUOK(svl);
1093 baseuv = SvUVX(svl);
1095 const IV iv = SvIVX(svl);
1098 baseuok = TRUE; /* effectively it's a UV now */
1100 baseuv = -iv; /* abs, baseuok == false records sign */
1103 /* now we have integer ** positive integer. */
1106 /* foo & (foo - 1) is zero only for a power of 2. */
1107 if (!(baseuv & (baseuv - 1))) {
1108 /* We are raising power-of-2 to a positive integer.
1109 The logic here will work for any base (even non-integer
1110 bases) but it can be less accurate than
1111 pow (base,power) or exp (power * log (base)) when the
1112 intermediate values start to spill out of the mantissa.
1113 With powers of 2 we know this can't happen.
1114 And powers of 2 are the favourite thing for perl
1115 programmers to notice ** not doing what they mean. */
1117 NV base = baseuok ? baseuv : -(NV)baseuv;
1122 while (power >>= 1) {
1130 SvIV_please_nomg(svr);
1133 unsigned int highbit = 8 * sizeof(UV);
1134 unsigned int diff = 8 * sizeof(UV);
1135 while (diff >>= 1) {
1137 if (baseuv >> highbit) {
1141 /* we now have baseuv < 2 ** highbit */
1142 if (power * highbit <= 8 * sizeof(UV)) {
1143 /* result will definitely fit in UV, so use UV math
1144 on same algorithm as above */
1147 const bool odd_power = cBOOL(power & 1);
1151 while (power >>= 1) {
1158 if (baseuok || !odd_power)
1159 /* answer is positive */
1161 else if (result <= (UV)IV_MAX)
1162 /* answer negative, fits in IV */
1163 SETi( -(IV)result );
1164 else if (result == (UV)IV_MIN)
1165 /* 2's complement assumption: special case IV_MIN */
1168 /* answer negative, doesn't fit */
1169 SETn( -(NV)result );
1177 NV right = SvNV_nomg(svr);
1178 NV left = SvNV_nomg(svl);
1181 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1183 We are building perl with long double support and are on an AIX OS
1184 afflicted with a powl() function that wrongly returns NaNQ for any
1185 negative base. This was reported to IBM as PMR #23047-379 on
1186 03/06/2006. The problem exists in at least the following versions
1187 of AIX and the libm fileset, and no doubt others as well:
1189 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1190 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1191 AIX 5.2.0 bos.adt.libm 5.2.0.85
1193 So, until IBM fixes powl(), we provide the following workaround to
1194 handle the problem ourselves. Our logic is as follows: for
1195 negative bases (left), we use fmod(right, 2) to check if the
1196 exponent is an odd or even integer:
1198 - if odd, powl(left, right) == -powl(-left, right)
1199 - if even, powl(left, right) == powl(-left, right)
1201 If the exponent is not an integer, the result is rightly NaNQ, so
1202 we just return that (as NV_NAN).
1206 NV mod2 = Perl_fmod( right, 2.0 );
1207 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1208 SETn( -Perl_pow( -left, right) );
1209 } else if (mod2 == 0.0) { /* even integer */
1210 SETn( Perl_pow( -left, right) );
1211 } else { /* fractional power */
1215 SETn( Perl_pow( left, right) );
1218 SETn( Perl_pow( left, right) );
1219 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1221 #ifdef PERL_PRESERVE_IVUV
1223 SvIV_please_nomg(svr);
1231 dSP; dATARGET; SV *svl, *svr;
1232 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1236 #ifdef PERL_PRESERVE_IVUV
1238 /* special-case some simple common cases */
1239 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1241 U32 flags = (svl->sv_flags & svr->sv_flags);
1242 if (flags & SVf_IOK) {
1243 /* both args are simple IVs */
1248 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1249 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1251 /* if both are in a range that can't under/overflow, do a
1252 * simple integer multiply: if the top halves(*) of both numbers
1253 * are 00...00 or 11...11, then it's safe.
1254 * (*) for 32-bits, the "top half" is the top 17 bits,
1255 * for 64-bits, its 33 bits */
1257 ((topl+1) | (topr+1))
1258 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1261 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1267 else if (flags & SVf_NOK) {
1268 /* both args are NVs */
1274 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1275 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1276 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1278 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1281 /* nothing was lost by converting to IVs */
1285 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1286 if (Perl_isinf(result)) {
1287 Zero((U8*)&result + 8, 8, U8);
1290 TARGn(result, 0); /* args not GMG, so can't be tainted */
1298 if (SvIV_please_nomg(svr)) {
1299 /* Unless the left argument is integer in range we are going to have to
1300 use NV maths. Hence only attempt to coerce the right argument if
1301 we know the left is integer. */
1302 /* Left operand is defined, so is it IV? */
1303 if (SvIV_please_nomg(svl)) {
1304 bool auvok = SvUOK(svl);
1305 bool buvok = SvUOK(svr);
1306 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1307 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1316 const IV aiv = SvIVX(svl);
1319 auvok = TRUE; /* effectively it's a UV now */
1321 /* abs, auvok == false records sign */
1328 const IV biv = SvIVX(svr);
1331 buvok = TRUE; /* effectively it's a UV now */
1333 /* abs, buvok == false records sign */
1338 /* If this does sign extension on unsigned it's time for plan B */
1339 ahigh = alow >> (4 * sizeof (UV));
1341 bhigh = blow >> (4 * sizeof (UV));
1343 if (ahigh && bhigh) {
1345 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1346 which is overflow. Drop to NVs below. */
1347 } else if (!ahigh && !bhigh) {
1348 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1349 so the unsigned multiply cannot overflow. */
1350 const UV product = alow * blow;
1351 if (auvok == buvok) {
1352 /* -ve * -ve or +ve * +ve gives a +ve result. */
1356 } else if (product <= (UV)IV_MIN) {
1357 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1358 /* -ve result, which could overflow an IV */
1360 /* can't negate IV_MIN, but there are aren't two
1361 * integers such that !ahigh && !bhigh, where the
1362 * product equals 0x800....000 */
1363 assert(product != (UV)IV_MIN);
1364 SETi( -(IV)product );
1366 } /* else drop to NVs below. */
1368 /* One operand is large, 1 small */
1371 /* swap the operands */
1373 bhigh = blow; /* bhigh now the temp var for the swap */
1377 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1378 multiplies can't overflow. shift can, add can, -ve can. */
1379 product_middle = ahigh * blow;
1380 if (!(product_middle & topmask)) {
1381 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1383 product_middle <<= (4 * sizeof (UV));
1384 product_low = alow * blow;
1386 /* as for pp_add, UV + something mustn't get smaller.
1387 IIRC ANSI mandates this wrapping *behaviour* for
1388 unsigned whatever the actual representation*/
1389 product_low += product_middle;
1390 if (product_low >= product_middle) {
1391 /* didn't overflow */
1392 if (auvok == buvok) {
1393 /* -ve * -ve or +ve * +ve gives a +ve result. */
1395 SETu( product_low );
1397 } else if (product_low <= (UV)IV_MIN) {
1398 /* 2s complement assumption again */
1399 /* -ve result, which could overflow an IV */
1401 SETi(product_low == (UV)IV_MIN
1402 ? IV_MIN : -(IV)product_low);
1404 } /* else drop to NVs below. */
1406 } /* product_middle too large */
1407 } /* ahigh && bhigh */
1412 NV right = SvNV_nomg(svr);
1413 NV left = SvNV_nomg(svl);
1414 NV result = left * right;
1417 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1418 if (Perl_isinf(result)) {
1419 Zero((U8*)&result + 8, 8, U8);
1429 dSP; dATARGET; SV *svl, *svr;
1430 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1433 /* Only try to do UV divide first
1434 if ((SLOPPYDIVIDE is true) or
1435 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1437 The assumption is that it is better to use floating point divide
1438 whenever possible, only doing integer divide first if we can't be sure.
1439 If NV_PRESERVES_UV is true then we know at compile time that no UV
1440 can be too large to preserve, so don't need to compile the code to
1441 test the size of UVs. */
1443 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1444 # define PERL_TRY_UV_DIVIDE
1445 /* ensure that 20./5. == 4. */
1448 #ifdef PERL_TRY_UV_DIVIDE
1449 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1450 bool left_non_neg = SvUOK(svl);
1451 bool right_non_neg = SvUOK(svr);
1455 if (right_non_neg) {
1459 const IV biv = SvIVX(svr);
1462 right_non_neg = TRUE; /* effectively it's a UV now */
1468 /* historically undef()/0 gives a "Use of uninitialized value"
1469 warning before dieing, hence this test goes here.
1470 If it were immediately before the second SvIV_please, then
1471 DIE() would be invoked before left was even inspected, so
1472 no inspection would give no warning. */
1474 DIE(aTHX_ "Illegal division by zero");
1480 const IV aiv = SvIVX(svl);
1483 left_non_neg = TRUE; /* effectively it's a UV now */
1492 /* For sloppy divide we always attempt integer division. */
1494 /* Otherwise we only attempt it if either or both operands
1495 would not be preserved by an NV. If both fit in NVs
1496 we fall through to the NV divide code below. However,
1497 as left >= right to ensure integer result here, we know that
1498 we can skip the test on the right operand - right big
1499 enough not to be preserved can't get here unless left is
1502 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1505 /* Integer division can't overflow, but it can be imprecise. */
1507 /* Modern compilers optimize division followed by
1508 * modulo into a single div instruction */
1509 const UV result = left / right;
1510 if (left % right == 0) {
1511 SP--; /* result is valid */
1512 if (left_non_neg == right_non_neg) {
1513 /* signs identical, result is positive. */
1517 /* 2s complement assumption */
1518 if (result <= (UV)IV_MIN)
1519 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1521 /* It's exact but too negative for IV. */
1522 SETn( -(NV)result );
1525 } /* tried integer divide but it was not an integer result */
1526 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1527 } /* one operand wasn't SvIOK */
1528 #endif /* PERL_TRY_UV_DIVIDE */
1530 NV right = SvNV_nomg(svr);
1531 NV left = SvNV_nomg(svl);
1532 (void)POPs;(void)POPs;
1533 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1534 if (! Perl_isnan(right) && right == 0.0)
1538 DIE(aTHX_ "Illegal division by zero");
1539 PUSHn( left / right );
1547 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1551 bool left_neg = FALSE;
1552 bool right_neg = FALSE;
1553 bool use_double = FALSE;
1554 bool dright_valid = FALSE;
1557 SV * const svr = TOPs;
1558 SV * const svl = TOPm1s;
1559 if (SvIV_please_nomg(svr)) {
1560 right_neg = !SvUOK(svr);
1564 const IV biv = SvIVX(svr);
1567 right_neg = FALSE; /* effectively it's a UV now */
1574 dright = SvNV_nomg(svr);
1575 right_neg = dright < 0;
1578 if (dright < UV_MAX_P1) {
1579 right = U_V(dright);
1580 dright_valid = TRUE; /* In case we need to use double below. */
1586 /* At this point use_double is only true if right is out of range for
1587 a UV. In range NV has been rounded down to nearest UV and
1588 use_double false. */
1589 if (!use_double && SvIV_please_nomg(svl)) {
1590 left_neg = !SvUOK(svl);
1594 const IV aiv = SvIVX(svl);
1597 left_neg = FALSE; /* effectively it's a UV now */
1604 dleft = SvNV_nomg(svl);
1605 left_neg = dleft < 0;
1609 /* This should be exactly the 5.6 behaviour - if left and right are
1610 both in range for UV then use U_V() rather than floor. */
1612 if (dleft < UV_MAX_P1) {
1613 /* right was in range, so is dleft, so use UVs not double.
1617 /* left is out of range for UV, right was in range, so promote
1618 right (back) to double. */
1620 /* The +0.5 is used in 5.6 even though it is not strictly
1621 consistent with the implicit +0 floor in the U_V()
1622 inside the #if 1. */
1623 dleft = Perl_floor(dleft + 0.5);
1626 dright = Perl_floor(dright + 0.5);
1637 DIE(aTHX_ "Illegal modulus zero");
1639 dans = Perl_fmod(dleft, dright);
1640 if ((left_neg != right_neg) && dans)
1641 dans = dright - dans;
1644 sv_setnv(TARG, dans);
1650 DIE(aTHX_ "Illegal modulus zero");
1653 if ((left_neg != right_neg) && ans)
1656 /* XXX may warn: unary minus operator applied to unsigned type */
1657 /* could change -foo to be (~foo)+1 instead */
1658 if (ans <= ~((UV)IV_MAX)+1)
1659 sv_setiv(TARG, ~ans+1);
1661 sv_setnv(TARG, -(NV)ans);
1664 sv_setuv(TARG, ans);
1676 bool infnan = FALSE;
1677 const U8 gimme = GIMME_V;
1679 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1680 /* TODO: think of some way of doing list-repeat overloading ??? */
1685 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1686 /* The parser saw this as a list repeat, and there
1687 are probably several items on the stack. But we're
1688 in scalar/void context, and there's no pp_list to save us
1689 now. So drop the rest of the items -- robin@kitsite.com
1692 if (MARK + 1 < SP) {
1698 ASSUME(MARK + 1 == SP);
1700 MARK[1] = &PL_sv_undef;
1704 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1710 const UV uv = SvUV_nomg(sv);
1712 count = IV_MAX; /* The best we can do? */
1716 count = SvIV_nomg(sv);
1719 else if (SvNOKp(sv)) {
1720 const NV nv = SvNV_nomg(sv);
1721 infnan = Perl_isinfnan(nv);
1722 if (UNLIKELY(infnan)) {
1726 count = -1; /* An arbitrary negative integer */
1732 count = SvIV_nomg(sv);
1735 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1736 "Non-finite repeat count does nothing");
1737 } else if (count < 0) {
1739 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1740 "Negative repeat count does nothing");
1743 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1745 const SSize_t items = SP - MARK;
1746 const U8 mod = PL_op->op_flags & OPf_MOD;
1751 if ( items > SSize_t_MAX / count /* max would overflow */
1752 /* repeatcpy would overflow */
1753 || items > I32_MAX / (I32)sizeof(SV *)
1755 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1756 max = items * count;
1761 if (mod && SvPADTMP(*SP)) {
1762 *SP = sv_mortalcopy(*SP);
1769 repeatcpy((char*)(MARK + items), (char*)MARK,
1770 items * sizeof(const SV *), count - 1);
1773 else if (count <= 0)
1776 else { /* Note: mark already snarfed by pp_list */
1777 SV * const tmpstr = POPs;
1782 sv_setsv_nomg(TARG, tmpstr);
1783 SvPV_force_nomg(TARG, len);
1784 isutf = DO_UTF8(TARG);
1791 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1792 || len > (U32)I32_MAX /* repeatcpy would overflow */
1794 Perl_croak(aTHX_ "%s",
1795 "Out of memory during string extend");
1796 max = (UV)count * len + 1;
1799 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1800 SvCUR_set(TARG, SvCUR(TARG) * count);
1802 *SvEND(TARG) = '\0';
1805 (void)SvPOK_only_UTF8(TARG);
1807 (void)SvPOK_only(TARG);
1816 dSP; dATARGET; bool useleft; SV *svl, *svr;
1817 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1821 #ifdef PERL_PRESERVE_IVUV
1823 /* special-case some simple common cases */
1824 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1826 U32 flags = (svl->sv_flags & svr->sv_flags);
1827 if (flags & SVf_IOK) {
1828 /* both args are simple IVs */
1833 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1834 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1836 /* if both are in a range that can't under/overflow, do a
1837 * simple integer subtract: if the top of both numbers
1838 * are 00 or 11, then it's safe */
1839 if (!( ((topl+1) | (topr+1)) & 2)) {
1841 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1847 else if (flags & SVf_NOK) {
1848 /* both args are NVs */
1853 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1854 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1855 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1857 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1860 /* nothing was lost by converting to IVs */
1863 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1871 useleft = USE_LEFT(svl);
1872 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1873 "bad things" happen if you rely on signed integers wrapping. */
1874 if (SvIV_please_nomg(svr)) {
1875 /* Unless the left argument is integer in range we are going to have to
1876 use NV maths. Hence only attempt to coerce the right argument if
1877 we know the left is integer. */
1884 a_valid = auvok = 1;
1885 /* left operand is undef, treat as zero. */
1887 /* Left operand is defined, so is it IV? */
1888 if (SvIV_please_nomg(svl)) {
1889 if ((auvok = SvUOK(svl)))
1892 const IV aiv = SvIVX(svl);
1895 auvok = 1; /* Now acting as a sign flag. */
1904 bool result_good = 0;
1907 bool buvok = SvUOK(svr);
1912 const IV biv = SvIVX(svr);
1919 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1920 else "IV" now, independent of how it came in.
1921 if a, b represents positive, A, B negative, a maps to -A etc
1926 all UV maths. negate result if A negative.
1927 subtract if signs same, add if signs differ. */
1929 if (auvok ^ buvok) {
1938 /* Must get smaller */
1943 if (result <= buv) {
1944 /* result really should be -(auv-buv). as its negation
1945 of true value, need to swap our result flag */
1957 if (result <= (UV)IV_MIN)
1958 SETi(result == (UV)IV_MIN
1959 ? IV_MIN : -(IV)result);
1961 /* result valid, but out of range for IV. */
1962 SETn( -(NV)result );
1966 } /* Overflow, drop through to NVs. */
1970 useleft = USE_LEFT(svl);
1973 NV value = SvNV_nomg(svr);
1977 /* left operand is undef, treat as zero - value */
1981 SETn( SvNV_nomg(svl) - value );
1986 #define IV_BITS (IVSIZE * 8)
1988 static UV S_uv_shift(UV uv, int shift, bool left)
1994 if (shift >= IV_BITS) {
1997 return left ? uv << shift : uv >> shift;
2000 static IV S_iv_shift(IV iv, int shift, bool left)
2006 if (shift >= IV_BITS) {
2007 return iv < 0 && !left ? -1 : 0;
2009 return left ? iv << shift : iv >> shift;
2012 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2013 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2014 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2015 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2019 dSP; dATARGET; SV *svl, *svr;
2020 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2024 const IV shift = SvIV_nomg(svr);
2025 if (PL_op->op_private & HINT_INTEGER) {
2026 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2029 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2037 dSP; dATARGET; SV *svl, *svr;
2038 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2042 const IV shift = SvIV_nomg(svr);
2043 if (PL_op->op_private & HINT_INTEGER) {
2044 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2047 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2058 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2062 (SvIOK_notUV(left) && SvIOK_notUV(right))
2063 ? (SvIVX(left) < SvIVX(right))
2064 : (do_ncmp(left, right) == -1)
2074 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2078 (SvIOK_notUV(left) && SvIOK_notUV(right))
2079 ? (SvIVX(left) > SvIVX(right))
2080 : (do_ncmp(left, right) == 1)
2090 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2094 (SvIOK_notUV(left) && SvIOK_notUV(right))
2095 ? (SvIVX(left) <= SvIVX(right))
2096 : (do_ncmp(left, right) <= 0)
2106 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2110 (SvIOK_notUV(left) && SvIOK_notUV(right))
2111 ? (SvIVX(left) >= SvIVX(right))
2112 : ( (do_ncmp(left, right) & 2) == 0)
2122 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2126 (SvIOK_notUV(left) && SvIOK_notUV(right))
2127 ? (SvIVX(left) != SvIVX(right))
2128 : (do_ncmp(left, right) != 0)
2133 /* compare left and right SVs. Returns:
2137 * 2: left or right was a NaN
2140 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2142 PERL_ARGS_ASSERT_DO_NCMP;
2143 #ifdef PERL_PRESERVE_IVUV
2144 /* Fortunately it seems NaN isn't IOK */
2145 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2147 const IV leftiv = SvIVX(left);
2148 if (!SvUOK(right)) {
2149 /* ## IV <=> IV ## */
2150 const IV rightiv = SvIVX(right);
2151 return (leftiv > rightiv) - (leftiv < rightiv);
2153 /* ## IV <=> UV ## */
2155 /* As (b) is a UV, it's >=0, so it must be < */
2158 const UV rightuv = SvUVX(right);
2159 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2164 /* ## UV <=> UV ## */
2165 const UV leftuv = SvUVX(left);
2166 const UV rightuv = SvUVX(right);
2167 return (leftuv > rightuv) - (leftuv < rightuv);
2169 /* ## UV <=> IV ## */
2171 const IV rightiv = SvIVX(right);
2173 /* As (a) is a UV, it's >=0, so it cannot be < */
2176 const UV leftuv = SvUVX(left);
2177 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2180 NOT_REACHED; /* NOTREACHED */
2184 NV const rnv = SvNV_nomg(right);
2185 NV const lnv = SvNV_nomg(left);
2187 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2188 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2191 return (lnv > rnv) - (lnv < rnv);
2210 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2213 value = do_ncmp(left, right);
2225 /* also used for: pp_sge() pp_sgt() pp_slt() */
2231 int amg_type = sle_amg;
2235 switch (PL_op->op_type) {
2254 tryAMAGICbin_MG(amg_type, AMGf_set);
2258 #ifdef USE_LOCALE_COLLATE
2259 (IN_LC_RUNTIME(LC_COLLATE))
2260 ? sv_cmp_locale_flags(left, right, 0)
2263 sv_cmp_flags(left, right, 0);
2264 SETs(boolSV(cmp * multiplier < rhs));
2272 tryAMAGICbin_MG(seq_amg, AMGf_set);
2275 SETs(boolSV(sv_eq_flags(left, right, 0)));
2283 tryAMAGICbin_MG(sne_amg, AMGf_set);
2286 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2294 tryAMAGICbin_MG(scmp_amg, 0);
2298 #ifdef USE_LOCALE_COLLATE
2299 (IN_LC_RUNTIME(LC_COLLATE))
2300 ? sv_cmp_locale_flags(left, right, 0)
2303 sv_cmp_flags(left, right, 0);
2312 tryAMAGICbin_MG(band_amg, AMGf_assign);
2315 if (SvNIOKp(left) || SvNIOKp(right)) {
2316 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2317 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2318 if (PL_op->op_private & HINT_INTEGER) {
2319 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2323 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2326 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2327 if (right_ro_nonnum) SvNIOK_off(right);
2330 do_vop(PL_op->op_type, TARG, left, right);
2340 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2342 dATARGET; dPOPTOPssrl;
2343 if (PL_op->op_private & HINT_INTEGER) {
2344 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2348 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2358 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2360 dATARGET; dPOPTOPssrl;
2361 do_vop(OP_BIT_AND, TARG, left, right);
2366 /* also used for: pp_bit_xor() */
2371 const int op_type = PL_op->op_type;
2373 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2376 if (SvNIOKp(left) || SvNIOKp(right)) {
2377 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2378 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2379 if (PL_op->op_private & HINT_INTEGER) {
2380 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2381 const IV r = SvIV_nomg(right);
2382 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2386 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2387 const UV r = SvUV_nomg(right);
2388 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2391 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2392 if (right_ro_nonnum) SvNIOK_off(right);
2395 do_vop(op_type, TARG, left, right);
2402 /* also used for: pp_nbit_xor() */
2407 const int op_type = PL_op->op_type;
2409 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2410 AMGf_assign|AMGf_numarg);
2412 dATARGET; dPOPTOPssrl;
2413 if (PL_op->op_private & HINT_INTEGER) {
2414 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2415 const IV r = SvIV_nomg(right);
2416 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2420 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2421 const UV r = SvUV_nomg(right);
2422 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2429 /* also used for: pp_sbit_xor() */
2434 const int op_type = PL_op->op_type;
2436 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2439 dATARGET; dPOPTOPssrl;
2440 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2446 PERL_STATIC_INLINE bool
2447 S_negate_string(pTHX)
2452 SV * const sv = TOPs;
2453 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2455 s = SvPV_nomg_const(sv, len);
2456 if (isIDFIRST(*s)) {
2457 sv_setpvs(TARG, "-");
2460 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2461 sv_setsv_nomg(TARG, sv);
2462 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2472 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2473 if (S_negate_string(aTHX)) return NORMAL;
2475 SV * const sv = TOPs;
2478 /* It's publicly an integer */
2481 if (SvIVX(sv) == IV_MIN) {
2482 /* 2s complement assumption. */
2483 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2487 else if (SvUVX(sv) <= IV_MAX) {
2492 else if (SvIVX(sv) != IV_MIN) {
2496 #ifdef PERL_PRESERVE_IVUV
2503 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2504 SETn(-SvNV_nomg(sv));
2505 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2506 goto oops_its_an_int;
2508 SETn(-SvNV_nomg(sv));
2518 tryAMAGICun_MG(not_amg, AMGf_set);
2520 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2525 S_scomplement(pTHX_ SV *targ, SV *sv)
2531 sv_copypv_nomg(TARG, sv);
2532 tmps = (U8*)SvPV_nomg(TARG, len);
2535 if (len && ! utf8_to_bytes(tmps, &len)) {
2536 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2547 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2550 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2555 for ( ; anum > 0; anum--, tmps++)
2562 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2566 if (PL_op->op_private & HINT_INTEGER) {
2567 const IV i = ~SvIV_nomg(sv);
2571 const UV u = ~SvUV_nomg(sv);
2576 S_scomplement(aTHX_ TARG, sv);
2586 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2589 if (PL_op->op_private & HINT_INTEGER) {
2590 const IV i = ~SvIV_nomg(sv);
2594 const UV u = ~SvUV_nomg(sv);
2604 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2607 S_scomplement(aTHX_ TARG, sv);
2613 /* integer versions of some of the above */
2618 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2621 SETi( left * right );
2630 tryAMAGICbin_MG(div_amg, AMGf_assign);
2633 IV value = SvIV_nomg(right);
2635 DIE(aTHX_ "Illegal division by zero");
2636 num = SvIV_nomg(left);
2638 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2642 value = num / value;
2650 /* This is the vanilla old i_modulo. */
2652 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2656 DIE(aTHX_ "Illegal modulus zero");
2657 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2661 SETi( left % right );
2666 #if defined(__GLIBC__) && IVSIZE == 8 \
2667 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2669 PP(pp_i_modulo_glibc_bugfix)
2671 /* This is the i_modulo with the workaround for the _moddi3 bug
2672 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2673 * See below for pp_i_modulo. */
2675 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2679 DIE(aTHX_ "Illegal modulus zero");
2680 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2684 SETi( left % PERL_ABS(right) );
2693 tryAMAGICbin_MG(add_amg, AMGf_assign);
2695 dPOPTOPiirl_ul_nomg;
2696 SETi( left + right );
2704 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2706 dPOPTOPiirl_ul_nomg;
2707 SETi( left - right );
2715 tryAMAGICbin_MG(lt_amg, AMGf_set);
2718 SETs(boolSV(left < right));
2726 tryAMAGICbin_MG(gt_amg, AMGf_set);
2729 SETs(boolSV(left > right));
2737 tryAMAGICbin_MG(le_amg, AMGf_set);
2740 SETs(boolSV(left <= right));
2748 tryAMAGICbin_MG(ge_amg, AMGf_set);
2751 SETs(boolSV(left >= right));
2759 tryAMAGICbin_MG(eq_amg, AMGf_set);
2762 SETs(boolSV(left == right));
2770 tryAMAGICbin_MG(ne_amg, AMGf_set);
2773 SETs(boolSV(left != right));
2781 tryAMAGICbin_MG(ncmp_amg, 0);
2788 else if (left < right)
2800 tryAMAGICun_MG(neg_amg, 0);
2801 if (S_negate_string(aTHX)) return NORMAL;
2803 SV * const sv = TOPs;
2804 IV const i = SvIV_nomg(sv);
2810 /* High falutin' math. */
2815 tryAMAGICbin_MG(atan2_amg, 0);
2818 SETn(Perl_atan2(left, right));
2824 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2829 int amg_type = fallback_amg;
2830 const char *neg_report = NULL;
2831 const int op_type = PL_op->op_type;
2834 case OP_SIN: amg_type = sin_amg; break;
2835 case OP_COS: amg_type = cos_amg; break;
2836 case OP_EXP: amg_type = exp_amg; break;
2837 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2838 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2841 assert(amg_type != fallback_amg);
2843 tryAMAGICun_MG(amg_type, 0);
2845 SV * const arg = TOPs;
2846 const NV value = SvNV_nomg(arg);
2852 if (neg_report) { /* log or sqrt */
2854 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2855 ! Perl_isnan(value) &&
2857 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2858 SET_NUMERIC_STANDARD();
2859 /* diag_listed_as: Can't take log of %g */
2860 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2865 case OP_SIN: result = Perl_sin(value); break;
2866 case OP_COS: result = Perl_cos(value); break;
2867 case OP_EXP: result = Perl_exp(value); break;
2868 case OP_LOG: result = Perl_log(value); break;
2869 case OP_SQRT: result = Perl_sqrt(value); break;
2876 /* Support Configure command-line overrides for rand() functions.
2877 After 5.005, perhaps we should replace this by Configure support
2878 for drand48(), random(), or rand(). For 5.005, though, maintain
2879 compatibility by calling rand() but allow the user to override it.
2880 See INSTALL for details. --Andy Dougherty 15 July 1998
2882 /* Now it's after 5.005, and Configure supports drand48() and random(),
2883 in addition to rand(). So the overrides should not be needed any more.
2884 --Jarkko Hietaniemi 27 September 1998
2889 if (!PL_srand_called) {
2890 (void)seedDrand01((Rand_seed_t)seed());
2891 PL_srand_called = TRUE;
2903 SV * const sv = POPs;
2909 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2910 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2911 if (! Perl_isnan(value) && value == 0.0)
2921 sv_setnv_mg(TARG, value);
2932 if (MAXARG >= 1 && (TOPs || POPs)) {
2939 pv = SvPV(top, len);
2940 flags = grok_number(pv, len, &anum);
2942 if (!(flags & IS_NUMBER_IN_UV)) {
2943 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2944 "Integer overflow in srand");
2952 (void)seedDrand01((Rand_seed_t)anum);
2953 PL_srand_called = TRUE;
2957 /* Historically srand always returned true. We can avoid breaking
2959 sv_setpvs(TARG, "0 but true");
2968 tryAMAGICun_MG(int_amg, AMGf_numeric);
2970 SV * const sv = TOPs;
2971 const IV iv = SvIV_nomg(sv);
2972 /* XXX it's arguable that compiler casting to IV might be subtly
2973 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2974 else preferring IV has introduced a subtle behaviour change bug. OTOH
2975 relying on floating point to be accurate is a bug. */
2980 else if (SvIOK(sv)) {
2982 SETu(SvUV_nomg(sv));
2987 const NV value = SvNV_nomg(sv);
2988 if (UNLIKELY(Perl_isinfnan(value)))
2990 else if (value >= 0.0) {
2991 if (value < (NV)UV_MAX + 0.5) {
2994 SETn(Perl_floor(value));
2998 if (value > (NV)IV_MIN - 0.5) {
3001 SETn(Perl_ceil(value));
3012 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3014 SV * const sv = TOPs;
3015 /* This will cache the NV value if string isn't actually integer */
3016 const IV iv = SvIV_nomg(sv);
3021 else if (SvIOK(sv)) {
3022 /* IVX is precise */
3024 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3032 /* 2s complement assumption. Also, not really needed as
3033 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3039 const NV value = SvNV_nomg(sv);
3050 /* also used for: pp_hex() */
3056 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3060 SV* const sv = TOPs;
3062 tmps = (SvPV_const(sv, len));
3064 /* If Unicode, try to downgrade
3065 * If not possible, croak. */
3066 SV* const tsv = sv_2mortal(newSVsv(sv));
3069 sv_utf8_downgrade(tsv, FALSE);
3070 tmps = SvPV_const(tsv, len);
3072 if (PL_op->op_type == OP_HEX)
3075 while (*tmps && len && isSPACE(*tmps))
3079 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3081 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3083 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3084 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3086 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3088 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3103 SV * const sv = TOPs;
3105 U32 in_bytes = IN_BYTES;
3106 /* Simplest case shortcut:
3107 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3108 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3111 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3113 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3116 if (LIKELY(svflags == SVf_POK))
3119 if (svflags & SVs_GMG)
3124 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3125 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3127 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3128 /* no need to convert from bytes to chars */
3132 len = sv_len_utf8_nomg(sv);
3135 /* unrolled SvPV_nomg_const(sv,len) */
3136 if (SvPOK_nog(sv)) {
3139 if (PL_op->op_private & OPpTRUEBOOL) {
3141 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3146 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3149 TARGi((IV)(len), 1);
3152 if (!SvPADTMP(TARG)) {
3153 /* OPpTARGET_MY: targ is var in '$lex = length()' */
3158 /* TARG is on stack at this point and is overwriten by SETs.
3159 * This branch is the odd one out, so put TARG by default on
3160 * stack earlier to let local SP go out of liveness sooner */
3163 return NORMAL; /* no putback, SP didn't move in this opcode */
3167 /* Returns false if substring is completely outside original string.
3168 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3169 always be true for an explicit 0.
3172 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3173 bool pos1_is_uv, IV len_iv,
3174 bool len_is_uv, STRLEN *posp,
3180 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3182 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3183 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3186 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3189 if (len_iv || len_is_uv) {
3190 if (!len_is_uv && len_iv < 0) {
3191 pos2_iv = curlen + len_iv;
3193 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3196 } else { /* len_iv >= 0 */
3197 if (!pos1_is_uv && pos1_iv < 0) {
3198 pos2_iv = pos1_iv + len_iv;
3199 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3201 if ((UV)len_iv > curlen-(UV)pos1_iv)
3204 pos2_iv = pos1_iv+len_iv;
3214 if (!pos2_is_uv && pos2_iv < 0) {
3215 if (!pos1_is_uv && pos1_iv < 0)
3219 else if (!pos1_is_uv && pos1_iv < 0)
3222 if ((UV)pos2_iv < (UV)pos1_iv)
3224 if ((UV)pos2_iv > curlen)
3227 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3228 *posp = (STRLEN)( (UV)pos1_iv );
3229 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3246 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3247 const bool rvalue = (GIMME_V != G_VOID);
3250 const char *repl = NULL;
3252 int num_args = PL_op->op_private & 7;
3253 bool repl_need_utf8_upgrade = FALSE;
3257 if(!(repl_sv = POPs)) num_args--;
3259 if ((len_sv = POPs)) {
3260 len_iv = SvIV(len_sv);
3261 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3266 pos1_iv = SvIV(pos_sv);
3267 pos1_is_uv = SvIOK_UV(pos_sv);
3269 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3273 if (lvalue && !repl_sv) {
3275 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3276 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3278 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3280 pos1_is_uv || pos1_iv >= 0
3281 ? (STRLEN)(UV)pos1_iv
3282 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3284 len_is_uv || len_iv > 0
3285 ? (STRLEN)(UV)len_iv
3286 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3288 PUSHs(ret); /* avoid SvSETMAGIC here */
3292 repl = SvPV_const(repl_sv, repl_len);
3295 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3296 "Attempt to use reference as lvalue in substr"
3298 tmps = SvPV_force_nomg(sv, curlen);
3299 if (DO_UTF8(repl_sv) && repl_len) {
3301 /* Upgrade the dest, and recalculate tmps in case the buffer
3302 * got reallocated; curlen may also have been changed */
3303 sv_utf8_upgrade_nomg(sv);
3304 tmps = SvPV_nomg(sv, curlen);
3307 else if (DO_UTF8(sv))
3308 repl_need_utf8_upgrade = TRUE;
3310 else tmps = SvPV_const(sv, curlen);
3312 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3313 if (utf8_curlen == curlen)
3316 curlen = utf8_curlen;
3322 STRLEN pos, len, byte_len, byte_pos;
3324 if (!translate_substr_offsets(
3325 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3329 byte_pos = utf8_curlen
3330 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3335 SvTAINTED_off(TARG); /* decontaminate */
3336 SvUTF8_off(TARG); /* decontaminate */
3337 sv_setpvn(TARG, tmps, byte_len);
3338 #ifdef USE_LOCALE_COLLATE
3339 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3346 SV* repl_sv_copy = NULL;
3348 if (repl_need_utf8_upgrade) {
3349 repl_sv_copy = newSVsv(repl_sv);
3350 sv_utf8_upgrade(repl_sv_copy);
3351 repl = SvPV_const(repl_sv_copy, repl_len);
3355 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3356 SvREFCNT_dec(repl_sv_copy);
3359 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3369 Perl_croak(aTHX_ "substr outside of string");
3370 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3377 const IV size = POPi;
3378 SV* offsetsv = POPs;
3379 SV * const src = POPs;
3380 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3386 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3387 * or flag that its out of range */
3389 IV iv = SvIV(offsetsv);
3391 /* avoid a large UV being wrapped to a negative value */
3392 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3393 errflags = LVf_OUT_OF_RANGE;
3395 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3396 #if PTRSIZE < IVSIZE
3397 else if (iv > Size_t_MAX)
3398 errflags = LVf_OUT_OF_RANGE;
3401 offset = (STRLEN)iv;
3404 retuv = errflags ? 0 : do_vecget(src, offset, size);
3406 if (lvalue) { /* it's an lvalue! */
3407 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3408 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3410 LvTARG(ret) = SvREFCNT_inc_simple(src);
3411 LvTARGOFF(ret) = offset;
3412 LvTARGLEN(ret) = size;
3413 LvFLAGS(ret) = errflags;
3417 SvTAINTED_off(TARG); /* decontaminate */
3421 sv_setuv(ret, retuv);
3429 /* also used for: pp_rindex() */
3442 const char *little_p;
3445 const bool is_index = PL_op->op_type == OP_INDEX;
3446 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3452 big_p = SvPV_const(big, biglen);
3453 little_p = SvPV_const(little, llen);
3455 big_utf8 = DO_UTF8(big);
3456 little_utf8 = DO_UTF8(little);
3457 if (big_utf8 ^ little_utf8) {
3458 /* One needs to be upgraded. */
3460 /* Well, maybe instead we might be able to downgrade the small
3462 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3465 /* If the large string is ISO-8859-1, and it's not possible to
3466 convert the small string to ISO-8859-1, then there is no
3467 way that it could be found anywhere by index. */
3472 /* At this point, pv is a malloc()ed string. So donate it to temp
3473 to ensure it will get free()d */
3474 little = temp = newSV(0);
3475 sv_usepvn(temp, pv, llen);
3476 little_p = SvPVX(little);
3478 temp = newSVpvn(little_p, llen);
3480 sv_utf8_upgrade(temp);
3482 little_p = SvPV_const(little, llen);
3485 if (SvGAMAGIC(big)) {
3486 /* Life just becomes a lot easier if I use a temporary here.
3487 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3488 will trigger magic and overloading again, as will fbm_instr()
3490 big = newSVpvn_flags(big_p, biglen,
3491 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3494 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3495 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3496 warn on undef, and we've already triggered a warning with the
3497 SvPV_const some lines above. We can't remove that, as we need to
3498 call some SvPV to trigger overloading early and find out if the
3500 This is all getting too messy. The API isn't quite clean enough,
3501 because data access has side effects.
3503 little = newSVpvn_flags(little_p, llen,
3504 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3505 little_p = SvPVX(little);
3509 offset = is_index ? 0 : biglen;
3511 if (big_utf8 && offset > 0)
3512 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3518 else if (offset > (SSize_t)biglen)
3520 if (!(little_p = is_index
3521 ? fbm_instr((unsigned char*)big_p + offset,
3522 (unsigned char*)big_p + biglen, little, 0)
3523 : rninstr(big_p, big_p + offset,
3524 little_p, little_p + llen)))
3527 retval = little_p - big_p;
3528 if (retval > 1 && big_utf8)
3529 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3534 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3535 if (PL_op->op_private & OPpTRUEBOOL) {
3536 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3537 ? &PL_sv_yes : &PL_sv_no);
3538 if (PL_op->op_private & OPpTARGET_MY)
3539 /* $lex = (index() == -1) */
3540 sv_setsv(TARG, TOPs);
3549 dSP; dMARK; dORIGMARK; dTARGET;
3550 SvTAINTED_off(TARG);
3551 do_sprintf(TARG, SP-MARK, MARK+1);
3552 TAINT_IF(SvTAINTED(TARG));
3564 const U8 *s = (U8*)SvPV_const(argsv, len);
3567 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3581 if (UNLIKELY(SvAMAGIC(top)))
3583 if (UNLIKELY(isinfnansv(top)))
3584 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3586 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3587 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3589 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3590 && SvNV_nomg(top) < 0.0)))
3592 if (ckWARN(WARN_UTF8)) {
3593 if (SvGMAGICAL(top)) {
3594 SV *top2 = sv_newmortal();
3595 sv_setsv_nomg(top2, top);
3598 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3599 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3601 value = UNICODE_REPLACEMENT;
3603 value = SvUV_nomg(top);
3607 SvUPGRADE(TARG,SVt_PV);
3609 if (value > 255 && !IN_BYTES) {
3610 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3611 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3612 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3614 (void)SvPOK_only(TARG);
3623 *tmps++ = (char)value;
3625 (void)SvPOK_only(TARG);
3637 const char *tmps = SvPV_const(left, len);
3639 if (DO_UTF8(left)) {
3640 /* If Unicode, try to downgrade.
3641 * If not possible, croak.
3642 * Yes, we made this up. */
3643 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3645 sv_utf8_downgrade(tsv, FALSE);
3646 tmps = SvPV_const(tsv, len);
3648 # ifdef USE_ITHREADS
3650 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3651 /* This should be threadsafe because in ithreads there is only
3652 * one thread per interpreter. If this would not be true,
3653 * we would need a mutex to protect this malloc. */
3654 PL_reentrant_buffer->_crypt_struct_buffer =
3655 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3656 #if defined(__GLIBC__) || defined(__EMX__)
3657 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3658 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3659 #if (defined(__GLIBC__) && __GLIBC__ == 2) && \
3660 (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
3661 /* work around glibc-2.2.5 bug, has been fixed at some
3662 * time in glibc-2.3.X */
3663 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3668 # endif /* HAS_CRYPT_R */
3669 # endif /* USE_ITHREADS */
3671 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3673 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3680 "The crypt() function is unimplemented due to excessive paranoia.");
3684 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3685 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3688 /* also used for: pp_lcfirst() */
3692 /* Actually is both lcfirst() and ucfirst(). Only the first character
3693 * changes. This means that possibly we can change in-place, ie., just
3694 * take the source and change that one character and store it back, but not
3695 * if read-only etc, or if the length changes */
3699 STRLEN slen; /* slen is the byte length of the whole SV. */
3702 bool inplace; /* ? Convert first char only, in-place */
3703 bool doing_utf8 = FALSE; /* ? using utf8 */
3704 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3705 const int op_type = PL_op->op_type;
3708 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3709 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3710 * stored as UTF-8 at s. */
3711 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3712 * lowercased) character stored in tmpbuf. May be either
3713 * UTF-8 or not, but in either case is the number of bytes */
3715 s = (const U8*)SvPV_const(source, slen);
3717 /* We may be able to get away with changing only the first character, in
3718 * place, but not if read-only, etc. Later we may discover more reasons to
3719 * not convert in-place. */
3720 inplace = !SvREADONLY(source) && SvPADTMP(source);
3722 #ifdef USE_LOCALE_CTYPE
3724 if (IN_LC_RUNTIME(LC_CTYPE)) {
3725 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3730 /* First calculate what the changed first character should be. This affects
3731 * whether we can just swap it out, leaving the rest of the string unchanged,
3732 * or even if have to convert the dest to UTF-8 when the source isn't */
3734 if (! slen) { /* If empty */
3735 need = 1; /* still need a trailing NUL */
3739 else if (DO_UTF8(source)) { /* Is the source utf8? */
3742 if (op_type == OP_UCFIRST) {
3743 #ifdef USE_LOCALE_CTYPE
3744 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3746 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3750 #ifdef USE_LOCALE_CTYPE
3751 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3753 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3757 /* we can't do in-place if the length changes. */
3758 if (ulen != tculen) inplace = FALSE;
3759 need = slen + 1 - ulen + tculen;
3761 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3762 * latin1 is treated as caseless. Note that a locale takes
3764 ulen = 1; /* Original character is 1 byte */
3765 tculen = 1; /* Most characters will require one byte, but this will
3766 * need to be overridden for the tricky ones */
3769 if (op_type == OP_LCFIRST) {
3771 /* lower case the first letter: no trickiness for any character */
3772 #ifdef USE_LOCALE_CTYPE
3773 if (IN_LC_RUNTIME(LC_CTYPE)) {
3774 *tmpbuf = toLOWER_LC(*s);
3779 *tmpbuf = (IN_UNI_8_BIT)
3780 ? toLOWER_LATIN1(*s)
3784 #ifdef USE_LOCALE_CTYPE
3786 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3787 if (IN_UTF8_CTYPE_LOCALE) {
3791 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3792 locales have upper and title case
3796 else if (! IN_UNI_8_BIT) {
3797 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3798 * on EBCDIC machines whatever the
3799 * native function does */
3802 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3803 * UTF-8, which we treat as not in locale), and cased latin1 */
3805 #ifdef USE_LOCALE_CTYPE
3809 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3811 assert(tculen == 2);
3813 /* If the result is an upper Latin1-range character, it can
3814 * still be represented in one byte, which is its ordinal */
3815 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3816 *tmpbuf = (U8) title_ord;
3820 /* Otherwise it became more than one ASCII character (in
3821 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3822 * beyond Latin1, so the number of bytes changed, so can't
3823 * replace just the first character in place. */
3826 /* If the result won't fit in a byte, the entire result
3827 * will have to be in UTF-8. Assume worst case sizing in
3828 * conversion. (all latin1 characters occupy at most two
3830 if (title_ord > 255) {
3832 convert_source_to_utf8 = TRUE;
3833 need = slen * 2 + 1;
3835 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3836 * (both) characters whose title case is above 255 is
3840 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3841 need = slen + 1 + 1;
3845 } /* End of use Unicode (Latin1) semantics */
3846 } /* End of changing the case of the first character */
3848 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3849 * generate the result */
3852 /* We can convert in place. This means we change just the first
3853 * character without disturbing the rest; no need to grow */
3855 s = d = (U8*)SvPV_force_nomg(source, slen);
3861 /* Here, we can't convert in place; we earlier calculated how much
3862 * space we will need, so grow to accommodate that */
3863 SvUPGRADE(dest, SVt_PV);
3864 d = (U8*)SvGROW(dest, need);
3865 (void)SvPOK_only(dest);
3872 if (! convert_source_to_utf8) {
3874 /* Here both source and dest are in UTF-8, but have to create
3875 * the entire output. We initialize the result to be the
3876 * title/lower cased first character, and then append the rest
3878 sv_setpvn(dest, (char*)tmpbuf, tculen);
3880 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3884 const U8 *const send = s + slen;
3886 /* Here the dest needs to be in UTF-8, but the source isn't,
3887 * except we earlier UTF-8'd the first character of the source
3888 * into tmpbuf. First put that into dest, and then append the
3889 * rest of the source, converting it to UTF-8 as we go. */
3891 /* Assert tculen is 2 here because the only two characters that
3892 * get to this part of the code have 2-byte UTF-8 equivalents */
3894 *d++ = *(tmpbuf + 1);
3895 s++; /* We have just processed the 1st char */
3897 for (; s < send; s++) {
3898 d = uvchr_to_utf8(d, *s);
3901 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3905 else { /* in-place UTF-8. Just overwrite the first character */
3906 Copy(tmpbuf, d, tculen, U8);
3907 SvCUR_set(dest, need - 1);
3911 else { /* Neither source nor dest are in or need to be UTF-8 */
3913 if (inplace) { /* in-place, only need to change the 1st char */
3916 else { /* Not in-place */
3918 /* Copy the case-changed character(s) from tmpbuf */
3919 Copy(tmpbuf, d, tculen, U8);
3920 d += tculen - 1; /* Code below expects d to point to final
3921 * character stored */
3924 else { /* empty source */
3925 /* See bug #39028: Don't taint if empty */
3929 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3930 * the destination to retain that flag */
3931 if (SvUTF8(source) && ! IN_BYTES)
3934 if (!inplace) { /* Finish the rest of the string, unchanged */
3935 /* This will copy the trailing NUL */
3936 Copy(s + 1, d + 1, slen, U8);
3937 SvCUR_set(dest, need - 1);
3940 #ifdef USE_LOCALE_CTYPE
3941 if (IN_LC_RUNTIME(LC_CTYPE)) {
3946 if (dest != source && SvTAINTED(source))
3952 /* There's so much setup/teardown code common between uc and lc, I wonder if
3953 it would be worth merging the two, and just having a switch outside each
3954 of the three tight loops. There is less and less commonality though */
3967 if ( SvPADTMP(source)
3968 && !SvREADONLY(source) && SvPOK(source)
3971 #ifdef USE_LOCALE_CTYPE
3972 (IN_LC_RUNTIME(LC_CTYPE))
3973 ? ! IN_UTF8_CTYPE_LOCALE
3979 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3980 * make the loop tight, so we overwrite the source with the dest before
3981 * looking at it, and we need to look at the original source
3982 * afterwards. There would also need to be code added to handle
3983 * switching to not in-place in midstream if we run into characters
3984 * that change the length. Since being in locale overrides UNI_8_BIT,
3985 * that latter becomes irrelevant in the above test; instead for
3986 * locale, the size can't normally change, except if the locale is a
3989 s = d = (U8*)SvPV_force_nomg(source, len);
3996 s = (const U8*)SvPV_nomg_const(source, len);
3999 SvUPGRADE(dest, SVt_PV);
4000 d = (U8*)SvGROW(dest, min);
4001 (void)SvPOK_only(dest);
4006 #ifdef USE_LOCALE_CTYPE
4008 if (IN_LC_RUNTIME(LC_CTYPE)) {
4009 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4014 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4015 to check DO_UTF8 again here. */
4017 if (DO_UTF8(source)) {
4018 const U8 *const send = s + len;
4019 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4021 /* All occurrences of these are to be moved to follow any other marks.
4022 * This is context-dependent. We may not be passed enough context to
4023 * move the iota subscript beyond all of them, but we do the best we can
4024 * with what we're given. The result is always better than if we
4025 * hadn't done this. And, the problem would only arise if we are
4026 * passed a character without all its combining marks, which would be
4027 * the caller's mistake. The information this is based on comes from a
4028 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4029 * itself) and so can't be checked properly to see if it ever gets
4030 * revised. But the likelihood of it changing is remote */
4031 bool in_iota_subscript = FALSE;
4037 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4039 /* A non-mark. Time to output the iota subscript */
4040 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4041 d += capital_iota_len;
4042 in_iota_subscript = FALSE;
4045 /* Then handle the current character. Get the changed case value
4046 * and copy it to the output buffer */
4049 #ifdef USE_LOCALE_CTYPE
4050 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4052 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4054 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4055 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4056 if (uv == GREEK_CAPITAL_LETTER_IOTA
4057 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4059 in_iota_subscript = TRUE;
4062 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4063 /* If the eventually required minimum size outgrows the
4064 * available space, we need to grow. */
4065 const UV o = d - (U8*)SvPVX_const(dest);
4067 /* If someone uppercases one million U+03B0s we SvGROW()
4068 * one million times. Or we could try guessing how much to
4069 * allocate without allocating too much. Such is life.
4070 * See corresponding comment in lc code for another option
4072 d = o + (U8*) SvGROW(dest, min);
4074 Copy(tmpbuf, d, ulen, U8);
4079 if (in_iota_subscript) {
4080 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4081 d += capital_iota_len;
4086 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4088 else { /* Not UTF-8 */
4090 const U8 *const send = s + len;
4092 /* Use locale casing if in locale; regular style if not treating
4093 * latin1 as having case; otherwise the latin1 casing. Do the
4094 * whole thing in a tight loop, for speed, */
4095 #ifdef USE_LOCALE_CTYPE
4096 if (IN_LC_RUNTIME(LC_CTYPE)) {
4097 if (IN_UTF8_CTYPE_LOCALE) {
4100 for (; s < send; d++, s++)
4101 *d = (U8) toUPPER_LC(*s);
4105 if (! IN_UNI_8_BIT) {
4106 for (; s < send; d++, s++) {
4111 #ifdef USE_LOCALE_CTYPE
4114 for (; s < send; d++, s++) {
4115 *d = toUPPER_LATIN1_MOD(*s);
4116 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4120 /* The mainstream case is the tight loop above. To avoid
4121 * extra tests in that, all three characters that require
4122 * special handling are mapped by the MOD to the one tested
4124 * Use the source to distinguish between the three cases */
4126 #if UNICODE_MAJOR_VERSION > 2 \
4127 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4128 && UNICODE_DOT_DOT_VERSION >= 8)
4129 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4131 /* uc() of this requires 2 characters, but they are
4132 * ASCII. If not enough room, grow the string */
4133 if (SvLEN(dest) < ++min) {
4134 const UV o = d - (U8*)SvPVX_const(dest);
4135 d = o + (U8*) SvGROW(dest, min);
4137 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4138 continue; /* Back to the tight loop; still in ASCII */
4142 /* The other two special handling characters have their
4143 * upper cases outside the latin1 range, hence need to be
4144 * in UTF-8, so the whole result needs to be in UTF-8. So,
4145 * here we are somewhere in the middle of processing a
4146 * non-UTF-8 string, and realize that we will have to convert
4147 * the whole thing to UTF-8. What to do? There are
4148 * several possibilities. The simplest to code is to
4149 * convert what we have so far, set a flag, and continue on
4150 * in the loop. The flag would be tested each time through
4151 * the loop, and if set, the next character would be
4152 * converted to UTF-8 and stored. But, I (khw) didn't want
4153 * to slow down the mainstream case at all for this fairly
4154 * rare case, so I didn't want to add a test that didn't
4155 * absolutely have to be there in the loop, besides the
4156 * possibility that it would get too complicated for
4157 * optimizers to deal with. Another possibility is to just
4158 * give up, convert the source to UTF-8, and restart the
4159 * function that way. Another possibility is to convert
4160 * both what has already been processed and what is yet to
4161 * come separately to UTF-8, then jump into the loop that
4162 * handles UTF-8. But the most efficient time-wise of the
4163 * ones I could think of is what follows, and turned out to
4164 * not require much extra code. */
4166 /* Convert what we have so far into UTF-8, telling the
4167 * function that we know it should be converted, and to
4168 * allow extra space for what we haven't processed yet.
4169 * Assume the worst case space requirements for converting
4170 * what we haven't processed so far: that it will require
4171 * two bytes for each remaining source character, plus the
4172 * NUL at the end. This may cause the string pointer to
4173 * move, so re-find it. */
4175 len = d - (U8*)SvPVX_const(dest);
4176 SvCUR_set(dest, len);
4177 len = sv_utf8_upgrade_flags_grow(dest,
4178 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4180 d = (U8*)SvPVX(dest) + len;
4182 /* Now process the remainder of the source, converting to
4183 * upper and UTF-8. If a resulting byte is invariant in
4184 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4185 * append it to the output. */
4186 for (; s < send; s++) {
4187 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4191 /* Here have processed the whole source; no need to continue
4192 * with the outer loop. Each character has been converted
4193 * to upper case and converted to UTF-8 */
4196 } /* End of processing all latin1-style chars */
4197 } /* End of processing all chars */
4198 } /* End of source is not empty */
4200 if (source != dest) {
4201 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4202 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4204 } /* End of isn't utf8 */
4205 #ifdef USE_LOCALE_CTYPE
4206 if (IN_LC_RUNTIME(LC_CTYPE)) {
4211 if (dest != source && SvTAINTED(source))
4229 if ( SvPADTMP(source)
4230 && !SvREADONLY(source) && SvPOK(source)
4231 && !DO_UTF8(source)) {
4233 /* We can convert in place, as lowercasing anything in the latin1 range
4234 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4236 s = d = (U8*)SvPV_force_nomg(source, len);
4243 s = (const U8*)SvPV_nomg_const(source, len);
4246 SvUPGRADE(dest, SVt_PV);
4247 d = (U8*)SvGROW(dest, min);
4248 (void)SvPOK_only(dest);
4253 #ifdef USE_LOCALE_CTYPE
4255 if (IN_LC_RUNTIME(LC_CTYPE)) {
4256 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4261 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4262 to check DO_UTF8 again here. */
4264 if (DO_UTF8(source)) {
4265 const U8 *const send = s + len;
4266 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4269 const STRLEN u = UTF8SKIP(s);
4272 #ifdef USE_LOCALE_CTYPE
4273 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4275 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4278 /* Here is where we would do context-sensitive actions. See the
4279 * commit message for 86510fb15 for why there isn't any */
4281 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4283 /* If the eventually required minimum size outgrows the
4284 * available space, we need to grow. */
4285 const UV o = d - (U8*)SvPVX_const(dest);
4287 /* If someone lowercases one million U+0130s we SvGROW() one
4288 * million times. Or we could try guessing how much to
4289 * allocate without allocating too much. Such is life.
4290 * Another option would be to grow an extra byte or two more
4291 * each time we need to grow, which would cut down the million
4292 * to 500K, with little waste */
4293 d = o + (U8*) SvGROW(dest, min);
4296 /* Copy the newly lowercased letter to the output buffer we're
4298 Copy(tmpbuf, d, ulen, U8);
4301 } /* End of looping through the source string */
4304 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4305 } else { /* Not utf8 */
4307 const U8 *const send = s + len;
4309 /* Use locale casing if in locale; regular style if not treating
4310 * latin1 as having case; otherwise the latin1 casing. Do the
4311 * whole thing in a tight loop, for speed, */
4312 #ifdef USE_LOCALE_CTYPE
4313 if (IN_LC_RUNTIME(LC_CTYPE)) {
4314 for (; s < send; d++, s++)
4315 *d = toLOWER_LC(*s);
4319 if (! IN_UNI_8_BIT) {
4320 for (; s < send; d++, s++) {
4325 for (; s < send; d++, s++) {
4326 *d = toLOWER_LATIN1(*s);
4330 if (source != dest) {
4332 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4335 #ifdef USE_LOCALE_CTYPE
4336 if (IN_LC_RUNTIME(LC_CTYPE)) {
4341 if (dest != source && SvTAINTED(source))
4350 SV * const sv = TOPs;
4352 const char *s = SvPV_const(sv,len);
4354 SvUTF8_off(TARG); /* decontaminate */
4357 SvUPGRADE(TARG, SVt_PV);
4358 SvGROW(TARG, (len * 2) + 1);
4362 STRLEN ulen = UTF8SKIP(s);
4363 bool to_quote = FALSE;
4365 if (UTF8_IS_INVARIANT(*s)) {
4366 if (_isQUOTEMETA(*s)) {
4370 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4372 #ifdef USE_LOCALE_CTYPE
4373 /* In locale, we quote all non-ASCII Latin1 chars.
4374 * Otherwise use the quoting rules */
4376 IN_LC_RUNTIME(LC_CTYPE)
4379 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4384 else if (is_QUOTEMETA_high(s)) {
4399 else if (IN_UNI_8_BIT) {
4401 if (_isQUOTEMETA(*s))
4407 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4408 * including everything above ASCII */
4410 if (!isWORDCHAR_A(*s))
4416 SvCUR_set(TARG, d - SvPVX_const(TARG));
4417 (void)SvPOK_only_UTF8(TARG);
4420 sv_setpvn(TARG, s, len);
4436 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4437 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4438 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4439 || UNICODE_DOT_DOT_VERSION > 0)
4440 const bool full_folding = TRUE; /* This variable is here so we can easily
4441 move to more generality later */
4443 const bool full_folding = FALSE;
4445 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4446 #ifdef USE_LOCALE_CTYPE
4447 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4451 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4452 * You are welcome(?) -Hugmeir
4460 s = (const U8*)SvPV_nomg_const(source, len);
4462 if (ckWARN(WARN_UNINITIALIZED))
4463 report_uninit(source);
4470 SvUPGRADE(dest, SVt_PV);
4471 d = (U8*)SvGROW(dest, min);
4472 (void)SvPOK_only(dest);
4478 #ifdef USE_LOCALE_CTYPE
4480 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4481 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4486 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4488 const STRLEN u = UTF8SKIP(s);
4491 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4493 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4494 const UV o = d - (U8*)SvPVX_const(dest);
4495 d = o + (U8*) SvGROW(dest, min);
4498 Copy(tmpbuf, d, ulen, U8);
4503 } /* Unflagged string */
4505 #ifdef USE_LOCALE_CTYPE
4506 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4507 if (IN_UTF8_CTYPE_LOCALE) {
4508 goto do_uni_folding;
4510 for (; s < send; d++, s++)
4511 *d = (U8) toFOLD_LC(*s);
4515 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4516 for (; s < send; d++, s++)
4520 #ifdef USE_LOCALE_CTYPE
4523 /* For ASCII and the Latin-1 range, there's only two troublesome
4524 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4525 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4526 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4527 * For the rest, the casefold is their lowercase. */
4528 for (; s < send; d++, s++) {
4529 if (*s == MICRO_SIGN) {
4530 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4531 * which is outside of the latin-1 range. There's a couple
4532 * of ways to deal with this -- khw discusses them in
4533 * pp_lc/uc, so go there :) What we do here is upgrade what
4534 * we had already casefolded, then enter an inner loop that
4535 * appends the rest of the characters as UTF-8. */
4536 len = d - (U8*)SvPVX_const(dest);
4537 SvCUR_set(dest, len);
4538 len = sv_utf8_upgrade_flags_grow(dest,
4539 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4540 /* The max expansion for latin1
4541 * chars is 1 byte becomes 2 */
4543 d = (U8*)SvPVX(dest) + len;
4545 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4548 for (; s < send; s++) {
4550 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4551 if UVCHR_IS_INVARIANT(fc) {
4553 && *s == LATIN_SMALL_LETTER_SHARP_S)
4562 Copy(tmpbuf, d, ulen, U8);
4568 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4569 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4570 * becomes "ss", which may require growing the SV. */
4571 if (SvLEN(dest) < ++min) {
4572 const UV o = d - (U8*)SvPVX_const(dest);
4573 d = o + (U8*) SvGROW(dest, min);
4578 else { /* If it's not one of those two, the fold is their lower
4580 *d = toLOWER_LATIN1(*s);
4586 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4588 #ifdef USE_LOCALE_CTYPE
4589 if (IN_LC_RUNTIME(LC_CTYPE)) {
4594 if (SvTAINTED(source))
4604 dSP; dMARK; dORIGMARK;
4605 AV *const av = MUTABLE_AV(POPs);
4606 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4608 if (SvTYPE(av) == SVt_PVAV) {
4609 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4610 bool can_preserve = FALSE;
4616 can_preserve = SvCANEXISTDELETE(av);
4619 if (lval && localizing) {
4622 for (svp = MARK + 1; svp <= SP; svp++) {
4623 const SSize_t elem = SvIV(*svp);
4627 if (max > AvMAX(av))
4631 while (++MARK <= SP) {
4633 SSize_t elem = SvIV(*MARK);
4634 bool preeminent = TRUE;
4636 if (localizing && can_preserve) {
4637 /* If we can determine whether the element exist,
4638 * Try to preserve the existenceness of a tied array
4639 * element by using EXISTS and DELETE if possible.
4640 * Fallback to FETCH and STORE otherwise. */
4641 preeminent = av_exists(av, elem);
4644 svp = av_fetch(av, elem, lval);
4647 DIE(aTHX_ PL_no_aelem, elem);
4650 save_aelem(av, elem, svp);
4652 SAVEADELETE(av, elem);
4655 *MARK = svp ? *svp : &PL_sv_undef;
4658 if (GIMME_V != G_ARRAY) {
4660 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4669 AV *const av = MUTABLE_AV(POPs);
4670 I32 lval = (PL_op->op_flags & OPf_MOD);
4671 SSize_t items = SP - MARK;
4673 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4674 const I32 flags = is_lvalue_sub();
4676 if (!(flags & OPpENTERSUB_INARGS))
4677 /* diag_listed_as: Can't modify %s in %s */
4678 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4685 *(MARK+items*2-1) = *(MARK+items);
4691 while (++MARK <= SP) {
4694 svp = av_fetch(av, SvIV(*MARK), lval);
4696 if (!svp || !*svp || *svp == &PL_sv_undef) {
4697 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4699 *MARK = sv_mortalcopy(*MARK);
4701 *++MARK = svp ? *svp : &PL_sv_undef;
4703 if (GIMME_V != G_ARRAY) {
4704 MARK = SP - items*2;
4705 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4715 AV *array = MUTABLE_AV(POPs);
4716 const U8 gimme = GIMME_V;
4717 IV *iterp = Perl_av_iter_p(aTHX_ array);
4718 const IV current = (*iterp)++;
4720 if (current > av_tindex(array)) {
4722 if (gimme == G_SCALAR)
4730 if (gimme == G_ARRAY) {
4731 SV **const element = av_fetch(array, current, 0);
4732 PUSHs(element ? *element : &PL_sv_undef);
4737 /* also used for: pp_avalues()*/
4741 AV *array = MUTABLE_AV(POPs);
4742 const U8 gimme = GIMME_V;
4744 *Perl_av_iter_p(aTHX_ array) = 0;
4746 if (gimme == G_SCALAR) {
4748 PUSHi(av_tindex(array) + 1);
4750 else if (gimme == G_ARRAY) {
4751 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4752 const I32 flags = is_lvalue_sub();
4753 if (flags && !(flags & OPpENTERSUB_INARGS))
4754 /* diag_listed_as: Can't modify %s in %s */
4756 "Can't modify keys on array in list assignment");
4759 IV n = Perl_av_len(aTHX_ array);
4764 if ( PL_op->op_type == OP_AKEYS
4765 || ( PL_op->op_type == OP_AVHVSWITCH
4766 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
4768 for (i = 0; i <= n; i++) {
4773 for (i = 0; i <= n; i++) {
4774 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4775 PUSHs(elem ? *elem : &PL_sv_undef);
4783 /* Associative arrays. */
4788 HV * hash = MUTABLE_HV(POPs);
4790 const U8 gimme = GIMME_V;
4792 entry = hv_iternext(hash);
4796 SV* const sv = hv_iterkeysv(entry);
4798 if (gimme == G_ARRAY) {
4800 val = hv_iterval(hash, entry);
4804 else if (gimme == G_SCALAR)
4811 S_do_delete_local(pTHX)
4814 const U8 gimme = GIMME_V;
4817 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4818 SV **unsliced_keysv = sliced ? NULL : sp--;
4819 SV * const osv = POPs;
4820 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4822 const bool tied = SvRMAGICAL(osv)
4823 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4824 const bool can_preserve = SvCANEXISTDELETE(osv);
4825 const U32 type = SvTYPE(osv);
4826 SV ** const end = sliced ? SP : unsliced_keysv;
4828 if (type == SVt_PVHV) { /* hash element */
4829 HV * const hv = MUTABLE_HV(osv);
4830 while (++MARK <= end) {
4831 SV * const keysv = *MARK;
4833 bool preeminent = TRUE;
4835 preeminent = hv_exists_ent(hv, keysv, 0);
4837 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4844 sv = hv_delete_ent(hv, keysv, 0, 0);
4846 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4849 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4850 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4852 *MARK = sv_mortalcopy(sv);
4858 SAVEHDELETE(hv, keysv);
4859 *MARK = &PL_sv_undef;
4863 else if (type == SVt_PVAV) { /* array element */
4864 if (PL_op->op_flags & OPf_SPECIAL) {
4865 AV * const av = MUTABLE_AV(osv);
4866 while (++MARK <= end) {
4867 SSize_t idx = SvIV(*MARK);
4869 bool preeminent = TRUE;
4871 preeminent = av_exists(av, idx);
4873 SV **svp = av_fetch(av, idx, 1);
4880 sv = av_delete(av, idx, 0);
4882 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4885 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4887 *MARK = sv_mortalcopy(sv);
4893 SAVEADELETE(av, idx);
4894 *MARK = &PL_sv_undef;
4899 DIE(aTHX_ "panic: avhv_delete no longer supported");
4902 DIE(aTHX_ "Not a HASH reference");
4904 if (gimme == G_VOID)
4906 else if (gimme == G_SCALAR) {
4911 *++MARK = &PL_sv_undef;
4915 else if (gimme != G_VOID)
4916 PUSHs(*unsliced_keysv);
4927 if (PL_op->op_private & OPpLVAL_INTRO)
4928 return do_delete_local();
4931 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4933 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
4935 HV * const hv = MUTABLE_HV(POPs);
4936 const U32 hvtype = SvTYPE(hv);
4938 if (PL_op->op_private & OPpKVSLICE) {
4939 SSize_t items = SP - MARK;
4943 *(MARK+items*2-1) = *(MARK+items);
4950 if (hvtype == SVt_PVHV) { /* hash element */
4951 while ((MARK += (1+skip)) <= SP) {
4952 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
4953 *MARK = sv ? sv : &PL_sv_undef;
4956 else if (hvtype == SVt_PVAV) { /* array element */
4957 if (PL_op->op_flags & OPf_SPECIAL) {
4958 while ((MARK += (1+skip)) <= SP) {
4959 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
4960 *MARK = sv ? sv : &PL_sv_undef;
4965 DIE(aTHX_ "Not a HASH reference");
4968 else if (gimme == G_SCALAR) {
4973 *++MARK = &PL_sv_undef;
4979 HV * const hv = MUTABLE_HV(POPs);
4981 if (SvTYPE(hv) == SVt_PVHV)
4982 sv = hv_delete_ent(hv, keysv, discard, 0);
4983 else if (SvTYPE(hv) == SVt_PVAV) {
4984 if (PL_op->op_flags & OPf_SPECIAL)
4985 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4987 DIE(aTHX_ "panic: avhv_delete no longer supported");
4990 DIE(aTHX_ "Not a HASH reference");
5005 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5007 SV * const sv = POPs;
5008 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5011 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5016 hv = MUTABLE_HV(POPs);
5017 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5018 if (hv_exists_ent(hv, tmpsv, 0))
5021 else if (SvTYPE(hv) == SVt_PVAV) {
5022 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5023 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5028 DIE(aTHX_ "Not a HASH reference");
5035 dSP; dMARK; dORIGMARK;
5036 HV * const hv = MUTABLE_HV(POPs);
5037 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5038 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5039 bool can_preserve = FALSE;
5045 if (SvCANEXISTDELETE(hv))
5046 can_preserve = TRUE;
5049 while (++MARK <= SP) {
5050 SV * const keysv = *MARK;
5053 bool preeminent = TRUE;
5055 if (localizing && can_preserve) {
5056 /* If we can determine whether the element exist,
5057 * try to preserve the existenceness of a tied hash
5058 * element by using EXISTS and DELETE if possible.
5059 * Fallback to FETCH and STORE otherwise. */
5060 preeminent = hv_exists_ent(hv, keysv, 0);
5063 he = hv_fetch_ent(hv, keysv, lval, 0);
5064 svp = he ? &HeVAL(he) : NULL;
5067 if (!svp || !*svp || *svp == &PL_sv_undef) {
5068 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5071 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5072 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5073 else if (preeminent)
5074 save_helem_flags(hv, keysv, svp,
5075 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5077 SAVEHDELETE(hv, keysv);
5080 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5082 if (GIMME_V != G_ARRAY) {
5084 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5093 HV * const hv = MUTABLE_HV(POPs);
5094 I32 lval = (PL_op->op_flags & OPf_MOD);
5095 SSize_t items = SP - MARK;
5097 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5098 const I32 flags = is_lvalue_sub();
5100 if (!(flags & OPpENTERSUB_INARGS))
5101 /* diag_listed_as: Can't modify %s in %s */
5102 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5103 GIMME_V == G_ARRAY ? "list" : "scalar");
5110 *(MARK+items*2-1) = *(MARK+items);
5116 while (++MARK <= SP) {
5117 SV * const keysv = *MARK;
5121 he = hv_fetch_ent(hv, keysv, lval, 0);
5122 svp = he ? &HeVAL(he) : NULL;
5125 if (!svp || !*svp || *svp == &PL_sv_undef) {
5126 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5128 *MARK = sv_mortalcopy(*MARK);
5130 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5132 if (GIMME_V != G_ARRAY) {
5133 MARK = SP - items*2;
5134 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5140 /* List operators. */
5144 I32 markidx = POPMARK;
5145 if (GIMME_V != G_ARRAY) {
5146 /* don't initialize mark here, EXTEND() may move the stack */
5149 EXTEND(SP, 1); /* in case no arguments, as in @empty */
5150 mark = PL_stack_base + markidx;
5152 *MARK = *SP; /* unwanted list, return last item */
5154 *MARK = &PL_sv_undef;
5164 SV ** const lastrelem = PL_stack_sp;
5165 SV ** const lastlelem = PL_stack_base + POPMARK;
5166 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5167 SV ** const firstrelem = lastlelem + 1;
5168 const U8 mod = PL_op->op_flags & OPf_MOD;
5170 const I32 max = lastrelem - lastlelem;
5173 if (GIMME_V != G_ARRAY) {
5174 if (lastlelem < firstlelem) {
5176 *firstlelem = &PL_sv_undef;
5179 I32 ix = SvIV(*lastlelem);
5182 if (ix < 0 || ix >= max)
5183 *firstlelem = &PL_sv_undef;
5185 *firstlelem = firstrelem[ix];
5192 SP = firstlelem - 1;
5196 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5197 I32 ix = SvIV(*lelem);
5200 if (ix < 0 || ix >= max)
5201 *lelem = &PL_sv_undef;
5203 if (!(*lelem = firstrelem[ix]))
5204 *lelem = &PL_sv_undef;
5205 else if (mod && SvPADTMP(*lelem)) {
5206 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5217 const I32 items = SP - MARK;
5218 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5220 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5221 ? newRV_noinc(av) : av);
5227 dSP; dMARK; dORIGMARK;
5228 HV* const hv = newHV();
5229 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5230 ? newRV_noinc(MUTABLE_SV(hv))
5235 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5242 sv_setsv_nomg(val, *MARK);
5246 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5249 (void)hv_store_ent(hv,key,val,0);
5258 dSP; dMARK; dORIGMARK;
5259 int num_args = (SP - MARK);
5260 AV *ary = MUTABLE_AV(*++MARK);
5269 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5272 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5273 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5277 if (SvREADONLY(ary))
5278 Perl_croak_no_modify();
5283 offset = i = SvIV(*MARK);
5285 offset += AvFILLp(ary) + 1;
5287 DIE(aTHX_ PL_no_aelem, i);
5289 length = SvIVx(*MARK++);
5291 length += AvFILLp(ary) - offset + 1;
5297 length = AvMAX(ary) + 1; /* close enough to infinity */
5301 length = AvMAX(ary) + 1;
5303 if (offset > AvFILLp(ary) + 1) {
5305 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5306 offset = AvFILLp(ary) + 1;
5308 after = AvFILLp(ary) + 1 - (offset + length);
5309 if (after < 0) { /* not that much array */
5310 length += after; /* offset+length now in array */
5316 /* At this point, MARK .. SP-1 is our new LIST */
5319 diff = newlen - length;
5320 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5323 /* make new elements SVs now: avoid problems if they're from the array */
5324 for (dst = MARK, i = newlen; i; i--) {
5325 SV * const h = *dst;
5326 *dst++ = newSVsv(h);
5329 if (diff < 0) { /* shrinking the area */
5330 SV **tmparyval = NULL;
5332 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5333 Copy(MARK, tmparyval, newlen, SV*);
5336 MARK = ORIGMARK + 1;
5337 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5338 const bool real = cBOOL(AvREAL(ary));
5339 MEXTEND(MARK, length);
5341 EXTEND_MORTAL(length);
5342 for (i = 0, dst = MARK; i < length; i++) {
5343 if ((*dst = AvARRAY(ary)[i+offset])) {
5345 sv_2mortal(*dst); /* free them eventually */
5348 *dst = &PL_sv_undef;
5354 *MARK = AvARRAY(ary)[offset+length-1];
5357 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5358 SvREFCNT_dec(*dst++); /* free them now */
5361 *MARK = &PL_sv_undef;
5363 AvFILLp(ary) += diff;
5365 /* pull up or down? */
5367 if (offset < after) { /* easier to pull up */
5368 if (offset) { /* esp. if nothing to pull */
5369 src = &AvARRAY(ary)[offset-1];
5370 dst = src - diff; /* diff is negative */
5371 for (i = offset; i > 0; i--) /* can't trust Copy */
5375 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5379 if (after) { /* anything to pull down? */
5380 src = AvARRAY(ary) + offset + length;
5381 dst = src + diff; /* diff is negative */
5382 Move(src, dst, after, SV*);
5384 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5385 /* avoid later double free */
5392 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5393 Safefree(tmparyval);
5396 else { /* no, expanding (or same) */
5397 SV** tmparyval = NULL;
5399 Newx(tmparyval, length, SV*); /* so remember deletion */
5400 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5403 if (diff > 0) { /* expanding */
5404 /* push up or down? */
5405 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5409 Move(src, dst, offset, SV*);
5411 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5413 AvFILLp(ary) += diff;
5416 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5417 av_extend(ary, AvFILLp(ary) + diff);
5418 AvFILLp(ary) += diff;
5421 dst = AvARRAY(ary) + AvFILLp(ary);
5423 for (i = after; i; i--) {
5431 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5434 MARK = ORIGMARK + 1;
5435 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5437 const bool real = cBOOL(AvREAL(ary));
5439 EXTEND_MORTAL(length);
5440 for (i = 0, dst = MARK; i < length; i++) {
5441 if ((*dst = tmparyval[i])) {
5443 sv_2mortal(*dst); /* free them eventually */
5445 else *dst = &PL_sv_undef;
5451 else if (length--) {
5452 *MARK = tmparyval[length];
5455 while (length-- > 0)
5456 SvREFCNT_dec(tmparyval[length]);
5459 *MARK = &PL_sv_undef;
5462 *MARK = &PL_sv_undef;
5463 Safefree(tmparyval);
5467 mg_set(MUTABLE_SV(ary));
5475 dSP; dMARK; dORIGMARK; dTARGET;
5476 AV * const ary = MUTABLE_AV(*++MARK);
5477 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5480 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5483 ENTER_with_name("call_PUSH");
5484 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5485 LEAVE_with_name("call_PUSH");
5486 /* SPAGAIN; not needed: SP is assigned to immediately below */
5489 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5490 * only need to save locally, not on the save stack */
5491 U16 old_delaymagic = PL_delaymagic;
5493 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5494 PL_delaymagic = DM_DELAY;
5495 for (++MARK; MARK <= SP; MARK++) {
5497 if (*MARK) SvGETMAGIC(*MARK);
5500 sv_setsv_nomg(sv, *MARK);
5501 av_store(ary, AvFILLp(ary)+1, sv);
5503 if (PL_delaymagic & DM_ARRAY_ISA)
5504 mg_set(MUTABLE_SV(ary));
5505 PL_delaymagic = old_delaymagic;
5508 if (OP_GIMME(PL_op, 0) != G_VOID) {
5509 PUSHi( AvFILL(ary) + 1 );
5514 /* also used for: pp_pop()*/
5518 AV * const av = PL_op->op_flags & OPf_SPECIAL
5519 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5520 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5524 (void)sv_2mortal(sv);
5531 dSP; dMARK; dORIGMARK; dTARGET;
5532 AV *ary = MUTABLE_AV(*++MARK);
5533 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5536 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5539 ENTER_with_name("call_UNSHIFT");
5540 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5541 LEAVE_with_name("call_UNSHIFT");
5542 /* SPAGAIN; not needed: SP is assigned to immediately below */
5545 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5546 * only need to save locally, not on the save stack */
5547 U16 old_delaymagic = PL_delaymagic;
5550 av_unshift(ary, SP - MARK);
5551 PL_delaymagic = DM_DELAY;
5553 SV * const sv = newSVsv(*++MARK);
5554 (void)av_store(ary, i++, sv);
5556 if (PL_delaymagic & DM_ARRAY_ISA)
5557 mg_set(MUTABLE_SV(ary));
5558 PL_delaymagic = old_delaymagic;
5561 if (OP_GIMME(PL_op, 0) != G_VOID) {
5562 PUSHi( AvFILL(ary) + 1 );
5571 if (GIMME_V == G_ARRAY) {
5572 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5576 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5577 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5578 av = MUTABLE_AV((*SP));
5579 /* In-place reversing only happens in void context for the array
5580 * assignment. We don't need to push anything on the stack. */
5583 if (SvMAGICAL(av)) {
5585 SV *tmp = sv_newmortal();
5586 /* For SvCANEXISTDELETE */
5589 bool can_preserve = SvCANEXISTDELETE(av);
5591 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5595 if (!av_exists(av, i)) {
5596 if (av_exists(av, j)) {
5597 SV *sv = av_delete(av, j, 0);
5598 begin = *av_fetch(av, i, TRUE);
5599 sv_setsv_mg(begin, sv);
5603 else if (!av_exists(av, j)) {
5604 SV *sv = av_delete(av, i, 0);
5605 end = *av_fetch(av, j, TRUE);
5606 sv_setsv_mg(end, sv);
5611 begin = *av_fetch(av, i, TRUE);
5612 end = *av_fetch(av, j, TRUE);
5613 sv_setsv(tmp, begin);
5614 sv_setsv_mg(begin, end);
5615 sv_setsv_mg(end, tmp);
5619 SV **begin = AvARRAY(av);
5622 SV **end = begin + AvFILLp(av);
5624 while (begin < end) {
5625 SV * const tmp = *begin;
5636 SV * const tmp = *MARK;
5640 /* safe as long as stack cannot get extended in the above */
5649 SvUTF8_off(TARG); /* decontaminate */
5650 if (SP - MARK > 1) {
5651 do_join(TARG, &PL_sv_no, MARK, SP);
5654 } else if (SP > MARK) {
5655 sv_setsv(TARG, *SP);
5658 sv_setsv(TARG, DEFSV);
5662 up = SvPV_force(TARG, len);
5665 if (DO_UTF8(TARG)) { /* first reverse each character */
5666 U8* s = (U8*)SvPVX(TARG);
5667 const U8* send = (U8*)(s + len);
5669 if (UTF8_IS_INVARIANT(*s)) {
5674 if (!utf8_to_uvchr_buf(s, send, 0))
5678 down = (char*)(s - 1);
5679 /* reverse this character */
5681 const char tmp = *up;
5689 down = SvPVX(TARG) + len - 1;
5691 const char tmp = *up;
5695 (void)SvPOK_only_UTF8(TARG);
5704 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5705 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
5706 ? (AV *)POPs : NULL;
5707 IV limit = POPi; /* note, negative is forever */
5708 SV * const sv = POPs;
5710 const char *s = SvPV_const(sv, len);
5711 const bool do_utf8 = DO_UTF8(sv);
5712 const bool in_uni_8_bit = IN_UNI_8_BIT;
5713 const char *strend = s + len;
5714 PMOP *pm = cPMOPx(PL_op);
5719 const STRLEN slen = do_utf8
5720 ? utf8_length((U8*)s, (U8*)strend)
5721 : (STRLEN)(strend - s);
5722 SSize_t maxiters = slen + 10;
5723 I32 trailing_empty = 0;
5725 const IV origlimit = limit;
5728 const U8 gimme = GIMME_V;
5730 I32 oldsave = PL_savestack_ix;
5731 U32 make_mortal = SVs_TEMP;
5737 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5738 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5740 /* handle @ary = split(...) optimisation */
5741 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5742 if (!(PL_op->op_flags & OPf_STACKED)) {
5743 if (PL_op->op_private & OPpSPLIT_LEX) {
5744 if (PL_op->op_private & OPpLVAL_INTRO)
5745 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5746 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5751 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5753 pm->op_pmreplrootu.op_pmtargetgv;
5755 if (PL_op->op_private & OPpLVAL_INTRO)
5760 /* skip anything pushed by OPpLVAL_INTRO above */
5761 oldsave = PL_savestack_ix;
5767 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5770 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5772 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5779 for (i = AvFILLp(ary); i >= 0; i--)
5780 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5782 /* temporarily switch stacks */
5783 SAVESWITCHSTACK(PL_curstack, ary);
5788 base = SP - PL_stack_base;
5790 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5792 while (s < strend && isSPACE_utf8_safe(s, strend))
5795 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5796 while (s < strend && isSPACE_LC(*s))
5799 else if (in_uni_8_bit) {
5800 while (s < strend && isSPACE_L1(*s))
5804 while (s < strend && isSPACE(*s))
5808 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5812 gimme_scalar = gimme == G_SCALAR && !ary;
5815 limit = maxiters + 2;
5816 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5819 /* this one uses 'm' and is a negative test */
5821 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
5822 const int t = UTF8SKIP(m);
5823 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
5830 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5832 while (m < strend && !isSPACE_LC(*m))
5835 else if (in_uni_8_bit) {
5836 while (m < strend && !isSPACE_L1(*m))
5839 while (m < strend && !isSPACE(*m))
5852 dstr = newSVpvn_flags(s, m-s,
5853 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5857 /* skip the whitespace found last */
5859 s = m + UTF8SKIP(m);
5863 /* this one uses 's' and is a positive test */
5865 while (s < strend && isSPACE_utf8_safe(s, strend) )
5868 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5870 while (s < strend && isSPACE_LC(*s))
5873 else if (in_uni_8_bit) {
5874 while (s < strend && isSPACE_L1(*s))
5877 while (s < strend && isSPACE(*s))
5882 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5884 for (m = s; m < strend && *m != '\n'; m++)
5897 dstr = newSVpvn_flags(s, m-s,
5898 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5904 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5906 Pre-extend the stack, either the number of bytes or
5907 characters in the string or a limited amount, triggered by:
5909 my ($x, $y) = split //, $str;
5913 if (!gimme_scalar) {
5914 const IV items = limit - 1;
5915 /* setting it to -1 will trigger a panic in EXTEND() */
5916 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
5917 if (items >=0 && items < sslen)
5925 /* keep track of how many bytes we skip over */
5935 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5948 dstr = newSVpvn(s, 1);
5964 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5965 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5966 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5967 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5968 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5969 SV * const csv = CALLREG_INTUIT_STRING(rx);
5971 len = RX_MINLENRET(rx);
5972 if (len == 1 && !RX_UTF8(rx) && !tail) {
5973 const char c = *SvPV_nolen_const(csv);
5975 for (m = s; m < strend && *m != c; m++)
5986 dstr = newSVpvn_flags(s, m-s,
5987 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5990 /* The rx->minlen is in characters but we want to step
5991 * s ahead by bytes. */
5993 s = (char*)utf8_hop((U8*)m, len);
5995 s = m + len; /* Fake \n at the end */
5999 while (s < strend && --limit &&
6000 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6001 csv, multiline ? FBMrf_MULTILINE : 0)) )
6010 dstr = newSVpvn_flags(s, m-s,
6011 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6014 /* The rx->minlen is in characters but we want to step
6015 * s ahead by bytes. */
6017 s = (char*)utf8_hop((U8*)m, len);
6019 s = m + len; /* Fake \n at the end */
6024 maxiters += slen * RX_NPARENS(rx);
6025 while (s < strend && --limit)
6029 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6032 if (rex_return == 0)
6034 TAINT_IF(RX_MATCH_TAINTED(rx));
6035 /* we never pass the REXEC_COPY_STR flag, so it should
6036 * never get copied */
6037 assert(!RX_MATCH_COPIED(rx));
6038 m = RX_OFFS(rx)[0].start + orig;
6047 dstr = newSVpvn_flags(s, m-s,
6048 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6051 if (RX_NPARENS(rx)) {
6053 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6054 s = RX_OFFS(rx)[i].start + orig;
6055 m = RX_OFFS(rx)[i].end + orig;
6057 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6058 parens that didn't match -- they should be set to
6059 undef, not the empty string */
6067 if (m >= orig && s >= orig) {
6068 dstr = newSVpvn_flags(s, m-s,
6069 (do_utf8 ? SVf_UTF8 : 0)
6073 dstr = &PL_sv_undef; /* undef, not "" */
6079 s = RX_OFFS(rx)[0].end + orig;
6083 if (!gimme_scalar) {
6084 iters = (SP - PL_stack_base) - base;
6086 if (iters > maxiters)
6087 DIE(aTHX_ "Split loop");
6089 /* keep field after final delim? */
6090 if (s < strend || (iters && origlimit)) {
6091 if (!gimme_scalar) {
6092 const STRLEN l = strend - s;
6093 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6098 else if (!origlimit) {
6100 iters -= trailing_empty;
6102 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6103 if (TOPs && !make_mortal)
6112 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6116 if (SvSMAGICAL(ary)) {
6118 mg_set(MUTABLE_SV(ary));
6121 if (gimme == G_ARRAY) {
6123 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6130 ENTER_with_name("call_PUSH");
6131 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6132 LEAVE_with_name("call_PUSH");
6134 if (gimme == G_ARRAY) {
6136 /* EXTEND should not be needed - we just popped them */
6138 for (i=0; i < iters; i++) {
6139 SV **svp = av_fetch(ary, i, FALSE);
6140 PUSHs((svp) ? *svp : &PL_sv_undef);
6147 if (gimme == G_ARRAY)
6159 SV *const sv = PAD_SVl(PL_op->op_targ);
6161 if (SvPADSTALE(sv)) {
6164 RETURNOP(cLOGOP->op_other);
6166 RETURNOP(cLOGOP->op_next);
6175 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6176 || SvTYPE(retsv) == SVt_PVCV) {
6177 retsv = refto(retsv);
6184 /* used for: pp_padany(), pp_custom(); plus any system ops
6185 * that aren't implemented on a particular platform */
6187 PP(unimplemented_op)
6189 const Optype op_type = PL_op->op_type;
6190 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6191 with out of range op numbers - it only "special" cases op_custom.
6192 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6193 if we get here for a custom op then that means that the custom op didn't
6194 have an implementation. Given that OP_NAME() looks up the custom op
6195 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6196 registers &PL_unimplemented_op as the address of their custom op.
6197 NULL doesn't generate a useful error message. "custom" does. */
6198 const char *const name = op_type >= OP_max
6199 ? "[out of range]" : PL_op_name[PL_op->op_type];
6200 if(OP_IS_SOCKET(op_type))
6201 DIE(aTHX_ PL_no_sock_func, name);
6202 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6206 S_maybe_unwind_defav(pTHX)
6208 if (CX_CUR()->cx_type & CXp_HASARGS) {
6209 PERL_CONTEXT *cx = CX_CUR();
6211 assert(CxHASARGS(cx));
6213 cx->cx_type &= ~CXp_HASARGS;
6217 /* For sorting out arguments passed to a &CORE:: subroutine */
6221 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6222 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6223 AV * const at_ = GvAV(PL_defgv);
6224 SV **svp = at_ ? AvARRAY(at_) : NULL;
6225 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6226 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6227 bool seen_question = 0;
6228 const char *err = NULL;
6229 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6231 /* Count how many args there are first, to get some idea how far to
6232 extend the stack. */
6234 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6236 if (oa & OA_OPTIONAL) seen_question = 1;
6237 if (!seen_question) minargs++;
6241 if(numargs < minargs) err = "Not enough";
6242 else if(numargs > maxargs) err = "Too many";
6244 /* diag_listed_as: Too many arguments for %s */
6246 "%s arguments for %s", err,
6247 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6250 /* Reset the stack pointer. Without this, we end up returning our own
6251 arguments in list context, in addition to the values we are supposed
6252 to return. nextstate usually does this on sub entry, but we need
6253 to run the next op with the caller's hints, so we cannot have a
6255 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6257 if(!maxargs) RETURN;
6259 /* We do this here, rather than with a separate pushmark op, as it has
6260 to come in between two things this function does (stack reset and
6261 arg pushing). This seems the easiest way to do it. */
6264 (void)Perl_pp_pushmark(aTHX);
6267 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6268 PUTBACK; /* The code below can die in various places. */
6270 oa = PL_opargs[opnum] >> OASHIFT;
6271 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6276 if (!numargs && defgv && whicharg == minargs + 1) {
6279 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6283 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6290 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6293 S_maybe_unwind_defav(aTHX);
6296 PUSHs((SV *)GvAVn(gv));
6299 if (!svp || !*svp || !SvROK(*svp)
6300 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6302 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6303 "Type of arg %d to &CORE::%s must be array reference",
6304 whicharg, PL_op_desc[opnum]
6309 if (!svp || !*svp || !SvROK(*svp)
6310 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6311 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6312 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6314 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6315 "Type of arg %d to &CORE::%s must be hash%s reference",
6316 whicharg, PL_op_desc[opnum],
6317 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6324 if (!numargs) PUSHs(NULL);
6325 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6326 /* no magic here, as the prototype will have added an extra
6327 refgen and we just want what was there before that */
6330 const bool constr = PL_op->op_private & whicharg;
6332 svp && *svp ? *svp : &PL_sv_undef,
6333 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6339 if (!numargs) goto try_defsv;
6341 const bool wantscalar =
6342 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6343 if (!svp || !*svp || !SvROK(*svp)
6344 /* We have to permit globrefs even for the \$ proto, as
6345 *foo is indistinguishable from ${\*foo}, and the proto-
6346 type permits the latter. */
6347 || SvTYPE(SvRV(*svp)) > (
6348 wantscalar ? SVt_PVLV
6349 : opnum == OP_LOCK || opnum == OP_UNDEF
6355 "Type of arg %d to &CORE::%s must be %s",
6356 whicharg, PL_op_name[opnum],
6358 ? "scalar reference"
6359 : opnum == OP_LOCK || opnum == OP_UNDEF
6360 ? "reference to one of [$@%&*]"
6361 : "reference to one of [$@%*]"
6364 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6365 /* Undo @_ localisation, so that sub exit does not undo
6366 part of our undeffing. */
6367 S_maybe_unwind_defav(aTHX);
6372 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6380 /* Implement CORE::keys(),values(),each().
6382 * We won't know until run-time whether the arg is an array or hash,
6385 * pp_keys/pp_values/pp_each
6387 * pp_akeys/pp_avalues/pp_aeach
6389 * as appropriate (or whatever pp function actually implements the OP_FOO
6390 * functionality for each FOO).
6397 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6398 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6406 if (PL_op->op_private & OPpOFFBYONE) {
6407 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6409 else cv = find_runcv(NULL);
6410 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6415 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6416 const bool can_preserve)
6418 const SSize_t ix = SvIV(keysv);
6419 if (can_preserve ? av_exists(av, ix) : TRUE) {
6420 SV ** const svp = av_fetch(av, ix, 1);
6422 Perl_croak(aTHX_ PL_no_aelem, ix);
6423 save_aelem(av, ix, svp);
6426 SAVEADELETE(av, ix);
6430 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6431 const bool can_preserve)
6433 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6434 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6435 SV ** const svp = he ? &HeVAL(he) : NULL;
6437 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6438 save_helem_flags(hv, keysv, svp, 0);
6441 SAVEHDELETE(hv, keysv);
6445 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6447 if (type == OPpLVREF_SV) {
6448 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6451 else if (type == OPpLVREF_AV)
6452 /* XXX Inefficient, as it creates a new AV, which we are
6453 about to clobber. */
6456 assert(type == OPpLVREF_HV);
6457 /* XXX Likewise inefficient. */
6466 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6467 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6469 const char *bad = NULL;
6470 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6471 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6474 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6478 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6482 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6486 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6490 /* diag_listed_as: Assigned value is not %s reference */
6491 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6495 switch (left ? SvTYPE(left) : 0) {
6498 SV * const old = PAD_SV(ARGTARG);
6499 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6501 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6503 SAVECLEARSV(PAD_SVl(ARGTARG));
6507 if (PL_op->op_private & OPpLVAL_INTRO) {
6508 S_localise_gv_slot(aTHX_ (GV *)left, type);
6510 gv_setref(left, sv);
6515 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6516 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6517 SvCANEXISTDELETE(left));
6519 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6522 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6524 S_localise_helem_lval(aTHX_ (HV *)left, key,
6525 SvCANEXISTDELETE(left));
6527 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6529 if (PL_op->op_flags & OPf_MOD)
6530 SETs(sv_2mortal(newSVsv(sv)));
6531 /* XXX else can weak references go stale before they are read, e.g.,
6540 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6541 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6542 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6543 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6544 &PL_vtbl_lvref, (char *)elem,
6545 elem ? HEf_SVKEY : (I32)ARGTARG);
6546 mg->mg_private = PL_op->op_private;
6547 if (PL_op->op_private & OPpLVREF_ITER)
6548 mg->mg_flags |= MGf_PERSIST;
6549 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6555 const bool can_preserve = SvCANEXISTDELETE(arg);
6556 if (SvTYPE(arg) == SVt_PVAV)
6557 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6559 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6563 S_localise_gv_slot(aTHX_ (GV *)arg,
6564 PL_op->op_private & OPpLVREF_TYPE);
6566 else if (!(PL_op->op_private & OPpPAD_STATE))
6567 SAVECLEARSV(PAD_SVl(ARGTARG));
6576 AV * const av = (AV *)POPs;
6577 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6578 bool can_preserve = FALSE;
6580 if (UNLIKELY(localizing)) {
6585 can_preserve = SvCANEXISTDELETE(av);
6587 if (SvTYPE(av) == SVt_PVAV) {
6590 for (svp = MARK + 1; svp <= SP; svp++) {
6591 const SSize_t elem = SvIV(*svp);
6595 if (max > AvMAX(av))
6600 while (++MARK <= SP) {
6601 SV * const elemsv = *MARK;
6602 if (UNLIKELY(localizing)) {
6603 if (SvTYPE(av) == SVt_PVAV)
6604 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6606 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6608 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6609 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6616 if (PL_op->op_flags & OPf_STACKED)
6617 Perl_pp_rv2av(aTHX);
6619 Perl_pp_padav(aTHX);
6623 SETs(0); /* special alias marker that aassign recognises */
6633 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6634 ? CopSTASH(PL_curcop)
6636 NULL, SvREFCNT_inc_simple_NN(sv))));
6641 /* process one subroutine argument - typically when the sub has a signature:
6642 * introduce PL_curpad[op_targ] and assign to it the value
6643 * for $: (OPf_STACKED ? *sp : $_[N])
6644 * for @/%: @_[N..$#_]
6646 * It's equivalent to
6649 * my $foo = (value-on-stack)
6651 * my @foo = @_[N..$#_]
6661 AV *defav = GvAV(PL_defgv); /* @_ */
6662 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6665 /* do 'my $var, @var or %var' action */
6666 padentry = &(PAD_SVl(o->op_targ));
6667 save_clearsv(padentry);
6670 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6671 if (o->op_flags & OPf_STACKED) {
6678 /* should already have been checked */
6680 #if IVSIZE > PTRSIZE
6681 assert(ix <= SSize_t_MAX);
6684 svp = av_fetch(defav, ix, FALSE);
6685 val = svp ? *svp : &PL_sv_undef;
6690 /* cargo-culted from pp_sassign */
6691 assert(TAINTING_get || !TAINT_get);
6692 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6695 SvSetMagicSV(targ, val);
6699 /* must be AV or HV */
6701 assert(!(o->op_flags & OPf_STACKED));
6702 argc = ((IV)AvFILL(defav) + 1) - ix;
6704 /* This is a copy of the relevant parts of pp_aassign().
6706 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6709 if (AvFILL((AV*)targ) > -1) {
6710 /* target should usually be empty. If we get get
6711 * here, someone's been doing some weird closure tricks.
6712 * Make a copy of all args before clearing the array,
6713 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6714 * elements. See similar code in pp_aassign.
6716 for (i = 0; i < argc; i++) {
6717 SV **svp = av_fetch(defav, ix + i, FALSE);
6718 SV *newsv = newSV(0);
6719 sv_setsv_flags(newsv,
6720 svp ? *svp : &PL_sv_undef,
6721 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6722 if (!av_store(defav, ix + i, newsv))
6723 SvREFCNT_dec_NN(newsv);
6725 av_clear((AV*)targ);
6731 av_extend((AV*)targ, argc);
6736 SV **svp = av_fetch(defav, ix + i, FALSE);
6737 SV *val = svp ? *svp : &PL_sv_undef;
6739 sv_setsv(tmpsv, val);
6740 av_store((AV*)targ, i++, tmpsv);
6748 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6750 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6751 /* see "target should usually be empty" comment above */
6752 for (i = 0; i < argc; i++) {
6753 SV **svp = av_fetch(defav, ix + i, FALSE);
6754 SV *newsv = newSV(0);
6755 sv_setsv_flags(newsv,
6756 svp ? *svp : &PL_sv_undef,
6757 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6758 if (!av_store(defav, ix + i, newsv))
6759 SvREFCNT_dec_NN(newsv);
6761 hv_clear((HV*)targ);
6766 assert(argc % 2 == 0);
6775 svp = av_fetch(defav, ix + i++, FALSE);
6776 key = svp ? *svp : &PL_sv_undef;
6777 svp = av_fetch(defav, ix + i++, FALSE);
6778 val = svp ? *svp : &PL_sv_undef;
6781 if (UNLIKELY(SvGMAGICAL(key)))
6782 key = sv_mortalcopy(key);
6784 sv_setsv(tmpsv, val);
6785 hv_store_ent((HV*)targ, key, tmpsv, 0);
6793 /* Handle a default value for one subroutine argument (typically as part
6794 * of a subroutine signature).
6795 * It's equivalent to
6796 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
6798 * Intended to be used where op_next is an OP_ARGELEM
6800 * We abuse the op_targ field slightly: it's an index into @_ rather than
6806 OP * const o = PL_op;
6807 AV *defav = GvAV(PL_defgv); /* @_ */
6808 IV ix = (IV)o->op_targ;
6811 #if IVSIZE > PTRSIZE
6812 assert(ix <= SSize_t_MAX);
6815 if (AvFILL(defav) >= ix) {
6817 SV **svp = av_fetch(defav, ix, FALSE);
6818 SV *val = svp ? *svp : &PL_sv_undef;
6822 return cLOGOPo->op_other;
6827 S_find_runcv_name(void)
6842 sv = sv_2mortal(newSV(0));
6843 gv_fullname4(sv, gv, NULL, TRUE);
6847 /* Check a a subs arguments - i.e. that it has the correct number of args
6848 * (and anything else we might think of in future). Typically used with
6854 OP * const o = PL_op;
6855 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6856 IV params = aux[0].iv;
6857 IV opt_params = aux[1].iv;
6858 char slurpy = (char)(aux[2].iv);
6859 AV *defav = GvAV(PL_defgv); /* @_ */
6863 assert(!SvMAGICAL(defav));
6864 argc = (AvFILLp(defav) + 1);
6865 too_few = (argc < (params - opt_params));
6867 if (UNLIKELY(too_few || (!slurpy && argc > params)))
6868 /* diag_listed_as: Too few arguments for subroutine '%s' */
6869 /* diag_listed_as: Too many arguments for subroutine '%s' */
6870 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
6871 too_few ? "few" : "many", S_find_runcv_name());
6873 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6874 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
6875 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
6876 S_find_runcv_name());
6882 * ex: set ts=8 sts=4 sw=4 et: