3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
32 #include "regcharclass.h"
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
46 #if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
53 /* variations on pp_null */
58 if (GIMME_V == G_SCALAR)
65 /* This is also called directly by pp_lvavref. */
70 assert(SvTYPE(TARG) == SVt_PVAV);
71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
75 if (PL_op->op_flags & OPf_REF) {
78 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 const I32 flags = is_lvalue_sub();
80 if (flags && !(flags & OPpENTERSUB_INARGS)) {
81 if (GIMME_V == G_SCALAR)
82 /* diag_listed_as: Can't return %s to lvalue scalar context */
83 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
89 if (gimme == G_ARRAY) {
90 /* XXX see also S_pushav in pp_hot.c */
91 const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
93 if (SvMAGICAL(TARG)) {
95 for (i=0; i < maxarg; i++) {
96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
102 for (i=0; i < (PADOFFSET)maxarg; i++) {
103 SV * const sv = AvARRAY((const AV *)TARG)[i];
104 SP[i+1] = sv ? sv : &PL_sv_undef;
109 else if (gimme == G_SCALAR) {
110 SV* const sv = sv_newmortal();
111 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
112 sv_setiv(sv, maxarg);
123 assert(SvTYPE(TARG) == SVt_PVHV);
125 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
127 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
128 if (PL_op->op_flags & OPf_REF)
130 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131 const I32 flags = is_lvalue_sub();
132 if (flags && !(flags & OPpENTERSUB_INARGS)) {
133 if (GIMME_V == G_SCALAR)
134 /* diag_listed_as: Can't return %s to lvalue scalar context */
135 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
140 if (gimme == G_ARRAY) {
141 RETURNOP(Perl_do_kv(aTHX));
143 else if ((PL_op->op_private & OPpTRUEBOOL
144 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
145 && block_gimme() == G_VOID ))
146 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
148 else if (gimme == G_SCALAR) {
149 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
158 assert(SvTYPE(TARG) == SVt_PVCV);
166 SvPADSTALE_off(TARG);
173 CV * const protocv = PadnamePROTOCV(
174 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
176 assert(SvTYPE(TARG) == SVt_PVCV);
178 if (CvISXSUB(protocv)) { /* constant */
179 /* XXX Should we clone it here? */
180 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
181 to introcv and remove the SvPADSTALE_off. */
182 SAVEPADSVANDMORTALIZE(ARGTARG);
183 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
186 if (CvROOT(protocv)) {
187 assert(CvCLONE(protocv));
188 assert(!CvCLONED(protocv));
190 cv_clone_into(protocv,(CV *)TARG);
191 SAVECLEARSV(PAD_SVl(ARGTARG));
198 /* In some cases this function inspects PL_op. If this function is called
199 for new op types, more bool parameters may need to be added in place of
202 When noinit is true, the absence of a gv will cause a retval of undef.
203 This is unrelated to the cv-to-gv assignment case.
207 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
210 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
213 sv = amagic_deref_call(sv, to_gv_amg);
217 if (SvTYPE(sv) == SVt_PVIO) {
218 GV * const gv = MUTABLE_GV(sv_newmortal());
219 gv_init(gv, 0, "__ANONIO__", 10, 0);
220 GvIOp(gv) = MUTABLE_IO(sv);
221 SvREFCNT_inc_void_NN(sv);
224 else if (!isGV_with_GP(sv)) {
225 Perl_die(aTHX_ "Not a GLOB reference");
229 if (!isGV_with_GP(sv)) {
231 /* If this is a 'my' scalar and flag is set then vivify
234 if (vivify_sv && sv != &PL_sv_undef) {
237 Perl_croak_no_modify();
238 if (cUNOP->op_targ) {
239 SV * const namesv = PAD_SV(cUNOP->op_targ);
240 HV *stash = CopSTASH(PL_curcop);
241 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
242 gv = MUTABLE_GV(newSV(0));
243 gv_init_sv(gv, stash, namesv, 0);
246 const char * const name = CopSTASHPV(PL_curcop);
247 gv = newGVgen_flags(name,
248 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
249 SvREFCNT_inc_simple_void_NN(gv);
251 prepare_SV_for_RV(sv);
252 SvRV_set(sv, MUTABLE_SV(gv));
257 if (PL_op->op_flags & OPf_REF || strict) {
258 Perl_die(aTHX_ PL_no_usym, "a symbol");
260 if (ckWARN(WARN_UNINITIALIZED))
266 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
267 sv, GV_ADDMG, SVt_PVGV
276 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
280 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
281 == OPpDONT_INIT_GV) {
282 /* We are the target of a coderef assignment. Return
283 the scalar unchanged, and let pp_sasssign deal with
287 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
289 /* FAKE globs in the symbol table cause weird bugs (#77810) */
293 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
294 SV *newsv = sv_newmortal();
295 sv_setsv_flags(newsv, sv, 0);
307 sv, PL_op->op_private & OPpDEREF,
308 PL_op->op_private & HINT_STRICT_REFS,
309 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
310 || PL_op->op_type == OP_READLINE
312 if (PL_op->op_private & OPpLVAL_INTRO)
313 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
318 /* Helper function for pp_rv2sv and pp_rv2av */
320 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
321 const svtype type, SV ***spp)
325 PERL_ARGS_ASSERT_SOFTREF2XV;
327 if (PL_op->op_private & HINT_STRICT_REFS) {
329 Perl_die(aTHX_ PL_no_symref_sv, sv,
330 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
332 Perl_die(aTHX_ PL_no_usym, what);
336 PL_op->op_flags & OPf_REF
338 Perl_die(aTHX_ PL_no_usym, what);
339 if (ckWARN(WARN_UNINITIALIZED))
341 if (type != SVt_PV && GIMME_V == G_ARRAY) {
345 **spp = &PL_sv_undef;
348 if ((PL_op->op_flags & OPf_SPECIAL) &&
349 !(PL_op->op_flags & OPf_MOD))
351 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
353 **spp = &PL_sv_undef;
358 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
371 sv = amagic_deref_call(sv, to_sv_amg);
375 if (SvTYPE(sv) >= SVt_PVAV)
376 DIE(aTHX_ "Not a SCALAR reference");
381 if (!isGV_with_GP(gv)) {
382 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
388 if (PL_op->op_flags & OPf_MOD) {
389 if (PL_op->op_private & OPpLVAL_INTRO) {
390 if (cUNOP->op_first->op_type == OP_NULL)
391 sv = save_scalar(MUTABLE_GV(TOPs));
393 sv = save_scalar(gv);
395 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
397 else if (PL_op->op_private & OPpDEREF)
398 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
407 AV * const av = MUTABLE_AV(TOPs);
408 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
410 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
412 *svp = newSV_type(SVt_PVMG);
413 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
417 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
426 if (PL_op->op_flags & OPf_MOD || LVRET) {
427 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
428 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
430 LvTARG(ret) = SvREFCNT_inc_simple(sv);
431 SETs(ret); /* no SvSETMAGIC */
434 const MAGIC * const mg = mg_find_mglob(sv);
435 if (mg && mg->mg_len != -1) {
437 STRLEN i = mg->mg_len;
438 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
439 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
453 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
455 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
456 == OPpMAY_RETURN_CONSTANT)
459 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
460 /* (But not in defined().) */
462 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
464 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
465 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
466 ? MUTABLE_CV(SvRV(gv))
470 cv = MUTABLE_CV(&PL_sv_undef);
471 SETs(MUTABLE_SV(cv));
481 SV *ret = &PL_sv_undef;
483 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
484 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
485 const char * s = SvPVX_const(TOPs);
486 if (strnEQ(s, "CORE::", 6)) {
487 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
489 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
490 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
492 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
498 cv = sv_2cv(TOPs, &stash, &gv, 0);
500 ret = newSVpvn_flags(
501 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
511 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
513 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
515 PUSHs(MUTABLE_SV(cv));
529 if (GIMME_V != G_ARRAY) {
535 *MARK = &PL_sv_undef;
537 *MARK = refto(*MARK);
541 EXTEND_MORTAL(SP - MARK);
543 *MARK = refto(*MARK);
548 S_refto(pTHX_ SV *sv)
552 PERL_ARGS_ASSERT_REFTO;
554 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
557 if (!(sv = LvTARG(sv)))
560 SvREFCNT_inc_void_NN(sv);
562 else if (SvTYPE(sv) == SVt_PVAV) {
563 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
564 av_reify(MUTABLE_AV(sv));
566 SvREFCNT_inc_void_NN(sv);
568 else if (SvPADTMP(sv)) {
573 SvREFCNT_inc_void_NN(sv);
576 sv_upgrade(rv, SVt_IV);
585 SV * const sv = TOPs;
593 /* use the return value that is in a register, its the same as TARG */
594 TARG = sv_ref(TARG,SvRV(sv),TRUE);
609 stash = CopSTASH(PL_curcop);
610 if (SvTYPE(stash) != SVt_PVHV)
611 Perl_croak(aTHX_ "Attempt to bless into a freed package");
614 SV * const ssv = POPs;
618 if (!ssv) goto curstash;
621 if (!SvAMAGIC(ssv)) {
623 Perl_croak(aTHX_ "Attempt to bless into a reference");
625 /* SvAMAGIC is on here, but it only means potentially overloaded,
626 so after stringification: */
627 ptr = SvPV_nomg_const(ssv,len);
628 /* We need to check the flag again: */
629 if (!SvAMAGIC(ssv)) goto frog;
631 else ptr = SvPV_nomg_const(ssv,len);
633 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
634 "Explicit blessing to '' (assuming package main)");
635 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
638 (void)sv_bless(TOPs, stash);
648 const char * const elem = SvPV_const(sv, len);
649 GV * const gv = MUTABLE_GV(TOPs);
654 /* elem will always be NUL terminated. */
655 const char * const second_letter = elem + 1;
658 if (len == 5 && strEQ(second_letter, "RRAY"))
660 tmpRef = MUTABLE_SV(GvAV(gv));
661 if (tmpRef && !AvREAL((const AV *)tmpRef)
662 && AvREIFY((const AV *)tmpRef))
663 av_reify(MUTABLE_AV(tmpRef));
667 if (len == 4 && strEQ(second_letter, "ODE"))
668 tmpRef = MUTABLE_SV(GvCVu(gv));
671 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
672 /* finally deprecated in 5.8.0 */
673 deprecate("*glob{FILEHANDLE}");
674 tmpRef = MUTABLE_SV(GvIOp(gv));
677 if (len == 6 && strEQ(second_letter, "ORMAT"))
678 tmpRef = MUTABLE_SV(GvFORM(gv));
681 if (len == 4 && strEQ(second_letter, "LOB"))
682 tmpRef = MUTABLE_SV(gv);
685 if (len == 4 && strEQ(second_letter, "ASH"))
686 tmpRef = MUTABLE_SV(GvHV(gv));
689 if (*second_letter == 'O' && !elem[2] && len == 2)
690 tmpRef = MUTABLE_SV(GvIOp(gv));
693 if (len == 4 && strEQ(second_letter, "AME"))
694 sv = newSVhek(GvNAME_HEK(gv));
697 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
698 const HV * const stash = GvSTASH(gv);
699 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
700 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
704 if (len == 6 && strEQ(second_letter, "CALAR"))
719 /* Pattern matching */
727 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
728 /* Historically, study was skipped in these cases. */
733 /* Make study a no-op. It's no longer useful and its existence
734 complicates matters elsewhere. */
740 /* also used for: pp_transr() */
747 if (PL_op->op_flags & OPf_STACKED)
752 sv = PAD_SV(ARGTARG);
757 if(PL_op->op_type == OP_TRANSR) {
759 const char * const pv = SvPV(sv,len);
760 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
765 mPUSHi(do_trans(sv));
770 /* Lvalue operators. */
773 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
779 PERL_ARGS_ASSERT_DO_CHOMP;
781 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
783 if (SvTYPE(sv) == SVt_PVAV) {
785 AV *const av = MUTABLE_AV(sv);
786 const I32 max = AvFILL(av);
788 for (i = 0; i <= max; i++) {
789 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
790 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
791 count += do_chomp(retval, sv, chomping);
795 else if (SvTYPE(sv) == SVt_PVHV) {
796 HV* const hv = MUTABLE_HV(sv);
798 (void)hv_iterinit(hv);
799 while ((entry = hv_iternext(hv)))
800 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
803 else if (SvREADONLY(sv)) {
804 Perl_croak_no_modify();
809 /* XXX, here sv is utf8-ized as a side-effect!
810 If encoding.pm is used properly, almost string-generating
811 operations, including literal strings, chr(), input data, etc.
812 should have been utf8-ized already, right?
814 sv_recode_to_utf8(sv, _get_encoding());
820 char *temp_buffer = NULL;
829 while (len && s[-1] == '\n') {
836 STRLEN rslen, rs_charlen;
837 const char *rsptr = SvPV_const(PL_rs, rslen);
839 rs_charlen = SvUTF8(PL_rs)
843 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
844 /* Assumption is that rs is shorter than the scalar. */
846 /* RS is utf8, scalar is 8 bit. */
848 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
851 /* Cannot downgrade, therefore cannot possibly match
853 assert (temp_buffer == rsptr);
859 else if (IN_ENCODING) {
860 /* RS is 8 bit, encoding.pm is used.
861 * Do not recode PL_rs as a side-effect. */
862 svrecode = newSVpvn(rsptr, rslen);
863 sv_recode_to_utf8(svrecode, _get_encoding());
864 rsptr = SvPV_const(svrecode, rslen);
865 rs_charlen = sv_len_utf8(svrecode);
868 /* RS is 8 bit, scalar is utf8. */
869 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
883 if (memNE(s, rsptr, rslen))
888 SvPV_force_nomg_nolen(sv);
896 SvREFCNT_dec(svrecode);
898 Safefree(temp_buffer);
900 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
901 s = SvPV_force_nomg(sv, len);
904 char * const send = s + len;
905 char * const start = s;
907 while (s > start && UTF8_IS_CONTINUATION(*s))
909 if (is_utf8_string((U8*)s, send - s)) {
910 sv_setpvn(retval, s, send - s);
912 SvCUR_set(sv, s - start);
918 sv_setpvs(retval, "");
922 sv_setpvn(retval, s, 1);
929 sv_setpvs(retval, "");
936 /* also used for: pp_schomp() */
941 const bool chomping = PL_op->op_type == OP_SCHOMP;
943 const size_t count = do_chomp(TARG, TOPs, chomping);
945 sv_setiv(TARG, count);
951 /* also used for: pp_chomp() */
955 dSP; dMARK; dTARGET; dORIGMARK;
956 const bool chomping = PL_op->op_type == OP_CHOMP;
960 count += do_chomp(TARG, *++MARK, chomping);
962 sv_setiv(TARG, count);
973 if (!PL_op->op_private) {
985 if (SvTHINKFIRST(sv))
986 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
988 switch (SvTYPE(sv)) {
992 av_undef(MUTABLE_AV(sv));
995 hv_undef(MUTABLE_HV(sv));
998 if (cv_const_sv((const CV *)sv))
999 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1000 "Constant subroutine %"SVf" undefined",
1001 SVfARG(CvANON((const CV *)sv)
1002 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1003 : sv_2mortal(newSVhek(
1005 ? CvNAME_HEK((CV *)sv)
1006 : GvENAME_HEK(CvGV((const CV *)sv))
1011 /* let user-undef'd sub keep its identity */
1012 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1015 assert(isGV_with_GP(sv));
1016 assert(!SvFAKE(sv));
1021 /* undef *Pkg::meth_name ... */
1023 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1024 && HvENAME_get(stash);
1026 if((stash = GvHV((const GV *)sv))) {
1027 if(HvENAME_get(stash))
1028 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1032 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1033 gp_free(MUTABLE_GV(sv));
1035 GvGP_set(sv, gp_ref(gp));
1036 #ifndef PERL_DONT_CREATE_GVSV
1037 GvSV(sv) = newSV(0);
1039 GvLINE(sv) = CopLINE(PL_curcop);
1040 GvEGV(sv) = MUTABLE_GV(sv);
1044 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1046 /* undef *Foo::ISA */
1047 if( strEQ(GvNAME((const GV *)sv), "ISA")
1048 && (stash = GvSTASH((const GV *)sv))
1049 && (method_changed || HvENAME(stash)) )
1050 mro_isa_changed_in(stash);
1051 else if(method_changed)
1052 mro_method_changed_in(
1053 GvSTASH((const GV *)sv)
1059 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1073 /* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1079 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1080 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1081 Perl_croak_no_modify();
1083 TARG = sv_newmortal();
1084 sv_setsv(TARG, TOPs);
1085 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1086 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1088 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1089 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1093 else sv_dec_nomg(TOPs);
1095 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1096 if (inc && !SvOK(TARG))
1102 /* Ordinary operators. */
1106 dSP; dATARGET; SV *svl, *svr;
1107 #ifdef PERL_PRESERVE_IVUV
1110 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1113 #ifdef PERL_PRESERVE_IVUV
1114 /* For integer to integer power, we do the calculation by hand wherever
1115 we're sure it is safe; otherwise we call pow() and try to convert to
1116 integer afterwards. */
1117 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1125 const IV iv = SvIVX(svr);
1129 goto float_it; /* Can't do negative powers this way. */
1133 baseuok = SvUOK(svl);
1135 baseuv = SvUVX(svl);
1137 const IV iv = SvIVX(svl);
1140 baseuok = TRUE; /* effectively it's a UV now */
1142 baseuv = -iv; /* abs, baseuok == false records sign */
1145 /* now we have integer ** positive integer. */
1148 /* foo & (foo - 1) is zero only for a power of 2. */
1149 if (!(baseuv & (baseuv - 1))) {
1150 /* We are raising power-of-2 to a positive integer.
1151 The logic here will work for any base (even non-integer
1152 bases) but it can be less accurate than
1153 pow (base,power) or exp (power * log (base)) when the
1154 intermediate values start to spill out of the mantissa.
1155 With powers of 2 we know this can't happen.
1156 And powers of 2 are the favourite thing for perl
1157 programmers to notice ** not doing what they mean. */
1159 NV base = baseuok ? baseuv : -(NV)baseuv;
1164 while (power >>= 1) {
1172 SvIV_please_nomg(svr);
1175 unsigned int highbit = 8 * sizeof(UV);
1176 unsigned int diff = 8 * sizeof(UV);
1177 while (diff >>= 1) {
1179 if (baseuv >> highbit) {
1183 /* we now have baseuv < 2 ** highbit */
1184 if (power * highbit <= 8 * sizeof(UV)) {
1185 /* result will definitely fit in UV, so use UV math
1186 on same algorithm as above */
1189 const bool odd_power = cBOOL(power & 1);
1193 while (power >>= 1) {
1200 if (baseuok || !odd_power)
1201 /* answer is positive */
1203 else if (result <= (UV)IV_MAX)
1204 /* answer negative, fits in IV */
1205 SETi( -(IV)result );
1206 else if (result == (UV)IV_MIN)
1207 /* 2's complement assumption: special case IV_MIN */
1210 /* answer negative, doesn't fit */
1211 SETn( -(NV)result );
1219 NV right = SvNV_nomg(svr);
1220 NV left = SvNV_nomg(svl);
1223 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1225 We are building perl with long double support and are on an AIX OS
1226 afflicted with a powl() function that wrongly returns NaNQ for any
1227 negative base. This was reported to IBM as PMR #23047-379 on
1228 03/06/2006. The problem exists in at least the following versions
1229 of AIX and the libm fileset, and no doubt others as well:
1231 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1232 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1233 AIX 5.2.0 bos.adt.libm 5.2.0.85
1235 So, until IBM fixes powl(), we provide the following workaround to
1236 handle the problem ourselves. Our logic is as follows: for
1237 negative bases (left), we use fmod(right, 2) to check if the
1238 exponent is an odd or even integer:
1240 - if odd, powl(left, right) == -powl(-left, right)
1241 - if even, powl(left, right) == powl(-left, right)
1243 If the exponent is not an integer, the result is rightly NaNQ, so
1244 we just return that (as NV_NAN).
1248 NV mod2 = Perl_fmod( right, 2.0 );
1249 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1250 SETn( -Perl_pow( -left, right) );
1251 } else if (mod2 == 0.0) { /* even integer */
1252 SETn( Perl_pow( -left, right) );
1253 } else { /* fractional power */
1257 SETn( Perl_pow( left, right) );
1260 SETn( Perl_pow( left, right) );
1261 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1263 #ifdef PERL_PRESERVE_IVUV
1265 SvIV_please_nomg(svr);
1273 dSP; dATARGET; SV *svl, *svr;
1274 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1277 #ifdef PERL_PRESERVE_IVUV
1278 if (SvIV_please_nomg(svr)) {
1279 /* Unless the left argument is integer in range we are going to have to
1280 use NV maths. Hence only attempt to coerce the right argument if
1281 we know the left is integer. */
1282 /* Left operand is defined, so is it IV? */
1283 if (SvIV_please_nomg(svl)) {
1284 bool auvok = SvUOK(svl);
1285 bool buvok = SvUOK(svr);
1286 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1287 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1296 const IV aiv = SvIVX(svl);
1299 auvok = TRUE; /* effectively it's a UV now */
1301 /* abs, auvok == false records sign */
1302 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1308 const IV biv = SvIVX(svr);
1311 buvok = TRUE; /* effectively it's a UV now */
1313 /* abs, buvok == false records sign */
1314 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1318 /* If this does sign extension on unsigned it's time for plan B */
1319 ahigh = alow >> (4 * sizeof (UV));
1321 bhigh = blow >> (4 * sizeof (UV));
1323 if (ahigh && bhigh) {
1325 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1326 which is overflow. Drop to NVs below. */
1327 } else if (!ahigh && !bhigh) {
1328 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1329 so the unsigned multiply cannot overflow. */
1330 const UV product = alow * blow;
1331 if (auvok == buvok) {
1332 /* -ve * -ve or +ve * +ve gives a +ve result. */
1336 } else if (product <= (UV)IV_MIN) {
1337 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1338 /* -ve result, which could overflow an IV */
1340 /* can't negate IV_MIN, but there are aren't two
1341 * integers such that !ahigh && !bhigh, where the
1342 * product equals 0x800....000 */
1343 assert(product != (UV)IV_MIN);
1344 SETi( -(IV)product );
1346 } /* else drop to NVs below. */
1348 /* One operand is large, 1 small */
1351 /* swap the operands */
1353 bhigh = blow; /* bhigh now the temp var for the swap */
1357 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1358 multiplies can't overflow. shift can, add can, -ve can. */
1359 product_middle = ahigh * blow;
1360 if (!(product_middle & topmask)) {
1361 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1363 product_middle <<= (4 * sizeof (UV));
1364 product_low = alow * blow;
1366 /* as for pp_add, UV + something mustn't get smaller.
1367 IIRC ANSI mandates this wrapping *behaviour* for
1368 unsigned whatever the actual representation*/
1369 product_low += product_middle;
1370 if (product_low >= product_middle) {
1371 /* didn't overflow */
1372 if (auvok == buvok) {
1373 /* -ve * -ve or +ve * +ve gives a +ve result. */
1375 SETu( product_low );
1377 } else if (product_low <= (UV)IV_MIN) {
1378 /* 2s complement assumption again */
1379 /* -ve result, which could overflow an IV */
1381 SETi(product_low == (UV)IV_MIN
1382 ? IV_MIN : -(IV)product_low);
1384 } /* else drop to NVs below. */
1386 } /* product_middle too large */
1387 } /* ahigh && bhigh */
1392 NV right = SvNV_nomg(svr);
1393 NV left = SvNV_nomg(svl);
1395 SETn( left * right );
1402 dSP; dATARGET; SV *svl, *svr;
1403 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1406 /* Only try to do UV divide first
1407 if ((SLOPPYDIVIDE is true) or
1408 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1410 The assumption is that it is better to use floating point divide
1411 whenever possible, only doing integer divide first if we can't be sure.
1412 If NV_PRESERVES_UV is true then we know at compile time that no UV
1413 can be too large to preserve, so don't need to compile the code to
1414 test the size of UVs. */
1417 # define PERL_TRY_UV_DIVIDE
1418 /* ensure that 20./5. == 4. */
1420 # ifdef PERL_PRESERVE_IVUV
1421 # ifndef NV_PRESERVES_UV
1422 # define PERL_TRY_UV_DIVIDE
1427 #ifdef PERL_TRY_UV_DIVIDE
1428 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1429 bool left_non_neg = SvUOK(svl);
1430 bool right_non_neg = SvUOK(svr);
1434 if (right_non_neg) {
1438 const IV biv = SvIVX(svr);
1441 right_non_neg = TRUE; /* effectively it's a UV now */
1444 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1447 /* historically undef()/0 gives a "Use of uninitialized value"
1448 warning before dieing, hence this test goes here.
1449 If it were immediately before the second SvIV_please, then
1450 DIE() would be invoked before left was even inspected, so
1451 no inspection would give no warning. */
1453 DIE(aTHX_ "Illegal division by zero");
1459 const IV aiv = SvIVX(svl);
1462 left_non_neg = TRUE; /* effectively it's a UV now */
1465 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1471 /* For sloppy divide we always attempt integer division. */
1473 /* Otherwise we only attempt it if either or both operands
1474 would not be preserved by an NV. If both fit in NVs
1475 we fall through to the NV divide code below. However,
1476 as left >= right to ensure integer result here, we know that
1477 we can skip the test on the right operand - right big
1478 enough not to be preserved can't get here unless left is
1481 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1484 /* Integer division can't overflow, but it can be imprecise. */
1485 const UV result = left / right;
1486 if (result * right == left) {
1487 SP--; /* result is valid */
1488 if (left_non_neg == right_non_neg) {
1489 /* signs identical, result is positive. */
1493 /* 2s complement assumption */
1494 if (result <= (UV)IV_MIN)
1495 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1497 /* It's exact but too negative for IV. */
1498 SETn( -(NV)result );
1501 } /* tried integer divide but it was not an integer result */
1502 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1503 } /* one operand wasn't SvIOK */
1504 #endif /* PERL_TRY_UV_DIVIDE */
1506 NV right = SvNV_nomg(svr);
1507 NV left = SvNV_nomg(svl);
1508 (void)POPs;(void)POPs;
1509 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1510 if (! Perl_isnan(right) && right == 0.0)
1514 DIE(aTHX_ "Illegal division by zero");
1515 PUSHn( left / right );
1523 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1527 bool left_neg = FALSE;
1528 bool right_neg = FALSE;
1529 bool use_double = FALSE;
1530 bool dright_valid = FALSE;
1533 SV * const svr = TOPs;
1534 SV * const svl = TOPm1s;
1535 if (SvIV_please_nomg(svr)) {
1536 right_neg = !SvUOK(svr);
1540 const IV biv = SvIVX(svr);
1543 right_neg = FALSE; /* effectively it's a UV now */
1545 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1550 dright = SvNV_nomg(svr);
1551 right_neg = dright < 0;
1554 if (dright < UV_MAX_P1) {
1555 right = U_V(dright);
1556 dright_valid = TRUE; /* In case we need to use double below. */
1562 /* At this point use_double is only true if right is out of range for
1563 a UV. In range NV has been rounded down to nearest UV and
1564 use_double false. */
1565 if (!use_double && SvIV_please_nomg(svl)) {
1566 left_neg = !SvUOK(svl);
1570 const IV aiv = SvIVX(svl);
1573 left_neg = FALSE; /* effectively it's a UV now */
1575 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1580 dleft = SvNV_nomg(svl);
1581 left_neg = dleft < 0;
1585 /* This should be exactly the 5.6 behaviour - if left and right are
1586 both in range for UV then use U_V() rather than floor. */
1588 if (dleft < UV_MAX_P1) {
1589 /* right was in range, so is dleft, so use UVs not double.
1593 /* left is out of range for UV, right was in range, so promote
1594 right (back) to double. */
1596 /* The +0.5 is used in 5.6 even though it is not strictly
1597 consistent with the implicit +0 floor in the U_V()
1598 inside the #if 1. */
1599 dleft = Perl_floor(dleft + 0.5);
1602 dright = Perl_floor(dright + 0.5);
1613 DIE(aTHX_ "Illegal modulus zero");
1615 dans = Perl_fmod(dleft, dright);
1616 if ((left_neg != right_neg) && dans)
1617 dans = dright - dans;
1620 sv_setnv(TARG, dans);
1626 DIE(aTHX_ "Illegal modulus zero");
1629 if ((left_neg != right_neg) && ans)
1632 /* XXX may warn: unary minus operator applied to unsigned type */
1633 /* could change -foo to be (~foo)+1 instead */
1634 if (ans <= ~((UV)IV_MAX)+1)
1635 sv_setiv(TARG, ~ans+1);
1637 sv_setnv(TARG, -(NV)ans);
1640 sv_setuv(TARG, ans);
1652 bool infnan = FALSE;
1654 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1655 /* TODO: think of some way of doing list-repeat overloading ??? */
1660 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1661 /* The parser saw this as a list repeat, and there
1662 are probably several items on the stack. But we're
1663 in scalar/void context, and there's no pp_list to save us
1664 now. So drop the rest of the items -- robin@kitsite.com
1667 if (MARK + 1 < SP) {
1673 ASSUME(MARK + 1 == SP);
1675 MARK[1] = &PL_sv_undef;
1679 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1685 const UV uv = SvUV_nomg(sv);
1687 count = IV_MAX; /* The best we can do? */
1691 count = SvIV_nomg(sv);
1694 else if (SvNOKp(sv)) {
1695 const NV nv = SvNV_nomg(sv);
1696 infnan = Perl_isinfnan(nv);
1697 if (UNLIKELY(infnan)) {
1701 count = -1; /* An arbitrary negative integer */
1707 count = SvIV_nomg(sv);
1710 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1711 "Non-finite repeat count does nothing");
1712 } else if (count < 0) {
1714 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1715 "Negative repeat count does nothing");
1718 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1720 static const char* const oom_list_extend = "Out of memory during list extend";
1721 const I32 items = SP - MARK;
1722 const I32 max = items * count;
1723 const U8 mod = PL_op->op_flags & OPf_MOD;
1725 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1726 /* Did the max computation overflow? */
1727 if (items > 0 && max > 0 && (max < items || max < count))
1728 Perl_croak(aTHX_ "%s", oom_list_extend);
1733 if (mod && SvPADTMP(*SP)) {
1734 *SP = sv_mortalcopy(*SP);
1741 repeatcpy((char*)(MARK + items), (char*)MARK,
1742 items * sizeof(const SV *), count - 1);
1745 else if (count <= 0)
1748 else { /* Note: mark already snarfed by pp_list */
1749 SV * const tmpstr = POPs;
1752 static const char* const oom_string_extend =
1753 "Out of memory during string extend";
1756 sv_setsv_nomg(TARG, tmpstr);
1757 SvPV_force_nomg(TARG, len);
1758 isutf = DO_UTF8(TARG);
1763 const STRLEN max = (UV)count * len;
1764 if (len > MEM_SIZE_MAX / count)
1765 Perl_croak(aTHX_ "%s", oom_string_extend);
1766 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1767 SvGROW(TARG, max + 1);
1768 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1769 SvCUR_set(TARG, SvCUR(TARG) * count);
1771 *SvEND(TARG) = '\0';
1774 (void)SvPOK_only_UTF8(TARG);
1776 (void)SvPOK_only(TARG);
1785 dSP; dATARGET; bool useleft; SV *svl, *svr;
1786 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1789 useleft = USE_LEFT(svl);
1790 #ifdef PERL_PRESERVE_IVUV
1791 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1792 "bad things" happen if you rely on signed integers wrapping. */
1793 if (SvIV_please_nomg(svr)) {
1794 /* Unless the left argument is integer in range we are going to have to
1795 use NV maths. Hence only attempt to coerce the right argument if
1796 we know the left is integer. */
1803 a_valid = auvok = 1;
1804 /* left operand is undef, treat as zero. */
1806 /* Left operand is defined, so is it IV? */
1807 if (SvIV_please_nomg(svl)) {
1808 if ((auvok = SvUOK(svl)))
1811 const IV aiv = SvIVX(svl);
1814 auvok = 1; /* Now acting as a sign flag. */
1815 } else { /* 2s complement assumption for IV_MIN */
1816 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1823 bool result_good = 0;
1826 bool buvok = SvUOK(svr);
1831 const IV biv = SvIVX(svr);
1836 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
1838 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1839 else "IV" now, independent of how it came in.
1840 if a, b represents positive, A, B negative, a maps to -A etc
1845 all UV maths. negate result if A negative.
1846 subtract if signs same, add if signs differ. */
1848 if (auvok ^ buvok) {
1857 /* Must get smaller */
1862 if (result <= buv) {
1863 /* result really should be -(auv-buv). as its negation
1864 of true value, need to swap our result flag */
1876 if (result <= (UV)IV_MIN)
1877 SETi(result == (UV)IV_MIN
1878 ? IV_MIN : -(IV)result);
1880 /* result valid, but out of range for IV. */
1881 SETn( -(NV)result );
1885 } /* Overflow, drop through to NVs. */
1890 NV value = SvNV_nomg(svr);
1894 /* left operand is undef, treat as zero - value */
1898 SETn( SvNV_nomg(svl) - value );
1905 dSP; dATARGET; SV *svl, *svr;
1906 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1910 const IV shift = SvIV_nomg(svr);
1911 if (PL_op->op_private & HINT_INTEGER) {
1912 const IV i = SvIV_nomg(svl);
1916 const UV u = SvUV_nomg(svl);
1925 dSP; dATARGET; SV *svl, *svr;
1926 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1930 const IV shift = SvIV_nomg(svr);
1931 if (PL_op->op_private & HINT_INTEGER) {
1932 const IV i = SvIV_nomg(svl);
1936 const UV u = SvUV_nomg(svl);
1948 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1952 (SvIOK_notUV(left) && SvIOK_notUV(right))
1953 ? (SvIVX(left) < SvIVX(right))
1954 : (do_ncmp(left, right) == -1)
1964 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1968 (SvIOK_notUV(left) && SvIOK_notUV(right))
1969 ? (SvIVX(left) > SvIVX(right))
1970 : (do_ncmp(left, right) == 1)
1980 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1984 (SvIOK_notUV(left) && SvIOK_notUV(right))
1985 ? (SvIVX(left) <= SvIVX(right))
1986 : (do_ncmp(left, right) <= 0)
1996 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2000 (SvIOK_notUV(left) && SvIOK_notUV(right))
2001 ? (SvIVX(left) >= SvIVX(right))
2002 : ( (do_ncmp(left, right) & 2) == 0)
2012 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2016 (SvIOK_notUV(left) && SvIOK_notUV(right))
2017 ? (SvIVX(left) != SvIVX(right))
2018 : (do_ncmp(left, right) != 0)
2023 /* compare left and right SVs. Returns:
2027 * 2: left or right was a NaN
2030 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2032 PERL_ARGS_ASSERT_DO_NCMP;
2033 #ifdef PERL_PRESERVE_IVUV
2034 /* Fortunately it seems NaN isn't IOK */
2035 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2037 const IV leftiv = SvIVX(left);
2038 if (!SvUOK(right)) {
2039 /* ## IV <=> IV ## */
2040 const IV rightiv = SvIVX(right);
2041 return (leftiv > rightiv) - (leftiv < rightiv);
2043 /* ## IV <=> UV ## */
2045 /* As (b) is a UV, it's >=0, so it must be < */
2048 const UV rightuv = SvUVX(right);
2049 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2054 /* ## UV <=> UV ## */
2055 const UV leftuv = SvUVX(left);
2056 const UV rightuv = SvUVX(right);
2057 return (leftuv > rightuv) - (leftuv < rightuv);
2059 /* ## UV <=> IV ## */
2061 const IV rightiv = SvIVX(right);
2063 /* As (a) is a UV, it's >=0, so it cannot be < */
2066 const UV leftuv = SvUVX(left);
2067 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2070 NOT_REACHED; /* NOTREACHED */
2074 NV const rnv = SvNV_nomg(right);
2075 NV const lnv = SvNV_nomg(left);
2077 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2078 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2081 return (lnv > rnv) - (lnv < rnv);
2100 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2103 value = do_ncmp(left, right);
2115 /* also used for: pp_sge() pp_sgt() pp_slt() */
2121 int amg_type = sle_amg;
2125 switch (PL_op->op_type) {
2144 tryAMAGICbin_MG(amg_type, AMGf_set);
2148 #ifdef USE_LOCALE_COLLATE
2149 (IN_LC_RUNTIME(LC_COLLATE))
2150 ? sv_cmp_locale_flags(left, right, 0)
2153 sv_cmp_flags(left, right, 0);
2154 SETs(boolSV(cmp * multiplier < rhs));
2162 tryAMAGICbin_MG(seq_amg, AMGf_set);
2165 SETs(boolSV(sv_eq_flags(left, right, 0)));
2173 tryAMAGICbin_MG(sne_amg, AMGf_set);
2176 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2184 tryAMAGICbin_MG(scmp_amg, 0);
2188 #ifdef USE_LOCALE_COLLATE
2189 (IN_LC_RUNTIME(LC_COLLATE))
2190 ? sv_cmp_locale_flags(left, right, 0)
2193 sv_cmp_flags(left, right, 0);
2202 tryAMAGICbin_MG(band_amg, AMGf_assign);
2205 if (SvNIOKp(left) || SvNIOKp(right)) {
2206 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2207 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2208 if (PL_op->op_private & HINT_INTEGER) {
2209 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2213 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2216 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2217 if (right_ro_nonnum) SvNIOK_off(right);
2220 do_vop(PL_op->op_type, TARG, left, right);
2230 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2232 dATARGET; dPOPTOPssrl;
2233 if (PL_op->op_private & HINT_INTEGER) {
2234 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2238 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2248 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2250 dATARGET; dPOPTOPssrl;
2251 do_vop(OP_BIT_AND, TARG, left, right);
2256 /* also used for: pp_bit_xor() */
2261 const int op_type = PL_op->op_type;
2263 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2266 if (SvNIOKp(left) || SvNIOKp(right)) {
2267 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2268 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2269 if (PL_op->op_private & HINT_INTEGER) {
2270 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2271 const IV r = SvIV_nomg(right);
2272 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2276 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2277 const UV r = SvUV_nomg(right);
2278 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2281 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2282 if (right_ro_nonnum) SvNIOK_off(right);
2285 do_vop(op_type, TARG, left, right);
2292 /* also used for: pp_nbit_xor() */
2297 const int op_type = PL_op->op_type;
2299 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2300 AMGf_assign|AMGf_numarg);
2302 dATARGET; dPOPTOPssrl;
2303 if (PL_op->op_private & HINT_INTEGER) {
2304 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2305 const IV r = SvIV_nomg(right);
2306 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2310 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2311 const UV r = SvUV_nomg(right);
2312 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2319 /* also used for: pp_sbit_xor() */
2324 const int op_type = PL_op->op_type;
2326 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2329 dATARGET; dPOPTOPssrl;
2330 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2336 PERL_STATIC_INLINE bool
2337 S_negate_string(pTHX)
2342 SV * const sv = TOPs;
2343 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2345 s = SvPV_nomg_const(sv, len);
2346 if (isIDFIRST(*s)) {
2347 sv_setpvs(TARG, "-");
2350 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2351 sv_setsv_nomg(TARG, sv);
2352 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2362 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2363 if (S_negate_string(aTHX)) return NORMAL;
2365 SV * const sv = TOPs;
2368 /* It's publicly an integer */
2371 if (SvIVX(sv) == IV_MIN) {
2372 /* 2s complement assumption. */
2373 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2377 else if (SvUVX(sv) <= IV_MAX) {
2382 else if (SvIVX(sv) != IV_MIN) {
2386 #ifdef PERL_PRESERVE_IVUV
2393 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2394 SETn(-SvNV_nomg(sv));
2395 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2396 goto oops_its_an_int;
2398 SETn(-SvNV_nomg(sv));
2406 tryAMAGICun_MG(not_amg, AMGf_set);
2407 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2412 S_scomplement(pTHX_ SV *targ, SV *sv)
2418 sv_copypv_nomg(TARG, sv);
2419 tmps = (U8*)SvPV_nomg(TARG, len);
2422 /* Calculate exact length, let's not estimate. */
2427 U8 * const send = tmps + len;
2428 U8 * const origtmps = tmps;
2429 const UV utf8flags = UTF8_ALLOW_ANYUV;
2431 while (tmps < send) {
2432 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2434 targlen += UNISKIP(~c);
2440 /* Now rewind strings and write them. */
2447 Newx(result, targlen + 1, U8);
2449 while (tmps < send) {
2450 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2452 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2455 sv_usepvn_flags(TARG, (char*)result, targlen,
2456 SV_HAS_TRAILING_NUL);
2463 Newx(result, nchar + 1, U8);
2465 while (tmps < send) {
2466 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2471 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2479 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2482 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2487 for ( ; anum > 0; anum--, tmps++)
2494 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2498 if (PL_op->op_private & HINT_INTEGER) {
2499 const IV i = ~SvIV_nomg(sv);
2503 const UV u = ~SvUV_nomg(sv);
2508 S_scomplement(aTHX_ TARG, sv);
2518 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2521 if (PL_op->op_private & HINT_INTEGER) {
2522 const IV i = ~SvIV_nomg(sv);
2526 const UV u = ~SvUV_nomg(sv);
2536 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2539 S_scomplement(aTHX_ TARG, sv);
2545 /* integer versions of some of the above */
2550 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2553 SETi( left * right );
2562 tryAMAGICbin_MG(div_amg, AMGf_assign);
2565 IV value = SvIV_nomg(right);
2567 DIE(aTHX_ "Illegal division by zero");
2568 num = SvIV_nomg(left);
2570 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2574 value = num / value;
2580 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2581 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2588 /* This is the vanilla old i_modulo. */
2590 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2594 DIE(aTHX_ "Illegal modulus zero");
2595 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2599 SETi( left % right );
2604 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2605 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2610 /* This is the i_modulo with the workaround for the _moddi3 bug
2611 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2612 * See below for pp_i_modulo. */
2614 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2618 DIE(aTHX_ "Illegal modulus zero");
2619 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2623 SETi( left % PERL_ABS(right) );
2630 dVAR; dSP; dATARGET;
2631 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2635 DIE(aTHX_ "Illegal modulus zero");
2636 /* The assumption is to use hereafter the old vanilla version... */
2638 PL_ppaddr[OP_I_MODULO] =
2640 /* .. but if we have glibc, we might have a buggy _moddi3
2641 * (at least glibc 2.2.5 is known to have this bug), in other
2642 * words our integer modulus with negative quad as the second
2643 * argument might be broken. Test for this and re-patch the
2644 * opcode dispatch table if that is the case, remembering to
2645 * also apply the workaround so that this first round works
2646 * right, too. See [perl #9402] for more information. */
2650 /* Cannot do this check with inlined IV constants since
2651 * that seems to work correctly even with the buggy glibc. */
2653 /* Yikes, we have the bug.
2654 * Patch in the workaround version. */
2656 PL_ppaddr[OP_I_MODULO] =
2657 &Perl_pp_i_modulo_1;
2658 /* Make certain we work right this time, too. */
2659 right = PERL_ABS(right);
2662 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2666 SETi( left % right );
2675 tryAMAGICbin_MG(add_amg, AMGf_assign);
2677 dPOPTOPiirl_ul_nomg;
2678 SETi( left + right );
2686 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2688 dPOPTOPiirl_ul_nomg;
2689 SETi( left - right );
2697 tryAMAGICbin_MG(lt_amg, AMGf_set);
2700 SETs(boolSV(left < right));
2708 tryAMAGICbin_MG(gt_amg, AMGf_set);
2711 SETs(boolSV(left > right));
2719 tryAMAGICbin_MG(le_amg, AMGf_set);
2722 SETs(boolSV(left <= right));
2730 tryAMAGICbin_MG(ge_amg, AMGf_set);
2733 SETs(boolSV(left >= right));
2741 tryAMAGICbin_MG(eq_amg, AMGf_set);
2744 SETs(boolSV(left == right));
2752 tryAMAGICbin_MG(ne_amg, AMGf_set);
2755 SETs(boolSV(left != right));
2763 tryAMAGICbin_MG(ncmp_amg, 0);
2770 else if (left < right)
2782 tryAMAGICun_MG(neg_amg, 0);
2783 if (S_negate_string(aTHX)) return NORMAL;
2785 SV * const sv = TOPs;
2786 IV const i = SvIV_nomg(sv);
2792 /* High falutin' math. */
2797 tryAMAGICbin_MG(atan2_amg, 0);
2800 SETn(Perl_atan2(left, right));
2806 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2811 int amg_type = fallback_amg;
2812 const char *neg_report = NULL;
2813 const int op_type = PL_op->op_type;
2816 case OP_SIN: amg_type = sin_amg; break;
2817 case OP_COS: amg_type = cos_amg; break;
2818 case OP_EXP: amg_type = exp_amg; break;
2819 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2820 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2823 assert(amg_type != fallback_amg);
2825 tryAMAGICun_MG(amg_type, 0);
2827 SV * const arg = TOPs;
2828 const NV value = SvNV_nomg(arg);
2830 if (neg_report) { /* log or sqrt */
2832 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2833 ! Perl_isnan(value) &&
2835 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2836 SET_NUMERIC_STANDARD();
2837 /* diag_listed_as: Can't take log of %g */
2838 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2843 case OP_SIN: result = Perl_sin(value); break;
2844 case OP_COS: result = Perl_cos(value); break;
2845 case OP_EXP: result = Perl_exp(value); break;
2846 case OP_LOG: result = Perl_log(value); break;
2847 case OP_SQRT: result = Perl_sqrt(value); break;
2854 /* Support Configure command-line overrides for rand() functions.
2855 After 5.005, perhaps we should replace this by Configure support
2856 for drand48(), random(), or rand(). For 5.005, though, maintain
2857 compatibility by calling rand() but allow the user to override it.
2858 See INSTALL for details. --Andy Dougherty 15 July 1998
2860 /* Now it's after 5.005, and Configure supports drand48() and random(),
2861 in addition to rand(). So the overrides should not be needed any more.
2862 --Jarkko Hietaniemi 27 September 1998
2867 if (!PL_srand_called) {
2868 (void)seedDrand01((Rand_seed_t)seed());
2869 PL_srand_called = TRUE;
2881 SV * const sv = POPs;
2887 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2888 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2889 if (! Perl_isnan(value) && value == 0.0)
2899 sv_setnv_mg(TARG, value);
2910 if (MAXARG >= 1 && (TOPs || POPs)) {
2917 pv = SvPV(top, len);
2918 flags = grok_number(pv, len, &anum);
2920 if (!(flags & IS_NUMBER_IN_UV)) {
2921 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2922 "Integer overflow in srand");
2930 (void)seedDrand01((Rand_seed_t)anum);
2931 PL_srand_called = TRUE;
2935 /* Historically srand always returned true. We can avoid breaking
2937 sv_setpvs(TARG, "0 but true");
2946 tryAMAGICun_MG(int_amg, AMGf_numeric);
2948 SV * const sv = TOPs;
2949 const IV iv = SvIV_nomg(sv);
2950 /* XXX it's arguable that compiler casting to IV might be subtly
2951 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2952 else preferring IV has introduced a subtle behaviour change bug. OTOH
2953 relying on floating point to be accurate is a bug. */
2958 else if (SvIOK(sv)) {
2960 SETu(SvUV_nomg(sv));
2965 const NV value = SvNV_nomg(sv);
2966 if (UNLIKELY(Perl_isinfnan(value)))
2968 else if (value >= 0.0) {
2969 if (value < (NV)UV_MAX + 0.5) {
2972 SETn(Perl_floor(value));
2976 if (value > (NV)IV_MIN - 0.5) {
2979 SETn(Perl_ceil(value));
2990 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2992 SV * const sv = TOPs;
2993 /* This will cache the NV value if string isn't actually integer */
2994 const IV iv = SvIV_nomg(sv);
2999 else if (SvIOK(sv)) {
3000 /* IVX is precise */
3002 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3010 /* 2s complement assumption. Also, not really needed as
3011 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3017 const NV value = SvNV_nomg(sv);
3028 /* also used for: pp_hex() */
3034 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3038 SV* const sv = TOPs;
3040 tmps = (SvPV_const(sv, len));
3042 /* If Unicode, try to downgrade
3043 * If not possible, croak. */
3044 SV* const tsv = sv_2mortal(newSVsv(sv));
3047 sv_utf8_downgrade(tsv, FALSE);
3048 tmps = SvPV_const(tsv, len);
3050 if (PL_op->op_type == OP_HEX)
3053 while (*tmps && len && isSPACE(*tmps))
3057 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3059 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3061 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3062 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3064 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3066 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3080 SV * const sv = TOPs;
3082 U32 in_bytes = IN_BYTES;
3083 /* simplest case shortcut */
3084 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3085 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3086 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3089 if(LIKELY(svflags == SVf_POK))
3091 if(svflags & SVs_GMG)
3094 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3095 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3099 /* unrolled SvPV_nomg_const(sv,len) */
3104 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3106 sv_setiv(TARG, (IV)(len));
3109 if (!SvPADTMP(TARG)) {
3110 sv_setsv_nomg(TARG, &PL_sv_undef);
3111 } else { /* TARG is on stack at this point and is overwriten by SETs.
3112 This branch is the odd one out, so put TARG by default on
3113 stack earlier to let local SP go out of liveness sooner */
3120 return NORMAL; /* no putback, SP didn't move in this opcode */
3123 /* Returns false if substring is completely outside original string.
3124 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3125 always be true for an explicit 0.
3128 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3129 bool pos1_is_uv, IV len_iv,
3130 bool len_is_uv, STRLEN *posp,
3136 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3138 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3139 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3142 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3145 if (len_iv || len_is_uv) {
3146 if (!len_is_uv && len_iv < 0) {
3147 pos2_iv = curlen + len_iv;
3149 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3152 } else { /* len_iv >= 0 */
3153 if (!pos1_is_uv && pos1_iv < 0) {
3154 pos2_iv = pos1_iv + len_iv;
3155 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3157 if ((UV)len_iv > curlen-(UV)pos1_iv)
3160 pos2_iv = pos1_iv+len_iv;
3170 if (!pos2_is_uv && pos2_iv < 0) {
3171 if (!pos1_is_uv && pos1_iv < 0)
3175 else if (!pos1_is_uv && pos1_iv < 0)
3178 if ((UV)pos2_iv < (UV)pos1_iv)
3180 if ((UV)pos2_iv > curlen)
3183 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3184 *posp = (STRLEN)( (UV)pos1_iv );
3185 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3202 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3203 const bool rvalue = (GIMME_V != G_VOID);
3206 const char *repl = NULL;
3208 int num_args = PL_op->op_private & 7;
3209 bool repl_need_utf8_upgrade = FALSE;
3213 if(!(repl_sv = POPs)) num_args--;
3215 if ((len_sv = POPs)) {
3216 len_iv = SvIV(len_sv);
3217 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3222 pos1_iv = SvIV(pos_sv);
3223 pos1_is_uv = SvIOK_UV(pos_sv);
3225 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3229 if (lvalue && !repl_sv) {
3231 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3232 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3234 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3236 pos1_is_uv || pos1_iv >= 0
3237 ? (STRLEN)(UV)pos1_iv
3238 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3240 len_is_uv || len_iv > 0
3241 ? (STRLEN)(UV)len_iv
3242 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3244 PUSHs(ret); /* avoid SvSETMAGIC here */
3248 repl = SvPV_const(repl_sv, repl_len);
3251 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3252 "Attempt to use reference as lvalue in substr"
3254 tmps = SvPV_force_nomg(sv, curlen);
3255 if (DO_UTF8(repl_sv) && repl_len) {
3257 sv_utf8_upgrade_nomg(sv);
3261 else if (DO_UTF8(sv))
3262 repl_need_utf8_upgrade = TRUE;
3264 else tmps = SvPV_const(sv, curlen);
3266 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3267 if (utf8_curlen == curlen)
3270 curlen = utf8_curlen;
3276 STRLEN pos, len, byte_len, byte_pos;
3278 if (!translate_substr_offsets(
3279 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3283 byte_pos = utf8_curlen
3284 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3289 SvTAINTED_off(TARG); /* decontaminate */
3290 SvUTF8_off(TARG); /* decontaminate */
3291 sv_setpvn(TARG, tmps, byte_len);
3292 #ifdef USE_LOCALE_COLLATE
3293 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3300 SV* repl_sv_copy = NULL;
3302 if (repl_need_utf8_upgrade) {
3303 repl_sv_copy = newSVsv(repl_sv);
3304 sv_utf8_upgrade(repl_sv_copy);
3305 repl = SvPV_const(repl_sv_copy, repl_len);
3309 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3310 SvREFCNT_dec(repl_sv_copy);
3313 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3323 Perl_croak(aTHX_ "substr outside of string");
3324 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3331 const IV size = POPi;
3332 const IV offset = POPi;
3333 SV * const src = POPs;
3334 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3337 if (lvalue) { /* it's an lvalue! */
3338 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3339 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3341 LvTARG(ret) = SvREFCNT_inc_simple(src);
3342 LvTARGOFF(ret) = offset;
3343 LvTARGLEN(ret) = size;
3347 SvTAINTED_off(TARG); /* decontaminate */
3351 sv_setuv(ret, do_vecget(src, offset, size));
3359 /* also used for: pp_rindex() */
3372 const char *little_p;
3375 const bool is_index = PL_op->op_type == OP_INDEX;
3376 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3382 big_p = SvPV_const(big, biglen);
3383 little_p = SvPV_const(little, llen);
3385 big_utf8 = DO_UTF8(big);
3386 little_utf8 = DO_UTF8(little);
3387 if (big_utf8 ^ little_utf8) {
3388 /* One needs to be upgraded. */
3389 if (little_utf8 && !IN_ENCODING) {
3390 /* Well, maybe instead we might be able to downgrade the small
3392 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3395 /* If the large string is ISO-8859-1, and it's not possible to
3396 convert the small string to ISO-8859-1, then there is no
3397 way that it could be found anywhere by index. */
3402 /* At this point, pv is a malloc()ed string. So donate it to temp
3403 to ensure it will get free()d */
3404 little = temp = newSV(0);
3405 sv_usepvn(temp, pv, llen);
3406 little_p = SvPVX(little);
3409 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3412 sv_recode_to_utf8(temp, _get_encoding());
3414 sv_utf8_upgrade(temp);
3419 big_p = SvPV_const(big, biglen);
3422 little_p = SvPV_const(little, llen);
3426 if (SvGAMAGIC(big)) {
3427 /* Life just becomes a lot easier if I use a temporary here.
3428 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3429 will trigger magic and overloading again, as will fbm_instr()
3431 big = newSVpvn_flags(big_p, biglen,
3432 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3435 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3436 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3437 warn on undef, and we've already triggered a warning with the
3438 SvPV_const some lines above. We can't remove that, as we need to
3439 call some SvPV to trigger overloading early and find out if the
3441 This is all getting to messy. The API isn't quite clean enough,
3442 because data access has side effects.
3444 little = newSVpvn_flags(little_p, llen,
3445 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3446 little_p = SvPVX(little);
3450 offset = is_index ? 0 : biglen;
3452 if (big_utf8 && offset > 0)
3453 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3459 else if (offset > (SSize_t)biglen)
3461 if (!(little_p = is_index
3462 ? fbm_instr((unsigned char*)big_p + offset,
3463 (unsigned char*)big_p + biglen, little, 0)
3464 : rninstr(big_p, big_p + offset,
3465 little_p, little_p + llen)))
3468 retval = little_p - big_p;
3469 if (retval > 1 && big_utf8)
3470 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3480 dSP; dMARK; dORIGMARK; dTARGET;
3481 SvTAINTED_off(TARG);
3482 do_sprintf(TARG, SP-MARK, MARK+1);
3483 TAINT_IF(SvTAINTED(TARG));
3495 const U8 *s = (U8*)SvPV_const(argsv, len);
3497 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3498 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3499 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3500 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
3505 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3519 if (UNLIKELY(SvAMAGIC(top)))
3521 if (UNLIKELY(isinfnansv(top)))
3522 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3524 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3525 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3527 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3528 && SvNV_nomg(top) < 0.0))) {
3529 if (ckWARN(WARN_UTF8)) {
3530 if (SvGMAGICAL(top)) {
3531 SV *top2 = sv_newmortal();
3532 sv_setsv_nomg(top2, top);
3535 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3536 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3538 value = UNICODE_REPLACEMENT;
3540 value = SvUV_nomg(top);
3544 SvUPGRADE(TARG,SVt_PV);
3546 if (value > 255 && !IN_BYTES) {
3547 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3548 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3549 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3551 (void)SvPOK_only(TARG);
3560 *tmps++ = (char)value;
3562 (void)SvPOK_only(TARG);
3564 if (IN_ENCODING && !IN_BYTES) {
3565 sv_recode_to_utf8(TARG, _get_encoding());
3567 if (SvCUR(TARG) == 0
3568 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3569 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3574 *tmps++ = (char)value;
3590 const char *tmps = SvPV_const(left, len);
3592 if (DO_UTF8(left)) {
3593 /* If Unicode, try to downgrade.
3594 * If not possible, croak.
3595 * Yes, we made this up. */
3596 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3598 sv_utf8_downgrade(tsv, FALSE);
3599 tmps = SvPV_const(tsv, len);
3601 # ifdef USE_ITHREADS
3603 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3604 /* This should be threadsafe because in ithreads there is only
3605 * one thread per interpreter. If this would not be true,
3606 * we would need a mutex to protect this malloc. */
3607 PL_reentrant_buffer->_crypt_struct_buffer =
3608 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3609 #if defined(__GLIBC__) || defined(__EMX__)
3610 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3611 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3612 /* work around glibc-2.2.5 bug */
3613 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3617 # endif /* HAS_CRYPT_R */
3618 # endif /* USE_ITHREADS */
3620 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3622 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3629 "The crypt() function is unimplemented due to excessive paranoia.");
3633 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3634 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3637 /* also used for: pp_lcfirst() */
3641 /* Actually is both lcfirst() and ucfirst(). Only the first character
3642 * changes. This means that possibly we can change in-place, ie., just
3643 * take the source and change that one character and store it back, but not
3644 * if read-only etc, or if the length changes */
3648 STRLEN slen; /* slen is the byte length of the whole SV. */
3651 bool inplace; /* ? Convert first char only, in-place */
3652 bool doing_utf8 = FALSE; /* ? using utf8 */
3653 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3654 const int op_type = PL_op->op_type;
3657 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3658 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3659 * stored as UTF-8 at s. */
3660 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3661 * lowercased) character stored in tmpbuf. May be either
3662 * UTF-8 or not, but in either case is the number of bytes */
3664 s = (const U8*)SvPV_const(source, slen);
3666 /* We may be able to get away with changing only the first character, in
3667 * place, but not if read-only, etc. Later we may discover more reasons to
3668 * not convert in-place. */
3669 inplace = !SvREADONLY(source)
3670 && ( SvPADTMP(source)
3671 || ( SvTEMP(source) && !SvSMAGICAL(source)
3672 && SvREFCNT(source) == 1));
3674 /* First calculate what the changed first character should be. This affects
3675 * whether we can just swap it out, leaving the rest of the string unchanged,
3676 * or even if have to convert the dest to UTF-8 when the source isn't */
3678 if (! slen) { /* If empty */
3679 need = 1; /* still need a trailing NUL */
3682 else if (DO_UTF8(source)) { /* Is the source utf8? */
3685 if (op_type == OP_UCFIRST) {
3686 #ifdef USE_LOCALE_CTYPE
3687 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3689 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3693 #ifdef USE_LOCALE_CTYPE
3694 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3696 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3700 /* we can't do in-place if the length changes. */
3701 if (ulen != tculen) inplace = FALSE;
3702 need = slen + 1 - ulen + tculen;
3704 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3705 * latin1 is treated as caseless. Note that a locale takes
3707 ulen = 1; /* Original character is 1 byte */
3708 tculen = 1; /* Most characters will require one byte, but this will
3709 * need to be overridden for the tricky ones */
3712 if (op_type == OP_LCFIRST) {
3714 /* lower case the first letter: no trickiness for any character */
3715 #ifdef USE_LOCALE_CTYPE
3716 if (IN_LC_RUNTIME(LC_CTYPE)) {
3717 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3718 *tmpbuf = toLOWER_LC(*s);
3723 *tmpbuf = (IN_UNI_8_BIT)
3724 ? toLOWER_LATIN1(*s)
3728 #ifdef USE_LOCALE_CTYPE
3730 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3731 if (IN_UTF8_CTYPE_LOCALE) {
3735 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3736 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3737 locales have upper and title case
3741 else if (! IN_UNI_8_BIT) {
3742 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3743 * on EBCDIC machines whatever the
3744 * native function does */
3747 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3748 * UTF-8, which we treat as not in locale), and cased latin1 */
3750 #ifdef USE_LOCALE_CTYPE
3754 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3756 assert(tculen == 2);
3758 /* If the result is an upper Latin1-range character, it can
3759 * still be represented in one byte, which is its ordinal */
3760 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3761 *tmpbuf = (U8) title_ord;
3765 /* Otherwise it became more than one ASCII character (in
3766 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3767 * beyond Latin1, so the number of bytes changed, so can't
3768 * replace just the first character in place. */
3771 /* If the result won't fit in a byte, the entire result
3772 * will have to be in UTF-8. Assume worst case sizing in
3773 * conversion. (all latin1 characters occupy at most two
3775 if (title_ord > 255) {
3777 convert_source_to_utf8 = TRUE;
3778 need = slen * 2 + 1;
3780 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3781 * (both) characters whose title case is above 255 is
3785 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3786 need = slen + 1 + 1;
3790 } /* End of use Unicode (Latin1) semantics */
3791 } /* End of changing the case of the first character */
3793 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3794 * generate the result */
3797 /* We can convert in place. This means we change just the first
3798 * character without disturbing the rest; no need to grow */
3800 s = d = (U8*)SvPV_force_nomg(source, slen);
3806 /* Here, we can't convert in place; we earlier calculated how much
3807 * space we will need, so grow to accommodate that */
3808 SvUPGRADE(dest, SVt_PV);
3809 d = (U8*)SvGROW(dest, need);
3810 (void)SvPOK_only(dest);
3817 if (! convert_source_to_utf8) {
3819 /* Here both source and dest are in UTF-8, but have to create
3820 * the entire output. We initialize the result to be the
3821 * title/lower cased first character, and then append the rest
3823 sv_setpvn(dest, (char*)tmpbuf, tculen);
3825 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3829 const U8 *const send = s + slen;
3831 /* Here the dest needs to be in UTF-8, but the source isn't,
3832 * except we earlier UTF-8'd the first character of the source
3833 * into tmpbuf. First put that into dest, and then append the
3834 * rest of the source, converting it to UTF-8 as we go. */
3836 /* Assert tculen is 2 here because the only two characters that
3837 * get to this part of the code have 2-byte UTF-8 equivalents */
3839 *d++ = *(tmpbuf + 1);
3840 s++; /* We have just processed the 1st char */
3842 for (; s < send; s++) {
3843 d = uvchr_to_utf8(d, *s);
3846 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3850 else { /* in-place UTF-8. Just overwrite the first character */
3851 Copy(tmpbuf, d, tculen, U8);
3852 SvCUR_set(dest, need - 1);
3856 else { /* Neither source nor dest are in or need to be UTF-8 */
3858 if (inplace) { /* in-place, only need to change the 1st char */
3861 else { /* Not in-place */
3863 /* Copy the case-changed character(s) from tmpbuf */
3864 Copy(tmpbuf, d, tculen, U8);
3865 d += tculen - 1; /* Code below expects d to point to final
3866 * character stored */
3869 else { /* empty source */
3870 /* See bug #39028: Don't taint if empty */
3874 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3875 * the destination to retain that flag */
3876 if (SvUTF8(source) && ! IN_BYTES)
3879 if (!inplace) { /* Finish the rest of the string, unchanged */
3880 /* This will copy the trailing NUL */
3881 Copy(s + 1, d + 1, slen, U8);
3882 SvCUR_set(dest, need - 1);
3885 #ifdef USE_LOCALE_CTYPE
3886 if (IN_LC_RUNTIME(LC_CTYPE)) {
3891 if (dest != source && SvTAINTED(source))
3897 /* There's so much setup/teardown code common between uc and lc, I wonder if
3898 it would be worth merging the two, and just having a switch outside each
3899 of the three tight loops. There is less and less commonality though */
3912 if ((SvPADTMP(source)
3914 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3915 && !SvREADONLY(source) && SvPOK(source)
3918 #ifdef USE_LOCALE_CTYPE
3919 (IN_LC_RUNTIME(LC_CTYPE))
3920 ? ! IN_UTF8_CTYPE_LOCALE
3926 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3927 * make the loop tight, so we overwrite the source with the dest before
3928 * looking at it, and we need to look at the original source
3929 * afterwards. There would also need to be code added to handle
3930 * switching to not in-place in midstream if we run into characters
3931 * that change the length. Since being in locale overrides UNI_8_BIT,
3932 * that latter becomes irrelevant in the above test; instead for
3933 * locale, the size can't normally change, except if the locale is a
3936 s = d = (U8*)SvPV_force_nomg(source, len);
3943 s = (const U8*)SvPV_nomg_const(source, len);
3946 SvUPGRADE(dest, SVt_PV);
3947 d = (U8*)SvGROW(dest, min);
3948 (void)SvPOK_only(dest);
3953 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3954 to check DO_UTF8 again here. */
3956 if (DO_UTF8(source)) {
3957 const U8 *const send = s + len;
3958 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3960 /* All occurrences of these are to be moved to follow any other marks.
3961 * This is context-dependent. We may not be passed enough context to
3962 * move the iota subscript beyond all of them, but we do the best we can
3963 * with what we're given. The result is always better than if we
3964 * hadn't done this. And, the problem would only arise if we are
3965 * passed a character without all its combining marks, which would be
3966 * the caller's mistake. The information this is based on comes from a
3967 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3968 * itself) and so can't be checked properly to see if it ever gets
3969 * revised. But the likelihood of it changing is remote */
3970 bool in_iota_subscript = FALSE;
3976 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3978 /* A non-mark. Time to output the iota subscript */
3979 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3980 d += capital_iota_len;
3981 in_iota_subscript = FALSE;
3984 /* Then handle the current character. Get the changed case value
3985 * and copy it to the output buffer */
3988 #ifdef USE_LOCALE_CTYPE
3989 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
3991 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
3993 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3994 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3995 if (uv == GREEK_CAPITAL_LETTER_IOTA
3996 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3998 in_iota_subscript = TRUE;
4001 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4002 /* If the eventually required minimum size outgrows the
4003 * available space, we need to grow. */
4004 const UV o = d - (U8*)SvPVX_const(dest);
4006 /* If someone uppercases one million U+03B0s we SvGROW()
4007 * one million times. Or we could try guessing how much to
4008 * allocate without allocating too much. Such is life.
4009 * See corresponding comment in lc code for another option
4012 d = (U8*)SvPVX(dest) + o;
4014 Copy(tmpbuf, d, ulen, U8);
4019 if (in_iota_subscript) {
4020 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4021 d += capital_iota_len;
4026 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4028 else { /* Not UTF-8 */
4030 const U8 *const send = s + len;
4032 /* Use locale casing if in locale; regular style if not treating
4033 * latin1 as having case; otherwise the latin1 casing. Do the
4034 * whole thing in a tight loop, for speed, */
4035 #ifdef USE_LOCALE_CTYPE
4036 if (IN_LC_RUNTIME(LC_CTYPE)) {
4037 if (IN_UTF8_CTYPE_LOCALE) {
4040 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4041 for (; s < send; d++, s++)
4042 *d = (U8) toUPPER_LC(*s);
4046 if (! IN_UNI_8_BIT) {
4047 for (; s < send; d++, s++) {
4052 #ifdef USE_LOCALE_CTYPE
4055 for (; s < send; d++, s++) {
4056 *d = toUPPER_LATIN1_MOD(*s);
4057 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4061 /* The mainstream case is the tight loop above. To avoid
4062 * extra tests in that, all three characters that require
4063 * special handling are mapped by the MOD to the one tested
4065 * Use the source to distinguish between the three cases */
4067 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4069 /* uc() of this requires 2 characters, but they are
4070 * ASCII. If not enough room, grow the string */
4071 if (SvLEN(dest) < ++min) {
4072 const UV o = d - (U8*)SvPVX_const(dest);
4074 d = (U8*)SvPVX(dest) + o;
4076 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4077 continue; /* Back to the tight loop; still in ASCII */
4080 /* The other two special handling characters have their
4081 * upper cases outside the latin1 range, hence need to be
4082 * in UTF-8, so the whole result needs to be in UTF-8. So,
4083 * here we are somewhere in the middle of processing a
4084 * non-UTF-8 string, and realize that we will have to convert
4085 * the whole thing to UTF-8. What to do? There are
4086 * several possibilities. The simplest to code is to
4087 * convert what we have so far, set a flag, and continue on
4088 * in the loop. The flag would be tested each time through
4089 * the loop, and if set, the next character would be
4090 * converted to UTF-8 and stored. But, I (khw) didn't want
4091 * to slow down the mainstream case at all for this fairly
4092 * rare case, so I didn't want to add a test that didn't
4093 * absolutely have to be there in the loop, besides the
4094 * possibility that it would get too complicated for
4095 * optimizers to deal with. Another possibility is to just
4096 * give up, convert the source to UTF-8, and restart the
4097 * function that way. Another possibility is to convert
4098 * both what has already been processed and what is yet to
4099 * come separately to UTF-8, then jump into the loop that
4100 * handles UTF-8. But the most efficient time-wise of the
4101 * ones I could think of is what follows, and turned out to
4102 * not require much extra code. */
4104 /* Convert what we have so far into UTF-8, telling the
4105 * function that we know it should be converted, and to
4106 * allow extra space for what we haven't processed yet.
4107 * Assume the worst case space requirements for converting
4108 * what we haven't processed so far: that it will require
4109 * two bytes for each remaining source character, plus the
4110 * NUL at the end. This may cause the string pointer to
4111 * move, so re-find it. */
4113 len = d - (U8*)SvPVX_const(dest);
4114 SvCUR_set(dest, len);
4115 len = sv_utf8_upgrade_flags_grow(dest,
4116 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4118 d = (U8*)SvPVX(dest) + len;
4120 /* Now process the remainder of the source, converting to
4121 * upper and UTF-8. If a resulting byte is invariant in
4122 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4123 * append it to the output. */
4124 for (; s < send; s++) {
4125 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4129 /* Here have processed the whole source; no need to continue
4130 * with the outer loop. Each character has been converted
4131 * to upper case and converted to UTF-8 */
4134 } /* End of processing all latin1-style chars */
4135 } /* End of processing all chars */
4136 } /* End of source is not empty */
4138 if (source != dest) {
4139 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4140 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4142 } /* End of isn't utf8 */
4143 #ifdef USE_LOCALE_CTYPE
4144 if (IN_LC_RUNTIME(LC_CTYPE)) {
4149 if (dest != source && SvTAINTED(source))
4167 if ( ( SvPADTMP(source)
4168 || ( SvTEMP(source) && !SvSMAGICAL(source)
4169 && SvREFCNT(source) == 1 )
4171 && !SvREADONLY(source) && SvPOK(source)
4172 && !DO_UTF8(source)) {
4174 /* We can convert in place, as lowercasing anything in the latin1 range
4175 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4177 s = d = (U8*)SvPV_force_nomg(source, len);
4184 s = (const U8*)SvPV_nomg_const(source, len);
4187 SvUPGRADE(dest, SVt_PV);
4188 d = (U8*)SvGROW(dest, min);
4189 (void)SvPOK_only(dest);
4194 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4195 to check DO_UTF8 again here. */
4197 if (DO_UTF8(source)) {
4198 const U8 *const send = s + len;
4199 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4202 const STRLEN u = UTF8SKIP(s);
4205 #ifdef USE_LOCALE_CTYPE
4206 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4208 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4211 /* Here is where we would do context-sensitive actions. See the
4212 * commit message for 86510fb15 for why there isn't any */
4214 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4216 /* If the eventually required minimum size outgrows the
4217 * available space, we need to grow. */
4218 const UV o = d - (U8*)SvPVX_const(dest);
4220 /* If someone lowercases one million U+0130s we SvGROW() one
4221 * million times. Or we could try guessing how much to
4222 * allocate without allocating too much. Such is life.
4223 * Another option would be to grow an extra byte or two more
4224 * each time we need to grow, which would cut down the million
4225 * to 500K, with little waste */
4227 d = (U8*)SvPVX(dest) + o;
4230 /* Copy the newly lowercased letter to the output buffer we're
4232 Copy(tmpbuf, d, ulen, U8);
4235 } /* End of looping through the source string */
4238 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4239 } else { /* Not utf8 */
4241 const U8 *const send = s + len;
4243 /* Use locale casing if in locale; regular style if not treating
4244 * latin1 as having case; otherwise the latin1 casing. Do the
4245 * whole thing in a tight loop, for speed, */
4246 #ifdef USE_LOCALE_CTYPE
4247 if (IN_LC_RUNTIME(LC_CTYPE)) {
4248 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4249 for (; s < send; d++, s++)
4250 *d = toLOWER_LC(*s);
4254 if (! IN_UNI_8_BIT) {
4255 for (; s < send; d++, s++) {
4260 for (; s < send; d++, s++) {
4261 *d = toLOWER_LATIN1(*s);
4265 if (source != dest) {
4267 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4270 #ifdef USE_LOCALE_CTYPE
4271 if (IN_LC_RUNTIME(LC_CTYPE)) {
4276 if (dest != source && SvTAINTED(source))
4285 SV * const sv = TOPs;
4287 const char *s = SvPV_const(sv,len);
4289 SvUTF8_off(TARG); /* decontaminate */
4292 SvUPGRADE(TARG, SVt_PV);
4293 SvGROW(TARG, (len * 2) + 1);
4297 STRLEN ulen = UTF8SKIP(s);
4298 bool to_quote = FALSE;
4300 if (UTF8_IS_INVARIANT(*s)) {
4301 if (_isQUOTEMETA(*s)) {
4305 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4307 #ifdef USE_LOCALE_CTYPE
4308 /* In locale, we quote all non-ASCII Latin1 chars.
4309 * Otherwise use the quoting rules */
4311 IN_LC_RUNTIME(LC_CTYPE)
4314 _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4319 else if (is_QUOTEMETA_high(s)) {
4334 else if (IN_UNI_8_BIT) {
4336 if (_isQUOTEMETA(*s))
4342 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4343 * including everything above ASCII */
4345 if (!isWORDCHAR_A(*s))
4351 SvCUR_set(TARG, d - SvPVX_const(TARG));
4352 (void)SvPOK_only_UTF8(TARG);
4355 sv_setpvn(TARG, s, len);
4371 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4372 const bool full_folding = TRUE; /* This variable is here so we can easily
4373 move to more generality later */
4374 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4375 #ifdef USE_LOCALE_CTYPE
4376 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4380 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4381 * You are welcome(?) -Hugmeir
4389 s = (const U8*)SvPV_nomg_const(source, len);
4391 if (ckWARN(WARN_UNINITIALIZED))
4392 report_uninit(source);
4399 SvUPGRADE(dest, SVt_PV);
4400 d = (U8*)SvGROW(dest, min);
4401 (void)SvPOK_only(dest);
4406 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4408 const STRLEN u = UTF8SKIP(s);
4411 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4413 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4414 const UV o = d - (U8*)SvPVX_const(dest);
4416 d = (U8*)SvPVX(dest) + o;
4419 Copy(tmpbuf, d, ulen, U8);
4424 } /* Unflagged string */
4426 #ifdef USE_LOCALE_CTYPE
4427 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4428 if (IN_UTF8_CTYPE_LOCALE) {
4429 goto do_uni_folding;
4431 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4432 for (; s < send; d++, s++)
4433 *d = (U8) toFOLD_LC(*s);
4437 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4438 for (; s < send; d++, s++)
4442 #ifdef USE_LOCALE_CTYPE
4445 /* For ASCII and the Latin-1 range, there's only two troublesome
4446 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4447 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4448 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4449 * For the rest, the casefold is their lowercase. */
4450 for (; s < send; d++, s++) {
4451 if (*s == MICRO_SIGN) {
4452 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4453 * which is outside of the latin-1 range. There's a couple
4454 * of ways to deal with this -- khw discusses them in
4455 * pp_lc/uc, so go there :) What we do here is upgrade what
4456 * we had already casefolded, then enter an inner loop that
4457 * appends the rest of the characters as UTF-8. */
4458 len = d - (U8*)SvPVX_const(dest);
4459 SvCUR_set(dest, len);
4460 len = sv_utf8_upgrade_flags_grow(dest,
4461 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4462 /* The max expansion for latin1
4463 * chars is 1 byte becomes 2 */
4465 d = (U8*)SvPVX(dest) + len;
4467 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4470 for (; s < send; s++) {
4472 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4473 if UVCHR_IS_INVARIANT(fc) {
4475 && *s == LATIN_SMALL_LETTER_SHARP_S)
4484 Copy(tmpbuf, d, ulen, U8);
4490 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4491 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4492 * becomes "ss", which may require growing the SV. */
4493 if (SvLEN(dest) < ++min) {
4494 const UV o = d - (U8*)SvPVX_const(dest);
4496 d = (U8*)SvPVX(dest) + o;
4501 else { /* If it's not one of those two, the fold is their lower
4503 *d = toLOWER_LATIN1(*s);
4509 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4511 #ifdef USE_LOCALE_CTYPE
4512 if (IN_LC_RUNTIME(LC_CTYPE)) {
4517 if (SvTAINTED(source))
4527 dSP; dMARK; dORIGMARK;
4528 AV *const av = MUTABLE_AV(POPs);
4529 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4531 if (SvTYPE(av) == SVt_PVAV) {
4532 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4533 bool can_preserve = FALSE;
4539 can_preserve = SvCANEXISTDELETE(av);
4542 if (lval && localizing) {
4545 for (svp = MARK + 1; svp <= SP; svp++) {
4546 const SSize_t elem = SvIV(*svp);
4550 if (max > AvMAX(av))
4554 while (++MARK <= SP) {
4556 SSize_t elem = SvIV(*MARK);
4557 bool preeminent = TRUE;
4559 if (localizing && can_preserve) {
4560 /* If we can determine whether the element exist,
4561 * Try to preserve the existenceness of a tied array
4562 * element by using EXISTS and DELETE if possible.
4563 * Fallback to FETCH and STORE otherwise. */
4564 preeminent = av_exists(av, elem);
4567 svp = av_fetch(av, elem, lval);
4570 DIE(aTHX_ PL_no_aelem, elem);
4573 save_aelem(av, elem, svp);
4575 SAVEADELETE(av, elem);
4578 *MARK = svp ? *svp : &PL_sv_undef;
4581 if (GIMME_V != G_ARRAY) {
4583 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4592 AV *const av = MUTABLE_AV(POPs);
4593 I32 lval = (PL_op->op_flags & OPf_MOD);
4594 SSize_t items = SP - MARK;
4596 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4597 const I32 flags = is_lvalue_sub();
4599 if (!(flags & OPpENTERSUB_INARGS))
4600 /* diag_listed_as: Can't modify %s in %s */
4601 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4608 *(MARK+items*2-1) = *(MARK+items);
4614 while (++MARK <= SP) {
4617 svp = av_fetch(av, SvIV(*MARK), lval);
4619 if (!svp || !*svp || *svp == &PL_sv_undef) {
4620 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4622 *MARK = sv_mortalcopy(*MARK);
4624 *++MARK = svp ? *svp : &PL_sv_undef;
4626 if (GIMME_V != G_ARRAY) {
4627 MARK = SP - items*2;
4628 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4635 /* Smart dereferencing for keys, values and each */
4637 /* also used for: pp_reach() pp_rvalues() */
4649 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4654 "Type of argument to %s must be unblessed hashref or arrayref",
4655 PL_op_desc[PL_op->op_type] );
4658 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4660 "Can't modify %s in %s",
4661 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4664 /* Delegate to correct function for op type */
4666 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4667 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4670 return (SvTYPE(sv) == SVt_PVHV)
4671 ? Perl_pp_each(aTHX)
4672 : Perl_pp_aeach(aTHX);
4679 AV *array = MUTABLE_AV(POPs);
4680 const I32 gimme = GIMME_V;
4681 IV *iterp = Perl_av_iter_p(aTHX_ array);
4682 const IV current = (*iterp)++;
4684 if (current > av_tindex(array)) {
4686 if (gimme == G_SCALAR)
4694 if (gimme == G_ARRAY) {
4695 SV **const element = av_fetch(array, current, 0);
4696 PUSHs(element ? *element : &PL_sv_undef);
4701 /* also used for: pp_avalues()*/
4705 AV *array = MUTABLE_AV(POPs);
4706 const I32 gimme = GIMME_V;
4708 *Perl_av_iter_p(aTHX_ array) = 0;
4710 if (gimme == G_SCALAR) {
4712 PUSHi(av_tindex(array) + 1);
4714 else if (gimme == G_ARRAY) {
4715 IV n = Perl_av_len(aTHX_ array);
4720 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4721 for (i = 0; i <= n; i++) {
4726 for (i = 0; i <= n; i++) {
4727 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4728 PUSHs(elem ? *elem : &PL_sv_undef);
4735 /* Associative arrays. */
4740 HV * hash = MUTABLE_HV(POPs);
4742 const I32 gimme = GIMME_V;
4744 entry = hv_iternext(hash);
4748 SV* const sv = hv_iterkeysv(entry);
4750 if (gimme == G_ARRAY) {
4752 val = hv_iterval(hash, entry);
4756 else if (gimme == G_SCALAR)
4763 S_do_delete_local(pTHX)
4766 const I32 gimme = GIMME_V;
4769 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4770 SV **unsliced_keysv = sliced ? NULL : sp--;
4771 SV * const osv = POPs;
4772 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4774 const bool tied = SvRMAGICAL(osv)
4775 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4776 const bool can_preserve = SvCANEXISTDELETE(osv);
4777 const U32 type = SvTYPE(osv);
4778 SV ** const end = sliced ? SP : unsliced_keysv;
4780 if (type == SVt_PVHV) { /* hash element */
4781 HV * const hv = MUTABLE_HV(osv);
4782 while (++MARK <= end) {
4783 SV * const keysv = *MARK;
4785 bool preeminent = TRUE;
4787 preeminent = hv_exists_ent(hv, keysv, 0);
4789 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4796 sv = hv_delete_ent(hv, keysv, 0, 0);
4798 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4801 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4802 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4804 *MARK = sv_mortalcopy(sv);
4810 SAVEHDELETE(hv, keysv);
4811 *MARK = &PL_sv_undef;
4815 else if (type == SVt_PVAV) { /* array element */
4816 if (PL_op->op_flags & OPf_SPECIAL) {
4817 AV * const av = MUTABLE_AV(osv);
4818 while (++MARK <= end) {
4819 SSize_t idx = SvIV(*MARK);
4821 bool preeminent = TRUE;
4823 preeminent = av_exists(av, idx);
4825 SV **svp = av_fetch(av, idx, 1);
4832 sv = av_delete(av, idx, 0);
4834 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4837 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4839 *MARK = sv_mortalcopy(sv);
4845 SAVEADELETE(av, idx);
4846 *MARK = &PL_sv_undef;
4851 DIE(aTHX_ "panic: avhv_delete no longer supported");
4854 DIE(aTHX_ "Not a HASH reference");
4856 if (gimme == G_VOID)
4858 else if (gimme == G_SCALAR) {
4863 *++MARK = &PL_sv_undef;
4867 else if (gimme != G_VOID)
4868 PUSHs(*unsliced_keysv);
4879 if (PL_op->op_private & OPpLVAL_INTRO)
4880 return do_delete_local();
4883 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4885 if (PL_op->op_private & OPpSLICE) {
4887 HV * const hv = MUTABLE_HV(POPs);
4888 const U32 hvtype = SvTYPE(hv);
4889 if (hvtype == SVt_PVHV) { /* hash element */
4890 while (++MARK <= SP) {
4891 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4892 *MARK = sv ? sv : &PL_sv_undef;
4895 else if (hvtype == SVt_PVAV) { /* array element */
4896 if (PL_op->op_flags & OPf_SPECIAL) {
4897 while (++MARK <= SP) {
4898 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4899 *MARK = sv ? sv : &PL_sv_undef;
4904 DIE(aTHX_ "Not a HASH reference");
4907 else if (gimme == G_SCALAR) {
4912 *++MARK = &PL_sv_undef;
4918 HV * const hv = MUTABLE_HV(POPs);
4920 if (SvTYPE(hv) == SVt_PVHV)
4921 sv = hv_delete_ent(hv, keysv, discard, 0);
4922 else if (SvTYPE(hv) == SVt_PVAV) {
4923 if (PL_op->op_flags & OPf_SPECIAL)
4924 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4926 DIE(aTHX_ "panic: avhv_delete no longer supported");
4929 DIE(aTHX_ "Not a HASH reference");
4944 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4946 SV * const sv = POPs;
4947 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4950 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4955 hv = MUTABLE_HV(POPs);
4956 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4957 if (hv_exists_ent(hv, tmpsv, 0))
4960 else if (SvTYPE(hv) == SVt_PVAV) {
4961 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4962 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4967 DIE(aTHX_ "Not a HASH reference");
4974 dSP; dMARK; dORIGMARK;
4975 HV * const hv = MUTABLE_HV(POPs);
4976 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4977 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4978 bool can_preserve = FALSE;
4984 if (SvCANEXISTDELETE(hv))
4985 can_preserve = TRUE;
4988 while (++MARK <= SP) {
4989 SV * const keysv = *MARK;
4992 bool preeminent = TRUE;
4994 if (localizing && can_preserve) {
4995 /* If we can determine whether the element exist,
4996 * try to preserve the existenceness of a tied hash
4997 * element by using EXISTS and DELETE if possible.
4998 * Fallback to FETCH and STORE otherwise. */
4999 preeminent = hv_exists_ent(hv, keysv, 0);
5002 he = hv_fetch_ent(hv, keysv, lval, 0);
5003 svp = he ? &HeVAL(he) : NULL;
5006 if (!svp || !*svp || *svp == &PL_sv_undef) {
5007 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5010 if (HvNAME_get(hv) && isGV(*svp))
5011 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5012 else if (preeminent)
5013 save_helem_flags(hv, keysv, svp,
5014 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5016 SAVEHDELETE(hv, keysv);
5019 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5021 if (GIMME_V != G_ARRAY) {
5023 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5032 HV * const hv = MUTABLE_HV(POPs);
5033 I32 lval = (PL_op->op_flags & OPf_MOD);
5034 SSize_t items = SP - MARK;
5036 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5037 const I32 flags = is_lvalue_sub();
5039 if (!(flags & OPpENTERSUB_INARGS))
5040 /* diag_listed_as: Can't modify %s in %s */
5041 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
5048 *(MARK+items*2-1) = *(MARK+items);
5054 while (++MARK <= SP) {
5055 SV * const keysv = *MARK;
5059 he = hv_fetch_ent(hv, keysv, lval, 0);
5060 svp = he ? &HeVAL(he) : NULL;
5063 if (!svp || !*svp || *svp == &PL_sv_undef) {
5064 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5066 *MARK = sv_mortalcopy(*MARK);
5068 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5070 if (GIMME_V != G_ARRAY) {
5071 MARK = SP - items*2;
5072 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5078 /* List operators. */
5082 I32 markidx = POPMARK;
5083 if (GIMME_V != G_ARRAY) {
5084 SV **mark = PL_stack_base + markidx;
5087 *MARK = *SP; /* unwanted list, return last item */
5089 *MARK = &PL_sv_undef;
5099 SV ** const lastrelem = PL_stack_sp;
5100 SV ** const lastlelem = PL_stack_base + POPMARK;
5101 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5102 SV ** const firstrelem = lastlelem + 1;
5103 const U8 mod = PL_op->op_flags & OPf_MOD;
5105 const I32 max = lastrelem - lastlelem;
5108 if (GIMME_V != G_ARRAY) {
5109 I32 ix = SvIV(*lastlelem);
5112 if (ix < 0 || ix >= max)
5113 *firstlelem = &PL_sv_undef;
5115 *firstlelem = firstrelem[ix];
5121 SP = firstlelem - 1;
5125 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5126 I32 ix = SvIV(*lelem);
5129 if (ix < 0 || ix >= max)
5130 *lelem = &PL_sv_undef;
5132 if (!(*lelem = firstrelem[ix]))
5133 *lelem = &PL_sv_undef;
5134 else if (mod && SvPADTMP(*lelem)) {
5135 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5146 const I32 items = SP - MARK;
5147 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5149 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5150 ? newRV_noinc(av) : av);
5156 dSP; dMARK; dORIGMARK;
5157 HV* const hv = newHV();
5158 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5159 ? newRV_noinc(MUTABLE_SV(hv))
5164 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5171 sv_setsv_nomg(val, *MARK);
5175 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5178 (void)hv_store_ent(hv,key,val,0);
5186 S_deref_plain_array(pTHX_ AV *ary)
5188 if (SvTYPE(ary) == SVt_PVAV) return ary;
5189 SvGETMAGIC((SV *)ary);
5190 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5191 Perl_die(aTHX_ "Not an ARRAY reference");
5192 else if (SvOBJECT(SvRV(ary)))
5193 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5194 return (AV *)SvRV(ary);
5197 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5198 # define DEREF_PLAIN_ARRAY(ary) \
5201 SvTYPE(aRrRay) == SVt_PVAV \
5203 : S_deref_plain_array(aTHX_ aRrRay); \
5206 # define DEREF_PLAIN_ARRAY(ary) \
5208 PL_Sv = (SV *)(ary), \
5209 SvTYPE(PL_Sv) == SVt_PVAV \
5211 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5217 dSP; dMARK; dORIGMARK;
5218 int num_args = (SP - MARK);
5219 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5228 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5231 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5232 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5239 offset = i = SvIV(*MARK);
5241 offset += AvFILLp(ary) + 1;
5243 DIE(aTHX_ PL_no_aelem, i);
5245 length = SvIVx(*MARK++);
5247 length += AvFILLp(ary) - offset + 1;
5253 length = AvMAX(ary) + 1; /* close enough to infinity */
5257 length = AvMAX(ary) + 1;
5259 if (offset > AvFILLp(ary) + 1) {
5261 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5262 offset = AvFILLp(ary) + 1;
5264 after = AvFILLp(ary) + 1 - (offset + length);
5265 if (after < 0) { /* not that much array */
5266 length += after; /* offset+length now in array */
5272 /* At this point, MARK .. SP-1 is our new LIST */
5275 diff = newlen - length;
5276 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5279 /* make new elements SVs now: avoid problems if they're from the array */
5280 for (dst = MARK, i = newlen; i; i--) {
5281 SV * const h = *dst;
5282 *dst++ = newSVsv(h);
5285 if (diff < 0) { /* shrinking the area */
5286 SV **tmparyval = NULL;
5288 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5289 Copy(MARK, tmparyval, newlen, SV*);
5292 MARK = ORIGMARK + 1;
5293 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5294 const bool real = cBOOL(AvREAL(ary));
5295 MEXTEND(MARK, length);
5297 EXTEND_MORTAL(length);
5298 for (i = 0, dst = MARK; i < length; i++) {
5299 if ((*dst = AvARRAY(ary)[i+offset])) {
5301 sv_2mortal(*dst); /* free them eventually */
5304 *dst = &PL_sv_undef;
5310 *MARK = AvARRAY(ary)[offset+length-1];
5313 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5314 SvREFCNT_dec(*dst++); /* free them now */
5317 AvFILLp(ary) += diff;
5319 /* pull up or down? */
5321 if (offset < after) { /* easier to pull up */
5322 if (offset) { /* esp. if nothing to pull */
5323 src = &AvARRAY(ary)[offset-1];
5324 dst = src - diff; /* diff is negative */
5325 for (i = offset; i > 0; i--) /* can't trust Copy */
5329 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5333 if (after) { /* anything to pull down? */
5334 src = AvARRAY(ary) + offset + length;
5335 dst = src + diff; /* diff is negative */
5336 Move(src, dst, after, SV*);
5338 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5339 /* avoid later double free */
5346 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5347 Safefree(tmparyval);
5350 else { /* no, expanding (or same) */
5351 SV** tmparyval = NULL;
5353 Newx(tmparyval, length, SV*); /* so remember deletion */
5354 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5357 if (diff > 0) { /* expanding */
5358 /* push up or down? */
5359 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5363 Move(src, dst, offset, SV*);
5365 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5367 AvFILLp(ary) += diff;
5370 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5371 av_extend(ary, AvFILLp(ary) + diff);
5372 AvFILLp(ary) += diff;
5375 dst = AvARRAY(ary) + AvFILLp(ary);
5377 for (i = after; i; i--) {
5385 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5388 MARK = ORIGMARK + 1;
5389 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5391 const bool real = cBOOL(AvREAL(ary));
5393 EXTEND_MORTAL(length);
5394 for (i = 0, dst = MARK; i < length; i++) {
5395 if ((*dst = tmparyval[i])) {
5397 sv_2mortal(*dst); /* free them eventually */
5399 else *dst = &PL_sv_undef;
5405 else if (length--) {
5406 *MARK = tmparyval[length];
5409 while (length-- > 0)
5410 SvREFCNT_dec(tmparyval[length]);
5414 *MARK = &PL_sv_undef;
5415 Safefree(tmparyval);
5419 mg_set(MUTABLE_SV(ary));
5427 dSP; dMARK; dORIGMARK; dTARGET;
5428 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5429 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5432 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5435 ENTER_with_name("call_PUSH");
5436 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5437 LEAVE_with_name("call_PUSH");
5441 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5442 PL_delaymagic = DM_DELAY;
5443 for (++MARK; MARK <= SP; MARK++) {
5445 if (*MARK) SvGETMAGIC(*MARK);
5448 sv_setsv_nomg(sv, *MARK);
5449 av_store(ary, AvFILLp(ary)+1, sv);
5451 if (PL_delaymagic & DM_ARRAY_ISA)
5452 mg_set(MUTABLE_SV(ary));
5457 if (OP_GIMME(PL_op, 0) != G_VOID) {
5458 PUSHi( AvFILL(ary) + 1 );
5463 /* also used for: pp_pop()*/
5467 AV * const av = PL_op->op_flags & OPf_SPECIAL
5468 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5469 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5473 (void)sv_2mortal(sv);
5480 dSP; dMARK; dORIGMARK; dTARGET;
5481 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5482 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5485 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5488 ENTER_with_name("call_UNSHIFT");
5489 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5490 LEAVE_with_name("call_UNSHIFT");
5495 av_unshift(ary, SP - MARK);
5497 SV * const sv = newSVsv(*++MARK);
5498 (void)av_store(ary, i++, sv);
5502 if (OP_GIMME(PL_op, 0) != G_VOID) {
5503 PUSHi( AvFILL(ary) + 1 );
5512 if (GIMME_V == G_ARRAY) {
5513 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5517 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5518 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5519 av = MUTABLE_AV((*SP));
5520 /* In-place reversing only happens in void context for the array
5521 * assignment. We don't need to push anything on the stack. */
5524 if (SvMAGICAL(av)) {
5526 SV *tmp = sv_newmortal();
5527 /* For SvCANEXISTDELETE */
5530 bool can_preserve = SvCANEXISTDELETE(av);
5532 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5536 if (!av_exists(av, i)) {
5537 if (av_exists(av, j)) {
5538 SV *sv = av_delete(av, j, 0);
5539 begin = *av_fetch(av, i, TRUE);
5540 sv_setsv_mg(begin, sv);
5544 else if (!av_exists(av, j)) {
5545 SV *sv = av_delete(av, i, 0);
5546 end = *av_fetch(av, j, TRUE);
5547 sv_setsv_mg(end, sv);
5552 begin = *av_fetch(av, i, TRUE);
5553 end = *av_fetch(av, j, TRUE);
5554 sv_setsv(tmp, begin);
5555 sv_setsv_mg(begin, end);
5556 sv_setsv_mg(end, tmp);
5560 SV **begin = AvARRAY(av);
5563 SV **end = begin + AvFILLp(av);
5565 while (begin < end) {
5566 SV * const tmp = *begin;
5577 SV * const tmp = *MARK;
5581 /* safe as long as stack cannot get extended in the above */
5592 SvUTF8_off(TARG); /* decontaminate */
5594 do_join(TARG, &PL_sv_no, MARK, SP);
5596 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5599 up = SvPV_force(TARG, len);
5601 if (DO_UTF8(TARG)) { /* first reverse each character */
5602 U8* s = (U8*)SvPVX(TARG);
5603 const U8* send = (U8*)(s + len);
5605 if (UTF8_IS_INVARIANT(*s)) {
5610 if (!utf8_to_uvchr_buf(s, send, 0))
5614 down = (char*)(s - 1);
5615 /* reverse this character */
5619 *down-- = (char)tmp;
5625 down = SvPVX(TARG) + len - 1;
5629 *down-- = (char)tmp;
5631 (void)SvPOK_only_UTF8(TARG);
5642 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5643 IV limit = POPi; /* note, negative is forever */
5644 SV * const sv = POPs;
5646 const char *s = SvPV_const(sv, len);
5647 const bool do_utf8 = DO_UTF8(sv);
5648 const char *strend = s + len;
5654 const STRLEN slen = do_utf8
5655 ? utf8_length((U8*)s, (U8*)strend)
5656 : (STRLEN)(strend - s);
5657 SSize_t maxiters = slen + 10;
5658 I32 trailing_empty = 0;
5660 const I32 origlimit = limit;
5663 const I32 gimme = GIMME_V;
5665 const I32 oldsave = PL_savestack_ix;
5666 U32 make_mortal = SVs_TEMP;
5671 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5676 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5679 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5680 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5683 if (pm->op_pmreplrootu.op_pmtargetoff) {
5684 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5688 if (pm->op_pmreplrootu.op_pmtargetgv) {
5689 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5693 else if (pm->op_targ)
5694 ary = (AV *)PAD_SVl(pm->op_targ);
5700 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5703 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5705 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5712 for (i = AvFILLp(ary); i >= 0; i--)
5713 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5715 /* temporarily switch stacks */
5716 SAVESWITCHSTACK(PL_curstack, ary);
5720 base = SP - PL_stack_base;
5722 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5724 while (isSPACE_utf8(s))
5727 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5728 while (isSPACE_LC(*s))
5736 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5740 gimme_scalar = gimme == G_SCALAR && !ary;
5743 limit = maxiters + 2;
5744 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5747 /* this one uses 'm' and is a negative test */
5749 while (m < strend && ! isSPACE_utf8(m) ) {
5750 const int t = UTF8SKIP(m);
5751 /* isSPACE_utf8 returns FALSE for malform utf8 */
5758 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5760 while (m < strend && !isSPACE_LC(*m))
5763 while (m < strend && !isSPACE(*m))
5776 dstr = newSVpvn_flags(s, m-s,
5777 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5781 /* skip the whitespace found last */
5783 s = m + UTF8SKIP(m);
5787 /* this one uses 's' and is a positive test */
5789 while (s < strend && isSPACE_utf8(s) )
5792 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5794 while (s < strend && isSPACE_LC(*s))
5797 while (s < strend && isSPACE(*s))
5802 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5804 for (m = s; m < strend && *m != '\n'; m++)
5817 dstr = newSVpvn_flags(s, m-s,
5818 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5824 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5826 Pre-extend the stack, either the number of bytes or
5827 characters in the string or a limited amount, triggered by:
5829 my ($x, $y) = split //, $str;
5833 if (!gimme_scalar) {
5834 const U32 items = limit - 1;
5843 /* keep track of how many bytes we skip over */
5853 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5866 dstr = newSVpvn(s, 1);
5882 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5883 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5884 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5885 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5886 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5887 SV * const csv = CALLREG_INTUIT_STRING(rx);
5889 len = RX_MINLENRET(rx);
5890 if (len == 1 && !RX_UTF8(rx) && !tail) {
5891 const char c = *SvPV_nolen_const(csv);
5893 for (m = s; m < strend && *m != c; m++)
5904 dstr = newSVpvn_flags(s, m-s,
5905 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5908 /* The rx->minlen is in characters but we want to step
5909 * s ahead by bytes. */
5911 s = (char*)utf8_hop((U8*)m, len);
5913 s = m + len; /* Fake \n at the end */
5917 while (s < strend && --limit &&
5918 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5919 csv, multiline ? FBMrf_MULTILINE : 0)) )
5928 dstr = newSVpvn_flags(s, m-s,
5929 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5932 /* The rx->minlen is in characters but we want to step
5933 * s ahead by bytes. */
5935 s = (char*)utf8_hop((U8*)m, len);
5937 s = m + len; /* Fake \n at the end */
5942 maxiters += slen * RX_NPARENS(rx);
5943 while (s < strend && --limit)
5947 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5950 if (rex_return == 0)
5952 TAINT_IF(RX_MATCH_TAINTED(rx));
5953 /* we never pass the REXEC_COPY_STR flag, so it should
5954 * never get copied */
5955 assert(!RX_MATCH_COPIED(rx));
5956 m = RX_OFFS(rx)[0].start + orig;
5965 dstr = newSVpvn_flags(s, m-s,
5966 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5969 if (RX_NPARENS(rx)) {
5971 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5972 s = RX_OFFS(rx)[i].start + orig;
5973 m = RX_OFFS(rx)[i].end + orig;
5975 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5976 parens that didn't match -- they should be set to
5977 undef, not the empty string */
5985 if (m >= orig && s >= orig) {
5986 dstr = newSVpvn_flags(s, m-s,
5987 (do_utf8 ? SVf_UTF8 : 0)
5991 dstr = &PL_sv_undef; /* undef, not "" */
5997 s = RX_OFFS(rx)[0].end + orig;
6001 if (!gimme_scalar) {
6002 iters = (SP - PL_stack_base) - base;
6004 if (iters > maxiters)
6005 DIE(aTHX_ "Split loop");
6007 /* keep field after final delim? */
6008 if (s < strend || (iters && origlimit)) {
6009 if (!gimme_scalar) {
6010 const STRLEN l = strend - s;
6011 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6016 else if (!origlimit) {
6018 iters -= trailing_empty;
6020 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6021 if (TOPs && !make_mortal)
6023 *SP-- = &PL_sv_undef;
6030 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6034 if (SvSMAGICAL(ary)) {
6036 mg_set(MUTABLE_SV(ary));
6039 if (gimme == G_ARRAY) {
6041 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6048 ENTER_with_name("call_PUSH");
6049 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6050 LEAVE_with_name("call_PUSH");
6052 if (gimme == G_ARRAY) {
6054 /* EXTEND should not be needed - we just popped them */
6056 for (i=0; i < iters; i++) {
6057 SV **svp = av_fetch(ary, i, FALSE);
6058 PUSHs((svp) ? *svp : &PL_sv_undef);
6065 if (gimme == G_ARRAY)
6077 SV *const sv = PAD_SVl(PL_op->op_targ);
6079 if (SvPADSTALE(sv)) {
6082 RETURNOP(cLOGOP->op_other);
6084 RETURNOP(cLOGOP->op_next);
6093 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6094 || SvTYPE(retsv) == SVt_PVCV) {
6095 retsv = refto(retsv);
6102 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
6103 * that aren't implemented on a particular platform */
6105 PP(unimplemented_op)
6107 const Optype op_type = PL_op->op_type;
6108 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6109 with out of range op numbers - it only "special" cases op_custom.
6110 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6111 if we get here for a custom op then that means that the custom op didn't
6112 have an implementation. Given that OP_NAME() looks up the custom op
6113 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6114 registers &PL_unimplemented_op as the address of their custom op.
6115 NULL doesn't generate a useful error message. "custom" does. */
6116 const char *const name = op_type >= OP_max
6117 ? "[out of range]" : PL_op_name[PL_op->op_type];
6118 if(OP_IS_SOCKET(op_type))
6119 DIE(aTHX_ PL_no_sock_func, name);
6120 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6123 /* For sorting out arguments passed to a &CORE:: subroutine */
6127 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6128 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6129 AV * const at_ = GvAV(PL_defgv);
6130 SV **svp = at_ ? AvARRAY(at_) : NULL;
6131 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6132 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6133 bool seen_question = 0;
6134 const char *err = NULL;
6135 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6137 /* Count how many args there are first, to get some idea how far to
6138 extend the stack. */
6140 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6142 if (oa & OA_OPTIONAL) seen_question = 1;
6143 if (!seen_question) minargs++;
6147 if(numargs < minargs) err = "Not enough";
6148 else if(numargs > maxargs) err = "Too many";
6150 /* diag_listed_as: Too many arguments for %s */
6152 "%s arguments for %s", err,
6153 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6156 /* Reset the stack pointer. Without this, we end up returning our own
6157 arguments in list context, in addition to the values we are supposed
6158 to return. nextstate usually does this on sub entry, but we need
6159 to run the next op with the caller's hints, so we cannot have a
6161 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6163 if(!maxargs) RETURN;
6165 /* We do this here, rather than with a separate pushmark op, as it has
6166 to come in between two things this function does (stack reset and
6167 arg pushing). This seems the easiest way to do it. */
6170 (void)Perl_pp_pushmark(aTHX);
6173 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6174 PUTBACK; /* The code below can die in various places. */
6176 oa = PL_opargs[opnum] >> OASHIFT;
6177 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6182 if (!numargs && defgv && whicharg == minargs + 1) {
6183 PUSHs(find_rundefsv2(
6184 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6185 cxstack[cxstack_ix].blk_oldcop->cop_seq
6188 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6192 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6197 if (!svp || !*svp || !SvROK(*svp)
6198 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6200 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6201 "Type of arg %d to &CORE::%s must be hash reference",
6202 whicharg, OP_DESC(PL_op->op_next)
6207 if (!numargs) PUSHs(NULL);
6208 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6209 /* no magic here, as the prototype will have added an extra
6210 refgen and we just want what was there before that */
6213 const bool constr = PL_op->op_private & whicharg;
6215 svp && *svp ? *svp : &PL_sv_undef,
6216 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6222 if (!numargs) goto try_defsv;
6224 const bool wantscalar =
6225 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6226 if (!svp || !*svp || !SvROK(*svp)
6227 /* We have to permit globrefs even for the \$ proto, as
6228 *foo is indistinguishable from ${\*foo}, and the proto-
6229 type permits the latter. */
6230 || SvTYPE(SvRV(*svp)) > (
6231 wantscalar ? SVt_PVLV
6232 : opnum == OP_LOCK || opnum == OP_UNDEF
6238 "Type of arg %d to &CORE::%s must be %s",
6239 whicharg, PL_op_name[opnum],
6241 ? "scalar reference"
6242 : opnum == OP_LOCK || opnum == OP_UNDEF
6243 ? "reference to one of [$@%&*]"
6244 : "reference to one of [$@%*]"
6247 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6248 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6249 /* Undo @_ localisation, so that sub exit does not undo
6250 part of our undeffing. */
6251 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6253 cx->cx_type &= ~ CXp_HASARGS;
6254 assert(!AvREAL(cx->blk_sub.argarray));
6259 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6271 if (PL_op->op_private & OPpOFFBYONE) {
6272 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6274 else cv = find_runcv(NULL);
6275 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6280 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6281 const bool can_preserve)
6283 const SSize_t ix = SvIV(keysv);
6284 if (can_preserve ? av_exists(av, ix) : TRUE) {
6285 SV ** const svp = av_fetch(av, ix, 1);
6287 Perl_croak(aTHX_ PL_no_aelem, ix);
6288 save_aelem(av, ix, svp);
6291 SAVEADELETE(av, ix);
6295 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6296 const bool can_preserve)
6298 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6299 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6300 SV ** const svp = he ? &HeVAL(he) : NULL;
6302 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6303 save_helem_flags(hv, keysv, svp, 0);
6306 SAVEHDELETE(hv, keysv);
6310 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6312 if (type == OPpLVREF_SV) {
6313 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6316 else if (type == OPpLVREF_AV)
6317 /* XXX Inefficient, as it creates a new AV, which we are
6318 about to clobber. */
6321 assert(type == OPpLVREF_HV);
6322 /* XXX Likewise inefficient. */
6331 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6332 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6334 const char *bad = NULL;
6335 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6336 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6339 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6343 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6347 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6351 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6355 /* diag_listed_as: Assigned value is not %s reference */
6356 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6360 switch (left ? SvTYPE(left) : 0) {
6363 SV * const old = PAD_SV(ARGTARG);
6364 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6366 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6368 SAVECLEARSV(PAD_SVl(ARGTARG));
6372 if (PL_op->op_private & OPpLVAL_INTRO) {
6373 S_localise_gv_slot(aTHX_ (GV *)left, type);
6375 gv_setref(left, sv);
6379 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6380 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6381 SvCANEXISTDELETE(left));
6383 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6386 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6387 S_localise_helem_lval(aTHX_ (HV *)left, key,
6388 SvCANEXISTDELETE(left));
6389 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6391 if (PL_op->op_flags & OPf_MOD)
6392 SETs(sv_2mortal(newSVsv(sv)));
6393 /* XXX else can weak references go stale before they are read, e.g.,
6402 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6403 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6404 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6405 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6406 &PL_vtbl_lvref, (char *)elem,
6407 elem ? HEf_SVKEY : (I32)ARGTARG);
6408 mg->mg_private = PL_op->op_private;
6409 if (PL_op->op_private & OPpLVREF_ITER)
6410 mg->mg_flags |= MGf_PERSIST;
6411 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6415 const bool can_preserve = SvCANEXISTDELETE(arg);
6416 if (SvTYPE(arg) == SVt_PVAV)
6417 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6419 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6422 S_localise_gv_slot(aTHX_ (GV *)arg,
6423 PL_op->op_private & OPpLVREF_TYPE);
6425 else if (!(PL_op->op_private & OPpPAD_STATE))
6426 SAVECLEARSV(PAD_SVl(ARGTARG));
6435 AV * const av = (AV *)POPs;
6436 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6437 bool can_preserve = FALSE;
6439 if (UNLIKELY(localizing)) {
6444 can_preserve = SvCANEXISTDELETE(av);
6446 if (SvTYPE(av) == SVt_PVAV) {
6449 for (svp = MARK + 1; svp <= SP; svp++) {
6450 const SSize_t elem = SvIV(*svp);
6454 if (max > AvMAX(av))
6459 while (++MARK <= SP) {
6460 SV * const elemsv = *MARK;
6461 if (SvTYPE(av) == SVt_PVAV)
6462 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6464 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6465 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6466 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6473 if (PL_op->op_flags & OPf_STACKED)
6474 Perl_pp_rv2av(aTHX);
6476 Perl_pp_padav(aTHX);
6480 SETs(0); /* special alias marker that aassign recognises */
6490 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6491 ? CopSTASH(PL_curcop)
6493 NULL, SvREFCNT_inc_simple_NN(sv))));
6499 * c-indentation-style: bsd
6501 * indent-tabs-mode: nil
6504 * ex: set ts=8 sts=4 sw=4 et: