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 == 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 == 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 switch (SvTYPE(sv)) {
381 DIE(aTHX_ "Not a SCALAR reference");
388 if (!isGV_with_GP(gv)) {
389 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
395 if (PL_op->op_flags & OPf_MOD) {
396 if (PL_op->op_private & OPpLVAL_INTRO) {
397 if (cUNOP->op_first->op_type == OP_NULL)
398 sv = save_scalar(MUTABLE_GV(TOPs));
400 sv = save_scalar(gv);
402 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
404 else if (PL_op->op_private & OPpDEREF)
405 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
414 AV * const av = MUTABLE_AV(TOPs);
415 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
417 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
419 *svp = newSV_type(SVt_PVMG);
420 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
424 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
433 if (PL_op->op_flags & OPf_MOD || LVRET) {
434 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
435 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
437 LvTARG(ret) = SvREFCNT_inc_simple(sv);
438 PUSHs(ret); /* no SvSETMAGIC */
442 const MAGIC * const mg = mg_find_mglob(sv);
443 if (mg && mg->mg_len != -1) {
445 STRLEN i = mg->mg_len;
446 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
447 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
460 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
462 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
463 == OPpMAY_RETURN_CONSTANT)
466 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
467 /* (But not in defined().) */
469 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
471 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
472 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
473 ? MUTABLE_CV(SvRV(gv))
477 cv = MUTABLE_CV(&PL_sv_undef);
478 SETs(MUTABLE_SV(cv));
488 SV *ret = &PL_sv_undef;
490 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
491 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
492 const char * s = SvPVX_const(TOPs);
493 if (strnEQ(s, "CORE::", 6)) {
494 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
496 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
497 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
499 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
505 cv = sv_2cv(TOPs, &stash, &gv, 0);
507 ret = newSVpvn_flags(
508 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
518 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
520 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
522 PUSHs(MUTABLE_SV(cv));
536 if (GIMME != G_ARRAY) {
540 *MARK = &PL_sv_undef;
541 *MARK = refto(*MARK);
545 EXTEND_MORTAL(SP - MARK);
547 *MARK = refto(*MARK);
552 S_refto(pTHX_ SV *sv)
556 PERL_ARGS_ASSERT_REFTO;
558 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
561 if (!(sv = LvTARG(sv)))
564 SvREFCNT_inc_void_NN(sv);
566 else if (SvTYPE(sv) == SVt_PVAV) {
567 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
568 av_reify(MUTABLE_AV(sv));
570 SvREFCNT_inc_void_NN(sv);
572 else if (SvPADTMP(sv)) {
577 SvREFCNT_inc_void_NN(sv);
580 sv_upgrade(rv, SVt_IV);
589 SV * const sv = TOPs;
597 /* use the return value that is in a register, its the same as TARG */
598 TARG = sv_ref(TARG,SvRV(sv),TRUE);
613 stash = CopSTASH(PL_curcop);
614 if (SvTYPE(stash) != SVt_PVHV)
615 Perl_croak(aTHX_ "Attempt to bless into a freed package");
618 SV * const ssv = POPs;
622 if (!ssv) goto curstash;
625 if (!SvAMAGIC(ssv)) {
627 Perl_croak(aTHX_ "Attempt to bless into a reference");
629 /* SvAMAGIC is on here, but it only means potentially overloaded,
630 so after stringification: */
631 ptr = SvPV_nomg_const(ssv,len);
632 /* We need to check the flag again: */
633 if (!SvAMAGIC(ssv)) goto frog;
635 else ptr = SvPV_nomg_const(ssv,len);
637 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
638 "Explicit blessing to '' (assuming package main)");
639 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
642 (void)sv_bless(TOPs, stash);
652 const char * const elem = SvPV_const(sv, len);
653 GV * const gv = MUTABLE_GV(POPs);
658 /* elem will always be NUL terminated. */
659 const char * const second_letter = elem + 1;
662 if (len == 5 && strEQ(second_letter, "RRAY"))
664 tmpRef = MUTABLE_SV(GvAV(gv));
665 if (tmpRef && !AvREAL((const AV *)tmpRef)
666 && AvREIFY((const AV *)tmpRef))
667 av_reify(MUTABLE_AV(tmpRef));
671 if (len == 4 && strEQ(second_letter, "ODE"))
672 tmpRef = MUTABLE_SV(GvCVu(gv));
675 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
676 /* finally deprecated in 5.8.0 */
677 deprecate("*glob{FILEHANDLE}");
678 tmpRef = MUTABLE_SV(GvIOp(gv));
681 if (len == 6 && strEQ(second_letter, "ORMAT"))
682 tmpRef = MUTABLE_SV(GvFORM(gv));
685 if (len == 4 && strEQ(second_letter, "LOB"))
686 tmpRef = MUTABLE_SV(gv);
689 if (len == 4 && strEQ(second_letter, "ASH"))
690 tmpRef = MUTABLE_SV(GvHV(gv));
693 if (*second_letter == 'O' && !elem[2] && len == 2)
694 tmpRef = MUTABLE_SV(GvIOp(gv));
697 if (len == 4 && strEQ(second_letter, "AME"))
698 sv = newSVhek(GvNAME_HEK(gv));
701 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
702 const HV * const stash = GvSTASH(gv);
703 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
704 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
708 if (len == 6 && strEQ(second_letter, "CALAR"))
723 /* Pattern matching */
731 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
732 /* Historically, study was skipped in these cases. */
736 /* Make study a no-op. It's no longer useful and its existence
737 complicates matters elsewhere. */
742 /* also used for: pp_transr() */
749 if (PL_op->op_flags & OPf_STACKED)
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 TARG = sv_newmortal();
771 /* Lvalue operators. */
774 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
780 PERL_ARGS_ASSERT_DO_CHOMP;
782 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
784 if (SvTYPE(sv) == SVt_PVAV) {
786 AV *const av = MUTABLE_AV(sv);
787 const I32 max = AvFILL(av);
789 for (i = 0; i <= max; i++) {
790 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
791 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
792 count += do_chomp(retval, sv, chomping);
796 else if (SvTYPE(sv) == SVt_PVHV) {
797 HV* const hv = MUTABLE_HV(sv);
799 (void)hv_iterinit(hv);
800 while ((entry = hv_iternext(hv)))
801 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
804 else if (SvREADONLY(sv)) {
805 Perl_croak_no_modify();
810 /* XXX, here sv is utf8-ized as a side-effect!
811 If encoding.pm is used properly, almost string-generating
812 operations, including literal strings, chr(), input data, etc.
813 should have been utf8-ized already, right?
815 sv_recode_to_utf8(sv, _get_encoding());
821 char *temp_buffer = NULL;
830 while (len && s[-1] == '\n') {
837 STRLEN rslen, rs_charlen;
838 const char *rsptr = SvPV_const(PL_rs, rslen);
840 rs_charlen = SvUTF8(PL_rs)
844 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
845 /* Assumption is that rs is shorter than the scalar. */
847 /* RS is utf8, scalar is 8 bit. */
849 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
852 /* Cannot downgrade, therefore cannot possibly match
854 assert (temp_buffer == rsptr);
860 else if (IN_ENCODING) {
861 /* RS is 8 bit, encoding.pm is used.
862 * Do not recode PL_rs as a side-effect. */
863 svrecode = newSVpvn(rsptr, rslen);
864 sv_recode_to_utf8(svrecode, _get_encoding());
865 rsptr = SvPV_const(svrecode, rslen);
866 rs_charlen = sv_len_utf8(svrecode);
869 /* RS is 8 bit, scalar is utf8. */
870 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
884 if (memNE(s, rsptr, rslen))
889 SvPV_force_nomg_nolen(sv);
897 SvREFCNT_dec(svrecode);
899 Safefree(temp_buffer);
901 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
902 s = SvPV_force_nomg(sv, len);
905 char * const send = s + len;
906 char * const start = s;
908 while (s > start && UTF8_IS_CONTINUATION(*s))
910 if (is_utf8_string((U8*)s, send - s)) {
911 sv_setpvn(retval, s, send - s);
913 SvCUR_set(sv, s - start);
919 sv_setpvs(retval, "");
923 sv_setpvn(retval, s, 1);
930 sv_setpvs(retval, "");
937 /* also used for: pp_schomp() */
942 const bool chomping = PL_op->op_type == OP_SCHOMP;
944 const size_t count = do_chomp(TARG, TOPs, chomping);
946 sv_setiv(TARG, count);
952 /* also used for: pp_chomp() */
956 dSP; dMARK; dTARGET; dORIGMARK;
957 const bool chomping = PL_op->op_type == OP_CHOMP;
961 count += do_chomp(TARG, *++MARK, chomping);
963 sv_setiv(TARG, count);
974 if (!PL_op->op_private) {
983 if (SvTHINKFIRST(sv))
984 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
986 switch (SvTYPE(sv)) {
990 av_undef(MUTABLE_AV(sv));
993 hv_undef(MUTABLE_HV(sv));
996 if (cv_const_sv((const CV *)sv))
997 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
998 "Constant subroutine %"SVf" undefined",
999 SVfARG(CvANON((const CV *)sv)
1000 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1001 : sv_2mortal(newSVhek(
1003 ? CvNAME_HEK((CV *)sv)
1004 : GvENAME_HEK(CvGV((const CV *)sv))
1009 /* let user-undef'd sub keep its identity */
1010 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1013 assert(isGV_with_GP(sv));
1014 assert(!SvFAKE(sv));
1019 /* undef *Pkg::meth_name ... */
1021 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1022 && HvENAME_get(stash);
1024 if((stash = GvHV((const GV *)sv))) {
1025 if(HvENAME_get(stash))
1026 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1030 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1031 gp_free(MUTABLE_GV(sv));
1033 GvGP_set(sv, gp_ref(gp));
1034 #ifndef PERL_DONT_CREATE_GVSV
1035 GvSV(sv) = newSV(0);
1037 GvLINE(sv) = CopLINE(PL_curcop);
1038 GvEGV(sv) = MUTABLE_GV(sv);
1042 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1044 /* undef *Foo::ISA */
1045 if( strEQ(GvNAME((const GV *)sv), "ISA")
1046 && (stash = GvSTASH((const GV *)sv))
1047 && (method_changed || HvENAME(stash)) )
1048 mro_isa_changed_in(stash);
1049 else if(method_changed)
1050 mro_method_changed_in(
1051 GvSTASH((const GV *)sv)
1057 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1070 /* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1076 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1077 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1078 Perl_croak_no_modify();
1080 TARG = sv_newmortal();
1081 sv_setsv(TARG, TOPs);
1082 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1083 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1085 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1086 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1090 else sv_dec_nomg(TOPs);
1092 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1093 if (inc && !SvOK(TARG))
1099 /* Ordinary operators. */
1103 dSP; dATARGET; SV *svl, *svr;
1104 #ifdef PERL_PRESERVE_IVUV
1107 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1110 #ifdef PERL_PRESERVE_IVUV
1111 /* For integer to integer power, we do the calculation by hand wherever
1112 we're sure it is safe; otherwise we call pow() and try to convert to
1113 integer afterwards. */
1114 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1122 const IV iv = SvIVX(svr);
1126 goto float_it; /* Can't do negative powers this way. */
1130 baseuok = SvUOK(svl);
1132 baseuv = SvUVX(svl);
1134 const IV iv = SvIVX(svl);
1137 baseuok = TRUE; /* effectively it's a UV now */
1139 baseuv = -iv; /* abs, baseuok == false records sign */
1142 /* now we have integer ** positive integer. */
1145 /* foo & (foo - 1) is zero only for a power of 2. */
1146 if (!(baseuv & (baseuv - 1))) {
1147 /* We are raising power-of-2 to a positive integer.
1148 The logic here will work for any base (even non-integer
1149 bases) but it can be less accurate than
1150 pow (base,power) or exp (power * log (base)) when the
1151 intermediate values start to spill out of the mantissa.
1152 With powers of 2 we know this can't happen.
1153 And powers of 2 are the favourite thing for perl
1154 programmers to notice ** not doing what they mean. */
1156 NV base = baseuok ? baseuv : -(NV)baseuv;
1161 while (power >>= 1) {
1169 SvIV_please_nomg(svr);
1172 unsigned int highbit = 8 * sizeof(UV);
1173 unsigned int diff = 8 * sizeof(UV);
1174 while (diff >>= 1) {
1176 if (baseuv >> highbit) {
1180 /* we now have baseuv < 2 ** highbit */
1181 if (power * highbit <= 8 * sizeof(UV)) {
1182 /* result will definitely fit in UV, so use UV math
1183 on same algorithm as above */
1186 const bool odd_power = cBOOL(power & 1);
1190 while (power >>= 1) {
1197 if (baseuok || !odd_power)
1198 /* answer is positive */
1200 else if (result <= (UV)IV_MAX)
1201 /* answer negative, fits in IV */
1202 SETi( -(IV)result );
1203 else if (result == (UV)IV_MIN)
1204 /* 2's complement assumption: special case IV_MIN */
1207 /* answer negative, doesn't fit */
1208 SETn( -(NV)result );
1216 NV right = SvNV_nomg(svr);
1217 NV left = SvNV_nomg(svl);
1220 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1222 We are building perl with long double support and are on an AIX OS
1223 afflicted with a powl() function that wrongly returns NaNQ for any
1224 negative base. This was reported to IBM as PMR #23047-379 on
1225 03/06/2006. The problem exists in at least the following versions
1226 of AIX and the libm fileset, and no doubt others as well:
1228 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1229 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1230 AIX 5.2.0 bos.adt.libm 5.2.0.85
1232 So, until IBM fixes powl(), we provide the following workaround to
1233 handle the problem ourselves. Our logic is as follows: for
1234 negative bases (left), we use fmod(right, 2) to check if the
1235 exponent is an odd or even integer:
1237 - if odd, powl(left, right) == -powl(-left, right)
1238 - if even, powl(left, right) == powl(-left, right)
1240 If the exponent is not an integer, the result is rightly NaNQ, so
1241 we just return that (as NV_NAN).
1245 NV mod2 = Perl_fmod( right, 2.0 );
1246 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1247 SETn( -Perl_pow( -left, right) );
1248 } else if (mod2 == 0.0) { /* even integer */
1249 SETn( Perl_pow( -left, right) );
1250 } else { /* fractional power */
1254 SETn( Perl_pow( left, right) );
1257 SETn( Perl_pow( left, right) );
1258 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1260 #ifdef PERL_PRESERVE_IVUV
1262 SvIV_please_nomg(svr);
1270 dSP; dATARGET; SV *svl, *svr;
1271 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1274 #ifdef PERL_PRESERVE_IVUV
1275 if (SvIV_please_nomg(svr)) {
1276 /* Unless the left argument is integer in range we are going to have to
1277 use NV maths. Hence only attempt to coerce the right argument if
1278 we know the left is integer. */
1279 /* Left operand is defined, so is it IV? */
1280 if (SvIV_please_nomg(svl)) {
1281 bool auvok = SvUOK(svl);
1282 bool buvok = SvUOK(svr);
1283 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1284 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1293 const IV aiv = SvIVX(svl);
1296 auvok = TRUE; /* effectively it's a UV now */
1298 alow = -aiv; /* abs, auvok == false records sign */
1304 const IV biv = SvIVX(svr);
1307 buvok = TRUE; /* effectively it's a UV now */
1309 blow = -biv; /* abs, buvok == false records sign */
1313 /* If this does sign extension on unsigned it's time for plan B */
1314 ahigh = alow >> (4 * sizeof (UV));
1316 bhigh = blow >> (4 * sizeof (UV));
1318 if (ahigh && bhigh) {
1320 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1321 which is overflow. Drop to NVs below. */
1322 } else if (!ahigh && !bhigh) {
1323 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1324 so the unsigned multiply cannot overflow. */
1325 const UV product = alow * blow;
1326 if (auvok == buvok) {
1327 /* -ve * -ve or +ve * +ve gives a +ve result. */
1331 } else if (product <= (UV)IV_MIN) {
1332 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1333 /* -ve result, which could overflow an IV */
1335 SETi( -(IV)product );
1337 } /* else drop to NVs below. */
1339 /* One operand is large, 1 small */
1342 /* swap the operands */
1344 bhigh = blow; /* bhigh now the temp var for the swap */
1348 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1349 multiplies can't overflow. shift can, add can, -ve can. */
1350 product_middle = ahigh * blow;
1351 if (!(product_middle & topmask)) {
1352 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1354 product_middle <<= (4 * sizeof (UV));
1355 product_low = alow * blow;
1357 /* as for pp_add, UV + something mustn't get smaller.
1358 IIRC ANSI mandates this wrapping *behaviour* for
1359 unsigned whatever the actual representation*/
1360 product_low += product_middle;
1361 if (product_low >= product_middle) {
1362 /* didn't overflow */
1363 if (auvok == buvok) {
1364 /* -ve * -ve or +ve * +ve gives a +ve result. */
1366 SETu( product_low );
1368 } else if (product_low <= (UV)IV_MIN) {
1369 /* 2s complement assumption again */
1370 /* -ve result, which could overflow an IV */
1372 SETi( -(IV)product_low );
1374 } /* else drop to NVs below. */
1376 } /* product_middle too large */
1377 } /* ahigh && bhigh */
1382 NV right = SvNV_nomg(svr);
1383 NV left = SvNV_nomg(svl);
1385 SETn( left * right );
1392 dSP; dATARGET; SV *svl, *svr;
1393 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1396 /* Only try to do UV divide first
1397 if ((SLOPPYDIVIDE is true) or
1398 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1400 The assumption is that it is better to use floating point divide
1401 whenever possible, only doing integer divide first if we can't be sure.
1402 If NV_PRESERVES_UV is true then we know at compile time that no UV
1403 can be too large to preserve, so don't need to compile the code to
1404 test the size of UVs. */
1407 # define PERL_TRY_UV_DIVIDE
1408 /* ensure that 20./5. == 4. */
1410 # ifdef PERL_PRESERVE_IVUV
1411 # ifndef NV_PRESERVES_UV
1412 # define PERL_TRY_UV_DIVIDE
1417 #ifdef PERL_TRY_UV_DIVIDE
1418 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1419 bool left_non_neg = SvUOK(svl);
1420 bool right_non_neg = SvUOK(svr);
1424 if (right_non_neg) {
1428 const IV biv = SvIVX(svr);
1431 right_non_neg = TRUE; /* effectively it's a UV now */
1437 /* historically undef()/0 gives a "Use of uninitialized value"
1438 warning before dieing, hence this test goes here.
1439 If it were immediately before the second SvIV_please, then
1440 DIE() would be invoked before left was even inspected, so
1441 no inspection would give no warning. */
1443 DIE(aTHX_ "Illegal division by zero");
1449 const IV aiv = SvIVX(svl);
1452 left_non_neg = TRUE; /* effectively it's a UV now */
1461 /* For sloppy divide we always attempt integer division. */
1463 /* Otherwise we only attempt it if either or both operands
1464 would not be preserved by an NV. If both fit in NVs
1465 we fall through to the NV divide code below. However,
1466 as left >= right to ensure integer result here, we know that
1467 we can skip the test on the right operand - right big
1468 enough not to be preserved can't get here unless left is
1471 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1474 /* Integer division can't overflow, but it can be imprecise. */
1475 const UV result = left / right;
1476 if (result * right == left) {
1477 SP--; /* result is valid */
1478 if (left_non_neg == right_non_neg) {
1479 /* signs identical, result is positive. */
1483 /* 2s complement assumption */
1484 if (result <= (UV)IV_MIN)
1485 SETi( -(IV)result );
1487 /* It's exact but too negative for IV. */
1488 SETn( -(NV)result );
1491 } /* tried integer divide but it was not an integer result */
1492 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1493 } /* one operand wasn't SvIOK */
1494 #endif /* PERL_TRY_UV_DIVIDE */
1496 NV right = SvNV_nomg(svr);
1497 NV left = SvNV_nomg(svl);
1498 (void)POPs;(void)POPs;
1499 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1500 if (! Perl_isnan(right) && right == 0.0)
1504 DIE(aTHX_ "Illegal division by zero");
1505 PUSHn( left / right );
1513 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1517 bool left_neg = FALSE;
1518 bool right_neg = FALSE;
1519 bool use_double = FALSE;
1520 bool dright_valid = FALSE;
1523 SV * const svr = TOPs;
1524 SV * const svl = TOPm1s;
1525 if (SvIV_please_nomg(svr)) {
1526 right_neg = !SvUOK(svr);
1530 const IV biv = SvIVX(svr);
1533 right_neg = FALSE; /* effectively it's a UV now */
1540 dright = SvNV_nomg(svr);
1541 right_neg = dright < 0;
1544 if (dright < UV_MAX_P1) {
1545 right = U_V(dright);
1546 dright_valid = TRUE; /* In case we need to use double below. */
1552 /* At this point use_double is only true if right is out of range for
1553 a UV. In range NV has been rounded down to nearest UV and
1554 use_double false. */
1555 if (!use_double && SvIV_please_nomg(svl)) {
1556 left_neg = !SvUOK(svl);
1560 const IV aiv = SvIVX(svl);
1563 left_neg = FALSE; /* effectively it's a UV now */
1570 dleft = SvNV_nomg(svl);
1571 left_neg = dleft < 0;
1575 /* This should be exactly the 5.6 behaviour - if left and right are
1576 both in range for UV then use U_V() rather than floor. */
1578 if (dleft < UV_MAX_P1) {
1579 /* right was in range, so is dleft, so use UVs not double.
1583 /* left is out of range for UV, right was in range, so promote
1584 right (back) to double. */
1586 /* The +0.5 is used in 5.6 even though it is not strictly
1587 consistent with the implicit +0 floor in the U_V()
1588 inside the #if 1. */
1589 dleft = Perl_floor(dleft + 0.5);
1592 dright = Perl_floor(dright + 0.5);
1603 DIE(aTHX_ "Illegal modulus zero");
1605 dans = Perl_fmod(dleft, dright);
1606 if ((left_neg != right_neg) && dans)
1607 dans = dright - dans;
1610 sv_setnv(TARG, dans);
1616 DIE(aTHX_ "Illegal modulus zero");
1619 if ((left_neg != right_neg) && ans)
1622 /* XXX may warn: unary minus operator applied to unsigned type */
1623 /* could change -foo to be (~foo)+1 instead */
1624 if (ans <= ~((UV)IV_MAX)+1)
1625 sv_setiv(TARG, ~ans+1);
1627 sv_setnv(TARG, -(NV)ans);
1630 sv_setuv(TARG, ans);
1643 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1644 /* TODO: think of some way of doing list-repeat overloading ??? */
1649 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1650 /* The parser saw this as a list repeat, and there
1651 are probably several items on the stack. But we're
1652 in scalar/void context, and there's no pp_list to save us
1653 now. So drop the rest of the items -- robin@kitsite.com
1656 if (MARK + 1 < SP) {
1662 ASSUME(MARK + 1 == SP);
1664 MARK[1] = &PL_sv_undef;
1668 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1674 const UV uv = SvUV_nomg(sv);
1676 count = IV_MAX; /* The best we can do? */
1680 count = SvIV_nomg(sv);
1683 else if (SvNOKp(sv)) {
1684 const NV nv = SvNV_nomg(sv);
1686 count = -1; /* An arbitrary negative integer */
1691 count = SvIV_nomg(sv);
1695 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1696 "Negative repeat count does nothing");
1699 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1701 static const char* const oom_list_extend = "Out of memory during list extend";
1702 const I32 items = SP - MARK;
1703 const I32 max = items * count;
1704 const U8 mod = PL_op->op_flags & OPf_MOD;
1706 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1707 /* Did the max computation overflow? */
1708 if (items > 0 && max > 0 && (max < items || max < count))
1709 Perl_croak(aTHX_ "%s", oom_list_extend);
1714 if (mod && SvPADTMP(*SP)) {
1715 *SP = sv_mortalcopy(*SP);
1722 repeatcpy((char*)(MARK + items), (char*)MARK,
1723 items * sizeof(const SV *), count - 1);
1726 else if (count <= 0)
1729 else { /* Note: mark already snarfed by pp_list */
1730 SV * const tmpstr = POPs;
1733 static const char* const oom_string_extend =
1734 "Out of memory during string extend";
1737 sv_setsv_nomg(TARG, tmpstr);
1738 SvPV_force_nomg(TARG, len);
1739 isutf = DO_UTF8(TARG);
1744 const STRLEN max = (UV)count * len;
1745 if (len > MEM_SIZE_MAX / count)
1746 Perl_croak(aTHX_ "%s", oom_string_extend);
1747 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1748 SvGROW(TARG, max + 1);
1749 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1750 SvCUR_set(TARG, SvCUR(TARG) * count);
1752 *SvEND(TARG) = '\0';
1755 (void)SvPOK_only_UTF8(TARG);
1757 (void)SvPOK_only(TARG);
1766 dSP; dATARGET; bool useleft; SV *svl, *svr;
1767 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1770 useleft = USE_LEFT(svl);
1771 #ifdef PERL_PRESERVE_IVUV
1772 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1773 "bad things" happen if you rely on signed integers wrapping. */
1774 if (SvIV_please_nomg(svr)) {
1775 /* Unless the left argument is integer in range we are going to have to
1776 use NV maths. Hence only attempt to coerce the right argument if
1777 we know the left is integer. */
1784 a_valid = auvok = 1;
1785 /* left operand is undef, treat as zero. */
1787 /* Left operand is defined, so is it IV? */
1788 if (SvIV_please_nomg(svl)) {
1789 if ((auvok = SvUOK(svl)))
1792 const IV aiv = SvIVX(svl);
1795 auvok = 1; /* Now acting as a sign flag. */
1796 } else { /* 2s complement assumption for IV_MIN */
1804 bool result_good = 0;
1807 bool buvok = SvUOK(svr);
1812 const IV biv = SvIVX(svr);
1819 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1820 else "IV" now, independent of how it came in.
1821 if a, b represents positive, A, B negative, a maps to -A etc
1826 all UV maths. negate result if A negative.
1827 subtract if signs same, add if signs differ. */
1829 if (auvok ^ buvok) {
1838 /* Must get smaller */
1843 if (result <= buv) {
1844 /* result really should be -(auv-buv). as its negation
1845 of true value, need to swap our result flag */
1857 if (result <= (UV)IV_MIN)
1858 SETi( -(IV)result );
1860 /* result valid, but out of range for IV. */
1861 SETn( -(NV)result );
1865 } /* Overflow, drop through to NVs. */
1870 NV value = SvNV_nomg(svr);
1874 /* left operand is undef, treat as zero - value */
1878 SETn( SvNV_nomg(svl) - value );
1885 dSP; dATARGET; SV *svl, *svr;
1886 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1890 const IV shift = SvIV_nomg(svr);
1891 if (PL_op->op_private & HINT_INTEGER) {
1892 const IV i = SvIV_nomg(svl);
1896 const UV u = SvUV_nomg(svl);
1905 dSP; dATARGET; SV *svl, *svr;
1906 tryAMAGICbin_MG(rshift_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);
1928 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1932 (SvIOK_notUV(left) && SvIOK_notUV(right))
1933 ? (SvIVX(left) < SvIVX(right))
1934 : (do_ncmp(left, right) == -1)
1944 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1948 (SvIOK_notUV(left) && SvIOK_notUV(right))
1949 ? (SvIVX(left) > SvIVX(right))
1950 : (do_ncmp(left, right) == 1)
1960 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1964 (SvIOK_notUV(left) && SvIOK_notUV(right))
1965 ? (SvIVX(left) <= SvIVX(right))
1966 : (do_ncmp(left, right) <= 0)
1976 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1980 (SvIOK_notUV(left) && SvIOK_notUV(right))
1981 ? (SvIVX(left) >= SvIVX(right))
1982 : ( (do_ncmp(left, right) & 2) == 0)
1992 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1996 (SvIOK_notUV(left) && SvIOK_notUV(right))
1997 ? (SvIVX(left) != SvIVX(right))
1998 : (do_ncmp(left, right) != 0)
2003 /* compare left and right SVs. Returns:
2007 * 2: left or right was a NaN
2010 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2012 PERL_ARGS_ASSERT_DO_NCMP;
2013 #ifdef PERL_PRESERVE_IVUV
2014 /* Fortunately it seems NaN isn't IOK */
2015 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2017 const IV leftiv = SvIVX(left);
2018 if (!SvUOK(right)) {
2019 /* ## IV <=> IV ## */
2020 const IV rightiv = SvIVX(right);
2021 return (leftiv > rightiv) - (leftiv < rightiv);
2023 /* ## IV <=> UV ## */
2025 /* As (b) is a UV, it's >=0, so it must be < */
2028 const UV rightuv = SvUVX(right);
2029 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2034 /* ## UV <=> UV ## */
2035 const UV leftuv = SvUVX(left);
2036 const UV rightuv = SvUVX(right);
2037 return (leftuv > rightuv) - (leftuv < rightuv);
2039 /* ## UV <=> IV ## */
2041 const IV rightiv = SvIVX(right);
2043 /* As (a) is a UV, it's >=0, so it cannot be < */
2046 const UV leftuv = SvUVX(left);
2047 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2050 NOT_REACHED; /* NOTREACHED */
2054 NV const rnv = SvNV_nomg(right);
2055 NV const lnv = SvNV_nomg(left);
2057 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2058 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2061 return (lnv > rnv) - (lnv < rnv);
2080 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2083 value = do_ncmp(left, right);
2095 /* also used for: pp_sge() pp_sgt() pp_slt() */
2101 int amg_type = sle_amg;
2105 switch (PL_op->op_type) {
2124 tryAMAGICbin_MG(amg_type, AMGf_set);
2128 #ifdef USE_LOCALE_COLLATE
2129 (IN_LC_RUNTIME(LC_COLLATE))
2130 ? sv_cmp_locale_flags(left, right, 0)
2133 sv_cmp_flags(left, right, 0);
2134 SETs(boolSV(cmp * multiplier < rhs));
2142 tryAMAGICbin_MG(seq_amg, AMGf_set);
2145 SETs(boolSV(sv_eq_flags(left, right, 0)));
2153 tryAMAGICbin_MG(sne_amg, AMGf_set);
2156 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2164 tryAMAGICbin_MG(scmp_amg, 0);
2168 #ifdef USE_LOCALE_COLLATE
2169 (IN_LC_RUNTIME(LC_COLLATE))
2170 ? sv_cmp_locale_flags(left, right, 0)
2173 sv_cmp_flags(left, right, 0);
2182 tryAMAGICbin_MG(band_amg, AMGf_assign);
2185 if (SvNIOKp(left) || SvNIOKp(right)) {
2186 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2187 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2188 if (PL_op->op_private & HINT_INTEGER) {
2189 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2193 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2196 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2197 if (right_ro_nonnum) SvNIOK_off(right);
2200 do_vop(PL_op->op_type, TARG, left, right);
2208 /* also used for: pp_bit_xor() */
2213 const int op_type = PL_op->op_type;
2215 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2218 if (SvNIOKp(left) || SvNIOKp(right)) {
2219 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2220 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2221 if (PL_op->op_private & HINT_INTEGER) {
2222 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2223 const IV r = SvIV_nomg(right);
2224 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2228 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2229 const UV r = SvUV_nomg(right);
2230 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2233 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2234 if (right_ro_nonnum) SvNIOK_off(right);
2237 do_vop(op_type, TARG, left, right);
2244 PERL_STATIC_INLINE bool
2245 S_negate_string(pTHX)
2250 SV * const sv = TOPs;
2251 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2253 s = SvPV_nomg_const(sv, len);
2254 if (isIDFIRST(*s)) {
2255 sv_setpvs(TARG, "-");
2258 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2259 sv_setsv_nomg(TARG, sv);
2260 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2270 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2271 if (S_negate_string(aTHX)) return NORMAL;
2273 SV * const sv = TOPs;
2276 /* It's publicly an integer */
2279 if (SvIVX(sv) == IV_MIN) {
2280 /* 2s complement assumption. */
2281 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2285 else if (SvUVX(sv) <= IV_MAX) {
2290 else if (SvIVX(sv) != IV_MIN) {
2294 #ifdef PERL_PRESERVE_IVUV
2301 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2302 SETn(-SvNV_nomg(sv));
2303 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2304 goto oops_its_an_int;
2306 SETn(-SvNV_nomg(sv));
2314 tryAMAGICun_MG(not_amg, AMGf_set);
2315 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2322 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2326 if (PL_op->op_private & HINT_INTEGER) {
2327 const IV i = ~SvIV_nomg(sv);
2331 const UV u = ~SvUV_nomg(sv);
2340 sv_copypv_nomg(TARG, sv);
2341 tmps = (U8*)SvPV_nomg(TARG, len);
2344 /* Calculate exact length, let's not estimate. */
2349 U8 * const send = tmps + len;
2350 U8 * const origtmps = tmps;
2351 const UV utf8flags = UTF8_ALLOW_ANYUV;
2353 while (tmps < send) {
2354 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2356 targlen += UNISKIP(~c);
2362 /* Now rewind strings and write them. */
2369 Newx(result, targlen + 1, U8);
2371 while (tmps < send) {
2372 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2374 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2377 sv_usepvn_flags(TARG, (char*)result, targlen,
2378 SV_HAS_TRAILING_NUL);
2385 Newx(result, nchar + 1, U8);
2387 while (tmps < send) {
2388 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2393 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2402 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2405 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2410 for ( ; anum > 0; anum--, tmps++)
2418 /* integer versions of some of the above */
2423 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2426 SETi( left * right );
2435 tryAMAGICbin_MG(div_amg, AMGf_assign);
2438 IV value = SvIV_nomg(right);
2440 DIE(aTHX_ "Illegal division by zero");
2441 num = SvIV_nomg(left);
2443 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2447 value = num / value;
2453 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2454 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2461 /* This is the vanilla old i_modulo. */
2463 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2467 DIE(aTHX_ "Illegal modulus zero");
2468 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2472 SETi( left % right );
2477 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2478 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2483 /* This is the i_modulo with the workaround for the _moddi3 bug
2484 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2485 * See below for pp_i_modulo. */
2487 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2491 DIE(aTHX_ "Illegal modulus zero");
2492 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2496 SETi( left % PERL_ABS(right) );
2503 dVAR; dSP; dATARGET;
2504 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2508 DIE(aTHX_ "Illegal modulus zero");
2509 /* The assumption is to use hereafter the old vanilla version... */
2511 PL_ppaddr[OP_I_MODULO] =
2513 /* .. but if we have glibc, we might have a buggy _moddi3
2514 * (at least glibc 2.2.5 is known to have this bug), in other
2515 * words our integer modulus with negative quad as the second
2516 * argument might be broken. Test for this and re-patch the
2517 * opcode dispatch table if that is the case, remembering to
2518 * also apply the workaround so that this first round works
2519 * right, too. See [perl #9402] for more information. */
2523 /* Cannot do this check with inlined IV constants since
2524 * that seems to work correctly even with the buggy glibc. */
2526 /* Yikes, we have the bug.
2527 * Patch in the workaround version. */
2529 PL_ppaddr[OP_I_MODULO] =
2530 &Perl_pp_i_modulo_1;
2531 /* Make certain we work right this time, too. */
2532 right = PERL_ABS(right);
2535 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2539 SETi( left % right );
2548 tryAMAGICbin_MG(add_amg, AMGf_assign);
2550 dPOPTOPiirl_ul_nomg;
2551 SETi( left + right );
2559 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2561 dPOPTOPiirl_ul_nomg;
2562 SETi( left - right );
2570 tryAMAGICbin_MG(lt_amg, AMGf_set);
2573 SETs(boolSV(left < right));
2581 tryAMAGICbin_MG(gt_amg, AMGf_set);
2584 SETs(boolSV(left > right));
2592 tryAMAGICbin_MG(le_amg, AMGf_set);
2595 SETs(boolSV(left <= right));
2603 tryAMAGICbin_MG(ge_amg, AMGf_set);
2606 SETs(boolSV(left >= right));
2614 tryAMAGICbin_MG(eq_amg, AMGf_set);
2617 SETs(boolSV(left == right));
2625 tryAMAGICbin_MG(ne_amg, AMGf_set);
2628 SETs(boolSV(left != right));
2636 tryAMAGICbin_MG(ncmp_amg, 0);
2643 else if (left < right)
2655 tryAMAGICun_MG(neg_amg, 0);
2656 if (S_negate_string(aTHX)) return NORMAL;
2658 SV * const sv = TOPs;
2659 IV const i = SvIV_nomg(sv);
2665 /* High falutin' math. */
2670 tryAMAGICbin_MG(atan2_amg, 0);
2673 SETn(Perl_atan2(left, right));
2679 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2684 int amg_type = fallback_amg;
2685 const char *neg_report = NULL;
2686 const int op_type = PL_op->op_type;
2689 case OP_SIN: amg_type = sin_amg; break;
2690 case OP_COS: amg_type = cos_amg; break;
2691 case OP_EXP: amg_type = exp_amg; break;
2692 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2693 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2696 assert(amg_type != fallback_amg);
2698 tryAMAGICun_MG(amg_type, 0);
2700 SV * const arg = POPs;
2701 const NV value = SvNV_nomg(arg);
2703 if (neg_report) { /* log or sqrt */
2705 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2706 ! Perl_isnan(value) &&
2708 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2709 SET_NUMERIC_STANDARD();
2710 /* diag_listed_as: Can't take log of %g */
2711 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2716 case OP_SIN: result = Perl_sin(value); break;
2717 case OP_COS: result = Perl_cos(value); break;
2718 case OP_EXP: result = Perl_exp(value); break;
2719 case OP_LOG: result = Perl_log(value); break;
2720 case OP_SQRT: result = Perl_sqrt(value); break;
2727 /* Support Configure command-line overrides for rand() functions.
2728 After 5.005, perhaps we should replace this by Configure support
2729 for drand48(), random(), or rand(). For 5.005, though, maintain
2730 compatibility by calling rand() but allow the user to override it.
2731 See INSTALL for details. --Andy Dougherty 15 July 1998
2733 /* Now it's after 5.005, and Configure supports drand48() and random(),
2734 in addition to rand(). So the overrides should not be needed any more.
2735 --Jarkko Hietaniemi 27 September 1998
2740 if (!PL_srand_called) {
2741 (void)seedDrand01((Rand_seed_t)seed());
2742 PL_srand_called = TRUE;
2752 SV * const sv = POPs;
2758 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2759 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2760 if (! Perl_isnan(value) && value == 0.0)
2770 sv_setnv_mg(TARG, value);
2781 if (MAXARG >= 1 && (TOPs || POPs)) {
2788 pv = SvPV(top, len);
2789 flags = grok_number(pv, len, &anum);
2791 if (!(flags & IS_NUMBER_IN_UV)) {
2792 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2793 "Integer overflow in srand");
2801 (void)seedDrand01((Rand_seed_t)anum);
2802 PL_srand_called = TRUE;
2806 /* Historically srand always returned true. We can avoid breaking
2808 sv_setpvs(TARG, "0 but true");
2817 tryAMAGICun_MG(int_amg, AMGf_numeric);
2819 SV * const sv = TOPs;
2820 const IV iv = SvIV_nomg(sv);
2821 /* XXX it's arguable that compiler casting to IV might be subtly
2822 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2823 else preferring IV has introduced a subtle behaviour change bug. OTOH
2824 relying on floating point to be accurate is a bug. */
2829 else if (SvIOK(sv)) {
2831 SETu(SvUV_nomg(sv));
2836 const NV value = SvNV_nomg(sv);
2837 if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
2839 else if (value >= 0.0) {
2840 if (value < (NV)UV_MAX + 0.5) {
2843 SETn(Perl_floor(value));
2847 if (value > (NV)IV_MIN - 0.5) {
2850 SETn(Perl_ceil(value));
2861 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2863 SV * const sv = TOPs;
2864 /* This will cache the NV value if string isn't actually integer */
2865 const IV iv = SvIV_nomg(sv);
2870 else if (SvIOK(sv)) {
2871 /* IVX is precise */
2873 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2881 /* 2s complement assumption. Also, not really needed as
2882 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2888 const NV value = SvNV_nomg(sv);
2899 /* also used for: pp_hex() */
2905 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2909 SV* const sv = POPs;
2911 tmps = (SvPV_const(sv, len));
2913 /* If Unicode, try to downgrade
2914 * If not possible, croak. */
2915 SV* const tsv = sv_2mortal(newSVsv(sv));
2918 sv_utf8_downgrade(tsv, FALSE);
2919 tmps = SvPV_const(tsv, len);
2921 if (PL_op->op_type == OP_HEX)
2924 while (*tmps && len && isSPACE(*tmps))
2928 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
2930 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2932 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
2933 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2935 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2937 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2951 SV * const sv = TOPs;
2953 U32 in_bytes = IN_BYTES;
2954 /* simplest case shortcut */
2955 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2956 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
2957 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
2960 if(LIKELY(svflags == SVf_POK))
2962 if(svflags & SVs_GMG)
2965 if (!IN_BYTES) /* reread to avoid using an C auto/register */
2966 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
2970 /* unrolled SvPV_nomg_const(sv,len) */
2975 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2977 sv_setiv(TARG, (IV)(len));
2980 if (!SvPADTMP(TARG)) {
2981 sv_setsv_nomg(TARG, &PL_sv_undef);
2982 } else { /* TARG is on stack at this point and is overwriten by SETs.
2983 This branch is the odd one out, so put TARG by default on
2984 stack earlier to let local SP go out of liveness sooner */
2991 return NORMAL; /* no putback, SP didn't move in this opcode */
2994 /* Returns false if substring is completely outside original string.
2995 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2996 always be true for an explicit 0.
2999 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3000 bool pos1_is_uv, IV len_iv,
3001 bool len_is_uv, STRLEN *posp,
3007 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3009 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3010 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3013 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3016 if (len_iv || len_is_uv) {
3017 if (!len_is_uv && len_iv < 0) {
3018 pos2_iv = curlen + len_iv;
3020 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3023 } else { /* len_iv >= 0 */
3024 if (!pos1_is_uv && pos1_iv < 0) {
3025 pos2_iv = pos1_iv + len_iv;
3026 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3028 if ((UV)len_iv > curlen-(UV)pos1_iv)
3031 pos2_iv = pos1_iv+len_iv;
3041 if (!pos2_is_uv && pos2_iv < 0) {
3042 if (!pos1_is_uv && pos1_iv < 0)
3046 else if (!pos1_is_uv && pos1_iv < 0)
3049 if ((UV)pos2_iv < (UV)pos1_iv)
3051 if ((UV)pos2_iv > curlen)
3054 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3055 *posp = (STRLEN)( (UV)pos1_iv );
3056 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3073 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3074 const bool rvalue = (GIMME_V != G_VOID);
3077 const char *repl = NULL;
3079 int num_args = PL_op->op_private & 7;
3080 bool repl_need_utf8_upgrade = FALSE;
3084 if(!(repl_sv = POPs)) num_args--;
3086 if ((len_sv = POPs)) {
3087 len_iv = SvIV(len_sv);
3088 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3093 pos1_iv = SvIV(pos_sv);
3094 pos1_is_uv = SvIOK_UV(pos_sv);
3096 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3101 if (lvalue && !repl_sv) {
3103 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3104 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3106 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3108 pos1_is_uv || pos1_iv >= 0
3109 ? (STRLEN)(UV)pos1_iv
3110 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3112 len_is_uv || len_iv > 0
3113 ? (STRLEN)(UV)len_iv
3114 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3117 PUSHs(ret); /* avoid SvSETMAGIC here */
3121 repl = SvPV_const(repl_sv, repl_len);
3124 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3125 "Attempt to use reference as lvalue in substr"
3127 tmps = SvPV_force_nomg(sv, curlen);
3128 if (DO_UTF8(repl_sv) && repl_len) {
3130 sv_utf8_upgrade_nomg(sv);
3134 else if (DO_UTF8(sv))
3135 repl_need_utf8_upgrade = TRUE;
3137 else tmps = SvPV_const(sv, curlen);
3139 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3140 if (utf8_curlen == curlen)
3143 curlen = utf8_curlen;
3149 STRLEN pos, len, byte_len, byte_pos;
3151 if (!translate_substr_offsets(
3152 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3156 byte_pos = utf8_curlen
3157 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3162 SvTAINTED_off(TARG); /* decontaminate */
3163 SvUTF8_off(TARG); /* decontaminate */
3164 sv_setpvn(TARG, tmps, byte_len);
3165 #ifdef USE_LOCALE_COLLATE
3166 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3173 SV* repl_sv_copy = NULL;
3175 if (repl_need_utf8_upgrade) {
3176 repl_sv_copy = newSVsv(repl_sv);
3177 sv_utf8_upgrade(repl_sv_copy);
3178 repl = SvPV_const(repl_sv_copy, repl_len);
3182 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3183 SvREFCNT_dec(repl_sv_copy);
3187 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3197 Perl_croak(aTHX_ "substr outside of string");
3198 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3205 const IV size = POPi;
3206 const IV offset = POPi;
3207 SV * const src = POPs;
3208 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3211 if (lvalue) { /* it's an lvalue! */
3212 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3213 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3215 LvTARG(ret) = SvREFCNT_inc_simple(src);
3216 LvTARGOFF(ret) = offset;
3217 LvTARGLEN(ret) = size;
3221 SvTAINTED_off(TARG); /* decontaminate */
3225 sv_setuv(ret, do_vecget(src, offset, size));
3233 /* also used for: pp_rindex() */
3246 const char *little_p;
3249 const bool is_index = PL_op->op_type == OP_INDEX;
3250 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3256 big_p = SvPV_const(big, biglen);
3257 little_p = SvPV_const(little, llen);
3259 big_utf8 = DO_UTF8(big);
3260 little_utf8 = DO_UTF8(little);
3261 if (big_utf8 ^ little_utf8) {
3262 /* One needs to be upgraded. */
3263 if (little_utf8 && !IN_ENCODING) {
3264 /* Well, maybe instead we might be able to downgrade the small
3266 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3269 /* If the large string is ISO-8859-1, and it's not possible to
3270 convert the small string to ISO-8859-1, then there is no
3271 way that it could be found anywhere by index. */
3276 /* At this point, pv is a malloc()ed string. So donate it to temp
3277 to ensure it will get free()d */
3278 little = temp = newSV(0);
3279 sv_usepvn(temp, pv, llen);
3280 little_p = SvPVX(little);
3283 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3286 sv_recode_to_utf8(temp, _get_encoding());
3288 sv_utf8_upgrade(temp);
3293 big_p = SvPV_const(big, biglen);
3296 little_p = SvPV_const(little, llen);
3300 if (SvGAMAGIC(big)) {
3301 /* Life just becomes a lot easier if I use a temporary here.
3302 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3303 will trigger magic and overloading again, as will fbm_instr()
3305 big = newSVpvn_flags(big_p, biglen,
3306 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3309 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3310 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3311 warn on undef, and we've already triggered a warning with the
3312 SvPV_const some lines above. We can't remove that, as we need to
3313 call some SvPV to trigger overloading early and find out if the
3315 This is all getting to messy. The API isn't quite clean enough,
3316 because data access has side effects.
3318 little = newSVpvn_flags(little_p, llen,
3319 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3320 little_p = SvPVX(little);
3324 offset = is_index ? 0 : biglen;
3326 if (big_utf8 && offset > 0)
3327 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3333 else if (offset > (SSize_t)biglen)
3335 if (!(little_p = is_index
3336 ? fbm_instr((unsigned char*)big_p + offset,
3337 (unsigned char*)big_p + biglen, little, 0)
3338 : rninstr(big_p, big_p + offset,
3339 little_p, little_p + llen)))
3342 retval = little_p - big_p;
3343 if (retval > 1 && big_utf8)
3344 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3354 dSP; dMARK; dORIGMARK; dTARGET;
3355 SvTAINTED_off(TARG);
3356 do_sprintf(TARG, SP-MARK, MARK+1);
3357 TAINT_IF(SvTAINTED(TARG));
3369 const U8 *s = (U8*)SvPV_const(argsv, len);
3371 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3372 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3373 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3374 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
3378 XPUSHu(DO_UTF8(argsv)
3379 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3393 if (UNLIKELY(isinfnansv(top)))
3394 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3396 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3397 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3399 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3400 && SvNV_nomg(top) < 0.0))) {
3401 if (ckWARN(WARN_UTF8)) {
3402 if (SvGMAGICAL(top)) {
3403 SV *top2 = sv_newmortal();
3404 sv_setsv_nomg(top2, top);
3407 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3408 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3410 value = UNICODE_REPLACEMENT;
3412 value = SvUV_nomg(top);
3416 SvUPGRADE(TARG,SVt_PV);
3418 if (value > 255 && !IN_BYTES) {
3419 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3420 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3421 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3423 (void)SvPOK_only(TARG);
3432 *tmps++ = (char)value;
3434 (void)SvPOK_only(TARG);
3436 if (IN_ENCODING && !IN_BYTES) {
3437 sv_recode_to_utf8(TARG, _get_encoding());
3439 if (SvCUR(TARG) == 0
3440 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3441 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3446 *tmps++ = (char)value;
3462 const char *tmps = SvPV_const(left, len);
3464 if (DO_UTF8(left)) {
3465 /* If Unicode, try to downgrade.
3466 * If not possible, croak.
3467 * Yes, we made this up. */
3468 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3470 sv_utf8_downgrade(tsv, FALSE);
3471 tmps = SvPV_const(tsv, len);
3473 # ifdef USE_ITHREADS
3475 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3476 /* This should be threadsafe because in ithreads there is only
3477 * one thread per interpreter. If this would not be true,
3478 * we would need a mutex to protect this malloc. */
3479 PL_reentrant_buffer->_crypt_struct_buffer =
3480 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3481 #if defined(__GLIBC__) || defined(__EMX__)
3482 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3483 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3484 /* work around glibc-2.2.5 bug */
3485 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3489 # endif /* HAS_CRYPT_R */
3490 # endif /* USE_ITHREADS */
3492 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3494 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3501 "The crypt() function is unimplemented due to excessive paranoia.");
3505 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3506 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3509 /* also used for: pp_lcfirst() */
3513 /* Actually is both lcfirst() and ucfirst(). Only the first character
3514 * changes. This means that possibly we can change in-place, ie., just
3515 * take the source and change that one character and store it back, but not
3516 * if read-only etc, or if the length changes */
3520 STRLEN slen; /* slen is the byte length of the whole SV. */
3523 bool inplace; /* ? Convert first char only, in-place */
3524 bool doing_utf8 = FALSE; /* ? using utf8 */
3525 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3526 const int op_type = PL_op->op_type;
3529 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3530 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3531 * stored as UTF-8 at s. */
3532 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3533 * lowercased) character stored in tmpbuf. May be either
3534 * UTF-8 or not, but in either case is the number of bytes */
3536 s = (const U8*)SvPV_const(source, slen);
3538 /* We may be able to get away with changing only the first character, in
3539 * place, but not if read-only, etc. Later we may discover more reasons to
3540 * not convert in-place. */
3541 inplace = !SvREADONLY(source)
3542 && ( SvPADTMP(source)
3543 || ( SvTEMP(source) && !SvSMAGICAL(source)
3544 && SvREFCNT(source) == 1));
3546 /* First calculate what the changed first character should be. This affects
3547 * whether we can just swap it out, leaving the rest of the string unchanged,
3548 * or even if have to convert the dest to UTF-8 when the source isn't */
3550 if (! slen) { /* If empty */
3551 need = 1; /* still need a trailing NUL */
3554 else if (DO_UTF8(source)) { /* Is the source utf8? */
3557 if (op_type == OP_UCFIRST) {
3558 #ifdef USE_LOCALE_CTYPE
3559 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3561 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3565 #ifdef USE_LOCALE_CTYPE
3566 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3568 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3572 /* we can't do in-place if the length changes. */
3573 if (ulen != tculen) inplace = FALSE;
3574 need = slen + 1 - ulen + tculen;
3576 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3577 * latin1 is treated as caseless. Note that a locale takes
3579 ulen = 1; /* Original character is 1 byte */
3580 tculen = 1; /* Most characters will require one byte, but this will
3581 * need to be overridden for the tricky ones */
3584 if (op_type == OP_LCFIRST) {
3586 /* lower case the first letter: no trickiness for any character */
3588 #ifdef USE_LOCALE_CTYPE
3589 (IN_LC_RUNTIME(LC_CTYPE))
3594 ? toLOWER_LATIN1(*s)
3598 #ifdef USE_LOCALE_CTYPE
3599 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3600 if (IN_UTF8_CTYPE_LOCALE) {
3604 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3605 locales have upper and title case
3609 else if (! IN_UNI_8_BIT) {
3610 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3611 * on EBCDIC machines whatever the
3612 * native function does */
3615 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3616 * UTF-8, which we treat as not in locale), and cased latin1 */
3618 #ifdef USE_LOCALE_CTYPE
3622 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3624 assert(tculen == 2);
3626 /* If the result is an upper Latin1-range character, it can
3627 * still be represented in one byte, which is its ordinal */
3628 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3629 *tmpbuf = (U8) title_ord;
3633 /* Otherwise it became more than one ASCII character (in
3634 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3635 * beyond Latin1, so the number of bytes changed, so can't
3636 * replace just the first character in place. */
3639 /* If the result won't fit in a byte, the entire result
3640 * will have to be in UTF-8. Assume worst case sizing in
3641 * conversion. (all latin1 characters occupy at most two
3643 if (title_ord > 255) {
3645 convert_source_to_utf8 = TRUE;
3646 need = slen * 2 + 1;
3648 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3649 * (both) characters whose title case is above 255 is
3653 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3654 need = slen + 1 + 1;
3658 } /* End of use Unicode (Latin1) semantics */
3659 } /* End of changing the case of the first character */
3661 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3662 * generate the result */
3665 /* We can convert in place. This means we change just the first
3666 * character without disturbing the rest; no need to grow */
3668 s = d = (U8*)SvPV_force_nomg(source, slen);
3674 /* Here, we can't convert in place; we earlier calculated how much
3675 * space we will need, so grow to accommodate that */
3676 SvUPGRADE(dest, SVt_PV);
3677 d = (U8*)SvGROW(dest, need);
3678 (void)SvPOK_only(dest);
3685 if (! convert_source_to_utf8) {
3687 /* Here both source and dest are in UTF-8, but have to create
3688 * the entire output. We initialize the result to be the
3689 * title/lower cased first character, and then append the rest
3691 sv_setpvn(dest, (char*)tmpbuf, tculen);
3693 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3697 const U8 *const send = s + slen;
3699 /* Here the dest needs to be in UTF-8, but the source isn't,
3700 * except we earlier UTF-8'd the first character of the source
3701 * into tmpbuf. First put that into dest, and then append the
3702 * rest of the source, converting it to UTF-8 as we go. */
3704 /* Assert tculen is 2 here because the only two characters that
3705 * get to this part of the code have 2-byte UTF-8 equivalents */
3707 *d++ = *(tmpbuf + 1);
3708 s++; /* We have just processed the 1st char */
3710 for (; s < send; s++) {
3711 d = uvchr_to_utf8(d, *s);
3714 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3718 else { /* in-place UTF-8. Just overwrite the first character */
3719 Copy(tmpbuf, d, tculen, U8);
3720 SvCUR_set(dest, need - 1);
3724 else { /* Neither source nor dest are in or need to be UTF-8 */
3726 if (inplace) { /* in-place, only need to change the 1st char */
3729 else { /* Not in-place */
3731 /* Copy the case-changed character(s) from tmpbuf */
3732 Copy(tmpbuf, d, tculen, U8);
3733 d += tculen - 1; /* Code below expects d to point to final
3734 * character stored */
3737 else { /* empty source */
3738 /* See bug #39028: Don't taint if empty */
3742 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3743 * the destination to retain that flag */
3744 if (SvUTF8(source) && ! IN_BYTES)
3747 if (!inplace) { /* Finish the rest of the string, unchanged */
3748 /* This will copy the trailing NUL */
3749 Copy(s + 1, d + 1, slen, U8);
3750 SvCUR_set(dest, need - 1);
3753 #ifdef USE_LOCALE_CTYPE
3754 if (IN_LC_RUNTIME(LC_CTYPE)) {
3759 if (dest != source && SvTAINTED(source))
3765 /* There's so much setup/teardown code common between uc and lc, I wonder if
3766 it would be worth merging the two, and just having a switch outside each
3767 of the three tight loops. There is less and less commonality though */
3780 if ((SvPADTMP(source)
3782 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3783 && !SvREADONLY(source) && SvPOK(source)
3786 #ifdef USE_LOCALE_CTYPE
3787 (IN_LC_RUNTIME(LC_CTYPE))
3788 ? ! IN_UTF8_CTYPE_LOCALE
3794 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3795 * make the loop tight, so we overwrite the source with the dest before
3796 * looking at it, and we need to look at the original source
3797 * afterwards. There would also need to be code added to handle
3798 * switching to not in-place in midstream if we run into characters
3799 * that change the length. Since being in locale overrides UNI_8_BIT,
3800 * that latter becomes irrelevant in the above test; instead for
3801 * locale, the size can't normally change, except if the locale is a
3804 s = d = (U8*)SvPV_force_nomg(source, len);
3811 s = (const U8*)SvPV_nomg_const(source, len);
3814 SvUPGRADE(dest, SVt_PV);
3815 d = (U8*)SvGROW(dest, min);
3816 (void)SvPOK_only(dest);
3821 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3822 to check DO_UTF8 again here. */
3824 if (DO_UTF8(source)) {
3825 const U8 *const send = s + len;
3826 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3828 /* All occurrences of these are to be moved to follow any other marks.
3829 * This is context-dependent. We may not be passed enough context to
3830 * move the iota subscript beyond all of them, but we do the best we can
3831 * with what we're given. The result is always better than if we
3832 * hadn't done this. And, the problem would only arise if we are
3833 * passed a character without all its combining marks, which would be
3834 * the caller's mistake. The information this is based on comes from a
3835 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3836 * itself) and so can't be checked properly to see if it ever gets
3837 * revised. But the likelihood of it changing is remote */
3838 bool in_iota_subscript = FALSE;
3844 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3846 /* A non-mark. Time to output the iota subscript */
3847 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3848 d += capital_iota_len;
3849 in_iota_subscript = FALSE;
3852 /* Then handle the current character. Get the changed case value
3853 * and copy it to the output buffer */
3856 #ifdef USE_LOCALE_CTYPE
3857 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
3859 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
3861 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3862 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3863 if (uv == GREEK_CAPITAL_LETTER_IOTA
3864 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3866 in_iota_subscript = TRUE;
3869 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3870 /* If the eventually required minimum size outgrows the
3871 * available space, we need to grow. */
3872 const UV o = d - (U8*)SvPVX_const(dest);
3874 /* If someone uppercases one million U+03B0s we SvGROW()
3875 * one million times. Or we could try guessing how much to
3876 * allocate without allocating too much. Such is life.
3877 * See corresponding comment in lc code for another option
3880 d = (U8*)SvPVX(dest) + o;
3882 Copy(tmpbuf, d, ulen, U8);
3887 if (in_iota_subscript) {
3888 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3889 d += capital_iota_len;
3894 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3896 else { /* Not UTF-8 */
3898 const U8 *const send = s + len;
3900 /* Use locale casing if in locale; regular style if not treating
3901 * latin1 as having case; otherwise the latin1 casing. Do the
3902 * whole thing in a tight loop, for speed, */
3903 #ifdef USE_LOCALE_CTYPE
3904 if (IN_LC_RUNTIME(LC_CTYPE)) {
3905 if (IN_UTF8_CTYPE_LOCALE) {
3908 for (; s < send; d++, s++)
3909 *d = (U8) toUPPER_LC(*s);
3913 if (! IN_UNI_8_BIT) {
3914 for (; s < send; d++, s++) {
3919 #ifdef USE_LOCALE_CTYPE
3922 for (; s < send; d++, s++) {
3923 *d = toUPPER_LATIN1_MOD(*s);
3924 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3928 /* The mainstream case is the tight loop above. To avoid
3929 * extra tests in that, all three characters that require
3930 * special handling are mapped by the MOD to the one tested
3932 * Use the source to distinguish between the three cases */
3934 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3936 /* uc() of this requires 2 characters, but they are
3937 * ASCII. If not enough room, grow the string */
3938 if (SvLEN(dest) < ++min) {
3939 const UV o = d - (U8*)SvPVX_const(dest);
3941 d = (U8*)SvPVX(dest) + o;
3943 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3944 continue; /* Back to the tight loop; still in ASCII */
3947 /* The other two special handling characters have their
3948 * upper cases outside the latin1 range, hence need to be
3949 * in UTF-8, so the whole result needs to be in UTF-8. So,
3950 * here we are somewhere in the middle of processing a
3951 * non-UTF-8 string, and realize that we will have to convert
3952 * the whole thing to UTF-8. What to do? There are
3953 * several possibilities. The simplest to code is to
3954 * convert what we have so far, set a flag, and continue on
3955 * in the loop. The flag would be tested each time through
3956 * the loop, and if set, the next character would be
3957 * converted to UTF-8 and stored. But, I (khw) didn't want
3958 * to slow down the mainstream case at all for this fairly
3959 * rare case, so I didn't want to add a test that didn't
3960 * absolutely have to be there in the loop, besides the
3961 * possibility that it would get too complicated for
3962 * optimizers to deal with. Another possibility is to just
3963 * give up, convert the source to UTF-8, and restart the
3964 * function that way. Another possibility is to convert
3965 * both what has already been processed and what is yet to
3966 * come separately to UTF-8, then jump into the loop that
3967 * handles UTF-8. But the most efficient time-wise of the
3968 * ones I could think of is what follows, and turned out to
3969 * not require much extra code. */
3971 /* Convert what we have so far into UTF-8, telling the
3972 * function that we know it should be converted, and to
3973 * allow extra space for what we haven't processed yet.
3974 * Assume the worst case space requirements for converting
3975 * what we haven't processed so far: that it will require
3976 * two bytes for each remaining source character, plus the
3977 * NUL at the end. This may cause the string pointer to
3978 * move, so re-find it. */
3980 len = d - (U8*)SvPVX_const(dest);
3981 SvCUR_set(dest, len);
3982 len = sv_utf8_upgrade_flags_grow(dest,
3983 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3985 d = (U8*)SvPVX(dest) + len;
3987 /* Now process the remainder of the source, converting to
3988 * upper and UTF-8. If a resulting byte is invariant in
3989 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3990 * append it to the output. */
3991 for (; s < send; s++) {
3992 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3996 /* Here have processed the whole source; no need to continue
3997 * with the outer loop. Each character has been converted
3998 * to upper case and converted to UTF-8 */
4001 } /* End of processing all latin1-style chars */
4002 } /* End of processing all chars */
4003 } /* End of source is not empty */
4005 if (source != dest) {
4006 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4007 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4009 } /* End of isn't utf8 */
4010 #ifdef USE_LOCALE_CTYPE
4011 if (IN_LC_RUNTIME(LC_CTYPE)) {
4016 if (dest != source && SvTAINTED(source))
4034 if ( ( SvPADTMP(source)
4035 || ( SvTEMP(source) && !SvSMAGICAL(source)
4036 && SvREFCNT(source) == 1 )
4038 && !SvREADONLY(source) && SvPOK(source)
4039 && !DO_UTF8(source)) {
4041 /* We can convert in place, as lowercasing anything in the latin1 range
4042 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4044 s = d = (U8*)SvPV_force_nomg(source, len);
4051 s = (const U8*)SvPV_nomg_const(source, len);
4054 SvUPGRADE(dest, SVt_PV);
4055 d = (U8*)SvGROW(dest, min);
4056 (void)SvPOK_only(dest);
4061 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4062 to check DO_UTF8 again here. */
4064 if (DO_UTF8(source)) {
4065 const U8 *const send = s + len;
4066 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4069 const STRLEN u = UTF8SKIP(s);
4072 #ifdef USE_LOCALE_CTYPE
4073 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4075 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4078 /* Here is where we would do context-sensitive actions. See the
4079 * commit message for 86510fb15 for why there isn't any */
4081 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4083 /* If the eventually required minimum size outgrows the
4084 * available space, we need to grow. */
4085 const UV o = d - (U8*)SvPVX_const(dest);
4087 /* If someone lowercases one million U+0130s we SvGROW() one
4088 * million times. Or we could try guessing how much to
4089 * allocate without allocating too much. Such is life.
4090 * Another option would be to grow an extra byte or two more
4091 * each time we need to grow, which would cut down the million
4092 * to 500K, with little waste */
4094 d = (U8*)SvPVX(dest) + o;
4097 /* Copy the newly lowercased letter to the output buffer we're
4099 Copy(tmpbuf, d, ulen, U8);
4102 } /* End of looping through the source string */
4105 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4106 } else { /* Not utf8 */
4108 const U8 *const send = s + len;
4110 /* Use locale casing if in locale; regular style if not treating
4111 * latin1 as having case; otherwise the latin1 casing. Do the
4112 * whole thing in a tight loop, for speed, */
4113 #ifdef USE_LOCALE_CTYPE
4114 if (IN_LC_RUNTIME(LC_CTYPE)) {
4115 for (; s < send; d++, s++)
4116 *d = toLOWER_LC(*s);
4120 if (! IN_UNI_8_BIT) {
4121 for (; s < send; d++, s++) {
4126 for (; s < send; d++, s++) {
4127 *d = toLOWER_LATIN1(*s);
4131 if (source != dest) {
4133 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4136 #ifdef USE_LOCALE_CTYPE
4137 if (IN_LC_RUNTIME(LC_CTYPE)) {
4142 if (dest != source && SvTAINTED(source))
4151 SV * const sv = TOPs;
4153 const char *s = SvPV_const(sv,len);
4155 SvUTF8_off(TARG); /* decontaminate */
4158 SvUPGRADE(TARG, SVt_PV);
4159 SvGROW(TARG, (len * 2) + 1);
4163 STRLEN ulen = UTF8SKIP(s);
4164 bool to_quote = FALSE;
4166 if (UTF8_IS_INVARIANT(*s)) {
4167 if (_isQUOTEMETA(*s)) {
4171 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4173 #ifdef USE_LOCALE_CTYPE
4174 /* In locale, we quote all non-ASCII Latin1 chars.
4175 * Otherwise use the quoting rules */
4177 IN_LC_RUNTIME(LC_CTYPE)
4180 _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4185 else if (is_QUOTEMETA_high(s)) {
4200 else if (IN_UNI_8_BIT) {
4202 if (_isQUOTEMETA(*s))
4208 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4209 * including everything above ASCII */
4211 if (!isWORDCHAR_A(*s))
4217 SvCUR_set(TARG, d - SvPVX_const(TARG));
4218 (void)SvPOK_only_UTF8(TARG);
4221 sv_setpvn(TARG, s, len);
4237 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4238 const bool full_folding = TRUE; /* This variable is here so we can easily
4239 move to more generality later */
4240 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4241 #ifdef USE_LOCALE_CTYPE
4242 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4246 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4247 * You are welcome(?) -Hugmeir
4255 s = (const U8*)SvPV_nomg_const(source, len);
4257 if (ckWARN(WARN_UNINITIALIZED))
4258 report_uninit(source);
4265 SvUPGRADE(dest, SVt_PV);
4266 d = (U8*)SvGROW(dest, min);
4267 (void)SvPOK_only(dest);
4272 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4274 const STRLEN u = UTF8SKIP(s);
4277 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4279 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4280 const UV o = d - (U8*)SvPVX_const(dest);
4282 d = (U8*)SvPVX(dest) + o;
4285 Copy(tmpbuf, d, ulen, U8);
4290 } /* Unflagged string */
4292 #ifdef USE_LOCALE_CTYPE
4293 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4294 if (IN_UTF8_CTYPE_LOCALE) {
4295 goto do_uni_folding;
4297 for (; s < send; d++, s++)
4298 *d = (U8) toFOLD_LC(*s);
4302 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4303 for (; s < send; d++, s++)
4307 #ifdef USE_LOCALE_CTYPE
4310 /* For ASCII and the Latin-1 range, there's only two troublesome
4311 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4312 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4313 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4314 * For the rest, the casefold is their lowercase. */
4315 for (; s < send; d++, s++) {
4316 if (*s == MICRO_SIGN) {
4317 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4318 * which is outside of the latin-1 range. There's a couple
4319 * of ways to deal with this -- khw discusses them in
4320 * pp_lc/uc, so go there :) What we do here is upgrade what
4321 * we had already casefolded, then enter an inner loop that
4322 * appends the rest of the characters as UTF-8. */
4323 len = d - (U8*)SvPVX_const(dest);
4324 SvCUR_set(dest, len);
4325 len = sv_utf8_upgrade_flags_grow(dest,
4326 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4327 /* The max expansion for latin1
4328 * chars is 1 byte becomes 2 */
4330 d = (U8*)SvPVX(dest) + len;
4332 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4335 for (; s < send; s++) {
4337 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4338 if UVCHR_IS_INVARIANT(fc) {
4340 && *s == LATIN_SMALL_LETTER_SHARP_S)
4349 Copy(tmpbuf, d, ulen, U8);
4355 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4356 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4357 * becomes "ss", which may require growing the SV. */
4358 if (SvLEN(dest) < ++min) {
4359 const UV o = d - (U8*)SvPVX_const(dest);
4361 d = (U8*)SvPVX(dest) + o;
4366 else { /* If it's not one of those two, the fold is their lower
4368 *d = toLOWER_LATIN1(*s);
4374 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4376 #ifdef USE_LOCALE_CTYPE
4377 if (IN_LC_RUNTIME(LC_CTYPE)) {
4382 if (SvTAINTED(source))
4392 dSP; dMARK; dORIGMARK;
4393 AV *const av = MUTABLE_AV(POPs);
4394 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4396 if (SvTYPE(av) == SVt_PVAV) {
4397 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4398 bool can_preserve = FALSE;
4404 can_preserve = SvCANEXISTDELETE(av);
4407 if (lval && localizing) {
4410 for (svp = MARK + 1; svp <= SP; svp++) {
4411 const SSize_t elem = SvIV(*svp);
4415 if (max > AvMAX(av))
4419 while (++MARK <= SP) {
4421 SSize_t elem = SvIV(*MARK);
4422 bool preeminent = TRUE;
4424 if (localizing && can_preserve) {
4425 /* If we can determine whether the element exist,
4426 * Try to preserve the existenceness of a tied array
4427 * element by using EXISTS and DELETE if possible.
4428 * Fallback to FETCH and STORE otherwise. */
4429 preeminent = av_exists(av, elem);
4432 svp = av_fetch(av, elem, lval);
4435 DIE(aTHX_ PL_no_aelem, elem);
4438 save_aelem(av, elem, svp);
4440 SAVEADELETE(av, elem);
4443 *MARK = svp ? *svp : &PL_sv_undef;
4446 if (GIMME != G_ARRAY) {
4448 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4457 AV *const av = MUTABLE_AV(POPs);
4458 I32 lval = (PL_op->op_flags & OPf_MOD);
4459 SSize_t items = SP - MARK;
4461 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4462 const I32 flags = is_lvalue_sub();
4464 if (!(flags & OPpENTERSUB_INARGS))
4465 /* diag_listed_as: Can't modify %s in %s */
4466 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4473 *(MARK+items*2-1) = *(MARK+items);
4479 while (++MARK <= SP) {
4482 svp = av_fetch(av, SvIV(*MARK), lval);
4484 if (!svp || !*svp || *svp == &PL_sv_undef) {
4485 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4487 *MARK = sv_mortalcopy(*MARK);
4489 *++MARK = svp ? *svp : &PL_sv_undef;
4491 if (GIMME != G_ARRAY) {
4492 MARK = SP - items*2;
4493 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4500 /* Smart dereferencing for keys, values and each */
4502 /* also used for: pp_reach() pp_rvalues() */
4514 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4519 "Type of argument to %s must be unblessed hashref or arrayref",
4520 PL_op_desc[PL_op->op_type] );
4523 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4525 "Can't modify %s in %s",
4526 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4529 /* Delegate to correct function for op type */
4531 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4532 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4535 return (SvTYPE(sv) == SVt_PVHV)
4536 ? Perl_pp_each(aTHX)
4537 : Perl_pp_aeach(aTHX);
4544 AV *array = MUTABLE_AV(POPs);
4545 const I32 gimme = GIMME_V;
4546 IV *iterp = Perl_av_iter_p(aTHX_ array);
4547 const IV current = (*iterp)++;
4549 if (current > av_tindex(array)) {
4551 if (gimme == G_SCALAR)
4559 if (gimme == G_ARRAY) {
4560 SV **const element = av_fetch(array, current, 0);
4561 PUSHs(element ? *element : &PL_sv_undef);
4566 /* also used for: pp_avalues()*/
4570 AV *array = MUTABLE_AV(POPs);
4571 const I32 gimme = GIMME_V;
4573 *Perl_av_iter_p(aTHX_ array) = 0;
4575 if (gimme == G_SCALAR) {
4577 PUSHi(av_tindex(array) + 1);
4579 else if (gimme == G_ARRAY) {
4580 IV n = Perl_av_len(aTHX_ array);
4585 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4586 for (i = 0; i <= n; i++) {
4591 for (i = 0; i <= n; i++) {
4592 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4593 PUSHs(elem ? *elem : &PL_sv_undef);
4600 /* Associative arrays. */
4605 HV * hash = MUTABLE_HV(POPs);
4607 const I32 gimme = GIMME_V;
4610 /* might clobber stack_sp */
4611 entry = hv_iternext(hash);
4616 SV* const sv = hv_iterkeysv(entry);
4617 PUSHs(sv); /* won't clobber stack_sp */
4618 if (gimme == G_ARRAY) {
4621 /* might clobber stack_sp */
4622 val = hv_iterval(hash, entry);
4627 else if (gimme == G_SCALAR)
4634 S_do_delete_local(pTHX)
4637 const I32 gimme = GIMME_V;
4640 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4641 SV **unsliced_keysv = sliced ? NULL : sp--;
4642 SV * const osv = POPs;
4643 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4645 const bool tied = SvRMAGICAL(osv)
4646 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4647 const bool can_preserve = SvCANEXISTDELETE(osv);
4648 const U32 type = SvTYPE(osv);
4649 SV ** const end = sliced ? SP : unsliced_keysv;
4651 if (type == SVt_PVHV) { /* hash element */
4652 HV * const hv = MUTABLE_HV(osv);
4653 while (++MARK <= end) {
4654 SV * const keysv = *MARK;
4656 bool preeminent = TRUE;
4658 preeminent = hv_exists_ent(hv, keysv, 0);
4660 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4667 sv = hv_delete_ent(hv, keysv, 0, 0);
4669 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4672 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4673 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4675 *MARK = sv_mortalcopy(sv);
4681 SAVEHDELETE(hv, keysv);
4682 *MARK = &PL_sv_undef;
4686 else if (type == SVt_PVAV) { /* array element */
4687 if (PL_op->op_flags & OPf_SPECIAL) {
4688 AV * const av = MUTABLE_AV(osv);
4689 while (++MARK <= end) {
4690 SSize_t idx = SvIV(*MARK);
4692 bool preeminent = TRUE;
4694 preeminent = av_exists(av, idx);
4696 SV **svp = av_fetch(av, idx, 1);
4703 sv = av_delete(av, idx, 0);
4705 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4708 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4710 *MARK = sv_mortalcopy(sv);
4716 SAVEADELETE(av, idx);
4717 *MARK = &PL_sv_undef;
4722 DIE(aTHX_ "panic: avhv_delete no longer supported");
4725 DIE(aTHX_ "Not a HASH reference");
4727 if (gimme == G_VOID)
4729 else if (gimme == G_SCALAR) {
4734 *++MARK = &PL_sv_undef;
4738 else if (gimme != G_VOID)
4739 PUSHs(*unsliced_keysv);
4750 if (PL_op->op_private & OPpLVAL_INTRO)
4751 return do_delete_local();
4754 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4756 if (PL_op->op_private & OPpSLICE) {
4758 HV * const hv = MUTABLE_HV(POPs);
4759 const U32 hvtype = SvTYPE(hv);
4760 if (hvtype == SVt_PVHV) { /* hash element */
4761 while (++MARK <= SP) {
4762 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4763 *MARK = sv ? sv : &PL_sv_undef;
4766 else if (hvtype == SVt_PVAV) { /* array element */
4767 if (PL_op->op_flags & OPf_SPECIAL) {
4768 while (++MARK <= SP) {
4769 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4770 *MARK = sv ? sv : &PL_sv_undef;
4775 DIE(aTHX_ "Not a HASH reference");
4778 else if (gimme == G_SCALAR) {
4783 *++MARK = &PL_sv_undef;
4789 HV * const hv = MUTABLE_HV(POPs);
4791 if (SvTYPE(hv) == SVt_PVHV)
4792 sv = hv_delete_ent(hv, keysv, discard, 0);
4793 else if (SvTYPE(hv) == SVt_PVAV) {
4794 if (PL_op->op_flags & OPf_SPECIAL)
4795 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4797 DIE(aTHX_ "panic: avhv_delete no longer supported");
4800 DIE(aTHX_ "Not a HASH reference");
4815 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4817 SV * const sv = POPs;
4818 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4821 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4826 hv = MUTABLE_HV(POPs);
4827 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4828 if (hv_exists_ent(hv, tmpsv, 0))
4831 else if (SvTYPE(hv) == SVt_PVAV) {
4832 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4833 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4838 DIE(aTHX_ "Not a HASH reference");
4845 dSP; dMARK; dORIGMARK;
4846 HV * const hv = MUTABLE_HV(POPs);
4847 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4848 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4849 bool can_preserve = FALSE;
4855 if (SvCANEXISTDELETE(hv))
4856 can_preserve = TRUE;
4859 while (++MARK <= SP) {
4860 SV * const keysv = *MARK;
4863 bool preeminent = TRUE;
4865 if (localizing && can_preserve) {
4866 /* If we can determine whether the element exist,
4867 * try to preserve the existenceness of a tied hash
4868 * element by using EXISTS and DELETE if possible.
4869 * Fallback to FETCH and STORE otherwise. */
4870 preeminent = hv_exists_ent(hv, keysv, 0);
4873 he = hv_fetch_ent(hv, keysv, lval, 0);
4874 svp = he ? &HeVAL(he) : NULL;
4877 if (!svp || !*svp || *svp == &PL_sv_undef) {
4878 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4881 if (HvNAME_get(hv) && isGV(*svp))
4882 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4883 else if (preeminent)
4884 save_helem_flags(hv, keysv, svp,
4885 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4887 SAVEHDELETE(hv, keysv);
4890 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4892 if (GIMME != G_ARRAY) {
4894 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4903 HV * const hv = MUTABLE_HV(POPs);
4904 I32 lval = (PL_op->op_flags & OPf_MOD);
4905 SSize_t items = SP - MARK;
4907 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4908 const I32 flags = is_lvalue_sub();
4910 if (!(flags & OPpENTERSUB_INARGS))
4911 /* diag_listed_as: Can't modify %s in %s */
4912 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4919 *(MARK+items*2-1) = *(MARK+items);
4925 while (++MARK <= SP) {
4926 SV * const keysv = *MARK;
4930 he = hv_fetch_ent(hv, keysv, lval, 0);
4931 svp = he ? &HeVAL(he) : NULL;
4934 if (!svp || !*svp || *svp == &PL_sv_undef) {
4935 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4937 *MARK = sv_mortalcopy(*MARK);
4939 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4941 if (GIMME != G_ARRAY) {
4942 MARK = SP - items*2;
4943 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4949 /* List operators. */
4953 I32 markidx = POPMARK;
4954 if (GIMME != G_ARRAY) {
4955 SV **mark = PL_stack_base + markidx;
4958 *MARK = *SP; /* unwanted list, return last item */
4960 *MARK = &PL_sv_undef;
4970 SV ** const lastrelem = PL_stack_sp;
4971 SV ** const lastlelem = PL_stack_base + POPMARK;
4972 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4973 SV ** const firstrelem = lastlelem + 1;
4974 const U8 mod = PL_op->op_flags & OPf_MOD;
4976 const I32 max = lastrelem - lastlelem;
4979 if (GIMME != G_ARRAY) {
4980 I32 ix = SvIV(*lastlelem);
4983 if (ix < 0 || ix >= max)
4984 *firstlelem = &PL_sv_undef;
4986 *firstlelem = firstrelem[ix];
4992 SP = firstlelem - 1;
4996 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4997 I32 ix = SvIV(*lelem);
5000 if (ix < 0 || ix >= max)
5001 *lelem = &PL_sv_undef;
5003 if (!(*lelem = firstrelem[ix]))
5004 *lelem = &PL_sv_undef;
5005 else if (mod && SvPADTMP(*lelem)) {
5006 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5017 const I32 items = SP - MARK;
5018 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5020 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5021 ? newRV_noinc(av) : av);
5027 dSP; dMARK; dORIGMARK;
5028 HV* const hv = newHV();
5029 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5030 ? newRV_noinc(MUTABLE_SV(hv))
5035 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5042 sv_setsv(val, *MARK);
5046 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5049 (void)hv_store_ent(hv,key,val,0);
5057 S_deref_plain_array(pTHX_ AV *ary)
5059 if (SvTYPE(ary) == SVt_PVAV) return ary;
5060 SvGETMAGIC((SV *)ary);
5061 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5062 Perl_die(aTHX_ "Not an ARRAY reference");
5063 else if (SvOBJECT(SvRV(ary)))
5064 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5065 return (AV *)SvRV(ary);
5068 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5069 # define DEREF_PLAIN_ARRAY(ary) \
5072 SvTYPE(aRrRay) == SVt_PVAV \
5074 : S_deref_plain_array(aTHX_ aRrRay); \
5077 # define DEREF_PLAIN_ARRAY(ary) \
5079 PL_Sv = (SV *)(ary), \
5080 SvTYPE(PL_Sv) == SVt_PVAV \
5082 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5088 dSP; dMARK; dORIGMARK;
5089 int num_args = (SP - MARK);
5090 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5099 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5102 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5103 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5110 offset = i = SvIV(*MARK);
5112 offset += AvFILLp(ary) + 1;
5114 DIE(aTHX_ PL_no_aelem, i);
5116 length = SvIVx(*MARK++);
5118 length += AvFILLp(ary) - offset + 1;
5124 length = AvMAX(ary) + 1; /* close enough to infinity */
5128 length = AvMAX(ary) + 1;
5130 if (offset > AvFILLp(ary) + 1) {
5132 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5133 offset = AvFILLp(ary) + 1;
5135 after = AvFILLp(ary) + 1 - (offset + length);
5136 if (after < 0) { /* not that much array */
5137 length += after; /* offset+length now in array */
5143 /* At this point, MARK .. SP-1 is our new LIST */
5146 diff = newlen - length;
5147 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5150 /* make new elements SVs now: avoid problems if they're from the array */
5151 for (dst = MARK, i = newlen; i; i--) {
5152 SV * const h = *dst;
5153 *dst++ = newSVsv(h);
5156 if (diff < 0) { /* shrinking the area */
5157 SV **tmparyval = NULL;
5159 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5160 Copy(MARK, tmparyval, newlen, SV*);
5163 MARK = ORIGMARK + 1;
5164 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5165 const bool real = cBOOL(AvREAL(ary));
5166 MEXTEND(MARK, length);
5168 EXTEND_MORTAL(length);
5169 for (i = 0, dst = MARK; i < length; i++) {
5170 if ((*dst = AvARRAY(ary)[i+offset])) {
5172 sv_2mortal(*dst); /* free them eventually */
5175 *dst = &PL_sv_undef;
5181 *MARK = AvARRAY(ary)[offset+length-1];
5184 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5185 SvREFCNT_dec(*dst++); /* free them now */
5188 AvFILLp(ary) += diff;
5190 /* pull up or down? */
5192 if (offset < after) { /* easier to pull up */
5193 if (offset) { /* esp. if nothing to pull */
5194 src = &AvARRAY(ary)[offset-1];
5195 dst = src - diff; /* diff is negative */
5196 for (i = offset; i > 0; i--) /* can't trust Copy */
5200 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5204 if (after) { /* anything to pull down? */
5205 src = AvARRAY(ary) + offset + length;
5206 dst = src + diff; /* diff is negative */
5207 Move(src, dst, after, SV*);
5209 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5210 /* avoid later double free */
5217 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5218 Safefree(tmparyval);
5221 else { /* no, expanding (or same) */
5222 SV** tmparyval = NULL;
5224 Newx(tmparyval, length, SV*); /* so remember deletion */
5225 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5228 if (diff > 0) { /* expanding */
5229 /* push up or down? */
5230 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5234 Move(src, dst, offset, SV*);
5236 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5238 AvFILLp(ary) += diff;
5241 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5242 av_extend(ary, AvFILLp(ary) + diff);
5243 AvFILLp(ary) += diff;
5246 dst = AvARRAY(ary) + AvFILLp(ary);
5248 for (i = after; i; i--) {
5256 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5259 MARK = ORIGMARK + 1;
5260 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5262 const bool real = cBOOL(AvREAL(ary));
5264 EXTEND_MORTAL(length);
5265 for (i = 0, dst = MARK; i < length; i++) {
5266 if ((*dst = tmparyval[i])) {
5268 sv_2mortal(*dst); /* free them eventually */
5270 else *dst = &PL_sv_undef;
5276 else if (length--) {
5277 *MARK = tmparyval[length];
5280 while (length-- > 0)
5281 SvREFCNT_dec(tmparyval[length]);
5285 *MARK = &PL_sv_undef;
5286 Safefree(tmparyval);
5290 mg_set(MUTABLE_SV(ary));
5298 dSP; dMARK; dORIGMARK; dTARGET;
5299 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5300 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5303 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5306 ENTER_with_name("call_PUSH");
5307 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5308 LEAVE_with_name("call_PUSH");
5312 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5313 PL_delaymagic = DM_DELAY;
5314 for (++MARK; MARK <= SP; MARK++) {
5316 if (*MARK) SvGETMAGIC(*MARK);
5319 sv_setsv_nomg(sv, *MARK);
5320 av_store(ary, AvFILLp(ary)+1, sv);
5322 if (PL_delaymagic & DM_ARRAY_ISA)
5323 mg_set(MUTABLE_SV(ary));
5328 if (OP_GIMME(PL_op, 0) != G_VOID) {
5329 PUSHi( AvFILL(ary) + 1 );
5334 /* also used for: pp_pop()*/
5338 AV * const av = PL_op->op_flags & OPf_SPECIAL
5339 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5340 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5344 (void)sv_2mortal(sv);
5351 dSP; dMARK; dORIGMARK; dTARGET;
5352 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5353 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5356 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5359 ENTER_with_name("call_UNSHIFT");
5360 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5361 LEAVE_with_name("call_UNSHIFT");
5366 av_unshift(ary, SP - MARK);
5368 SV * const sv = newSVsv(*++MARK);
5369 (void)av_store(ary, i++, sv);
5373 if (OP_GIMME(PL_op, 0) != G_VOID) {
5374 PUSHi( AvFILL(ary) + 1 );
5383 if (GIMME == G_ARRAY) {
5384 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5388 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5389 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5390 av = MUTABLE_AV((*SP));
5391 /* In-place reversing only happens in void context for the array
5392 * assignment. We don't need to push anything on the stack. */
5395 if (SvMAGICAL(av)) {
5397 SV *tmp = sv_newmortal();
5398 /* For SvCANEXISTDELETE */
5401 bool can_preserve = SvCANEXISTDELETE(av);
5403 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5407 if (!av_exists(av, i)) {
5408 if (av_exists(av, j)) {
5409 SV *sv = av_delete(av, j, 0);
5410 begin = *av_fetch(av, i, TRUE);
5411 sv_setsv_mg(begin, sv);
5415 else if (!av_exists(av, j)) {
5416 SV *sv = av_delete(av, i, 0);
5417 end = *av_fetch(av, j, TRUE);
5418 sv_setsv_mg(end, sv);
5423 begin = *av_fetch(av, i, TRUE);
5424 end = *av_fetch(av, j, TRUE);
5425 sv_setsv(tmp, begin);
5426 sv_setsv_mg(begin, end);
5427 sv_setsv_mg(end, tmp);
5431 SV **begin = AvARRAY(av);
5434 SV **end = begin + AvFILLp(av);
5436 while (begin < end) {
5437 SV * const tmp = *begin;
5448 SV * const tmp = *MARK;
5452 /* safe as long as stack cannot get extended in the above */
5463 SvUTF8_off(TARG); /* decontaminate */
5465 do_join(TARG, &PL_sv_no, MARK, SP);
5467 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5470 up = SvPV_force(TARG, len);
5472 if (DO_UTF8(TARG)) { /* first reverse each character */
5473 U8* s = (U8*)SvPVX(TARG);
5474 const U8* send = (U8*)(s + len);
5476 if (UTF8_IS_INVARIANT(*s)) {
5481 if (!utf8_to_uvchr_buf(s, send, 0))
5485 down = (char*)(s - 1);
5486 /* reverse this character */
5490 *down-- = (char)tmp;
5496 down = SvPVX(TARG) + len - 1;
5500 *down-- = (char)tmp;
5502 (void)SvPOK_only_UTF8(TARG);
5513 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5514 IV limit = POPi; /* note, negative is forever */
5515 SV * const sv = POPs;
5517 const char *s = SvPV_const(sv, len);
5518 const bool do_utf8 = DO_UTF8(sv);
5519 const char *strend = s + len;
5525 const STRLEN slen = do_utf8
5526 ? utf8_length((U8*)s, (U8*)strend)
5527 : (STRLEN)(strend - s);
5528 SSize_t maxiters = slen + 10;
5529 I32 trailing_empty = 0;
5531 const I32 origlimit = limit;
5534 const I32 gimme = GIMME_V;
5536 const I32 oldsave = PL_savestack_ix;
5537 U32 make_mortal = SVs_TEMP;
5542 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5547 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5550 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5551 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5554 if (pm->op_pmreplrootu.op_pmtargetoff) {
5555 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5558 if (pm->op_pmreplrootu.op_pmtargetgv) {
5559 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5562 else if (pm->op_targ)
5563 ary = (AV *)PAD_SVl(pm->op_targ);
5568 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5571 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5573 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5580 for (i = AvFILLp(ary); i >= 0; i--)
5581 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5583 /* temporarily switch stacks */
5584 SAVESWITCHSTACK(PL_curstack, ary);
5588 base = SP - PL_stack_base;
5590 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5592 while (isSPACE_utf8(s))
5595 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5596 while (isSPACE_LC(*s))
5604 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5608 gimme_scalar = gimme == G_SCALAR && !ary;
5611 limit = maxiters + 2;
5612 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5615 /* this one uses 'm' and is a negative test */
5617 while (m < strend && ! isSPACE_utf8(m) ) {
5618 const int t = UTF8SKIP(m);
5619 /* isSPACE_utf8 returns FALSE for malform utf8 */
5626 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5628 while (m < strend && !isSPACE_LC(*m))
5631 while (m < strend && !isSPACE(*m))
5644 dstr = newSVpvn_flags(s, m-s,
5645 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5649 /* skip the whitespace found last */
5651 s = m + UTF8SKIP(m);
5655 /* this one uses 's' and is a positive test */
5657 while (s < strend && isSPACE_utf8(s) )
5660 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5662 while (s < strend && isSPACE_LC(*s))
5665 while (s < strend && isSPACE(*s))
5670 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5672 for (m = s; m < strend && *m != '\n'; m++)
5685 dstr = newSVpvn_flags(s, m-s,
5686 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5692 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5694 Pre-extend the stack, either the number of bytes or
5695 characters in the string or a limited amount, triggered by:
5697 my ($x, $y) = split //, $str;
5701 if (!gimme_scalar) {
5702 const U32 items = limit - 1;
5711 /* keep track of how many bytes we skip over */
5721 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5734 dstr = newSVpvn(s, 1);
5750 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5751 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5752 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5753 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5754 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5755 SV * const csv = CALLREG_INTUIT_STRING(rx);
5757 len = RX_MINLENRET(rx);
5758 if (len == 1 && !RX_UTF8(rx) && !tail) {
5759 const char c = *SvPV_nolen_const(csv);
5761 for (m = s; m < strend && *m != c; m++)
5772 dstr = newSVpvn_flags(s, m-s,
5773 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5776 /* The rx->minlen is in characters but we want to step
5777 * s ahead by bytes. */
5779 s = (char*)utf8_hop((U8*)m, len);
5781 s = m + len; /* Fake \n at the end */
5785 while (s < strend && --limit &&
5786 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5787 csv, multiline ? FBMrf_MULTILINE : 0)) )
5796 dstr = newSVpvn_flags(s, m-s,
5797 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5800 /* The rx->minlen is in characters but we want to step
5801 * s ahead by bytes. */
5803 s = (char*)utf8_hop((U8*)m, len);
5805 s = m + len; /* Fake \n at the end */
5810 maxiters += slen * RX_NPARENS(rx);
5811 while (s < strend && --limit)
5815 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5818 if (rex_return == 0)
5820 TAINT_IF(RX_MATCH_TAINTED(rx));
5821 /* we never pass the REXEC_COPY_STR flag, so it should
5822 * never get copied */
5823 assert(!RX_MATCH_COPIED(rx));
5824 m = RX_OFFS(rx)[0].start + orig;
5833 dstr = newSVpvn_flags(s, m-s,
5834 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5837 if (RX_NPARENS(rx)) {
5839 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5840 s = RX_OFFS(rx)[i].start + orig;
5841 m = RX_OFFS(rx)[i].end + orig;
5843 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5844 parens that didn't match -- they should be set to
5845 undef, not the empty string */
5853 if (m >= orig && s >= orig) {
5854 dstr = newSVpvn_flags(s, m-s,
5855 (do_utf8 ? SVf_UTF8 : 0)
5859 dstr = &PL_sv_undef; /* undef, not "" */
5865 s = RX_OFFS(rx)[0].end + orig;
5869 if (!gimme_scalar) {
5870 iters = (SP - PL_stack_base) - base;
5872 if (iters > maxiters)
5873 DIE(aTHX_ "Split loop");
5875 /* keep field after final delim? */
5876 if (s < strend || (iters && origlimit)) {
5877 if (!gimme_scalar) {
5878 const STRLEN l = strend - s;
5879 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5884 else if (!origlimit) {
5886 iters -= trailing_empty;
5888 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5889 if (TOPs && !make_mortal)
5891 *SP-- = &PL_sv_undef;
5898 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5902 if (SvSMAGICAL(ary)) {
5904 mg_set(MUTABLE_SV(ary));
5907 if (gimme == G_ARRAY) {
5909 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5916 ENTER_with_name("call_PUSH");
5917 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5918 LEAVE_with_name("call_PUSH");
5920 if (gimme == G_ARRAY) {
5922 /* EXTEND should not be needed - we just popped them */
5924 for (i=0; i < iters; i++) {
5925 SV **svp = av_fetch(ary, i, FALSE);
5926 PUSHs((svp) ? *svp : &PL_sv_undef);
5933 if (gimme == G_ARRAY)
5945 SV *const sv = PAD_SVl(PL_op->op_targ);
5947 if (SvPADSTALE(sv)) {
5950 RETURNOP(cLOGOP->op_other);
5952 RETURNOP(cLOGOP->op_next);
5961 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5962 || SvTYPE(retsv) == SVt_PVCV) {
5963 retsv = refto(retsv);
5970 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5971 * that aren't implemented on a particular platform */
5973 PP(unimplemented_op)
5975 const Optype op_type = PL_op->op_type;
5976 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5977 with out of range op numbers - it only "special" cases op_custom.
5978 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5979 if we get here for a custom op then that means that the custom op didn't
5980 have an implementation. Given that OP_NAME() looks up the custom op
5981 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5982 registers &PL_unimplemented_op as the address of their custom op.
5983 NULL doesn't generate a useful error message. "custom" does. */
5984 const char *const name = op_type >= OP_max
5985 ? "[out of range]" : PL_op_name[PL_op->op_type];
5986 if(OP_IS_SOCKET(op_type))
5987 DIE(aTHX_ PL_no_sock_func, name);
5988 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5991 /* For sorting out arguments passed to a &CORE:: subroutine */
5995 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5996 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5997 AV * const at_ = GvAV(PL_defgv);
5998 SV **svp = at_ ? AvARRAY(at_) : NULL;
5999 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6000 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6001 bool seen_question = 0;
6002 const char *err = NULL;
6003 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6005 /* Count how many args there are first, to get some idea how far to
6006 extend the stack. */
6008 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6010 if (oa & OA_OPTIONAL) seen_question = 1;
6011 if (!seen_question) minargs++;
6015 if(numargs < minargs) err = "Not enough";
6016 else if(numargs > maxargs) err = "Too many";
6018 /* diag_listed_as: Too many arguments for %s */
6020 "%s arguments for %s", err,
6021 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6024 /* Reset the stack pointer. Without this, we end up returning our own
6025 arguments in list context, in addition to the values we are supposed
6026 to return. nextstate usually does this on sub entry, but we need
6027 to run the next op with the caller's hints, so we cannot have a
6029 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6031 if(!maxargs) RETURN;
6033 /* We do this here, rather than with a separate pushmark op, as it has
6034 to come in between two things this function does (stack reset and
6035 arg pushing). This seems the easiest way to do it. */
6038 (void)Perl_pp_pushmark(aTHX);
6041 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6042 PUTBACK; /* The code below can die in various places. */
6044 oa = PL_opargs[opnum] >> OASHIFT;
6045 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6050 if (!numargs && defgv && whicharg == minargs + 1) {
6051 PUSHs(find_rundefsv2(
6052 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6053 cxstack[cxstack_ix].blk_oldcop->cop_seq
6056 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6060 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6065 if (!svp || !*svp || !SvROK(*svp)
6066 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6068 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6069 "Type of arg %d to &CORE::%s must be hash reference",
6070 whicharg, OP_DESC(PL_op->op_next)
6075 if (!numargs) PUSHs(NULL);
6076 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6077 /* no magic here, as the prototype will have added an extra
6078 refgen and we just want what was there before that */
6081 const bool constr = PL_op->op_private & whicharg;
6083 svp && *svp ? *svp : &PL_sv_undef,
6084 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6090 if (!numargs) goto try_defsv;
6092 const bool wantscalar =
6093 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6094 if (!svp || !*svp || !SvROK(*svp)
6095 /* We have to permit globrefs even for the \$ proto, as
6096 *foo is indistinguishable from ${\*foo}, and the proto-
6097 type permits the latter. */
6098 || SvTYPE(SvRV(*svp)) > (
6099 wantscalar ? SVt_PVLV
6100 : opnum == OP_LOCK || opnum == OP_UNDEF
6106 "Type of arg %d to &CORE::%s must be %s",
6107 whicharg, PL_op_name[opnum],
6109 ? "scalar reference"
6110 : opnum == OP_LOCK || opnum == OP_UNDEF
6111 ? "reference to one of [$@%&*]"
6112 : "reference to one of [$@%*]"
6115 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6116 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6117 /* Undo @_ localisation, so that sub exit does not undo
6118 part of our undeffing. */
6119 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6121 cx->cx_type &= ~ CXp_HASARGS;
6122 assert(!AvREAL(cx->blk_sub.argarray));
6127 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6139 if (PL_op->op_private & OPpOFFBYONE) {
6140 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6142 else cv = find_runcv(NULL);
6143 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6148 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6149 const bool can_preserve)
6151 const SSize_t ix = SvIV(keysv);
6152 if (can_preserve ? av_exists(av, ix) : TRUE) {
6153 SV ** const svp = av_fetch(av, ix, 1);
6155 Perl_croak(aTHX_ PL_no_aelem, ix);
6156 save_aelem(av, ix, svp);
6159 SAVEADELETE(av, ix);
6163 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6164 const bool can_preserve)
6166 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6167 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6168 SV ** const svp = he ? &HeVAL(he) : NULL;
6170 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6171 save_helem_flags(hv, keysv, svp, 0);
6174 SAVEHDELETE(hv, keysv);
6178 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6180 if (type == OPpLVREF_SV) {
6181 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6184 else if (type == OPpLVREF_AV)
6185 /* XXX Inefficient, as it creates a new AV, which we are
6186 about to clobber. */
6189 assert(type == OPpLVREF_HV);
6190 /* XXX Likewise inefficient. */
6199 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6200 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6202 const char *bad = NULL;
6203 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6204 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6207 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6211 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6215 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6219 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6223 /* diag_listed_as: Assigned value is not %s reference */
6224 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6228 switch (left ? SvTYPE(left) : 0) {
6231 SV * const old = PAD_SV(ARGTARG);
6232 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6234 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6236 SAVECLEARSV(PAD_SVl(ARGTARG));
6240 if (PL_op->op_private & OPpLVAL_INTRO) {
6241 S_localise_gv_slot(aTHX_ (GV *)left, type);
6243 gv_setref(left, sv);
6247 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6248 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6249 SvCANEXISTDELETE(left));
6251 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6254 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6255 S_localise_helem_lval(aTHX_ (HV *)left, key,
6256 SvCANEXISTDELETE(left));
6257 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6259 if (PL_op->op_flags & OPf_MOD)
6260 SETs(sv_2mortal(newSVsv(sv)));
6261 /* XXX else can weak references go stale before they are read, e.g.,
6270 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6271 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6272 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6273 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6274 &PL_vtbl_lvref, (char *)elem,
6275 elem ? HEf_SVKEY : (I32)ARGTARG);
6276 mg->mg_private = PL_op->op_private;
6277 if (PL_op->op_private & OPpLVREF_ITER)
6278 mg->mg_flags |= MGf_PERSIST;
6279 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6283 const bool can_preserve = SvCANEXISTDELETE(arg);
6284 if (SvTYPE(arg) == SVt_PVAV)
6285 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6287 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6290 S_localise_gv_slot(aTHX_ (GV *)arg,
6291 PL_op->op_private & OPpLVREF_TYPE);
6293 else if (!(PL_op->op_private & OPpPAD_STATE))
6294 SAVECLEARSV(PAD_SVl(ARGTARG));
6303 AV * const av = (AV *)POPs;
6304 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6305 bool can_preserve = FALSE;
6307 if (UNLIKELY(localizing)) {
6312 can_preserve = SvCANEXISTDELETE(av);
6314 if (SvTYPE(av) == SVt_PVAV) {
6317 for (svp = MARK + 1; svp <= SP; svp++) {
6318 const SSize_t elem = SvIV(*svp);
6322 if (max > AvMAX(av))
6327 while (++MARK <= SP) {
6328 SV * const elemsv = *MARK;
6329 if (SvTYPE(av) == SVt_PVAV)
6330 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6332 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6333 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6334 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6341 if (PL_op->op_flags & OPf_STACKED)
6342 Perl_pp_rv2av(aTHX);
6344 Perl_pp_padav(aTHX);
6348 SETs(0); /* special alias marker that aassign recognises */
6356 * c-indentation-style: bsd
6358 * indent-tabs-mode: nil
6361 * ex: set ts=8 sts=4 sw=4 et: