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 */
1322 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1328 const IV biv = SvIVX(svr);
1331 buvok = TRUE; /* effectively it's a UV now */
1333 /* abs, buvok == false records sign */
1334 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
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 */
1465 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
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 */
1486 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
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. */
1506 const UV result = left / right;
1507 if (result * right == left) {
1508 SP--; /* result is valid */
1509 if (left_non_neg == right_non_neg) {
1510 /* signs identical, result is positive. */
1514 /* 2s complement assumption */
1515 if (result <= (UV)IV_MIN)
1516 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1518 /* It's exact but too negative for IV. */
1519 SETn( -(NV)result );
1522 } /* tried integer divide but it was not an integer result */
1523 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1524 } /* one operand wasn't SvIOK */
1525 #endif /* PERL_TRY_UV_DIVIDE */
1527 NV right = SvNV_nomg(svr);
1528 NV left = SvNV_nomg(svl);
1529 (void)POPs;(void)POPs;
1530 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1531 if (! Perl_isnan(right) && right == 0.0)
1535 DIE(aTHX_ "Illegal division by zero");
1536 PUSHn( left / right );
1544 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1548 bool left_neg = FALSE;
1549 bool right_neg = FALSE;
1550 bool use_double = FALSE;
1551 bool dright_valid = FALSE;
1554 SV * const svr = TOPs;
1555 SV * const svl = TOPm1s;
1556 if (SvIV_please_nomg(svr)) {
1557 right_neg = !SvUOK(svr);
1561 const IV biv = SvIVX(svr);
1564 right_neg = FALSE; /* effectively it's a UV now */
1566 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1571 dright = SvNV_nomg(svr);
1572 right_neg = dright < 0;
1575 if (dright < UV_MAX_P1) {
1576 right = U_V(dright);
1577 dright_valid = TRUE; /* In case we need to use double below. */
1583 /* At this point use_double is only true if right is out of range for
1584 a UV. In range NV has been rounded down to nearest UV and
1585 use_double false. */
1586 if (!use_double && SvIV_please_nomg(svl)) {
1587 left_neg = !SvUOK(svl);
1591 const IV aiv = SvIVX(svl);
1594 left_neg = FALSE; /* effectively it's a UV now */
1596 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1601 dleft = SvNV_nomg(svl);
1602 left_neg = dleft < 0;
1606 /* This should be exactly the 5.6 behaviour - if left and right are
1607 both in range for UV then use U_V() rather than floor. */
1609 if (dleft < UV_MAX_P1) {
1610 /* right was in range, so is dleft, so use UVs not double.
1614 /* left is out of range for UV, right was in range, so promote
1615 right (back) to double. */
1617 /* The +0.5 is used in 5.6 even though it is not strictly
1618 consistent with the implicit +0 floor in the U_V()
1619 inside the #if 1. */
1620 dleft = Perl_floor(dleft + 0.5);
1623 dright = Perl_floor(dright + 0.5);
1634 DIE(aTHX_ "Illegal modulus zero");
1636 dans = Perl_fmod(dleft, dright);
1637 if ((left_neg != right_neg) && dans)
1638 dans = dright - dans;
1641 sv_setnv(TARG, dans);
1647 DIE(aTHX_ "Illegal modulus zero");
1650 if ((left_neg != right_neg) && ans)
1653 /* XXX may warn: unary minus operator applied to unsigned type */
1654 /* could change -foo to be (~foo)+1 instead */
1655 if (ans <= ~((UV)IV_MAX)+1)
1656 sv_setiv(TARG, ~ans+1);
1658 sv_setnv(TARG, -(NV)ans);
1661 sv_setuv(TARG, ans);
1673 bool infnan = FALSE;
1675 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1676 /* TODO: think of some way of doing list-repeat overloading ??? */
1681 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1682 /* The parser saw this as a list repeat, and there
1683 are probably several items on the stack. But we're
1684 in scalar/void context, and there's no pp_list to save us
1685 now. So drop the rest of the items -- robin@kitsite.com
1688 if (MARK + 1 < SP) {
1694 ASSUME(MARK + 1 == SP);
1696 MARK[1] = &PL_sv_undef;
1700 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1706 const UV uv = SvUV_nomg(sv);
1708 count = IV_MAX; /* The best we can do? */
1712 count = SvIV_nomg(sv);
1715 else if (SvNOKp(sv)) {
1716 const NV nv = SvNV_nomg(sv);
1717 infnan = Perl_isinfnan(nv);
1718 if (UNLIKELY(infnan)) {
1722 count = -1; /* An arbitrary negative integer */
1728 count = SvIV_nomg(sv);
1731 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1732 "Non-finite repeat count does nothing");
1733 } else if (count < 0) {
1735 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1736 "Negative repeat count does nothing");
1739 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1741 const SSize_t items = SP - MARK;
1742 const U8 mod = PL_op->op_flags & OPf_MOD;
1747 if ( items > SSize_t_MAX / count /* max would overflow */
1748 /* repeatcpy would overflow */
1749 || items > I32_MAX / (I32)sizeof(SV *)
1751 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1752 max = items * count;
1757 if (mod && SvPADTMP(*SP)) {
1758 *SP = sv_mortalcopy(*SP);
1765 repeatcpy((char*)(MARK + items), (char*)MARK,
1766 items * sizeof(const SV *), count - 1);
1769 else if (count <= 0)
1772 else { /* Note: mark already snarfed by pp_list */
1773 SV * const tmpstr = POPs;
1778 sv_setsv_nomg(TARG, tmpstr);
1779 SvPV_force_nomg(TARG, len);
1780 isutf = DO_UTF8(TARG);
1787 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1788 || len > (U32)I32_MAX /* repeatcpy would overflow */
1790 Perl_croak(aTHX_ "%s",
1791 "Out of memory during string extend");
1792 max = (UV)count * len + 1;
1795 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1796 SvCUR_set(TARG, SvCUR(TARG) * count);
1798 *SvEND(TARG) = '\0';
1801 (void)SvPOK_only_UTF8(TARG);
1803 (void)SvPOK_only(TARG);
1812 dSP; dATARGET; bool useleft; SV *svl, *svr;
1813 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1817 #ifdef PERL_PRESERVE_IVUV
1819 /* special-case some simple common cases */
1820 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1822 U32 flags = (svl->sv_flags & svr->sv_flags);
1823 if (flags & SVf_IOK) {
1824 /* both args are simple IVs */
1829 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1830 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1832 /* if both are in a range that can't under/overflow, do a
1833 * simple integer subtract: if the top of both numbers
1834 * are 00 or 11, then it's safe */
1835 if (!( ((topl+1) | (topr+1)) & 2)) {
1837 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1843 else if (flags & SVf_NOK) {
1844 /* both args are NVs */
1849 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1850 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1851 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1853 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1856 /* nothing was lost by converting to IVs */
1859 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1867 useleft = USE_LEFT(svl);
1868 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1869 "bad things" happen if you rely on signed integers wrapping. */
1870 if (SvIV_please_nomg(svr)) {
1871 /* Unless the left argument is integer in range we are going to have to
1872 use NV maths. Hence only attempt to coerce the right argument if
1873 we know the left is integer. */
1880 a_valid = auvok = 1;
1881 /* left operand is undef, treat as zero. */
1883 /* Left operand is defined, so is it IV? */
1884 if (SvIV_please_nomg(svl)) {
1885 if ((auvok = SvUOK(svl)))
1888 const IV aiv = SvIVX(svl);
1891 auvok = 1; /* Now acting as a sign flag. */
1892 } else { /* 2s complement assumption for IV_MIN */
1893 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1900 bool result_good = 0;
1903 bool buvok = SvUOK(svr);
1908 const IV biv = SvIVX(svr);
1913 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
1915 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1916 else "IV" now, independent of how it came in.
1917 if a, b represents positive, A, B negative, a maps to -A etc
1922 all UV maths. negate result if A negative.
1923 subtract if signs same, add if signs differ. */
1925 if (auvok ^ buvok) {
1934 /* Must get smaller */
1939 if (result <= buv) {
1940 /* result really should be -(auv-buv). as its negation
1941 of true value, need to swap our result flag */
1953 if (result <= (UV)IV_MIN)
1954 SETi(result == (UV)IV_MIN
1955 ? IV_MIN : -(IV)result);
1957 /* result valid, but out of range for IV. */
1958 SETn( -(NV)result );
1962 } /* Overflow, drop through to NVs. */
1966 useleft = USE_LEFT(svl);
1969 NV value = SvNV_nomg(svr);
1973 /* left operand is undef, treat as zero - value */
1977 SETn( SvNV_nomg(svl) - value );
1982 #define IV_BITS (IVSIZE * 8)
1984 static UV S_uv_shift(UV uv, int shift, bool left)
1990 if (shift >= IV_BITS) {
1993 return left ? uv << shift : uv >> shift;
1996 static IV S_iv_shift(IV iv, int shift, bool left)
2002 if (shift >= IV_BITS) {
2003 return iv < 0 && !left ? -1 : 0;
2005 return left ? iv << shift : iv >> shift;
2008 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2009 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2010 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2011 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2015 dSP; dATARGET; SV *svl, *svr;
2016 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2020 const IV shift = SvIV_nomg(svr);
2021 if (PL_op->op_private & HINT_INTEGER) {
2022 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2025 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2033 dSP; dATARGET; SV *svl, *svr;
2034 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2038 const IV shift = SvIV_nomg(svr);
2039 if (PL_op->op_private & HINT_INTEGER) {
2040 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2043 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2054 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2058 (SvIOK_notUV(left) && SvIOK_notUV(right))
2059 ? (SvIVX(left) < SvIVX(right))
2060 : (do_ncmp(left, right) == -1)
2070 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2074 (SvIOK_notUV(left) && SvIOK_notUV(right))
2075 ? (SvIVX(left) > SvIVX(right))
2076 : (do_ncmp(left, right) == 1)
2086 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2090 (SvIOK_notUV(left) && SvIOK_notUV(right))
2091 ? (SvIVX(left) <= SvIVX(right))
2092 : (do_ncmp(left, right) <= 0)
2102 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2106 (SvIOK_notUV(left) && SvIOK_notUV(right))
2107 ? (SvIVX(left) >= SvIVX(right))
2108 : ( (do_ncmp(left, right) & 2) == 0)
2118 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2122 (SvIOK_notUV(left) && SvIOK_notUV(right))
2123 ? (SvIVX(left) != SvIVX(right))
2124 : (do_ncmp(left, right) != 0)
2129 /* compare left and right SVs. Returns:
2133 * 2: left or right was a NaN
2136 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2138 PERL_ARGS_ASSERT_DO_NCMP;
2139 #ifdef PERL_PRESERVE_IVUV
2140 /* Fortunately it seems NaN isn't IOK */
2141 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2143 const IV leftiv = SvIVX(left);
2144 if (!SvUOK(right)) {
2145 /* ## IV <=> IV ## */
2146 const IV rightiv = SvIVX(right);
2147 return (leftiv > rightiv) - (leftiv < rightiv);
2149 /* ## IV <=> UV ## */
2151 /* As (b) is a UV, it's >=0, so it must be < */
2154 const UV rightuv = SvUVX(right);
2155 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2160 /* ## UV <=> UV ## */
2161 const UV leftuv = SvUVX(left);
2162 const UV rightuv = SvUVX(right);
2163 return (leftuv > rightuv) - (leftuv < rightuv);
2165 /* ## UV <=> IV ## */
2167 const IV rightiv = SvIVX(right);
2169 /* As (a) is a UV, it's >=0, so it cannot be < */
2172 const UV leftuv = SvUVX(left);
2173 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2176 NOT_REACHED; /* NOTREACHED */
2180 NV const rnv = SvNV_nomg(right);
2181 NV const lnv = SvNV_nomg(left);
2183 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2184 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2187 return (lnv > rnv) - (lnv < rnv);
2206 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2209 value = do_ncmp(left, right);
2221 /* also used for: pp_sge() pp_sgt() pp_slt() */
2227 int amg_type = sle_amg;
2231 switch (PL_op->op_type) {
2250 tryAMAGICbin_MG(amg_type, AMGf_set);
2254 #ifdef USE_LOCALE_COLLATE
2255 (IN_LC_RUNTIME(LC_COLLATE))
2256 ? sv_cmp_locale_flags(left, right, 0)
2259 sv_cmp_flags(left, right, 0);
2260 SETs(boolSV(cmp * multiplier < rhs));
2268 tryAMAGICbin_MG(seq_amg, AMGf_set);
2271 SETs(boolSV(sv_eq_flags(left, right, 0)));
2279 tryAMAGICbin_MG(sne_amg, AMGf_set);
2282 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2290 tryAMAGICbin_MG(scmp_amg, 0);
2294 #ifdef USE_LOCALE_COLLATE
2295 (IN_LC_RUNTIME(LC_COLLATE))
2296 ? sv_cmp_locale_flags(left, right, 0)
2299 sv_cmp_flags(left, right, 0);
2308 tryAMAGICbin_MG(band_amg, AMGf_assign);
2311 if (SvNIOKp(left) || SvNIOKp(right)) {
2312 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2313 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2314 if (PL_op->op_private & HINT_INTEGER) {
2315 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2319 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2322 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2323 if (right_ro_nonnum) SvNIOK_off(right);
2326 do_vop(PL_op->op_type, TARG, left, right);
2336 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2338 dATARGET; dPOPTOPssrl;
2339 if (PL_op->op_private & HINT_INTEGER) {
2340 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2344 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2354 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2356 dATARGET; dPOPTOPssrl;
2357 do_vop(OP_BIT_AND, TARG, left, right);
2362 /* also used for: pp_bit_xor() */
2367 const int op_type = PL_op->op_type;
2369 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2372 if (SvNIOKp(left) || SvNIOKp(right)) {
2373 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2374 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2375 if (PL_op->op_private & HINT_INTEGER) {
2376 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2377 const IV r = SvIV_nomg(right);
2378 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2382 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2383 const UV r = SvUV_nomg(right);
2384 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2387 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2388 if (right_ro_nonnum) SvNIOK_off(right);
2391 do_vop(op_type, TARG, left, right);
2398 /* also used for: pp_nbit_xor() */
2403 const int op_type = PL_op->op_type;
2405 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2406 AMGf_assign|AMGf_numarg);
2408 dATARGET; dPOPTOPssrl;
2409 if (PL_op->op_private & HINT_INTEGER) {
2410 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2411 const IV r = SvIV_nomg(right);
2412 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2416 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2417 const UV r = SvUV_nomg(right);
2418 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2425 /* also used for: pp_sbit_xor() */
2430 const int op_type = PL_op->op_type;
2432 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2435 dATARGET; dPOPTOPssrl;
2436 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2442 PERL_STATIC_INLINE bool
2443 S_negate_string(pTHX)
2448 SV * const sv = TOPs;
2449 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2451 s = SvPV_nomg_const(sv, len);
2452 if (isIDFIRST(*s)) {
2453 sv_setpvs(TARG, "-");
2456 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2457 sv_setsv_nomg(TARG, sv);
2458 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2468 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2469 if (S_negate_string(aTHX)) return NORMAL;
2471 SV * const sv = TOPs;
2474 /* It's publicly an integer */
2477 if (SvIVX(sv) == IV_MIN) {
2478 /* 2s complement assumption. */
2479 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2483 else if (SvUVX(sv) <= IV_MAX) {
2488 else if (SvIVX(sv) != IV_MIN) {
2492 #ifdef PERL_PRESERVE_IVUV
2499 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2500 SETn(-SvNV_nomg(sv));
2501 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2502 goto oops_its_an_int;
2504 SETn(-SvNV_nomg(sv));
2514 tryAMAGICun_MG(not_amg, AMGf_set);
2516 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2521 S_scomplement(pTHX_ SV *targ, SV *sv)
2527 sv_copypv_nomg(TARG, sv);
2528 tmps = (U8*)SvPV_nomg(TARG, len);
2531 if (len && ! utf8_to_bytes(tmps, &len)) {
2532 Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
2543 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2546 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2551 for ( ; anum > 0; anum--, tmps++)
2558 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2562 if (PL_op->op_private & HINT_INTEGER) {
2563 const IV i = ~SvIV_nomg(sv);
2567 const UV u = ~SvUV_nomg(sv);
2572 S_scomplement(aTHX_ TARG, sv);
2582 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2585 if (PL_op->op_private & HINT_INTEGER) {
2586 const IV i = ~SvIV_nomg(sv);
2590 const UV u = ~SvUV_nomg(sv);
2600 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2603 S_scomplement(aTHX_ TARG, sv);
2609 /* integer versions of some of the above */
2614 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2617 SETi( left * right );
2626 tryAMAGICbin_MG(div_amg, AMGf_assign);
2629 IV value = SvIV_nomg(right);
2631 DIE(aTHX_ "Illegal division by zero");
2632 num = SvIV_nomg(left);
2634 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2638 value = num / value;
2646 /* This is the vanilla old i_modulo. */
2648 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2652 DIE(aTHX_ "Illegal modulus zero");
2653 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2657 SETi( left % right );
2662 #if defined(__GLIBC__) && IVSIZE == 8 \
2663 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2665 PP(pp_i_modulo_glibc_bugfix)
2667 /* This is the i_modulo with the workaround for the _moddi3 bug
2668 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2669 * See below for pp_i_modulo. */
2671 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2675 DIE(aTHX_ "Illegal modulus zero");
2676 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2680 SETi( left % PERL_ABS(right) );
2689 tryAMAGICbin_MG(add_amg, AMGf_assign);
2691 dPOPTOPiirl_ul_nomg;
2692 SETi( left + right );
2700 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2702 dPOPTOPiirl_ul_nomg;
2703 SETi( left - right );
2711 tryAMAGICbin_MG(lt_amg, AMGf_set);
2714 SETs(boolSV(left < right));
2722 tryAMAGICbin_MG(gt_amg, AMGf_set);
2725 SETs(boolSV(left > right));
2733 tryAMAGICbin_MG(le_amg, AMGf_set);
2736 SETs(boolSV(left <= right));
2744 tryAMAGICbin_MG(ge_amg, AMGf_set);
2747 SETs(boolSV(left >= right));
2755 tryAMAGICbin_MG(eq_amg, AMGf_set);
2758 SETs(boolSV(left == right));
2766 tryAMAGICbin_MG(ne_amg, AMGf_set);
2769 SETs(boolSV(left != right));
2777 tryAMAGICbin_MG(ncmp_amg, 0);
2784 else if (left < right)
2796 tryAMAGICun_MG(neg_amg, 0);
2797 if (S_negate_string(aTHX)) return NORMAL;
2799 SV * const sv = TOPs;
2800 IV const i = SvIV_nomg(sv);
2806 /* High falutin' math. */
2811 tryAMAGICbin_MG(atan2_amg, 0);
2814 SETn(Perl_atan2(left, right));
2820 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2825 int amg_type = fallback_amg;
2826 const char *neg_report = NULL;
2827 const int op_type = PL_op->op_type;
2830 case OP_SIN: amg_type = sin_amg; break;
2831 case OP_COS: amg_type = cos_amg; break;
2832 case OP_EXP: amg_type = exp_amg; break;
2833 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2834 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2837 assert(amg_type != fallback_amg);
2839 tryAMAGICun_MG(amg_type, 0);
2841 SV * const arg = TOPs;
2842 const NV value = SvNV_nomg(arg);
2848 if (neg_report) { /* log or sqrt */
2850 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2851 ! Perl_isnan(value) &&
2853 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2854 SET_NUMERIC_STANDARD();
2855 /* diag_listed_as: Can't take log of %g */
2856 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2861 case OP_SIN: result = Perl_sin(value); break;
2862 case OP_COS: result = Perl_cos(value); break;
2863 case OP_EXP: result = Perl_exp(value); break;
2864 case OP_LOG: result = Perl_log(value); break;
2865 case OP_SQRT: result = Perl_sqrt(value); break;
2872 /* Support Configure command-line overrides for rand() functions.
2873 After 5.005, perhaps we should replace this by Configure support
2874 for drand48(), random(), or rand(). For 5.005, though, maintain
2875 compatibility by calling rand() but allow the user to override it.
2876 See INSTALL for details. --Andy Dougherty 15 July 1998
2878 /* Now it's after 5.005, and Configure supports drand48() and random(),
2879 in addition to rand(). So the overrides should not be needed any more.
2880 --Jarkko Hietaniemi 27 September 1998
2885 if (!PL_srand_called) {
2886 (void)seedDrand01((Rand_seed_t)seed());
2887 PL_srand_called = TRUE;
2899 SV * const sv = POPs;
2905 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2906 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2907 if (! Perl_isnan(value) && value == 0.0)
2917 sv_setnv_mg(TARG, value);
2928 if (MAXARG >= 1 && (TOPs || POPs)) {
2935 pv = SvPV(top, len);
2936 flags = grok_number(pv, len, &anum);
2938 if (!(flags & IS_NUMBER_IN_UV)) {
2939 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2940 "Integer overflow in srand");
2948 (void)seedDrand01((Rand_seed_t)anum);
2949 PL_srand_called = TRUE;
2953 /* Historically srand always returned true. We can avoid breaking
2955 sv_setpvs(TARG, "0 but true");
2964 tryAMAGICun_MG(int_amg, AMGf_numeric);
2966 SV * const sv = TOPs;
2967 const IV iv = SvIV_nomg(sv);
2968 /* XXX it's arguable that compiler casting to IV might be subtly
2969 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2970 else preferring IV has introduced a subtle behaviour change bug. OTOH
2971 relying on floating point to be accurate is a bug. */
2976 else if (SvIOK(sv)) {
2978 SETu(SvUV_nomg(sv));
2983 const NV value = SvNV_nomg(sv);
2984 if (UNLIKELY(Perl_isinfnan(value)))
2986 else if (value >= 0.0) {
2987 if (value < (NV)UV_MAX + 0.5) {
2990 SETn(Perl_floor(value));
2994 if (value > (NV)IV_MIN - 0.5) {
2997 SETn(Perl_ceil(value));
3008 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3010 SV * const sv = TOPs;
3011 /* This will cache the NV value if string isn't actually integer */
3012 const IV iv = SvIV_nomg(sv);
3017 else if (SvIOK(sv)) {
3018 /* IVX is precise */
3020 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3028 /* 2s complement assumption. Also, not really needed as
3029 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3035 const NV value = SvNV_nomg(sv);
3046 /* also used for: pp_hex() */
3052 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3056 SV* const sv = TOPs;
3058 tmps = (SvPV_const(sv, len));
3060 /* If Unicode, try to downgrade
3061 * If not possible, croak. */
3062 SV* const tsv = sv_2mortal(newSVsv(sv));
3065 sv_utf8_downgrade(tsv, FALSE);
3066 tmps = SvPV_const(tsv, len);
3068 if (PL_op->op_type == OP_HEX)
3071 while (*tmps && len && isSPACE(*tmps))
3075 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3077 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3079 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3080 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3082 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3084 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3099 SV * const sv = TOPs;
3101 U32 in_bytes = IN_BYTES;
3102 /* Simplest case shortcut:
3103 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3104 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3107 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3109 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3112 if (LIKELY(svflags == SVf_POK))
3115 if (svflags & SVs_GMG)
3120 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3121 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3123 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3124 /* no need to convert from bytes to chars */
3128 len = sv_len_utf8_nomg(sv);
3131 /* unrolled SvPV_nomg_const(sv,len) */
3132 if (SvPOK_nog(sv)) {
3135 if (PL_op->op_private & OPpTRUEBOOL) {
3137 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3142 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3145 TARGi((IV)(len), 1);
3148 if (!SvPADTMP(TARG)) {
3149 /* OPpTARGET_MY: targ is var in '$lex = length()' */
3154 /* TARG is on stack at this point and is overwriten by SETs.
3155 * This branch is the odd one out, so put TARG by default on
3156 * stack earlier to let local SP go out of liveness sooner */
3159 return NORMAL; /* no putback, SP didn't move in this opcode */
3163 /* Returns false if substring is completely outside original string.
3164 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3165 always be true for an explicit 0.
3168 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3169 bool pos1_is_uv, IV len_iv,
3170 bool len_is_uv, STRLEN *posp,
3176 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3178 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3179 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3182 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3185 if (len_iv || len_is_uv) {
3186 if (!len_is_uv && len_iv < 0) {
3187 pos2_iv = curlen + len_iv;
3189 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3192 } else { /* len_iv >= 0 */
3193 if (!pos1_is_uv && pos1_iv < 0) {
3194 pos2_iv = pos1_iv + len_iv;
3195 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3197 if ((UV)len_iv > curlen-(UV)pos1_iv)
3200 pos2_iv = pos1_iv+len_iv;
3210 if (!pos2_is_uv && pos2_iv < 0) {
3211 if (!pos1_is_uv && pos1_iv < 0)
3215 else if (!pos1_is_uv && pos1_iv < 0)
3218 if ((UV)pos2_iv < (UV)pos1_iv)
3220 if ((UV)pos2_iv > curlen)
3223 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3224 *posp = (STRLEN)( (UV)pos1_iv );
3225 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3242 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3243 const bool rvalue = (GIMME_V != G_VOID);
3246 const char *repl = NULL;
3248 int num_args = PL_op->op_private & 7;
3249 bool repl_need_utf8_upgrade = FALSE;
3253 if(!(repl_sv = POPs)) num_args--;
3255 if ((len_sv = POPs)) {
3256 len_iv = SvIV(len_sv);
3257 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3262 pos1_iv = SvIV(pos_sv);
3263 pos1_is_uv = SvIOK_UV(pos_sv);
3265 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3269 if (lvalue && !repl_sv) {
3271 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3272 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3274 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3276 pos1_is_uv || pos1_iv >= 0
3277 ? (STRLEN)(UV)pos1_iv
3278 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3280 len_is_uv || len_iv > 0
3281 ? (STRLEN)(UV)len_iv
3282 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3284 PUSHs(ret); /* avoid SvSETMAGIC here */
3288 repl = SvPV_const(repl_sv, repl_len);
3291 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3292 "Attempt to use reference as lvalue in substr"
3294 tmps = SvPV_force_nomg(sv, curlen);
3295 if (DO_UTF8(repl_sv) && repl_len) {
3297 /* Upgrade the dest, and recalculate tmps in case the buffer
3298 * got reallocated; curlen may also have been changed */
3299 sv_utf8_upgrade_nomg(sv);
3300 tmps = SvPV_nomg(sv, curlen);
3303 else if (DO_UTF8(sv))
3304 repl_need_utf8_upgrade = TRUE;
3306 else tmps = SvPV_const(sv, curlen);
3308 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3309 if (utf8_curlen == curlen)
3312 curlen = utf8_curlen;
3318 STRLEN pos, len, byte_len, byte_pos;
3320 if (!translate_substr_offsets(
3321 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3325 byte_pos = utf8_curlen
3326 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3331 SvTAINTED_off(TARG); /* decontaminate */
3332 SvUTF8_off(TARG); /* decontaminate */
3333 sv_setpvn(TARG, tmps, byte_len);
3334 #ifdef USE_LOCALE_COLLATE
3335 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3342 SV* repl_sv_copy = NULL;
3344 if (repl_need_utf8_upgrade) {
3345 repl_sv_copy = newSVsv(repl_sv);
3346 sv_utf8_upgrade(repl_sv_copy);
3347 repl = SvPV_const(repl_sv_copy, repl_len);
3351 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3352 SvREFCNT_dec(repl_sv_copy);
3355 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3365 Perl_croak(aTHX_ "substr outside of string");
3366 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3373 const IV size = POPi;
3374 SV* offsetsv = POPs;
3375 SV * const src = POPs;
3376 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3382 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3383 * or flag that its out of range */
3385 IV iv = SvIV(offsetsv);
3387 /* avoid a large UV being wrapped to a negative value */
3388 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3389 errflags = LVf_OUT_OF_RANGE;
3391 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3392 #if PTRSIZE < IVSIZE
3393 else if (iv > Size_t_MAX)
3394 errflags = LVf_OUT_OF_RANGE;
3397 offset = (STRLEN)iv;
3400 retuv = errflags ? 0 : do_vecget(src, offset, size);
3402 if (lvalue) { /* it's an lvalue! */
3403 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3404 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3406 LvTARG(ret) = SvREFCNT_inc_simple(src);
3407 LvTARGOFF(ret) = offset;
3408 LvTARGLEN(ret) = size;
3409 LvFLAGS(ret) = errflags;
3413 SvTAINTED_off(TARG); /* decontaminate */
3417 sv_setuv(ret, retuv);
3425 /* also used for: pp_rindex() */
3438 const char *little_p;
3441 const bool is_index = PL_op->op_type == OP_INDEX;
3442 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3448 big_p = SvPV_const(big, biglen);
3449 little_p = SvPV_const(little, llen);
3451 big_utf8 = DO_UTF8(big);
3452 little_utf8 = DO_UTF8(little);
3453 if (big_utf8 ^ little_utf8) {
3454 /* One needs to be upgraded. */
3456 /* Well, maybe instead we might be able to downgrade the small
3458 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3461 /* If the large string is ISO-8859-1, and it's not possible to
3462 convert the small string to ISO-8859-1, then there is no
3463 way that it could be found anywhere by index. */
3468 /* At this point, pv is a malloc()ed string. So donate it to temp
3469 to ensure it will get free()d */
3470 little = temp = newSV(0);
3471 sv_usepvn(temp, pv, llen);
3472 little_p = SvPVX(little);
3474 temp = newSVpvn(little_p, llen);
3476 sv_utf8_upgrade(temp);
3478 little_p = SvPV_const(little, llen);
3481 if (SvGAMAGIC(big)) {
3482 /* Life just becomes a lot easier if I use a temporary here.
3483 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3484 will trigger magic and overloading again, as will fbm_instr()
3486 big = newSVpvn_flags(big_p, biglen,
3487 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3490 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3491 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3492 warn on undef, and we've already triggered a warning with the
3493 SvPV_const some lines above. We can't remove that, as we need to
3494 call some SvPV to trigger overloading early and find out if the
3496 This is all getting too messy. The API isn't quite clean enough,
3497 because data access has side effects.
3499 little = newSVpvn_flags(little_p, llen,
3500 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3501 little_p = SvPVX(little);
3505 offset = is_index ? 0 : biglen;
3507 if (big_utf8 && offset > 0)
3508 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3514 else if (offset > (SSize_t)biglen)
3516 if (!(little_p = is_index
3517 ? fbm_instr((unsigned char*)big_p + offset,
3518 (unsigned char*)big_p + biglen, little, 0)
3519 : rninstr(big_p, big_p + offset,
3520 little_p, little_p + llen)))
3523 retval = little_p - big_p;
3524 if (retval > 1 && big_utf8)
3525 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3530 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3531 if (PL_op->op_private & OPpTRUEBOOL) {
3532 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3533 ? &PL_sv_yes : &PL_sv_no);
3534 if (PL_op->op_private & OPpTARGET_MY)
3535 /* $lex = (index() == -1) */
3536 sv_setsv(TARG, TOPs);
3545 dSP; dMARK; dORIGMARK; dTARGET;
3546 SvTAINTED_off(TARG);
3547 do_sprintf(TARG, SP-MARK, MARK+1);
3548 TAINT_IF(SvTAINTED(TARG));
3560 const U8 *s = (U8*)SvPV_const(argsv, len);
3563 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3577 if (UNLIKELY(SvAMAGIC(top)))
3579 if (UNLIKELY(isinfnansv(top)))
3580 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3582 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3583 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3585 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3586 && SvNV_nomg(top) < 0.0)))
3588 if (ckWARN(WARN_UTF8)) {
3589 if (SvGMAGICAL(top)) {
3590 SV *top2 = sv_newmortal();
3591 sv_setsv_nomg(top2, top);
3594 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3595 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3597 value = UNICODE_REPLACEMENT;
3599 value = SvUV_nomg(top);
3603 SvUPGRADE(TARG,SVt_PV);
3605 if (value > 255 && !IN_BYTES) {
3606 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3607 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3608 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3610 (void)SvPOK_only(TARG);
3619 *tmps++ = (char)value;
3621 (void)SvPOK_only(TARG);
3633 const char *tmps = SvPV_const(left, len);
3635 if (DO_UTF8(left)) {
3636 /* If Unicode, try to downgrade.
3637 * If not possible, croak.
3638 * Yes, we made this up. */
3639 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3641 sv_utf8_downgrade(tsv, FALSE);
3642 tmps = SvPV_const(tsv, len);
3644 # ifdef USE_ITHREADS
3646 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3647 /* This should be threadsafe because in ithreads there is only
3648 * one thread per interpreter. If this would not be true,
3649 * we would need a mutex to protect this malloc. */
3650 PL_reentrant_buffer->_crypt_struct_buffer =
3651 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3652 #if defined(__GLIBC__) || defined(__EMX__)
3653 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3654 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3655 /* work around glibc-2.2.5 bug */
3656 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3660 # endif /* HAS_CRYPT_R */
3661 # endif /* USE_ITHREADS */
3663 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3665 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3672 "The crypt() function is unimplemented due to excessive paranoia.");
3676 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3677 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3680 /* also used for: pp_lcfirst() */
3684 /* Actually is both lcfirst() and ucfirst(). Only the first character
3685 * changes. This means that possibly we can change in-place, ie., just
3686 * take the source and change that one character and store it back, but not
3687 * if read-only etc, or if the length changes */
3691 STRLEN slen; /* slen is the byte length of the whole SV. */
3694 bool inplace; /* ? Convert first char only, in-place */
3695 bool doing_utf8 = FALSE; /* ? using utf8 */
3696 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3697 const int op_type = PL_op->op_type;
3700 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3701 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3702 * stored as UTF-8 at s. */
3703 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3704 * lowercased) character stored in tmpbuf. May be either
3705 * UTF-8 or not, but in either case is the number of bytes */
3707 s = (const U8*)SvPV_const(source, slen);
3709 /* We may be able to get away with changing only the first character, in
3710 * place, but not if read-only, etc. Later we may discover more reasons to
3711 * not convert in-place. */
3712 inplace = !SvREADONLY(source) && SvPADTMP(source);
3714 #ifdef USE_LOCALE_CTYPE
3716 if (IN_LC_RUNTIME(LC_CTYPE)) {
3717 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3722 /* First calculate what the changed first character should be. This affects
3723 * whether we can just swap it out, leaving the rest of the string unchanged,
3724 * or even if have to convert the dest to UTF-8 when the source isn't */
3726 if (! slen) { /* If empty */
3727 need = 1; /* still need a trailing NUL */
3730 else if (DO_UTF8(source)) { /* Is the source utf8? */
3733 if (op_type == OP_UCFIRST) {
3734 #ifdef USE_LOCALE_CTYPE
3735 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3737 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3741 #ifdef USE_LOCALE_CTYPE
3742 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3744 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3748 /* we can't do in-place if the length changes. */
3749 if (ulen != tculen) inplace = FALSE;
3750 need = slen + 1 - ulen + tculen;
3752 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3753 * latin1 is treated as caseless. Note that a locale takes
3755 ulen = 1; /* Original character is 1 byte */
3756 tculen = 1; /* Most characters will require one byte, but this will
3757 * need to be overridden for the tricky ones */
3760 if (op_type == OP_LCFIRST) {
3762 /* lower case the first letter: no trickiness for any character */
3763 #ifdef USE_LOCALE_CTYPE
3764 if (IN_LC_RUNTIME(LC_CTYPE)) {
3765 *tmpbuf = toLOWER_LC(*s);
3770 *tmpbuf = (IN_UNI_8_BIT)
3771 ? toLOWER_LATIN1(*s)
3775 #ifdef USE_LOCALE_CTYPE
3777 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3778 if (IN_UTF8_CTYPE_LOCALE) {
3782 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3783 locales have upper and title case
3787 else if (! IN_UNI_8_BIT) {
3788 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3789 * on EBCDIC machines whatever the
3790 * native function does */
3793 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3794 * UTF-8, which we treat as not in locale), and cased latin1 */
3796 #ifdef USE_LOCALE_CTYPE
3800 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3802 assert(tculen == 2);
3804 /* If the result is an upper Latin1-range character, it can
3805 * still be represented in one byte, which is its ordinal */
3806 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3807 *tmpbuf = (U8) title_ord;
3811 /* Otherwise it became more than one ASCII character (in
3812 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3813 * beyond Latin1, so the number of bytes changed, so can't
3814 * replace just the first character in place. */
3817 /* If the result won't fit in a byte, the entire result
3818 * will have to be in UTF-8. Assume worst case sizing in
3819 * conversion. (all latin1 characters occupy at most two
3821 if (title_ord > 255) {
3823 convert_source_to_utf8 = TRUE;
3824 need = slen * 2 + 1;
3826 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3827 * (both) characters whose title case is above 255 is
3831 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3832 need = slen + 1 + 1;
3836 } /* End of use Unicode (Latin1) semantics */
3837 } /* End of changing the case of the first character */
3839 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3840 * generate the result */
3843 /* We can convert in place. This means we change just the first
3844 * character without disturbing the rest; no need to grow */
3846 s = d = (U8*)SvPV_force_nomg(source, slen);
3852 /* Here, we can't convert in place; we earlier calculated how much
3853 * space we will need, so grow to accommodate that */
3854 SvUPGRADE(dest, SVt_PV);
3855 d = (U8*)SvGROW(dest, need);
3856 (void)SvPOK_only(dest);
3863 if (! convert_source_to_utf8) {
3865 /* Here both source and dest are in UTF-8, but have to create
3866 * the entire output. We initialize the result to be the
3867 * title/lower cased first character, and then append the rest
3869 sv_setpvn(dest, (char*)tmpbuf, tculen);
3871 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3875 const U8 *const send = s + slen;
3877 /* Here the dest needs to be in UTF-8, but the source isn't,
3878 * except we earlier UTF-8'd the first character of the source
3879 * into tmpbuf. First put that into dest, and then append the
3880 * rest of the source, converting it to UTF-8 as we go. */
3882 /* Assert tculen is 2 here because the only two characters that
3883 * get to this part of the code have 2-byte UTF-8 equivalents */
3885 *d++ = *(tmpbuf + 1);
3886 s++; /* We have just processed the 1st char */
3888 for (; s < send; s++) {
3889 d = uvchr_to_utf8(d, *s);
3892 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3896 else { /* in-place UTF-8. Just overwrite the first character */
3897 Copy(tmpbuf, d, tculen, U8);
3898 SvCUR_set(dest, need - 1);
3902 else { /* Neither source nor dest are in or need to be UTF-8 */
3904 if (inplace) { /* in-place, only need to change the 1st char */
3907 else { /* Not in-place */
3909 /* Copy the case-changed character(s) from tmpbuf */
3910 Copy(tmpbuf, d, tculen, U8);
3911 d += tculen - 1; /* Code below expects d to point to final
3912 * character stored */
3915 else { /* empty source */
3916 /* See bug #39028: Don't taint if empty */
3920 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3921 * the destination to retain that flag */
3922 if (SvUTF8(source) && ! IN_BYTES)
3925 if (!inplace) { /* Finish the rest of the string, unchanged */
3926 /* This will copy the trailing NUL */
3927 Copy(s + 1, d + 1, slen, U8);
3928 SvCUR_set(dest, need - 1);
3931 #ifdef USE_LOCALE_CTYPE
3932 if (IN_LC_RUNTIME(LC_CTYPE)) {
3937 if (dest != source && SvTAINTED(source))
3943 /* There's so much setup/teardown code common between uc and lc, I wonder if
3944 it would be worth merging the two, and just having a switch outside each
3945 of the three tight loops. There is less and less commonality though */
3958 if ( SvPADTMP(source)
3959 && !SvREADONLY(source) && SvPOK(source)
3962 #ifdef USE_LOCALE_CTYPE
3963 (IN_LC_RUNTIME(LC_CTYPE))
3964 ? ! IN_UTF8_CTYPE_LOCALE
3970 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3971 * make the loop tight, so we overwrite the source with the dest before
3972 * looking at it, and we need to look at the original source
3973 * afterwards. There would also need to be code added to handle
3974 * switching to not in-place in midstream if we run into characters
3975 * that change the length. Since being in locale overrides UNI_8_BIT,
3976 * that latter becomes irrelevant in the above test; instead for
3977 * locale, the size can't normally change, except if the locale is a
3980 s = d = (U8*)SvPV_force_nomg(source, len);
3987 s = (const U8*)SvPV_nomg_const(source, len);
3990 SvUPGRADE(dest, SVt_PV);
3991 d = (U8*)SvGROW(dest, min);
3992 (void)SvPOK_only(dest);
3997 #ifdef USE_LOCALE_CTYPE
3999 if (IN_LC_RUNTIME(LC_CTYPE)) {
4000 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4005 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4006 to check DO_UTF8 again here. */
4008 if (DO_UTF8(source)) {
4009 const U8 *const send = s + len;
4010 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4012 /* All occurrences of these are to be moved to follow any other marks.
4013 * This is context-dependent. We may not be passed enough context to
4014 * move the iota subscript beyond all of them, but we do the best we can
4015 * with what we're given. The result is always better than if we
4016 * hadn't done this. And, the problem would only arise if we are
4017 * passed a character without all its combining marks, which would be
4018 * the caller's mistake. The information this is based on comes from a
4019 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4020 * itself) and so can't be checked properly to see if it ever gets
4021 * revised. But the likelihood of it changing is remote */
4022 bool in_iota_subscript = FALSE;
4028 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4030 /* A non-mark. Time to output the iota subscript */
4031 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4032 d += capital_iota_len;
4033 in_iota_subscript = FALSE;
4036 /* Then handle the current character. Get the changed case value
4037 * and copy it to the output buffer */
4040 #ifdef USE_LOCALE_CTYPE
4041 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4043 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4045 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4046 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4047 if (uv == GREEK_CAPITAL_LETTER_IOTA
4048 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4050 in_iota_subscript = TRUE;
4053 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4054 /* If the eventually required minimum size outgrows the
4055 * available space, we need to grow. */
4056 const UV o = d - (U8*)SvPVX_const(dest);
4058 /* If someone uppercases one million U+03B0s we SvGROW()
4059 * one million times. Or we could try guessing how much to
4060 * allocate without allocating too much. Such is life.
4061 * See corresponding comment in lc code for another option
4063 d = o + (U8*) SvGROW(dest, min);
4065 Copy(tmpbuf, d, ulen, U8);
4070 if (in_iota_subscript) {
4071 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4072 d += capital_iota_len;
4077 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4079 else { /* Not UTF-8 */
4081 const U8 *const send = s + len;
4083 /* Use locale casing if in locale; regular style if not treating
4084 * latin1 as having case; otherwise the latin1 casing. Do the
4085 * whole thing in a tight loop, for speed, */
4086 #ifdef USE_LOCALE_CTYPE
4087 if (IN_LC_RUNTIME(LC_CTYPE)) {
4088 if (IN_UTF8_CTYPE_LOCALE) {
4091 for (; s < send; d++, s++)
4092 *d = (U8) toUPPER_LC(*s);
4096 if (! IN_UNI_8_BIT) {
4097 for (; s < send; d++, s++) {
4102 #ifdef USE_LOCALE_CTYPE
4105 for (; s < send; d++, s++) {
4106 *d = toUPPER_LATIN1_MOD(*s);
4107 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4111 /* The mainstream case is the tight loop above. To avoid
4112 * extra tests in that, all three characters that require
4113 * special handling are mapped by the MOD to the one tested
4115 * Use the source to distinguish between the three cases */
4117 #if UNICODE_MAJOR_VERSION > 2 \
4118 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4119 && UNICODE_DOT_DOT_VERSION >= 8)
4120 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4122 /* uc() of this requires 2 characters, but they are
4123 * ASCII. If not enough room, grow the string */
4124 if (SvLEN(dest) < ++min) {
4125 const UV o = d - (U8*)SvPVX_const(dest);
4126 d = o + (U8*) SvGROW(dest, min);
4128 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4129 continue; /* Back to the tight loop; still in ASCII */
4133 /* The other two special handling characters have their
4134 * upper cases outside the latin1 range, hence need to be
4135 * in UTF-8, so the whole result needs to be in UTF-8. So,
4136 * here we are somewhere in the middle of processing a
4137 * non-UTF-8 string, and realize that we will have to convert
4138 * the whole thing to UTF-8. What to do? There are
4139 * several possibilities. The simplest to code is to
4140 * convert what we have so far, set a flag, and continue on
4141 * in the loop. The flag would be tested each time through
4142 * the loop, and if set, the next character would be
4143 * converted to UTF-8 and stored. But, I (khw) didn't want
4144 * to slow down the mainstream case at all for this fairly
4145 * rare case, so I didn't want to add a test that didn't
4146 * absolutely have to be there in the loop, besides the
4147 * possibility that it would get too complicated for
4148 * optimizers to deal with. Another possibility is to just
4149 * give up, convert the source to UTF-8, and restart the
4150 * function that way. Another possibility is to convert
4151 * both what has already been processed and what is yet to
4152 * come separately to UTF-8, then jump into the loop that
4153 * handles UTF-8. But the most efficient time-wise of the
4154 * ones I could think of is what follows, and turned out to
4155 * not require much extra code. */
4157 /* Convert what we have so far into UTF-8, telling the
4158 * function that we know it should be converted, and to
4159 * allow extra space for what we haven't processed yet.
4160 * Assume the worst case space requirements for converting
4161 * what we haven't processed so far: that it will require
4162 * two bytes for each remaining source character, plus the
4163 * NUL at the end. This may cause the string pointer to
4164 * move, so re-find it. */
4166 len = d - (U8*)SvPVX_const(dest);
4167 SvCUR_set(dest, len);
4168 len = sv_utf8_upgrade_flags_grow(dest,
4169 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4171 d = (U8*)SvPVX(dest) + len;
4173 /* Now process the remainder of the source, converting to
4174 * upper and UTF-8. If a resulting byte is invariant in
4175 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4176 * append it to the output. */
4177 for (; s < send; s++) {
4178 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4182 /* Here have processed the whole source; no need to continue
4183 * with the outer loop. Each character has been converted
4184 * to upper case and converted to UTF-8 */
4187 } /* End of processing all latin1-style chars */
4188 } /* End of processing all chars */
4189 } /* End of source is not empty */
4191 if (source != dest) {
4192 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4193 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4195 } /* End of isn't utf8 */
4196 #ifdef USE_LOCALE_CTYPE
4197 if (IN_LC_RUNTIME(LC_CTYPE)) {
4202 if (dest != source && SvTAINTED(source))
4220 if ( SvPADTMP(source)
4221 && !SvREADONLY(source) && SvPOK(source)
4222 && !DO_UTF8(source)) {
4224 /* We can convert in place, as lowercasing anything in the latin1 range
4225 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4227 s = d = (U8*)SvPV_force_nomg(source, len);
4234 s = (const U8*)SvPV_nomg_const(source, len);
4237 SvUPGRADE(dest, SVt_PV);
4238 d = (U8*)SvGROW(dest, min);
4239 (void)SvPOK_only(dest);
4244 #ifdef USE_LOCALE_CTYPE
4246 if (IN_LC_RUNTIME(LC_CTYPE)) {
4247 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4252 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4253 to check DO_UTF8 again here. */
4255 if (DO_UTF8(source)) {
4256 const U8 *const send = s + len;
4257 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4260 const STRLEN u = UTF8SKIP(s);
4263 #ifdef USE_LOCALE_CTYPE
4264 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4266 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4269 /* Here is where we would do context-sensitive actions. See the
4270 * commit message for 86510fb15 for why there isn't any */
4272 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4274 /* If the eventually required minimum size outgrows the
4275 * available space, we need to grow. */
4276 const UV o = d - (U8*)SvPVX_const(dest);
4278 /* If someone lowercases one million U+0130s we SvGROW() one
4279 * million times. Or we could try guessing how much to
4280 * allocate without allocating too much. Such is life.
4281 * Another option would be to grow an extra byte or two more
4282 * each time we need to grow, which would cut down the million
4283 * to 500K, with little waste */
4284 d = o + (U8*) SvGROW(dest, min);
4287 /* Copy the newly lowercased letter to the output buffer we're
4289 Copy(tmpbuf, d, ulen, U8);
4292 } /* End of looping through the source string */
4295 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4296 } else { /* Not utf8 */
4298 const U8 *const send = s + len;
4300 /* Use locale casing if in locale; regular style if not treating
4301 * latin1 as having case; otherwise the latin1 casing. Do the
4302 * whole thing in a tight loop, for speed, */
4303 #ifdef USE_LOCALE_CTYPE
4304 if (IN_LC_RUNTIME(LC_CTYPE)) {
4305 for (; s < send; d++, s++)
4306 *d = toLOWER_LC(*s);
4310 if (! IN_UNI_8_BIT) {
4311 for (; s < send; d++, s++) {
4316 for (; s < send; d++, s++) {
4317 *d = toLOWER_LATIN1(*s);
4321 if (source != dest) {
4323 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4326 #ifdef USE_LOCALE_CTYPE
4327 if (IN_LC_RUNTIME(LC_CTYPE)) {
4332 if (dest != source && SvTAINTED(source))
4341 SV * const sv = TOPs;
4343 const char *s = SvPV_const(sv,len);
4345 SvUTF8_off(TARG); /* decontaminate */
4348 SvUPGRADE(TARG, SVt_PV);
4349 SvGROW(TARG, (len * 2) + 1);
4353 STRLEN ulen = UTF8SKIP(s);
4354 bool to_quote = FALSE;
4356 if (UTF8_IS_INVARIANT(*s)) {
4357 if (_isQUOTEMETA(*s)) {
4361 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4363 #ifdef USE_LOCALE_CTYPE
4364 /* In locale, we quote all non-ASCII Latin1 chars.
4365 * Otherwise use the quoting rules */
4367 IN_LC_RUNTIME(LC_CTYPE)
4370 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4375 else if (is_QUOTEMETA_high(s)) {
4390 else if (IN_UNI_8_BIT) {
4392 if (_isQUOTEMETA(*s))
4398 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4399 * including everything above ASCII */
4401 if (!isWORDCHAR_A(*s))
4407 SvCUR_set(TARG, d - SvPVX_const(TARG));
4408 (void)SvPOK_only_UTF8(TARG);
4411 sv_setpvn(TARG, s, len);
4427 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4428 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4429 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4430 || UNICODE_DOT_DOT_VERSION > 0)
4431 const bool full_folding = TRUE; /* This variable is here so we can easily
4432 move to more generality later */
4434 const bool full_folding = FALSE;
4436 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4437 #ifdef USE_LOCALE_CTYPE
4438 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4442 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4443 * You are welcome(?) -Hugmeir
4451 s = (const U8*)SvPV_nomg_const(source, len);
4453 if (ckWARN(WARN_UNINITIALIZED))
4454 report_uninit(source);
4461 SvUPGRADE(dest, SVt_PV);
4462 d = (U8*)SvGROW(dest, min);
4463 (void)SvPOK_only(dest);
4469 #ifdef USE_LOCALE_CTYPE
4471 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4472 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4477 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4479 const STRLEN u = UTF8SKIP(s);
4482 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4484 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4485 const UV o = d - (U8*)SvPVX_const(dest);
4486 d = o + (U8*) SvGROW(dest, min);
4489 Copy(tmpbuf, d, ulen, U8);
4494 } /* Unflagged string */
4496 #ifdef USE_LOCALE_CTYPE
4497 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4498 if (IN_UTF8_CTYPE_LOCALE) {
4499 goto do_uni_folding;
4501 for (; s < send; d++, s++)
4502 *d = (U8) toFOLD_LC(*s);
4506 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4507 for (; s < send; d++, s++)
4511 #ifdef USE_LOCALE_CTYPE
4514 /* For ASCII and the Latin-1 range, there's only two troublesome
4515 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4516 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4517 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4518 * For the rest, the casefold is their lowercase. */
4519 for (; s < send; d++, s++) {
4520 if (*s == MICRO_SIGN) {
4521 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4522 * which is outside of the latin-1 range. There's a couple
4523 * of ways to deal with this -- khw discusses them in
4524 * pp_lc/uc, so go there :) What we do here is upgrade what
4525 * we had already casefolded, then enter an inner loop that
4526 * appends the rest of the characters as UTF-8. */
4527 len = d - (U8*)SvPVX_const(dest);
4528 SvCUR_set(dest, len);
4529 len = sv_utf8_upgrade_flags_grow(dest,
4530 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4531 /* The max expansion for latin1
4532 * chars is 1 byte becomes 2 */
4534 d = (U8*)SvPVX(dest) + len;
4536 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4539 for (; s < send; s++) {
4541 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4542 if UVCHR_IS_INVARIANT(fc) {
4544 && *s == LATIN_SMALL_LETTER_SHARP_S)
4553 Copy(tmpbuf, d, ulen, U8);
4559 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4560 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4561 * becomes "ss", which may require growing the SV. */
4562 if (SvLEN(dest) < ++min) {
4563 const UV o = d - (U8*)SvPVX_const(dest);
4564 d = o + (U8*) SvGROW(dest, min);
4569 else { /* If it's not one of those two, the fold is their lower
4571 *d = toLOWER_LATIN1(*s);
4577 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4579 #ifdef USE_LOCALE_CTYPE
4580 if (IN_LC_RUNTIME(LC_CTYPE)) {
4585 if (SvTAINTED(source))
4595 dSP; dMARK; dORIGMARK;
4596 AV *const av = MUTABLE_AV(POPs);
4597 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4599 if (SvTYPE(av) == SVt_PVAV) {
4600 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4601 bool can_preserve = FALSE;
4607 can_preserve = SvCANEXISTDELETE(av);
4610 if (lval && localizing) {
4613 for (svp = MARK + 1; svp <= SP; svp++) {
4614 const SSize_t elem = SvIV(*svp);
4618 if (max > AvMAX(av))
4622 while (++MARK <= SP) {
4624 SSize_t elem = SvIV(*MARK);
4625 bool preeminent = TRUE;
4627 if (localizing && can_preserve) {
4628 /* If we can determine whether the element exist,
4629 * Try to preserve the existenceness of a tied array
4630 * element by using EXISTS and DELETE if possible.
4631 * Fallback to FETCH and STORE otherwise. */
4632 preeminent = av_exists(av, elem);
4635 svp = av_fetch(av, elem, lval);
4638 DIE(aTHX_ PL_no_aelem, elem);
4641 save_aelem(av, elem, svp);
4643 SAVEADELETE(av, elem);
4646 *MARK = svp ? *svp : &PL_sv_undef;
4649 if (GIMME_V != G_ARRAY) {
4651 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4660 AV *const av = MUTABLE_AV(POPs);
4661 I32 lval = (PL_op->op_flags & OPf_MOD);
4662 SSize_t items = SP - MARK;
4664 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4665 const I32 flags = is_lvalue_sub();
4667 if (!(flags & OPpENTERSUB_INARGS))
4668 /* diag_listed_as: Can't modify %s in %s */
4669 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4676 *(MARK+items*2-1) = *(MARK+items);
4682 while (++MARK <= SP) {
4685 svp = av_fetch(av, SvIV(*MARK), lval);
4687 if (!svp || !*svp || *svp == &PL_sv_undef) {
4688 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4690 *MARK = sv_mortalcopy(*MARK);
4692 *++MARK = svp ? *svp : &PL_sv_undef;
4694 if (GIMME_V != G_ARRAY) {
4695 MARK = SP - items*2;
4696 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4706 AV *array = MUTABLE_AV(POPs);
4707 const U8 gimme = GIMME_V;
4708 IV *iterp = Perl_av_iter_p(aTHX_ array);
4709 const IV current = (*iterp)++;
4711 if (current > av_tindex(array)) {
4713 if (gimme == G_SCALAR)
4721 if (gimme == G_ARRAY) {
4722 SV **const element = av_fetch(array, current, 0);
4723 PUSHs(element ? *element : &PL_sv_undef);
4728 /* also used for: pp_avalues()*/
4732 AV *array = MUTABLE_AV(POPs);
4733 const U8 gimme = GIMME_V;
4735 *Perl_av_iter_p(aTHX_ array) = 0;
4737 if (gimme == G_SCALAR) {
4739 PUSHi(av_tindex(array) + 1);
4741 else if (gimme == G_ARRAY) {
4742 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4743 const I32 flags = is_lvalue_sub();
4744 if (flags && !(flags & OPpENTERSUB_INARGS))
4745 /* diag_listed_as: Can't modify %s in %s */
4747 "Can't modify keys on array in list assignment");
4750 IV n = Perl_av_len(aTHX_ array);
4755 if ( PL_op->op_type == OP_AKEYS
4756 || ( PL_op->op_type == OP_AVHVSWITCH
4757 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
4759 for (i = 0; i <= n; i++) {
4764 for (i = 0; i <= n; i++) {
4765 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4766 PUSHs(elem ? *elem : &PL_sv_undef);
4774 /* Associative arrays. */
4779 HV * hash = MUTABLE_HV(POPs);
4781 const U8 gimme = GIMME_V;
4783 entry = hv_iternext(hash);
4787 SV* const sv = hv_iterkeysv(entry);
4789 if (gimme == G_ARRAY) {
4791 val = hv_iterval(hash, entry);
4795 else if (gimme == G_SCALAR)
4802 S_do_delete_local(pTHX)
4805 const U8 gimme = GIMME_V;
4808 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4809 SV **unsliced_keysv = sliced ? NULL : sp--;
4810 SV * const osv = POPs;
4811 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4813 const bool tied = SvRMAGICAL(osv)
4814 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4815 const bool can_preserve = SvCANEXISTDELETE(osv);
4816 const U32 type = SvTYPE(osv);
4817 SV ** const end = sliced ? SP : unsliced_keysv;
4819 if (type == SVt_PVHV) { /* hash element */
4820 HV * const hv = MUTABLE_HV(osv);
4821 while (++MARK <= end) {
4822 SV * const keysv = *MARK;
4824 bool preeminent = TRUE;
4826 preeminent = hv_exists_ent(hv, keysv, 0);
4828 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4835 sv = hv_delete_ent(hv, keysv, 0, 0);
4837 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4840 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4841 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4843 *MARK = sv_mortalcopy(sv);
4849 SAVEHDELETE(hv, keysv);
4850 *MARK = &PL_sv_undef;
4854 else if (type == SVt_PVAV) { /* array element */
4855 if (PL_op->op_flags & OPf_SPECIAL) {
4856 AV * const av = MUTABLE_AV(osv);
4857 while (++MARK <= end) {
4858 SSize_t idx = SvIV(*MARK);
4860 bool preeminent = TRUE;
4862 preeminent = av_exists(av, idx);
4864 SV **svp = av_fetch(av, idx, 1);
4871 sv = av_delete(av, idx, 0);
4873 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4876 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4878 *MARK = sv_mortalcopy(sv);
4884 SAVEADELETE(av, idx);
4885 *MARK = &PL_sv_undef;
4890 DIE(aTHX_ "panic: avhv_delete no longer supported");
4893 DIE(aTHX_ "Not a HASH reference");
4895 if (gimme == G_VOID)
4897 else if (gimme == G_SCALAR) {
4902 *++MARK = &PL_sv_undef;
4906 else if (gimme != G_VOID)
4907 PUSHs(*unsliced_keysv);
4918 if (PL_op->op_private & OPpLVAL_INTRO)
4919 return do_delete_local();
4922 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4924 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
4926 HV * const hv = MUTABLE_HV(POPs);
4927 const U32 hvtype = SvTYPE(hv);
4929 if (PL_op->op_private & OPpKVSLICE) {
4930 SSize_t items = SP - MARK;
4934 *(MARK+items*2-1) = *(MARK+items);
4941 if (hvtype == SVt_PVHV) { /* hash element */
4942 while ((MARK += (1+skip)) <= SP) {
4943 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
4944 *MARK = sv ? sv : &PL_sv_undef;
4947 else if (hvtype == SVt_PVAV) { /* array element */
4948 if (PL_op->op_flags & OPf_SPECIAL) {
4949 while ((MARK += (1+skip)) <= SP) {
4950 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
4951 *MARK = sv ? sv : &PL_sv_undef;
4956 DIE(aTHX_ "Not a HASH reference");
4959 else if (gimme == G_SCALAR) {
4964 *++MARK = &PL_sv_undef;
4970 HV * const hv = MUTABLE_HV(POPs);
4972 if (SvTYPE(hv) == SVt_PVHV)
4973 sv = hv_delete_ent(hv, keysv, discard, 0);
4974 else if (SvTYPE(hv) == SVt_PVAV) {
4975 if (PL_op->op_flags & OPf_SPECIAL)
4976 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4978 DIE(aTHX_ "panic: avhv_delete no longer supported");
4981 DIE(aTHX_ "Not a HASH reference");
4996 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4998 SV * const sv = POPs;
4999 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5002 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5007 hv = MUTABLE_HV(POPs);
5008 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5009 if (hv_exists_ent(hv, tmpsv, 0))
5012 else if (SvTYPE(hv) == SVt_PVAV) {
5013 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5014 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5019 DIE(aTHX_ "Not a HASH reference");
5026 dSP; dMARK; dORIGMARK;
5027 HV * const hv = MUTABLE_HV(POPs);
5028 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5029 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5030 bool can_preserve = FALSE;
5036 if (SvCANEXISTDELETE(hv))
5037 can_preserve = TRUE;
5040 while (++MARK <= SP) {
5041 SV * const keysv = *MARK;
5044 bool preeminent = TRUE;
5046 if (localizing && can_preserve) {
5047 /* If we can determine whether the element exist,
5048 * try to preserve the existenceness of a tied hash
5049 * element by using EXISTS and DELETE if possible.
5050 * Fallback to FETCH and STORE otherwise. */
5051 preeminent = hv_exists_ent(hv, keysv, 0);
5054 he = hv_fetch_ent(hv, keysv, lval, 0);
5055 svp = he ? &HeVAL(he) : NULL;
5058 if (!svp || !*svp || *svp == &PL_sv_undef) {
5059 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5062 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5063 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5064 else if (preeminent)
5065 save_helem_flags(hv, keysv, svp,
5066 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5068 SAVEHDELETE(hv, keysv);
5071 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5073 if (GIMME_V != G_ARRAY) {
5075 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5084 HV * const hv = MUTABLE_HV(POPs);
5085 I32 lval = (PL_op->op_flags & OPf_MOD);
5086 SSize_t items = SP - MARK;
5088 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5089 const I32 flags = is_lvalue_sub();
5091 if (!(flags & OPpENTERSUB_INARGS))
5092 /* diag_listed_as: Can't modify %s in %s */
5093 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5094 GIMME_V == G_ARRAY ? "list" : "scalar");
5101 *(MARK+items*2-1) = *(MARK+items);
5107 while (++MARK <= SP) {
5108 SV * const keysv = *MARK;
5112 he = hv_fetch_ent(hv, keysv, lval, 0);
5113 svp = he ? &HeVAL(he) : NULL;
5116 if (!svp || !*svp || *svp == &PL_sv_undef) {
5117 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5119 *MARK = sv_mortalcopy(*MARK);
5121 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5123 if (GIMME_V != G_ARRAY) {
5124 MARK = SP - items*2;
5125 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5131 /* List operators. */
5135 I32 markidx = POPMARK;
5136 if (GIMME_V != G_ARRAY) {
5137 /* don't initialize mark here, EXTEND() may move the stack */
5140 EXTEND(SP, 1); /* in case no arguments, as in @empty */
5141 mark = PL_stack_base + markidx;
5143 *MARK = *SP; /* unwanted list, return last item */
5145 *MARK = &PL_sv_undef;
5155 SV ** const lastrelem = PL_stack_sp;
5156 SV ** const lastlelem = PL_stack_base + POPMARK;
5157 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5158 SV ** const firstrelem = lastlelem + 1;
5159 const U8 mod = PL_op->op_flags & OPf_MOD;
5161 const I32 max = lastrelem - lastlelem;
5164 if (GIMME_V != G_ARRAY) {
5165 if (lastlelem < firstlelem) {
5167 *firstlelem = &PL_sv_undef;
5170 I32 ix = SvIV(*lastlelem);
5173 if (ix < 0 || ix >= max)
5174 *firstlelem = &PL_sv_undef;
5176 *firstlelem = firstrelem[ix];
5183 SP = firstlelem - 1;
5187 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5188 I32 ix = SvIV(*lelem);
5191 if (ix < 0 || ix >= max)
5192 *lelem = &PL_sv_undef;
5194 if (!(*lelem = firstrelem[ix]))
5195 *lelem = &PL_sv_undef;
5196 else if (mod && SvPADTMP(*lelem)) {
5197 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5208 const I32 items = SP - MARK;
5209 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5211 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5212 ? newRV_noinc(av) : av);
5218 dSP; dMARK; dORIGMARK;
5219 HV* const hv = newHV();
5220 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5221 ? newRV_noinc(MUTABLE_SV(hv))
5226 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5233 sv_setsv_nomg(val, *MARK);
5237 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5240 (void)hv_store_ent(hv,key,val,0);
5249 dSP; dMARK; dORIGMARK;
5250 int num_args = (SP - MARK);
5251 AV *ary = MUTABLE_AV(*++MARK);
5260 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5263 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5264 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5268 if (SvREADONLY(ary))
5269 Perl_croak_no_modify();
5274 offset = i = SvIV(*MARK);
5276 offset += AvFILLp(ary) + 1;
5278 DIE(aTHX_ PL_no_aelem, i);
5280 length = SvIVx(*MARK++);
5282 length += AvFILLp(ary) - offset + 1;
5288 length = AvMAX(ary) + 1; /* close enough to infinity */
5292 length = AvMAX(ary) + 1;
5294 if (offset > AvFILLp(ary) + 1) {
5296 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5297 offset = AvFILLp(ary) + 1;
5299 after = AvFILLp(ary) + 1 - (offset + length);
5300 if (after < 0) { /* not that much array */
5301 length += after; /* offset+length now in array */
5307 /* At this point, MARK .. SP-1 is our new LIST */
5310 diff = newlen - length;
5311 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5314 /* make new elements SVs now: avoid problems if they're from the array */
5315 for (dst = MARK, i = newlen; i; i--) {
5316 SV * const h = *dst;
5317 *dst++ = newSVsv(h);
5320 if (diff < 0) { /* shrinking the area */
5321 SV **tmparyval = NULL;
5323 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5324 Copy(MARK, tmparyval, newlen, SV*);
5327 MARK = ORIGMARK + 1;
5328 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5329 const bool real = cBOOL(AvREAL(ary));
5330 MEXTEND(MARK, length);
5332 EXTEND_MORTAL(length);
5333 for (i = 0, dst = MARK; i < length; i++) {
5334 if ((*dst = AvARRAY(ary)[i+offset])) {
5336 sv_2mortal(*dst); /* free them eventually */
5339 *dst = &PL_sv_undef;
5345 *MARK = AvARRAY(ary)[offset+length-1];
5348 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5349 SvREFCNT_dec(*dst++); /* free them now */
5352 *MARK = &PL_sv_undef;
5354 AvFILLp(ary) += diff;
5356 /* pull up or down? */
5358 if (offset < after) { /* easier to pull up */
5359 if (offset) { /* esp. if nothing to pull */
5360 src = &AvARRAY(ary)[offset-1];
5361 dst = src - diff; /* diff is negative */
5362 for (i = offset; i > 0; i--) /* can't trust Copy */
5366 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5370 if (after) { /* anything to pull down? */
5371 src = AvARRAY(ary) + offset + length;
5372 dst = src + diff; /* diff is negative */
5373 Move(src, dst, after, SV*);
5375 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5376 /* avoid later double free */
5383 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5384 Safefree(tmparyval);
5387 else { /* no, expanding (or same) */
5388 SV** tmparyval = NULL;
5390 Newx(tmparyval, length, SV*); /* so remember deletion */
5391 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5394 if (diff > 0) { /* expanding */
5395 /* push up or down? */
5396 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5400 Move(src, dst, offset, SV*);
5402 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5404 AvFILLp(ary) += diff;
5407 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5408 av_extend(ary, AvFILLp(ary) + diff);
5409 AvFILLp(ary) += diff;
5412 dst = AvARRAY(ary) + AvFILLp(ary);
5414 for (i = after; i; i--) {
5422 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5425 MARK = ORIGMARK + 1;
5426 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5428 const bool real = cBOOL(AvREAL(ary));
5430 EXTEND_MORTAL(length);
5431 for (i = 0, dst = MARK; i < length; i++) {
5432 if ((*dst = tmparyval[i])) {
5434 sv_2mortal(*dst); /* free them eventually */
5436 else *dst = &PL_sv_undef;
5442 else if (length--) {
5443 *MARK = tmparyval[length];
5446 while (length-- > 0)
5447 SvREFCNT_dec(tmparyval[length]);
5450 *MARK = &PL_sv_undef;
5453 *MARK = &PL_sv_undef;
5454 Safefree(tmparyval);
5458 mg_set(MUTABLE_SV(ary));
5466 dSP; dMARK; dORIGMARK; dTARGET;
5467 AV * const ary = MUTABLE_AV(*++MARK);
5468 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5471 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5474 ENTER_with_name("call_PUSH");
5475 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5476 LEAVE_with_name("call_PUSH");
5477 /* SPAGAIN; not needed: SP is assigned to immediately below */
5480 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5481 * only need to save locally, not on the save stack */
5482 U16 old_delaymagic = PL_delaymagic;
5484 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5485 PL_delaymagic = DM_DELAY;
5486 for (++MARK; MARK <= SP; MARK++) {
5488 if (*MARK) SvGETMAGIC(*MARK);
5491 sv_setsv_nomg(sv, *MARK);
5492 av_store(ary, AvFILLp(ary)+1, sv);
5494 if (PL_delaymagic & DM_ARRAY_ISA)
5495 mg_set(MUTABLE_SV(ary));
5496 PL_delaymagic = old_delaymagic;
5499 if (OP_GIMME(PL_op, 0) != G_VOID) {
5500 PUSHi( AvFILL(ary) + 1 );
5505 /* also used for: pp_pop()*/
5509 AV * const av = PL_op->op_flags & OPf_SPECIAL
5510 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5511 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5515 (void)sv_2mortal(sv);
5522 dSP; dMARK; dORIGMARK; dTARGET;
5523 AV *ary = MUTABLE_AV(*++MARK);
5524 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5527 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5530 ENTER_with_name("call_UNSHIFT");
5531 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5532 LEAVE_with_name("call_UNSHIFT");
5533 /* SPAGAIN; not needed: SP is assigned to immediately below */
5536 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5537 * only need to save locally, not on the save stack */
5538 U16 old_delaymagic = PL_delaymagic;
5541 av_unshift(ary, SP - MARK);
5542 PL_delaymagic = DM_DELAY;
5544 SV * const sv = newSVsv(*++MARK);
5545 (void)av_store(ary, i++, sv);
5547 if (PL_delaymagic & DM_ARRAY_ISA)
5548 mg_set(MUTABLE_SV(ary));
5549 PL_delaymagic = old_delaymagic;
5552 if (OP_GIMME(PL_op, 0) != G_VOID) {
5553 PUSHi( AvFILL(ary) + 1 );
5562 if (GIMME_V == G_ARRAY) {
5563 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5567 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5568 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5569 av = MUTABLE_AV((*SP));
5570 /* In-place reversing only happens in void context for the array
5571 * assignment. We don't need to push anything on the stack. */
5574 if (SvMAGICAL(av)) {
5576 SV *tmp = sv_newmortal();
5577 /* For SvCANEXISTDELETE */
5580 bool can_preserve = SvCANEXISTDELETE(av);
5582 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5586 if (!av_exists(av, i)) {
5587 if (av_exists(av, j)) {
5588 SV *sv = av_delete(av, j, 0);
5589 begin = *av_fetch(av, i, TRUE);
5590 sv_setsv_mg(begin, sv);
5594 else if (!av_exists(av, j)) {
5595 SV *sv = av_delete(av, i, 0);
5596 end = *av_fetch(av, j, TRUE);
5597 sv_setsv_mg(end, sv);
5602 begin = *av_fetch(av, i, TRUE);
5603 end = *av_fetch(av, j, TRUE);
5604 sv_setsv(tmp, begin);
5605 sv_setsv_mg(begin, end);
5606 sv_setsv_mg(end, tmp);
5610 SV **begin = AvARRAY(av);
5613 SV **end = begin + AvFILLp(av);
5615 while (begin < end) {
5616 SV * const tmp = *begin;
5620 if (tmp && SvWEAKREF(tmp))
5624 /* make sure we catch the middle element */
5625 if (begin == end && *begin && SvWEAKREF(*begin))
5626 sv_rvunweaken(*begin);
5634 SV * const tmp = *MARK;
5638 /* safe as long as stack cannot get extended in the above */
5647 SvUTF8_off(TARG); /* decontaminate */
5648 if (SP - MARK > 1) {
5649 do_join(TARG, &PL_sv_no, MARK, SP);
5652 } else if (SP > MARK) {
5653 sv_setsv(TARG, *SP);
5656 sv_setsv(TARG, DEFSV);
5660 up = SvPV_force(TARG, len);
5663 if (DO_UTF8(TARG)) { /* first reverse each character */
5664 U8* s = (U8*)SvPVX(TARG);
5665 const U8* send = (U8*)(s + len);
5667 if (UTF8_IS_INVARIANT(*s)) {
5672 if (!utf8_to_uvchr_buf(s, send, 0))
5676 down = (char*)(s - 1);
5677 /* reverse this character */
5679 const char tmp = *up;
5687 down = SvPVX(TARG) + len - 1;
5689 const char tmp = *up;
5693 (void)SvPOK_only_UTF8(TARG);
5702 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5703 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
5704 ? (AV *)POPs : NULL;
5705 IV limit = POPi; /* note, negative is forever */
5706 SV * const sv = POPs;
5708 const char *s = SvPV_const(sv, len);
5709 const bool do_utf8 = DO_UTF8(sv);
5710 const bool in_uni_8_bit = IN_UNI_8_BIT;
5711 const char *strend = s + len;
5712 PMOP *pm = cPMOPx(PL_op);
5717 const STRLEN slen = do_utf8
5718 ? utf8_length((U8*)s, (U8*)strend)
5719 : (STRLEN)(strend - s);
5720 SSize_t maxiters = slen + 10;
5721 I32 trailing_empty = 0;
5723 const IV origlimit = limit;
5726 const U8 gimme = GIMME_V;
5728 I32 oldsave = PL_savestack_ix;
5729 U32 make_mortal = SVs_TEMP;
5735 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5736 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5738 /* handle @ary = split(...) optimisation */
5739 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5740 if (!(PL_op->op_flags & OPf_STACKED)) {
5741 if (PL_op->op_private & OPpSPLIT_LEX) {
5742 if (PL_op->op_private & OPpLVAL_INTRO)
5743 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5744 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5749 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5751 pm->op_pmreplrootu.op_pmtargetgv;
5753 if (PL_op->op_private & OPpLVAL_INTRO)
5758 /* skip anything pushed by OPpLVAL_INTRO above */
5759 oldsave = PL_savestack_ix;
5765 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5768 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5770 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5777 for (i = AvFILLp(ary); i >= 0; i--)
5778 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5780 /* temporarily switch stacks */
5781 SAVESWITCHSTACK(PL_curstack, ary);
5786 base = SP - PL_stack_base;
5788 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5790 while (s < strend && isSPACE_utf8_safe(s, strend))
5793 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5794 while (s < strend && isSPACE_LC(*s))
5797 else if (in_uni_8_bit) {
5798 while (s < strend && isSPACE_L1(*s))
5802 while (s < strend && isSPACE(*s))
5806 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5810 gimme_scalar = gimme == G_SCALAR && !ary;
5813 limit = maxiters + 2;
5814 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5817 /* this one uses 'm' and is a negative test */
5819 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
5820 const int t = UTF8SKIP(m);
5821 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
5828 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5830 while (m < strend && !isSPACE_LC(*m))
5833 else if (in_uni_8_bit) {
5834 while (m < strend && !isSPACE_L1(*m))
5837 while (m < strend && !isSPACE(*m))
5850 dstr = newSVpvn_flags(s, m-s,
5851 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5855 /* skip the whitespace found last */
5857 s = m + UTF8SKIP(m);
5861 /* this one uses 's' and is a positive test */
5863 while (s < strend && isSPACE_utf8_safe(s, strend) )
5866 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5868 while (s < strend && isSPACE_LC(*s))
5871 else if (in_uni_8_bit) {
5872 while (s < strend && isSPACE_L1(*s))
5875 while (s < strend && isSPACE(*s))
5880 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5882 for (m = s; m < strend && *m != '\n'; m++)
5895 dstr = newSVpvn_flags(s, m-s,
5896 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5902 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5904 Pre-extend the stack, either the number of bytes or
5905 characters in the string or a limited amount, triggered by:
5907 my ($x, $y) = split //, $str;
5911 if (!gimme_scalar) {
5912 const IV items = limit - 1;
5913 /* setting it to -1 will trigger a panic in EXTEND() */
5914 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
5915 if (items >=0 && items < sslen)
5923 /* keep track of how many bytes we skip over */
5933 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5946 dstr = newSVpvn(s, 1);
5962 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5963 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5964 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5965 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5966 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5967 SV * const csv = CALLREG_INTUIT_STRING(rx);
5969 len = RX_MINLENRET(rx);
5970 if (len == 1 && !RX_UTF8(rx) && !tail) {
5971 const char c = *SvPV_nolen_const(csv);
5973 for (m = s; m < strend && *m != c; m++)
5984 dstr = newSVpvn_flags(s, m-s,
5985 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5988 /* The rx->minlen is in characters but we want to step
5989 * s ahead by bytes. */
5991 s = (char*)utf8_hop((U8*)m, len);
5993 s = m + len; /* Fake \n at the end */
5997 while (s < strend && --limit &&
5998 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5999 csv, multiline ? FBMrf_MULTILINE : 0)) )
6008 dstr = newSVpvn_flags(s, m-s,
6009 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6012 /* The rx->minlen is in characters but we want to step
6013 * s ahead by bytes. */
6015 s = (char*)utf8_hop((U8*)m, len);
6017 s = m + len; /* Fake \n at the end */
6022 maxiters += slen * RX_NPARENS(rx);
6023 while (s < strend && --limit)
6027 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6030 if (rex_return == 0)
6032 TAINT_IF(RX_MATCH_TAINTED(rx));
6033 /* we never pass the REXEC_COPY_STR flag, so it should
6034 * never get copied */
6035 assert(!RX_MATCH_COPIED(rx));
6036 m = RX_OFFS(rx)[0].start + orig;
6045 dstr = newSVpvn_flags(s, m-s,
6046 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6049 if (RX_NPARENS(rx)) {
6051 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6052 s = RX_OFFS(rx)[i].start + orig;
6053 m = RX_OFFS(rx)[i].end + orig;
6055 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6056 parens that didn't match -- they should be set to
6057 undef, not the empty string */
6065 if (m >= orig && s >= orig) {
6066 dstr = newSVpvn_flags(s, m-s,
6067 (do_utf8 ? SVf_UTF8 : 0)
6071 dstr = &PL_sv_undef; /* undef, not "" */
6077 s = RX_OFFS(rx)[0].end + orig;
6081 if (!gimme_scalar) {
6082 iters = (SP - PL_stack_base) - base;
6084 if (iters > maxiters)
6085 DIE(aTHX_ "Split loop");
6087 /* keep field after final delim? */
6088 if (s < strend || (iters && origlimit)) {
6089 if (!gimme_scalar) {
6090 const STRLEN l = strend - s;
6091 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6096 else if (!origlimit) {
6098 iters -= trailing_empty;
6100 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6101 if (TOPs && !make_mortal)
6110 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6114 if (SvSMAGICAL(ary)) {
6116 mg_set(MUTABLE_SV(ary));
6119 if (gimme == G_ARRAY) {
6121 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6128 ENTER_with_name("call_PUSH");
6129 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6130 LEAVE_with_name("call_PUSH");
6132 if (gimme == G_ARRAY) {
6134 /* EXTEND should not be needed - we just popped them */
6136 for (i=0; i < iters; i++) {
6137 SV **svp = av_fetch(ary, i, FALSE);
6138 PUSHs((svp) ? *svp : &PL_sv_undef);
6145 if (gimme == G_ARRAY)
6157 SV *const sv = PAD_SVl(PL_op->op_targ);
6159 if (SvPADSTALE(sv)) {
6162 RETURNOP(cLOGOP->op_other);
6164 RETURNOP(cLOGOP->op_next);
6173 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6174 || SvTYPE(retsv) == SVt_PVCV) {
6175 retsv = refto(retsv);
6182 /* used for: pp_padany(), pp_custom(); plus any system ops
6183 * that aren't implemented on a particular platform */
6185 PP(unimplemented_op)
6187 const Optype op_type = PL_op->op_type;
6188 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6189 with out of range op numbers - it only "special" cases op_custom.
6190 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6191 if we get here for a custom op then that means that the custom op didn't
6192 have an implementation. Given that OP_NAME() looks up the custom op
6193 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6194 registers &PL_unimplemented_op as the address of their custom op.
6195 NULL doesn't generate a useful error message. "custom" does. */
6196 const char *const name = op_type >= OP_max
6197 ? "[out of range]" : PL_op_name[PL_op->op_type];
6198 if(OP_IS_SOCKET(op_type))
6199 DIE(aTHX_ PL_no_sock_func, name);
6200 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6204 S_maybe_unwind_defav(pTHX)
6206 if (CX_CUR()->cx_type & CXp_HASARGS) {
6207 PERL_CONTEXT *cx = CX_CUR();
6209 assert(CxHASARGS(cx));
6211 cx->cx_type &= ~CXp_HASARGS;
6215 /* For sorting out arguments passed to a &CORE:: subroutine */
6219 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6220 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6221 AV * const at_ = GvAV(PL_defgv);
6222 SV **svp = at_ ? AvARRAY(at_) : NULL;
6223 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6224 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6225 bool seen_question = 0;
6226 const char *err = NULL;
6227 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6229 /* Count how many args there are first, to get some idea how far to
6230 extend the stack. */
6232 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6234 if (oa & OA_OPTIONAL) seen_question = 1;
6235 if (!seen_question) minargs++;
6239 if(numargs < minargs) err = "Not enough";
6240 else if(numargs > maxargs) err = "Too many";
6242 /* diag_listed_as: Too many arguments for %s */
6244 "%s arguments for %s", err,
6245 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6248 /* Reset the stack pointer. Without this, we end up returning our own
6249 arguments in list context, in addition to the values we are supposed
6250 to return. nextstate usually does this on sub entry, but we need
6251 to run the next op with the caller's hints, so we cannot have a
6253 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6255 if(!maxargs) RETURN;
6257 /* We do this here, rather than with a separate pushmark op, as it has
6258 to come in between two things this function does (stack reset and
6259 arg pushing). This seems the easiest way to do it. */
6262 (void)Perl_pp_pushmark(aTHX);
6265 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6266 PUTBACK; /* The code below can die in various places. */
6268 oa = PL_opargs[opnum] >> OASHIFT;
6269 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6274 if (!numargs && defgv && whicharg == minargs + 1) {
6277 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6281 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6288 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6291 S_maybe_unwind_defav(aTHX);
6294 PUSHs((SV *)GvAVn(gv));
6297 if (!svp || !*svp || !SvROK(*svp)
6298 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6300 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6301 "Type of arg %d to &CORE::%s must be array reference",
6302 whicharg, PL_op_desc[opnum]
6307 if (!svp || !*svp || !SvROK(*svp)
6308 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6309 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6310 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6312 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6313 "Type of arg %d to &CORE::%s must be hash%s reference",
6314 whicharg, PL_op_desc[opnum],
6315 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6322 if (!numargs) PUSHs(NULL);
6323 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6324 /* no magic here, as the prototype will have added an extra
6325 refgen and we just want what was there before that */
6328 const bool constr = PL_op->op_private & whicharg;
6330 svp && *svp ? *svp : &PL_sv_undef,
6331 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6337 if (!numargs) goto try_defsv;
6339 const bool wantscalar =
6340 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6341 if (!svp || !*svp || !SvROK(*svp)
6342 /* We have to permit globrefs even for the \$ proto, as
6343 *foo is indistinguishable from ${\*foo}, and the proto-
6344 type permits the latter. */
6345 || SvTYPE(SvRV(*svp)) > (
6346 wantscalar ? SVt_PVLV
6347 : opnum == OP_LOCK || opnum == OP_UNDEF
6353 "Type of arg %d to &CORE::%s must be %s",
6354 whicharg, PL_op_name[opnum],
6356 ? "scalar reference"
6357 : opnum == OP_LOCK || opnum == OP_UNDEF
6358 ? "reference to one of [$@%&*]"
6359 : "reference to one of [$@%*]"
6362 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6363 /* Undo @_ localisation, so that sub exit does not undo
6364 part of our undeffing. */
6365 S_maybe_unwind_defav(aTHX);
6370 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6378 /* Implement CORE::keys(),values(),each().
6380 * We won't know until run-time whether the arg is an array or hash,
6383 * pp_keys/pp_values/pp_each
6385 * pp_akeys/pp_avalues/pp_aeach
6387 * as appropriate (or whatever pp function actually implements the OP_FOO
6388 * functionality for each FOO).
6395 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6396 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6404 if (PL_op->op_private & OPpOFFBYONE) {
6405 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6407 else cv = find_runcv(NULL);
6408 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6413 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6414 const bool can_preserve)
6416 const SSize_t ix = SvIV(keysv);
6417 if (can_preserve ? av_exists(av, ix) : TRUE) {
6418 SV ** const svp = av_fetch(av, ix, 1);
6420 Perl_croak(aTHX_ PL_no_aelem, ix);
6421 save_aelem(av, ix, svp);
6424 SAVEADELETE(av, ix);
6428 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6429 const bool can_preserve)
6431 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6432 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6433 SV ** const svp = he ? &HeVAL(he) : NULL;
6435 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6436 save_helem_flags(hv, keysv, svp, 0);
6439 SAVEHDELETE(hv, keysv);
6443 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6445 if (type == OPpLVREF_SV) {
6446 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6449 else if (type == OPpLVREF_AV)
6450 /* XXX Inefficient, as it creates a new AV, which we are
6451 about to clobber. */
6454 assert(type == OPpLVREF_HV);
6455 /* XXX Likewise inefficient. */
6464 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6465 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6467 const char *bad = NULL;
6468 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6469 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6472 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6476 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6480 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6484 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6488 /* diag_listed_as: Assigned value is not %s reference */
6489 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6493 switch (left ? SvTYPE(left) : 0) {
6496 SV * const old = PAD_SV(ARGTARG);
6497 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6499 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6501 SAVECLEARSV(PAD_SVl(ARGTARG));
6505 if (PL_op->op_private & OPpLVAL_INTRO) {
6506 S_localise_gv_slot(aTHX_ (GV *)left, type);
6508 gv_setref(left, sv);
6513 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6514 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6515 SvCANEXISTDELETE(left));
6517 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6520 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6522 S_localise_helem_lval(aTHX_ (HV *)left, key,
6523 SvCANEXISTDELETE(left));
6525 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6527 if (PL_op->op_flags & OPf_MOD)
6528 SETs(sv_2mortal(newSVsv(sv)));
6529 /* XXX else can weak references go stale before they are read, e.g.,
6538 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6539 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6540 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6541 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6542 &PL_vtbl_lvref, (char *)elem,
6543 elem ? HEf_SVKEY : (I32)ARGTARG);
6544 mg->mg_private = PL_op->op_private;
6545 if (PL_op->op_private & OPpLVREF_ITER)
6546 mg->mg_flags |= MGf_PERSIST;
6547 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6553 const bool can_preserve = SvCANEXISTDELETE(arg);
6554 if (SvTYPE(arg) == SVt_PVAV)
6555 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6557 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6561 S_localise_gv_slot(aTHX_ (GV *)arg,
6562 PL_op->op_private & OPpLVREF_TYPE);
6564 else if (!(PL_op->op_private & OPpPAD_STATE))
6565 SAVECLEARSV(PAD_SVl(ARGTARG));
6574 AV * const av = (AV *)POPs;
6575 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6576 bool can_preserve = FALSE;
6578 if (UNLIKELY(localizing)) {
6583 can_preserve = SvCANEXISTDELETE(av);
6585 if (SvTYPE(av) == SVt_PVAV) {
6588 for (svp = MARK + 1; svp <= SP; svp++) {
6589 const SSize_t elem = SvIV(*svp);
6593 if (max > AvMAX(av))
6598 while (++MARK <= SP) {
6599 SV * const elemsv = *MARK;
6600 if (SvTYPE(av) == SVt_PVAV)
6601 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6603 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6604 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6605 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6612 if (PL_op->op_flags & OPf_STACKED)
6613 Perl_pp_rv2av(aTHX);
6615 Perl_pp_padav(aTHX);
6619 SETs(0); /* special alias marker that aassign recognises */
6629 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6630 ? CopSTASH(PL_curcop)
6632 NULL, SvREFCNT_inc_simple_NN(sv))));
6637 /* process one subroutine argument - typically when the sub has a signature:
6638 * introduce PL_curpad[op_targ] and assign to it the value
6639 * for $: (OPf_STACKED ? *sp : $_[N])
6640 * for @/%: @_[N..$#_]
6642 * It's equivalent to
6645 * my $foo = (value-on-stack)
6647 * my @foo = @_[N..$#_]
6657 AV *defav = GvAV(PL_defgv); /* @_ */
6658 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6661 /* do 'my $var, @var or %var' action */
6662 padentry = &(PAD_SVl(o->op_targ));
6663 save_clearsv(padentry);
6666 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6667 if (o->op_flags & OPf_STACKED) {
6674 /* should already have been checked */
6676 #if IVSIZE > PTRSIZE
6677 assert(ix <= SSize_t_MAX);
6680 svp = av_fetch(defav, ix, FALSE);
6681 val = svp ? *svp : &PL_sv_undef;
6686 /* cargo-culted from pp_sassign */
6687 assert(TAINTING_get || !TAINT_get);
6688 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6691 SvSetMagicSV(targ, val);
6695 /* must be AV or HV */
6697 assert(!(o->op_flags & OPf_STACKED));
6698 argc = ((IV)AvFILL(defav) + 1) - ix;
6700 /* This is a copy of the relevant parts of pp_aassign().
6702 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6705 if (AvFILL((AV*)targ) > -1) {
6706 /* target should usually be empty. If we get get
6707 * here, someone's been doing some weird closure tricks.
6708 * Make a copy of all args before clearing the array,
6709 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6710 * elements. See similar code in pp_aassign.
6712 for (i = 0; i < argc; i++) {
6713 SV **svp = av_fetch(defav, ix + i, FALSE);
6714 SV *newsv = newSV(0);
6715 sv_setsv_flags(newsv,
6716 svp ? *svp : &PL_sv_undef,
6717 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6718 if (!av_store(defav, ix + i, newsv))
6719 SvREFCNT_dec_NN(newsv);
6721 av_clear((AV*)targ);
6727 av_extend((AV*)targ, argc);
6732 SV **svp = av_fetch(defav, ix + i, FALSE);
6733 SV *val = svp ? *svp : &PL_sv_undef;
6735 sv_setsv(tmpsv, val);
6736 av_store((AV*)targ, i++, tmpsv);
6744 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6746 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6747 /* see "target should usually be empty" comment above */
6748 for (i = 0; i < argc; i++) {
6749 SV **svp = av_fetch(defav, ix + i, FALSE);
6750 SV *newsv = newSV(0);
6751 sv_setsv_flags(newsv,
6752 svp ? *svp : &PL_sv_undef,
6753 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6754 if (!av_store(defav, ix + i, newsv))
6755 SvREFCNT_dec_NN(newsv);
6757 hv_clear((HV*)targ);
6762 assert(argc % 2 == 0);
6771 svp = av_fetch(defav, ix + i++, FALSE);
6772 key = svp ? *svp : &PL_sv_undef;
6773 svp = av_fetch(defav, ix + i++, FALSE);
6774 val = svp ? *svp : &PL_sv_undef;
6777 if (UNLIKELY(SvGMAGICAL(key)))
6778 key = sv_mortalcopy(key);
6780 sv_setsv(tmpsv, val);
6781 hv_store_ent((HV*)targ, key, tmpsv, 0);
6789 /* Handle a default value for one subroutine argument (typically as part
6790 * of a subroutine signature).
6791 * It's equivalent to
6792 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
6794 * Intended to be used where op_next is an OP_ARGELEM
6796 * We abuse the op_targ field slightly: it's an index into @_ rather than
6802 OP * const o = PL_op;
6803 AV *defav = GvAV(PL_defgv); /* @_ */
6804 IV ix = (IV)o->op_targ;
6807 #if IVSIZE > PTRSIZE
6808 assert(ix <= SSize_t_MAX);
6811 if (AvFILL(defav) >= ix) {
6813 SV **svp = av_fetch(defav, ix, FALSE);
6814 SV *val = svp ? *svp : &PL_sv_undef;
6818 return cLOGOPo->op_other;
6823 S_find_runcv_name(void)
6838 sv = sv_2mortal(newSV(0));
6839 gv_fullname4(sv, gv, NULL, TRUE);
6843 /* Check a a subs arguments - i.e. that it has the correct number of args
6844 * (and anything else we might think of in future). Typically used with
6850 OP * const o = PL_op;
6851 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6852 IV params = aux[0].iv;
6853 IV opt_params = aux[1].iv;
6854 char slurpy = (char)(aux[2].iv);
6855 AV *defav = GvAV(PL_defgv); /* @_ */
6859 assert(!SvMAGICAL(defav));
6860 argc = (AvFILLp(defav) + 1);
6861 too_few = (argc < (params - opt_params));
6863 if (UNLIKELY(too_few || (!slurpy && argc > params)))
6864 /* diag_listed_as: Too few arguments for subroutine '%s' */
6865 /* diag_listed_as: Too many arguments for subroutine '%s' */
6866 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
6867 too_few ? "few" : "many", S_find_runcv_name());
6869 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6870 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
6871 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
6872 S_find_runcv_name());
6878 * ex: set ts=8 sts=4 sw=4 et: