3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
32 #include "regcharclass.h"
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
46 #if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
53 /* variations on pp_null */
58 if (GIMME_V == G_SCALAR)
65 /* This is also called directly by pp_lvavref. */
70 assert(SvTYPE(TARG) == SVt_PVAV);
71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
76 if (PL_op->op_flags & OPf_REF) {
80 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
81 const I32 flags = is_lvalue_sub();
82 if (flags && !(flags & OPpENTERSUB_INARGS)) {
83 if (GIMME_V == G_SCALAR)
84 /* diag_listed_as: Can't return %s to lvalue scalar context */
85 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
92 if (gimme == G_ARRAY) {
93 /* XXX see also S_pushav in pp_hot.c */
94 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
96 if (SvMAGICAL(TARG)) {
98 for (i=0; i < maxarg; i++) {
99 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
100 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
105 for (i=0; i < maxarg; i++) {
106 SV * const sv = AvARRAY((const AV *)TARG)[i];
107 SP[i+1] = sv ? sv : &PL_sv_undef;
112 else if (gimme == G_SCALAR) {
113 SV* const sv = sv_newmortal();
114 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
115 sv_setiv(sv, maxarg);
126 assert(SvTYPE(TARG) == SVt_PVHV);
128 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
129 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
130 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
132 if (PL_op->op_flags & OPf_REF)
134 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
135 const I32 flags = is_lvalue_sub();
136 if (flags && !(flags & OPpENTERSUB_INARGS)) {
137 if (GIMME_V == G_SCALAR)
138 /* diag_listed_as: Can't return %s to lvalue scalar context */
139 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
145 if (gimme == G_ARRAY) {
146 RETURNOP(Perl_do_kv(aTHX));
148 else if ((PL_op->op_private & OPpTRUEBOOL
149 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
150 && block_gimme() == G_VOID ))
151 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
153 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
154 else if (gimme == G_SCALAR) {
155 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
164 assert(SvTYPE(TARG) == SVt_PVCV);
172 SvPADSTALE_off(TARG);
179 CV * const protocv = PadnamePROTOCV(
180 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
182 assert(SvTYPE(TARG) == SVt_PVCV);
184 if (CvISXSUB(protocv)) { /* constant */
185 /* XXX Should we clone it here? */
186 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
187 to introcv and remove the SvPADSTALE_off. */
188 SAVEPADSVANDMORTALIZE(ARGTARG);
189 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
192 if (CvROOT(protocv)) {
193 assert(CvCLONE(protocv));
194 assert(!CvCLONED(protocv));
196 cv_clone_into(protocv,(CV *)TARG);
197 SAVECLEARSV(PAD_SVl(ARGTARG));
204 /* In some cases this function inspects PL_op. If this function is called
205 for new op types, more bool parameters may need to be added in place of
208 When noinit is true, the absence of a gv will cause a retval of undef.
209 This is unrelated to the cv-to-gv assignment case.
213 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
216 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
219 sv = amagic_deref_call(sv, to_gv_amg);
223 if (SvTYPE(sv) == SVt_PVIO) {
224 GV * const gv = MUTABLE_GV(sv_newmortal());
225 gv_init(gv, 0, "__ANONIO__", 10, 0);
226 GvIOp(gv) = MUTABLE_IO(sv);
227 SvREFCNT_inc_void_NN(sv);
230 else if (!isGV_with_GP(sv)) {
231 Perl_die(aTHX_ "Not a GLOB reference");
235 if (!isGV_with_GP(sv)) {
237 /* If this is a 'my' scalar and flag is set then vivify
240 if (vivify_sv && sv != &PL_sv_undef) {
243 Perl_croak_no_modify();
244 if (cUNOP->op_targ) {
245 SV * const namesv = PAD_SV(cUNOP->op_targ);
246 HV *stash = CopSTASH(PL_curcop);
247 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
248 gv = MUTABLE_GV(newSV(0));
249 gv_init_sv(gv, stash, namesv, 0);
252 const char * const name = CopSTASHPV(PL_curcop);
253 gv = newGVgen_flags(name,
254 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
255 SvREFCNT_inc_simple_void_NN(gv);
257 prepare_SV_for_RV(sv);
258 SvRV_set(sv, MUTABLE_SV(gv));
263 if (PL_op->op_flags & OPf_REF || strict) {
264 Perl_die(aTHX_ PL_no_usym, "a symbol");
266 if (ckWARN(WARN_UNINITIALIZED))
272 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
273 sv, GV_ADDMG, SVt_PVGV
282 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
286 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
287 == OPpDONT_INIT_GV) {
288 /* We are the target of a coderef assignment. Return
289 the scalar unchanged, and let pp_sasssign deal with
293 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
295 /* FAKE globs in the symbol table cause weird bugs (#77810) */
299 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
300 SV *newsv = sv_newmortal();
301 sv_setsv_flags(newsv, sv, 0);
313 sv, PL_op->op_private & OPpDEREF,
314 PL_op->op_private & HINT_STRICT_REFS,
315 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
316 || PL_op->op_type == OP_READLINE
318 if (PL_op->op_private & OPpLVAL_INTRO)
319 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
324 /* Helper function for pp_rv2sv and pp_rv2av */
326 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
327 const svtype type, SV ***spp)
331 PERL_ARGS_ASSERT_SOFTREF2XV;
333 if (PL_op->op_private & HINT_STRICT_REFS) {
335 Perl_die(aTHX_ PL_no_symref_sv, sv,
336 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
338 Perl_die(aTHX_ PL_no_usym, what);
342 PL_op->op_flags & OPf_REF
344 Perl_die(aTHX_ PL_no_usym, what);
345 if (ckWARN(WARN_UNINITIALIZED))
347 if (type != SVt_PV && GIMME_V == G_ARRAY) {
351 **spp = &PL_sv_undef;
354 if ((PL_op->op_flags & OPf_SPECIAL) &&
355 !(PL_op->op_flags & OPf_MOD))
357 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
359 **spp = &PL_sv_undef;
364 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
377 sv = amagic_deref_call(sv, to_sv_amg);
381 if (SvTYPE(sv) >= SVt_PVAV)
382 DIE(aTHX_ "Not a SCALAR reference");
387 if (!isGV_with_GP(gv)) {
388 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
394 if (PL_op->op_flags & OPf_MOD) {
395 if (PL_op->op_private & OPpLVAL_INTRO) {
396 if (cUNOP->op_first->op_type == OP_NULL)
397 sv = save_scalar(MUTABLE_GV(TOPs));
399 sv = save_scalar(gv);
401 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
403 else if (PL_op->op_private & OPpDEREF)
404 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
413 AV * const av = MUTABLE_AV(TOPs);
414 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
416 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
418 *svp = newSV_type(SVt_PVMG);
419 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
423 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
432 if (PL_op->op_flags & OPf_MOD || LVRET) {
433 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
434 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
436 LvTARG(ret) = SvREFCNT_inc_simple(sv);
437 SETs(ret); /* no SvSETMAGIC */
440 const MAGIC * const mg = mg_find_mglob(sv);
441 if (mg && mg->mg_len != -1) {
443 STRLEN i = mg->mg_len;
444 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
445 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
459 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
461 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
462 == OPpMAY_RETURN_CONSTANT)
465 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
466 /* (But not in defined().) */
468 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
470 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
471 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
472 ? MUTABLE_CV(SvRV(gv))
476 cv = MUTABLE_CV(&PL_sv_undef);
477 SETs(MUTABLE_SV(cv));
487 SV *ret = &PL_sv_undef;
489 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
490 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
491 const char * s = SvPVX_const(TOPs);
492 if (strnEQ(s, "CORE::", 6)) {
493 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
495 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
496 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
498 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
504 cv = sv_2cv(TOPs, &stash, &gv, 0);
506 ret = newSVpvn_flags(
507 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
517 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
519 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
521 PUSHs(MUTABLE_SV(cv));
535 if (GIMME_V != G_ARRAY) {
541 *MARK = &PL_sv_undef;
543 *MARK = refto(*MARK);
547 EXTEND_MORTAL(SP - MARK);
549 *MARK = refto(*MARK);
554 S_refto(pTHX_ SV *sv)
558 PERL_ARGS_ASSERT_REFTO;
560 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
563 if (!(sv = LvTARG(sv)))
566 SvREFCNT_inc_void_NN(sv);
568 else if (SvTYPE(sv) == SVt_PVAV) {
569 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
570 av_reify(MUTABLE_AV(sv));
572 SvREFCNT_inc_void_NN(sv);
574 else if (SvPADTMP(sv)) {
579 SvREFCNT_inc_void_NN(sv);
582 sv_upgrade(rv, SVt_IV);
591 SV * const sv = TOPs;
599 /* use the return value that is in a register, its the same as TARG */
600 TARG = sv_ref(TARG,SvRV(sv),TRUE);
615 stash = CopSTASH(PL_curcop);
616 if (SvTYPE(stash) != SVt_PVHV)
617 Perl_croak(aTHX_ "Attempt to bless into a freed package");
620 SV * const ssv = POPs;
624 if (!ssv) goto curstash;
627 if (!SvAMAGIC(ssv)) {
629 Perl_croak(aTHX_ "Attempt to bless into a reference");
631 /* SvAMAGIC is on here, but it only means potentially overloaded,
632 so after stringification: */
633 ptr = SvPV_nomg_const(ssv,len);
634 /* We need to check the flag again: */
635 if (!SvAMAGIC(ssv)) goto frog;
637 else ptr = SvPV_nomg_const(ssv,len);
639 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
640 "Explicit blessing to '' (assuming package main)");
641 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
644 (void)sv_bless(TOPs, stash);
654 const char * const elem = SvPV_const(sv, len);
655 GV * const gv = MUTABLE_GV(TOPs);
660 /* elem will always be NUL terminated. */
661 const char * const second_letter = elem + 1;
664 if (len == 5 && strEQ(second_letter, "RRAY"))
666 tmpRef = MUTABLE_SV(GvAV(gv));
667 if (tmpRef && !AvREAL((const AV *)tmpRef)
668 && AvREIFY((const AV *)tmpRef))
669 av_reify(MUTABLE_AV(tmpRef));
673 if (len == 4 && strEQ(second_letter, "ODE"))
674 tmpRef = MUTABLE_SV(GvCVu(gv));
677 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
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. */
737 /* Make study a no-op. It's no longer useful and its existence
738 complicates matters elsewhere. */
744 /* also used for: pp_transr() */
751 if (PL_op->op_flags & OPf_STACKED)
756 sv = PAD_SV(ARGTARG);
761 if(PL_op->op_type == OP_TRANSR) {
763 const char * const pv = SvPV(sv,len);
764 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
769 I32 i = do_trans(sv);
775 /* Lvalue operators. */
778 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
784 PERL_ARGS_ASSERT_DO_CHOMP;
786 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
788 if (SvTYPE(sv) == SVt_PVAV) {
790 AV *const av = MUTABLE_AV(sv);
791 const I32 max = AvFILL(av);
793 for (i = 0; i <= max; i++) {
794 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
795 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
796 count += do_chomp(retval, sv, chomping);
800 else if (SvTYPE(sv) == SVt_PVHV) {
801 HV* const hv = MUTABLE_HV(sv);
803 (void)hv_iterinit(hv);
804 while ((entry = hv_iternext(hv)))
805 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
808 else if (SvREADONLY(sv)) {
809 Perl_croak_no_modify();
814 /* XXX, here sv is utf8-ized as a side-effect!
815 If encoding.pm is used properly, almost string-generating
816 operations, including literal strings, chr(), input data, etc.
817 should have been utf8-ized already, right?
819 sv_recode_to_utf8(sv, _get_encoding());
826 char *temp_buffer = NULL;
831 goto nope_free_nothing;
833 while (len && s[-1] == '\n') {
840 STRLEN rslen, rs_charlen;
841 const char *rsptr = SvPV_const(PL_rs, rslen);
843 rs_charlen = SvUTF8(PL_rs)
847 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
848 /* Assumption is that rs is shorter than the scalar. */
850 /* RS is utf8, scalar is 8 bit. */
852 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
855 /* Cannot downgrade, therefore cannot possibly match.
856 At this point, temp_buffer is not alloced, and
857 is the buffer inside PL_rs, so dont free it.
859 assert (temp_buffer == rsptr);
864 else if (IN_ENCODING) {
865 /* RS is 8 bit, encoding.pm is used.
866 * Do not recode PL_rs as a side-effect. */
867 svrecode = newSVpvn(rsptr, rslen);
868 sv_recode_to_utf8(svrecode, _get_encoding());
869 rsptr = SvPV_const(svrecode, rslen);
870 rs_charlen = sv_len_utf8(svrecode);
873 /* RS is 8 bit, scalar is utf8. */
874 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
888 if (memNE(s, rsptr, rslen))
893 SvPV_force_nomg_nolen(sv);
900 Safefree(temp_buffer);
902 SvREFCNT_dec(svrecode);
906 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
907 s = SvPV_force_nomg(sv, len);
910 char * const send = s + len;
911 char * const start = s;
913 while (s > start && UTF8_IS_CONTINUATION(*s))
915 if (is_utf8_string((U8*)s, send - s)) {
916 sv_setpvn(retval, s, send - s);
918 SvCUR_set(sv, s - start);
924 sv_setpvs(retval, "");
928 sv_setpvn(retval, s, 1);
935 sv_setpvs(retval, "");
942 /* also used for: pp_schomp() */
947 const bool chomping = PL_op->op_type == OP_SCHOMP;
949 const size_t count = do_chomp(TARG, TOPs, chomping);
951 sv_setiv(TARG, count);
957 /* also used for: pp_chomp() */
961 dSP; dMARK; dTARGET; dORIGMARK;
962 const bool chomping = PL_op->op_type == OP_CHOMP;
966 count += do_chomp(TARG, *++MARK, chomping);
968 sv_setiv(TARG, count);
979 if (!PL_op->op_private) {
991 if (SvTHINKFIRST(sv))
992 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
994 switch (SvTYPE(sv)) {
998 av_undef(MUTABLE_AV(sv));
1001 hv_undef(MUTABLE_HV(sv));
1004 if (cv_const_sv((const CV *)sv))
1005 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1006 "Constant subroutine %"SVf" undefined",
1007 SVfARG(CvANON((const CV *)sv)
1008 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1009 : sv_2mortal(newSVhek(
1011 ? CvNAME_HEK((CV *)sv)
1012 : GvENAME_HEK(CvGV((const CV *)sv))
1017 /* let user-undef'd sub keep its identity */
1018 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1021 assert(isGV_with_GP(sv));
1022 assert(!SvFAKE(sv));
1027 /* undef *Pkg::meth_name ... */
1029 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1030 && HvENAME_get(stash);
1032 if((stash = GvHV((const GV *)sv))) {
1033 if(HvENAME_get(stash))
1034 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1038 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1039 gp_free(MUTABLE_GV(sv));
1041 GvGP_set(sv, gp_ref(gp));
1042 #ifndef PERL_DONT_CREATE_GVSV
1043 GvSV(sv) = newSV(0);
1045 GvLINE(sv) = CopLINE(PL_curcop);
1046 GvEGV(sv) = MUTABLE_GV(sv);
1050 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1052 /* undef *Foo::ISA */
1053 if( strEQ(GvNAME((const GV *)sv), "ISA")
1054 && (stash = GvSTASH((const GV *)sv))
1055 && (method_changed || HvENAME(stash)) )
1056 mro_isa_changed_in(stash);
1057 else if(method_changed)
1058 mro_method_changed_in(
1059 GvSTASH((const GV *)sv)
1065 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1079 /* common "slow" code for pp_postinc and pp_postdec */
1082 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1086 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1089 TARG = sv_newmortal();
1096 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1097 if (inc && !SvOK(TARG))
1104 /* also used for: pp_i_postinc() */
1111 /* special-case sv being a simple integer */
1112 if (LIKELY(((sv->sv_flags &
1113 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1114 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1116 && SvIVX(sv) != IV_MAX)
1119 SvIV_set(sv, iv + 1);
1120 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1125 return S_postincdec_common(aTHX_ sv, TARG);
1129 /* also used for: pp_i_postdec() */
1136 /* special-case sv being a simple integer */
1137 if (LIKELY(((sv->sv_flags &
1138 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1139 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1141 && SvIVX(sv) != IV_MIN)
1144 SvIV_set(sv, iv - 1);
1145 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1150 return S_postincdec_common(aTHX_ sv, TARG);
1154 /* Ordinary operators. */
1158 dSP; dATARGET; SV *svl, *svr;
1159 #ifdef PERL_PRESERVE_IVUV
1162 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1165 #ifdef PERL_PRESERVE_IVUV
1166 /* For integer to integer power, we do the calculation by hand wherever
1167 we're sure it is safe; otherwise we call pow() and try to convert to
1168 integer afterwards. */
1169 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1177 const IV iv = SvIVX(svr);
1181 goto float_it; /* Can't do negative powers this way. */
1185 baseuok = SvUOK(svl);
1187 baseuv = SvUVX(svl);
1189 const IV iv = SvIVX(svl);
1192 baseuok = TRUE; /* effectively it's a UV now */
1194 baseuv = -iv; /* abs, baseuok == false records sign */
1197 /* now we have integer ** positive integer. */
1200 /* foo & (foo - 1) is zero only for a power of 2. */
1201 if (!(baseuv & (baseuv - 1))) {
1202 /* We are raising power-of-2 to a positive integer.
1203 The logic here will work for any base (even non-integer
1204 bases) but it can be less accurate than
1205 pow (base,power) or exp (power * log (base)) when the
1206 intermediate values start to spill out of the mantissa.
1207 With powers of 2 we know this can't happen.
1208 And powers of 2 are the favourite thing for perl
1209 programmers to notice ** not doing what they mean. */
1211 NV base = baseuok ? baseuv : -(NV)baseuv;
1216 while (power >>= 1) {
1224 SvIV_please_nomg(svr);
1227 unsigned int highbit = 8 * sizeof(UV);
1228 unsigned int diff = 8 * sizeof(UV);
1229 while (diff >>= 1) {
1231 if (baseuv >> highbit) {
1235 /* we now have baseuv < 2 ** highbit */
1236 if (power * highbit <= 8 * sizeof(UV)) {
1237 /* result will definitely fit in UV, so use UV math
1238 on same algorithm as above */
1241 const bool odd_power = cBOOL(power & 1);
1245 while (power >>= 1) {
1252 if (baseuok || !odd_power)
1253 /* answer is positive */
1255 else if (result <= (UV)IV_MAX)
1256 /* answer negative, fits in IV */
1257 SETi( -(IV)result );
1258 else if (result == (UV)IV_MIN)
1259 /* 2's complement assumption: special case IV_MIN */
1262 /* answer negative, doesn't fit */
1263 SETn( -(NV)result );
1271 NV right = SvNV_nomg(svr);
1272 NV left = SvNV_nomg(svl);
1275 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1277 We are building perl with long double support and are on an AIX OS
1278 afflicted with a powl() function that wrongly returns NaNQ for any
1279 negative base. This was reported to IBM as PMR #23047-379 on
1280 03/06/2006. The problem exists in at least the following versions
1281 of AIX and the libm fileset, and no doubt others as well:
1283 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1284 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1285 AIX 5.2.0 bos.adt.libm 5.2.0.85
1287 So, until IBM fixes powl(), we provide the following workaround to
1288 handle the problem ourselves. Our logic is as follows: for
1289 negative bases (left), we use fmod(right, 2) to check if the
1290 exponent is an odd or even integer:
1292 - if odd, powl(left, right) == -powl(-left, right)
1293 - if even, powl(left, right) == powl(-left, right)
1295 If the exponent is not an integer, the result is rightly NaNQ, so
1296 we just return that (as NV_NAN).
1300 NV mod2 = Perl_fmod( right, 2.0 );
1301 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1302 SETn( -Perl_pow( -left, right) );
1303 } else if (mod2 == 0.0) { /* even integer */
1304 SETn( Perl_pow( -left, right) );
1305 } else { /* fractional power */
1309 SETn( Perl_pow( left, right) );
1312 SETn( Perl_pow( left, right) );
1313 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1315 #ifdef PERL_PRESERVE_IVUV
1317 SvIV_please_nomg(svr);
1325 dSP; dATARGET; SV *svl, *svr;
1326 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1330 #ifdef PERL_PRESERVE_IVUV
1332 /* special-case some simple common cases */
1333 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1335 U32 flags = (svl->sv_flags & svr->sv_flags);
1336 if (flags & SVf_IOK) {
1337 /* both args are simple IVs */
1342 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1343 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1345 /* if both are in a range that can't under/overflow, do a
1346 * simple integer multiply: if the top halves(*) of both numbers
1347 * are 00...00 or 11...11, then it's safe.
1348 * (*) for 32-bits, the "top half" is the top 17 bits,
1349 * for 64-bits, its 33 bits */
1351 ((topl+1) | (topr+1))
1352 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1355 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1361 else if (flags & SVf_NOK) {
1362 /* both args are NVs */
1368 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1369 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1370 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1372 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1375 /* nothing was lost by converting to IVs */
1379 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1380 if (Perl_isinf(result)) {
1381 Zero((U8*)&result + 8, 8, U8);
1384 TARGn(result, 0); /* args not GMG, so can't be tainted */
1392 if (SvIV_please_nomg(svr)) {
1393 /* Unless the left argument is integer in range we are going to have to
1394 use NV maths. Hence only attempt to coerce the right argument if
1395 we know the left is integer. */
1396 /* Left operand is defined, so is it IV? */
1397 if (SvIV_please_nomg(svl)) {
1398 bool auvok = SvUOK(svl);
1399 bool buvok = SvUOK(svr);
1400 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1401 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1410 const IV aiv = SvIVX(svl);
1413 auvok = TRUE; /* effectively it's a UV now */
1415 /* abs, auvok == false records sign */
1416 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1422 const IV biv = SvIVX(svr);
1425 buvok = TRUE; /* effectively it's a UV now */
1427 /* abs, buvok == false records sign */
1428 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1432 /* If this does sign extension on unsigned it's time for plan B */
1433 ahigh = alow >> (4 * sizeof (UV));
1435 bhigh = blow >> (4 * sizeof (UV));
1437 if (ahigh && bhigh) {
1439 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1440 which is overflow. Drop to NVs below. */
1441 } else if (!ahigh && !bhigh) {
1442 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1443 so the unsigned multiply cannot overflow. */
1444 const UV product = alow * blow;
1445 if (auvok == buvok) {
1446 /* -ve * -ve or +ve * +ve gives a +ve result. */
1450 } else if (product <= (UV)IV_MIN) {
1451 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1452 /* -ve result, which could overflow an IV */
1454 /* can't negate IV_MIN, but there are aren't two
1455 * integers such that !ahigh && !bhigh, where the
1456 * product equals 0x800....000 */
1457 assert(product != (UV)IV_MIN);
1458 SETi( -(IV)product );
1460 } /* else drop to NVs below. */
1462 /* One operand is large, 1 small */
1465 /* swap the operands */
1467 bhigh = blow; /* bhigh now the temp var for the swap */
1471 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1472 multiplies can't overflow. shift can, add can, -ve can. */
1473 product_middle = ahigh * blow;
1474 if (!(product_middle & topmask)) {
1475 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1477 product_middle <<= (4 * sizeof (UV));
1478 product_low = alow * blow;
1480 /* as for pp_add, UV + something mustn't get smaller.
1481 IIRC ANSI mandates this wrapping *behaviour* for
1482 unsigned whatever the actual representation*/
1483 product_low += product_middle;
1484 if (product_low >= product_middle) {
1485 /* didn't overflow */
1486 if (auvok == buvok) {
1487 /* -ve * -ve or +ve * +ve gives a +ve result. */
1489 SETu( product_low );
1491 } else if (product_low <= (UV)IV_MIN) {
1492 /* 2s complement assumption again */
1493 /* -ve result, which could overflow an IV */
1495 SETi(product_low == (UV)IV_MIN
1496 ? IV_MIN : -(IV)product_low);
1498 } /* else drop to NVs below. */
1500 } /* product_middle too large */
1501 } /* ahigh && bhigh */
1506 NV right = SvNV_nomg(svr);
1507 NV left = SvNV_nomg(svl);
1508 NV result = left * right;
1511 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1512 if (Perl_isinf(result)) {
1513 Zero((U8*)&result + 8, 8, U8);
1523 dSP; dATARGET; SV *svl, *svr;
1524 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1527 /* Only try to do UV divide first
1528 if ((SLOPPYDIVIDE is true) or
1529 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1531 The assumption is that it is better to use floating point divide
1532 whenever possible, only doing integer divide first if we can't be sure.
1533 If NV_PRESERVES_UV is true then we know at compile time that no UV
1534 can be too large to preserve, so don't need to compile the code to
1535 test the size of UVs. */
1538 # define PERL_TRY_UV_DIVIDE
1539 /* ensure that 20./5. == 4. */
1541 # ifdef PERL_PRESERVE_IVUV
1542 # ifndef NV_PRESERVES_UV
1543 # define PERL_TRY_UV_DIVIDE
1548 #ifdef PERL_TRY_UV_DIVIDE
1549 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1550 bool left_non_neg = SvUOK(svl);
1551 bool right_non_neg = SvUOK(svr);
1555 if (right_non_neg) {
1559 const IV biv = SvIVX(svr);
1562 right_non_neg = TRUE; /* effectively it's a UV now */
1565 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1568 /* historically undef()/0 gives a "Use of uninitialized value"
1569 warning before dieing, hence this test goes here.
1570 If it were immediately before the second SvIV_please, then
1571 DIE() would be invoked before left was even inspected, so
1572 no inspection would give no warning. */
1574 DIE(aTHX_ "Illegal division by zero");
1580 const IV aiv = SvIVX(svl);
1583 left_non_neg = TRUE; /* effectively it's a UV now */
1586 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1592 /* For sloppy divide we always attempt integer division. */
1594 /* Otherwise we only attempt it if either or both operands
1595 would not be preserved by an NV. If both fit in NVs
1596 we fall through to the NV divide code below. However,
1597 as left >= right to ensure integer result here, we know that
1598 we can skip the test on the right operand - right big
1599 enough not to be preserved can't get here unless left is
1602 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1605 /* Integer division can't overflow, but it can be imprecise. */
1606 const UV result = left / right;
1607 if (result * right == left) {
1608 SP--; /* result is valid */
1609 if (left_non_neg == right_non_neg) {
1610 /* signs identical, result is positive. */
1614 /* 2s complement assumption */
1615 if (result <= (UV)IV_MIN)
1616 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1618 /* It's exact but too negative for IV. */
1619 SETn( -(NV)result );
1622 } /* tried integer divide but it was not an integer result */
1623 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1624 } /* one operand wasn't SvIOK */
1625 #endif /* PERL_TRY_UV_DIVIDE */
1627 NV right = SvNV_nomg(svr);
1628 NV left = SvNV_nomg(svl);
1629 (void)POPs;(void)POPs;
1630 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1631 if (! Perl_isnan(right) && right == 0.0)
1635 DIE(aTHX_ "Illegal division by zero");
1636 PUSHn( left / right );
1644 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1648 bool left_neg = FALSE;
1649 bool right_neg = FALSE;
1650 bool use_double = FALSE;
1651 bool dright_valid = FALSE;
1654 SV * const svr = TOPs;
1655 SV * const svl = TOPm1s;
1656 if (SvIV_please_nomg(svr)) {
1657 right_neg = !SvUOK(svr);
1661 const IV biv = SvIVX(svr);
1664 right_neg = FALSE; /* effectively it's a UV now */
1666 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1671 dright = SvNV_nomg(svr);
1672 right_neg = dright < 0;
1675 if (dright < UV_MAX_P1) {
1676 right = U_V(dright);
1677 dright_valid = TRUE; /* In case we need to use double below. */
1683 /* At this point use_double is only true if right is out of range for
1684 a UV. In range NV has been rounded down to nearest UV and
1685 use_double false. */
1686 if (!use_double && SvIV_please_nomg(svl)) {
1687 left_neg = !SvUOK(svl);
1691 const IV aiv = SvIVX(svl);
1694 left_neg = FALSE; /* effectively it's a UV now */
1696 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1701 dleft = SvNV_nomg(svl);
1702 left_neg = dleft < 0;
1706 /* This should be exactly the 5.6 behaviour - if left and right are
1707 both in range for UV then use U_V() rather than floor. */
1709 if (dleft < UV_MAX_P1) {
1710 /* right was in range, so is dleft, so use UVs not double.
1714 /* left is out of range for UV, right was in range, so promote
1715 right (back) to double. */
1717 /* The +0.5 is used in 5.6 even though it is not strictly
1718 consistent with the implicit +0 floor in the U_V()
1719 inside the #if 1. */
1720 dleft = Perl_floor(dleft + 0.5);
1723 dright = Perl_floor(dright + 0.5);
1734 DIE(aTHX_ "Illegal modulus zero");
1736 dans = Perl_fmod(dleft, dright);
1737 if ((left_neg != right_neg) && dans)
1738 dans = dright - dans;
1741 sv_setnv(TARG, dans);
1747 DIE(aTHX_ "Illegal modulus zero");
1750 if ((left_neg != right_neg) && ans)
1753 /* XXX may warn: unary minus operator applied to unsigned type */
1754 /* could change -foo to be (~foo)+1 instead */
1755 if (ans <= ~((UV)IV_MAX)+1)
1756 sv_setiv(TARG, ~ans+1);
1758 sv_setnv(TARG, -(NV)ans);
1761 sv_setuv(TARG, ans);
1773 bool infnan = FALSE;
1775 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1776 /* TODO: think of some way of doing list-repeat overloading ??? */
1781 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1782 /* The parser saw this as a list repeat, and there
1783 are probably several items on the stack. But we're
1784 in scalar/void context, and there's no pp_list to save us
1785 now. So drop the rest of the items -- robin@kitsite.com
1788 if (MARK + 1 < SP) {
1794 ASSUME(MARK + 1 == SP);
1796 MARK[1] = &PL_sv_undef;
1800 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1806 const UV uv = SvUV_nomg(sv);
1808 count = IV_MAX; /* The best we can do? */
1812 count = SvIV_nomg(sv);
1815 else if (SvNOKp(sv)) {
1816 const NV nv = SvNV_nomg(sv);
1817 infnan = Perl_isinfnan(nv);
1818 if (UNLIKELY(infnan)) {
1822 count = -1; /* An arbitrary negative integer */
1828 count = SvIV_nomg(sv);
1831 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1832 "Non-finite repeat count does nothing");
1833 } else if (count < 0) {
1835 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1836 "Negative repeat count does nothing");
1839 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1841 const SSize_t items = SP - MARK;
1842 const U8 mod = PL_op->op_flags & OPf_MOD;
1847 if ( items > SSize_t_MAX / count /* max would overflow */
1848 /* repeatcpy would overflow */
1849 || items > I32_MAX / (I32)sizeof(SV *)
1851 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1852 max = items * count;
1857 if (mod && SvPADTMP(*SP)) {
1858 *SP = sv_mortalcopy(*SP);
1865 repeatcpy((char*)(MARK + items), (char*)MARK,
1866 items * sizeof(const SV *), count - 1);
1869 else if (count <= 0)
1872 else { /* Note: mark already snarfed by pp_list */
1873 SV * const tmpstr = POPs;
1878 sv_setsv_nomg(TARG, tmpstr);
1879 SvPV_force_nomg(TARG, len);
1880 isutf = DO_UTF8(TARG);
1887 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1888 || len > (U32)I32_MAX /* repeatcpy would overflow */
1890 Perl_croak(aTHX_ "%s",
1891 "Out of memory during string extend");
1892 max = (UV)count * len + 1;
1895 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1896 SvCUR_set(TARG, SvCUR(TARG) * count);
1898 *SvEND(TARG) = '\0';
1901 (void)SvPOK_only_UTF8(TARG);
1903 (void)SvPOK_only(TARG);
1912 dSP; dATARGET; bool useleft; SV *svl, *svr;
1913 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1917 #ifdef PERL_PRESERVE_IVUV
1919 /* special-case some simple common cases */
1920 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1922 U32 flags = (svl->sv_flags & svr->sv_flags);
1923 if (flags & SVf_IOK) {
1924 /* both args are simple IVs */
1929 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1930 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1932 /* if both are in a range that can't under/overflow, do a
1933 * simple integer subtract: if the top of both numbers
1934 * are 00 or 11, then it's safe */
1935 if (!( ((topl+1) | (topr+1)) & 2)) {
1937 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1943 else if (flags & SVf_NOK) {
1944 /* both args are NVs */
1949 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1950 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1951 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1953 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1956 /* nothing was lost by converting to IVs */
1959 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1967 useleft = USE_LEFT(svl);
1968 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1969 "bad things" happen if you rely on signed integers wrapping. */
1970 if (SvIV_please_nomg(svr)) {
1971 /* Unless the left argument is integer in range we are going to have to
1972 use NV maths. Hence only attempt to coerce the right argument if
1973 we know the left is integer. */
1980 a_valid = auvok = 1;
1981 /* left operand is undef, treat as zero. */
1983 /* Left operand is defined, so is it IV? */
1984 if (SvIV_please_nomg(svl)) {
1985 if ((auvok = SvUOK(svl)))
1988 const IV aiv = SvIVX(svl);
1991 auvok = 1; /* Now acting as a sign flag. */
1992 } else { /* 2s complement assumption for IV_MIN */
1993 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
2000 bool result_good = 0;
2003 bool buvok = SvUOK(svr);
2008 const IV biv = SvIVX(svr);
2013 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
2015 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
2016 else "IV" now, independent of how it came in.
2017 if a, b represents positive, A, B negative, a maps to -A etc
2022 all UV maths. negate result if A negative.
2023 subtract if signs same, add if signs differ. */
2025 if (auvok ^ buvok) {
2034 /* Must get smaller */
2039 if (result <= buv) {
2040 /* result really should be -(auv-buv). as its negation
2041 of true value, need to swap our result flag */
2053 if (result <= (UV)IV_MIN)
2054 SETi(result == (UV)IV_MIN
2055 ? IV_MIN : -(IV)result);
2057 /* result valid, but out of range for IV. */
2058 SETn( -(NV)result );
2062 } /* Overflow, drop through to NVs. */
2066 useleft = USE_LEFT(svl);
2069 NV value = SvNV_nomg(svr);
2073 /* left operand is undef, treat as zero - value */
2077 SETn( SvNV_nomg(svl) - value );
2082 #define IV_BITS (IVSIZE * 8)
2084 static UV S_uv_shift(UV uv, int shift, bool left)
2090 if (shift >= IV_BITS) {
2093 return left ? uv << shift : uv >> shift;
2096 static IV S_iv_shift(IV iv, int shift, bool left)
2102 if (shift >= IV_BITS) {
2103 return iv < 0 && !left ? -1 : 0;
2105 return left ? iv << shift : iv >> shift;
2108 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2109 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2110 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2111 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2115 dSP; dATARGET; SV *svl, *svr;
2116 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2120 const IV shift = SvIV_nomg(svr);
2121 if (PL_op->op_private & HINT_INTEGER) {
2122 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2125 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2133 dSP; dATARGET; SV *svl, *svr;
2134 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2138 const IV shift = SvIV_nomg(svr);
2139 if (PL_op->op_private & HINT_INTEGER) {
2140 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2143 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2154 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2158 (SvIOK_notUV(left) && SvIOK_notUV(right))
2159 ? (SvIVX(left) < SvIVX(right))
2160 : (do_ncmp(left, right) == -1)
2170 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2174 (SvIOK_notUV(left) && SvIOK_notUV(right))
2175 ? (SvIVX(left) > SvIVX(right))
2176 : (do_ncmp(left, right) == 1)
2186 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2190 (SvIOK_notUV(left) && SvIOK_notUV(right))
2191 ? (SvIVX(left) <= SvIVX(right))
2192 : (do_ncmp(left, right) <= 0)
2202 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2206 (SvIOK_notUV(left) && SvIOK_notUV(right))
2207 ? (SvIVX(left) >= SvIVX(right))
2208 : ( (do_ncmp(left, right) & 2) == 0)
2218 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2222 (SvIOK_notUV(left) && SvIOK_notUV(right))
2223 ? (SvIVX(left) != SvIVX(right))
2224 : (do_ncmp(left, right) != 0)
2229 /* compare left and right SVs. Returns:
2233 * 2: left or right was a NaN
2236 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2238 PERL_ARGS_ASSERT_DO_NCMP;
2239 #ifdef PERL_PRESERVE_IVUV
2240 /* Fortunately it seems NaN isn't IOK */
2241 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2243 const IV leftiv = SvIVX(left);
2244 if (!SvUOK(right)) {
2245 /* ## IV <=> IV ## */
2246 const IV rightiv = SvIVX(right);
2247 return (leftiv > rightiv) - (leftiv < rightiv);
2249 /* ## IV <=> UV ## */
2251 /* As (b) is a UV, it's >=0, so it must be < */
2254 const UV rightuv = SvUVX(right);
2255 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2260 /* ## UV <=> UV ## */
2261 const UV leftuv = SvUVX(left);
2262 const UV rightuv = SvUVX(right);
2263 return (leftuv > rightuv) - (leftuv < rightuv);
2265 /* ## UV <=> IV ## */
2267 const IV rightiv = SvIVX(right);
2269 /* As (a) is a UV, it's >=0, so it cannot be < */
2272 const UV leftuv = SvUVX(left);
2273 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2276 NOT_REACHED; /* NOTREACHED */
2280 NV const rnv = SvNV_nomg(right);
2281 NV const lnv = SvNV_nomg(left);
2283 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2284 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2287 return (lnv > rnv) - (lnv < rnv);
2306 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2309 value = do_ncmp(left, right);
2321 /* also used for: pp_sge() pp_sgt() pp_slt() */
2327 int amg_type = sle_amg;
2331 switch (PL_op->op_type) {
2350 tryAMAGICbin_MG(amg_type, AMGf_set);
2354 #ifdef USE_LOCALE_COLLATE
2355 (IN_LC_RUNTIME(LC_COLLATE))
2356 ? sv_cmp_locale_flags(left, right, 0)
2359 sv_cmp_flags(left, right, 0);
2360 SETs(boolSV(cmp * multiplier < rhs));
2368 tryAMAGICbin_MG(seq_amg, AMGf_set);
2371 SETs(boolSV(sv_eq_flags(left, right, 0)));
2379 tryAMAGICbin_MG(sne_amg, AMGf_set);
2382 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2390 tryAMAGICbin_MG(scmp_amg, 0);
2394 #ifdef USE_LOCALE_COLLATE
2395 (IN_LC_RUNTIME(LC_COLLATE))
2396 ? sv_cmp_locale_flags(left, right, 0)
2399 sv_cmp_flags(left, right, 0);
2408 tryAMAGICbin_MG(band_amg, AMGf_assign);
2411 if (SvNIOKp(left) || SvNIOKp(right)) {
2412 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2413 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2414 if (PL_op->op_private & HINT_INTEGER) {
2415 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2419 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2422 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2423 if (right_ro_nonnum) SvNIOK_off(right);
2426 do_vop(PL_op->op_type, TARG, left, right);
2436 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2438 dATARGET; dPOPTOPssrl;
2439 if (PL_op->op_private & HINT_INTEGER) {
2440 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2444 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2454 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2456 dATARGET; dPOPTOPssrl;
2457 do_vop(OP_BIT_AND, TARG, left, right);
2462 /* also used for: pp_bit_xor() */
2467 const int op_type = PL_op->op_type;
2469 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2472 if (SvNIOKp(left) || SvNIOKp(right)) {
2473 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2474 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2475 if (PL_op->op_private & HINT_INTEGER) {
2476 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2477 const IV r = SvIV_nomg(right);
2478 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2482 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2483 const UV r = SvUV_nomg(right);
2484 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2487 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2488 if (right_ro_nonnum) SvNIOK_off(right);
2491 do_vop(op_type, TARG, left, right);
2498 /* also used for: pp_nbit_xor() */
2503 const int op_type = PL_op->op_type;
2505 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2506 AMGf_assign|AMGf_numarg);
2508 dATARGET; dPOPTOPssrl;
2509 if (PL_op->op_private & HINT_INTEGER) {
2510 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2511 const IV r = SvIV_nomg(right);
2512 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2516 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2517 const UV r = SvUV_nomg(right);
2518 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2525 /* also used for: pp_sbit_xor() */
2530 const int op_type = PL_op->op_type;
2532 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2535 dATARGET; dPOPTOPssrl;
2536 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2542 PERL_STATIC_INLINE bool
2543 S_negate_string(pTHX)
2548 SV * const sv = TOPs;
2549 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2551 s = SvPV_nomg_const(sv, len);
2552 if (isIDFIRST(*s)) {
2553 sv_setpvs(TARG, "-");
2556 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2557 sv_setsv_nomg(TARG, sv);
2558 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2568 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2569 if (S_negate_string(aTHX)) return NORMAL;
2571 SV * const sv = TOPs;
2574 /* It's publicly an integer */
2577 if (SvIVX(sv) == IV_MIN) {
2578 /* 2s complement assumption. */
2579 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2583 else if (SvUVX(sv) <= IV_MAX) {
2588 else if (SvIVX(sv) != IV_MIN) {
2592 #ifdef PERL_PRESERVE_IVUV
2599 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2600 SETn(-SvNV_nomg(sv));
2601 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2602 goto oops_its_an_int;
2604 SETn(-SvNV_nomg(sv));
2612 tryAMAGICun_MG(not_amg, AMGf_set);
2613 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2618 S_scomplement(pTHX_ SV *targ, SV *sv)
2624 sv_copypv_nomg(TARG, sv);
2625 tmps = (U8*)SvPV_nomg(TARG, len);
2628 /* Calculate exact length, let's not estimate. */
2633 U8 * const send = tmps + len;
2634 U8 * const origtmps = tmps;
2635 const UV utf8flags = UTF8_ALLOW_ANYUV;
2637 while (tmps < send) {
2638 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2640 targlen += UVCHR_SKIP(~c);
2646 /* Now rewind strings and write them. */
2653 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2654 deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
2655 Newx(result, targlen + 1, U8);
2657 while (tmps < send) {
2658 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2660 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2663 sv_usepvn_flags(TARG, (char*)result, targlen,
2664 SV_HAS_TRAILING_NUL);
2671 Newx(result, nchar + 1, U8);
2673 while (tmps < send) {
2674 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2679 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2687 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2690 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2695 for ( ; anum > 0; anum--, tmps++)
2702 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2706 if (PL_op->op_private & HINT_INTEGER) {
2707 const IV i = ~SvIV_nomg(sv);
2711 const UV u = ~SvUV_nomg(sv);
2716 S_scomplement(aTHX_ TARG, sv);
2726 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2729 if (PL_op->op_private & HINT_INTEGER) {
2730 const IV i = ~SvIV_nomg(sv);
2734 const UV u = ~SvUV_nomg(sv);
2744 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2747 S_scomplement(aTHX_ TARG, sv);
2753 /* integer versions of some of the above */
2758 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2761 SETi( left * right );
2770 tryAMAGICbin_MG(div_amg, AMGf_assign);
2773 IV value = SvIV_nomg(right);
2775 DIE(aTHX_ "Illegal division by zero");
2776 num = SvIV_nomg(left);
2778 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2782 value = num / value;
2788 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2789 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2796 /* This is the vanilla old i_modulo. */
2798 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2802 DIE(aTHX_ "Illegal modulus zero");
2803 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2807 SETi( left % right );
2812 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2813 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2818 /* This is the i_modulo with the workaround for the _moddi3 bug
2819 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2820 * See below for pp_i_modulo. */
2822 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2826 DIE(aTHX_ "Illegal modulus zero");
2827 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2831 SETi( left % PERL_ABS(right) );
2838 dVAR; dSP; dATARGET;
2839 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2843 DIE(aTHX_ "Illegal modulus zero");
2844 /* The assumption is to use hereafter the old vanilla version... */
2846 PL_ppaddr[OP_I_MODULO] =
2848 /* .. but if we have glibc, we might have a buggy _moddi3
2849 * (at least glibc 2.2.5 is known to have this bug), in other
2850 * words our integer modulus with negative quad as the second
2851 * argument might be broken. Test for this and re-patch the
2852 * opcode dispatch table if that is the case, remembering to
2853 * also apply the workaround so that this first round works
2854 * right, too. See [perl #9402] for more information. */
2858 /* Cannot do this check with inlined IV constants since
2859 * that seems to work correctly even with the buggy glibc. */
2861 /* Yikes, we have the bug.
2862 * Patch in the workaround version. */
2864 PL_ppaddr[OP_I_MODULO] =
2865 &Perl_pp_i_modulo_1;
2866 /* Make certain we work right this time, too. */
2867 right = PERL_ABS(right);
2870 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2874 SETi( left % right );
2883 tryAMAGICbin_MG(add_amg, AMGf_assign);
2885 dPOPTOPiirl_ul_nomg;
2886 SETi( left + right );
2894 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2896 dPOPTOPiirl_ul_nomg;
2897 SETi( left - right );
2905 tryAMAGICbin_MG(lt_amg, AMGf_set);
2908 SETs(boolSV(left < right));
2916 tryAMAGICbin_MG(gt_amg, AMGf_set);
2919 SETs(boolSV(left > right));
2927 tryAMAGICbin_MG(le_amg, AMGf_set);
2930 SETs(boolSV(left <= right));
2938 tryAMAGICbin_MG(ge_amg, AMGf_set);
2941 SETs(boolSV(left >= right));
2949 tryAMAGICbin_MG(eq_amg, AMGf_set);
2952 SETs(boolSV(left == right));
2960 tryAMAGICbin_MG(ne_amg, AMGf_set);
2963 SETs(boolSV(left != right));
2971 tryAMAGICbin_MG(ncmp_amg, 0);
2978 else if (left < right)
2990 tryAMAGICun_MG(neg_amg, 0);
2991 if (S_negate_string(aTHX)) return NORMAL;
2993 SV * const sv = TOPs;
2994 IV const i = SvIV_nomg(sv);
3000 /* High falutin' math. */
3005 tryAMAGICbin_MG(atan2_amg, 0);
3008 SETn(Perl_atan2(left, right));
3014 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
3019 int amg_type = fallback_amg;
3020 const char *neg_report = NULL;
3021 const int op_type = PL_op->op_type;
3024 case OP_SIN: amg_type = sin_amg; break;
3025 case OP_COS: amg_type = cos_amg; break;
3026 case OP_EXP: amg_type = exp_amg; break;
3027 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
3028 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
3031 assert(amg_type != fallback_amg);
3033 tryAMAGICun_MG(amg_type, 0);
3035 SV * const arg = TOPs;
3036 const NV value = SvNV_nomg(arg);
3038 if (neg_report) { /* log or sqrt */
3040 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3041 ! Perl_isnan(value) &&
3043 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
3044 SET_NUMERIC_STANDARD();
3045 /* diag_listed_as: Can't take log of %g */
3046 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3051 case OP_SIN: result = Perl_sin(value); break;
3052 case OP_COS: result = Perl_cos(value); break;
3053 case OP_EXP: result = Perl_exp(value); break;
3054 case OP_LOG: result = Perl_log(value); break;
3055 case OP_SQRT: result = Perl_sqrt(value); break;
3062 /* Support Configure command-line overrides for rand() functions.
3063 After 5.005, perhaps we should replace this by Configure support
3064 for drand48(), random(), or rand(). For 5.005, though, maintain
3065 compatibility by calling rand() but allow the user to override it.
3066 See INSTALL for details. --Andy Dougherty 15 July 1998
3068 /* Now it's after 5.005, and Configure supports drand48() and random(),
3069 in addition to rand(). So the overrides should not be needed any more.
3070 --Jarkko Hietaniemi 27 September 1998
3075 if (!PL_srand_called) {
3076 (void)seedDrand01((Rand_seed_t)seed());
3077 PL_srand_called = TRUE;
3089 SV * const sv = POPs;
3095 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3096 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3097 if (! Perl_isnan(value) && value == 0.0)
3107 sv_setnv_mg(TARG, value);
3118 if (MAXARG >= 1 && (TOPs || POPs)) {
3125 pv = SvPV(top, len);
3126 flags = grok_number(pv, len, &anum);
3128 if (!(flags & IS_NUMBER_IN_UV)) {
3129 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3130 "Integer overflow in srand");
3138 (void)seedDrand01((Rand_seed_t)anum);
3139 PL_srand_called = TRUE;
3143 /* Historically srand always returned true. We can avoid breaking
3145 sv_setpvs(TARG, "0 but true");
3154 tryAMAGICun_MG(int_amg, AMGf_numeric);
3156 SV * const sv = TOPs;
3157 const IV iv = SvIV_nomg(sv);
3158 /* XXX it's arguable that compiler casting to IV might be subtly
3159 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3160 else preferring IV has introduced a subtle behaviour change bug. OTOH
3161 relying on floating point to be accurate is a bug. */
3166 else if (SvIOK(sv)) {
3168 SETu(SvUV_nomg(sv));
3173 const NV value = SvNV_nomg(sv);
3174 if (UNLIKELY(Perl_isinfnan(value)))
3176 else if (value >= 0.0) {
3177 if (value < (NV)UV_MAX + 0.5) {
3180 SETn(Perl_floor(value));
3184 if (value > (NV)IV_MIN - 0.5) {
3187 SETn(Perl_ceil(value));
3198 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3200 SV * const sv = TOPs;
3201 /* This will cache the NV value if string isn't actually integer */
3202 const IV iv = SvIV_nomg(sv);
3207 else if (SvIOK(sv)) {
3208 /* IVX is precise */
3210 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3218 /* 2s complement assumption. Also, not really needed as
3219 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3225 const NV value = SvNV_nomg(sv);
3236 /* also used for: pp_hex() */
3242 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3246 SV* const sv = TOPs;
3248 tmps = (SvPV_const(sv, len));
3250 /* If Unicode, try to downgrade
3251 * If not possible, croak. */
3252 SV* const tsv = sv_2mortal(newSVsv(sv));
3255 sv_utf8_downgrade(tsv, FALSE);
3256 tmps = SvPV_const(tsv, len);
3258 if (PL_op->op_type == OP_HEX)
3261 while (*tmps && len && isSPACE(*tmps))
3265 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3267 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3269 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3270 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3272 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3274 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3288 SV * const sv = TOPs;
3290 U32 in_bytes = IN_BYTES;
3291 /* simplest case shortcut */
3292 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3293 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3294 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3297 if(LIKELY(svflags == SVf_POK))
3299 if(svflags & SVs_GMG)
3302 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3303 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3307 /* unrolled SvPV_nomg_const(sv,len) */
3312 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3314 sv_setiv(TARG, (IV)(len));
3317 if (!SvPADTMP(TARG)) {
3318 sv_setsv_nomg(TARG, &PL_sv_undef);
3319 } else { /* TARG is on stack at this point and is overwriten by SETs.
3320 This branch is the odd one out, so put TARG by default on
3321 stack earlier to let local SP go out of liveness sooner */
3328 return NORMAL; /* no putback, SP didn't move in this opcode */
3331 /* Returns false if substring is completely outside original string.
3332 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3333 always be true for an explicit 0.
3336 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3337 bool pos1_is_uv, IV len_iv,
3338 bool len_is_uv, STRLEN *posp,
3344 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3346 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3347 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3350 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3353 if (len_iv || len_is_uv) {
3354 if (!len_is_uv && len_iv < 0) {
3355 pos2_iv = curlen + len_iv;
3357 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3360 } else { /* len_iv >= 0 */
3361 if (!pos1_is_uv && pos1_iv < 0) {
3362 pos2_iv = pos1_iv + len_iv;
3363 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3365 if ((UV)len_iv > curlen-(UV)pos1_iv)
3368 pos2_iv = pos1_iv+len_iv;
3378 if (!pos2_is_uv && pos2_iv < 0) {
3379 if (!pos1_is_uv && pos1_iv < 0)
3383 else if (!pos1_is_uv && pos1_iv < 0)
3386 if ((UV)pos2_iv < (UV)pos1_iv)
3388 if ((UV)pos2_iv > curlen)
3391 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3392 *posp = (STRLEN)( (UV)pos1_iv );
3393 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3410 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3411 const bool rvalue = (GIMME_V != G_VOID);
3414 const char *repl = NULL;
3416 int num_args = PL_op->op_private & 7;
3417 bool repl_need_utf8_upgrade = FALSE;
3421 if(!(repl_sv = POPs)) num_args--;
3423 if ((len_sv = POPs)) {
3424 len_iv = SvIV(len_sv);
3425 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3430 pos1_iv = SvIV(pos_sv);
3431 pos1_is_uv = SvIOK_UV(pos_sv);
3433 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3437 if (lvalue && !repl_sv) {
3439 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3440 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3442 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3444 pos1_is_uv || pos1_iv >= 0
3445 ? (STRLEN)(UV)pos1_iv
3446 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3448 len_is_uv || len_iv > 0
3449 ? (STRLEN)(UV)len_iv
3450 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3452 PUSHs(ret); /* avoid SvSETMAGIC here */
3456 repl = SvPV_const(repl_sv, repl_len);
3459 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3460 "Attempt to use reference as lvalue in substr"
3462 tmps = SvPV_force_nomg(sv, curlen);
3463 if (DO_UTF8(repl_sv) && repl_len) {
3465 sv_utf8_upgrade_nomg(sv);
3469 else if (DO_UTF8(sv))
3470 repl_need_utf8_upgrade = TRUE;
3472 else tmps = SvPV_const(sv, curlen);
3474 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3475 if (utf8_curlen == curlen)
3478 curlen = utf8_curlen;
3484 STRLEN pos, len, byte_len, byte_pos;
3486 if (!translate_substr_offsets(
3487 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3491 byte_pos = utf8_curlen
3492 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3497 SvTAINTED_off(TARG); /* decontaminate */
3498 SvUTF8_off(TARG); /* decontaminate */
3499 sv_setpvn(TARG, tmps, byte_len);
3500 #ifdef USE_LOCALE_COLLATE
3501 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3508 SV* repl_sv_copy = NULL;
3510 if (repl_need_utf8_upgrade) {
3511 repl_sv_copy = newSVsv(repl_sv);
3512 sv_utf8_upgrade(repl_sv_copy);
3513 repl = SvPV_const(repl_sv_copy, repl_len);
3517 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3518 SvREFCNT_dec(repl_sv_copy);
3521 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3531 Perl_croak(aTHX_ "substr outside of string");
3532 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3539 const IV size = POPi;
3540 const IV offset = POPi;
3541 SV * const src = POPs;
3542 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3545 if (lvalue) { /* it's an lvalue! */
3546 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3547 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3549 LvTARG(ret) = SvREFCNT_inc_simple(src);
3550 LvTARGOFF(ret) = offset;
3551 LvTARGLEN(ret) = size;
3555 SvTAINTED_off(TARG); /* decontaminate */
3559 sv_setuv(ret, do_vecget(src, offset, size));
3567 /* also used for: pp_rindex() */
3580 const char *little_p;
3583 const bool is_index = PL_op->op_type == OP_INDEX;
3584 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3590 big_p = SvPV_const(big, biglen);
3591 little_p = SvPV_const(little, llen);
3593 big_utf8 = DO_UTF8(big);
3594 little_utf8 = DO_UTF8(little);
3595 if (big_utf8 ^ little_utf8) {
3596 /* One needs to be upgraded. */
3597 if (little_utf8 && !IN_ENCODING) {
3598 /* Well, maybe instead we might be able to downgrade the small
3600 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3603 /* If the large string is ISO-8859-1, and it's not possible to
3604 convert the small string to ISO-8859-1, then there is no
3605 way that it could be found anywhere by index. */
3610 /* At this point, pv is a malloc()ed string. So donate it to temp
3611 to ensure it will get free()d */
3612 little = temp = newSV(0);
3613 sv_usepvn(temp, pv, llen);
3614 little_p = SvPVX(little);
3617 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3620 sv_recode_to_utf8(temp, _get_encoding());
3622 sv_utf8_upgrade(temp);
3627 big_p = SvPV_const(big, biglen);
3630 little_p = SvPV_const(little, llen);
3634 if (SvGAMAGIC(big)) {
3635 /* Life just becomes a lot easier if I use a temporary here.
3636 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3637 will trigger magic and overloading again, as will fbm_instr()
3639 big = newSVpvn_flags(big_p, biglen,
3640 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3643 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3644 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3645 warn on undef, and we've already triggered a warning with the
3646 SvPV_const some lines above. We can't remove that, as we need to
3647 call some SvPV to trigger overloading early and find out if the
3649 This is all getting too messy. The API isn't quite clean enough,
3650 because data access has side effects.
3652 little = newSVpvn_flags(little_p, llen,
3653 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3654 little_p = SvPVX(little);
3658 offset = is_index ? 0 : biglen;
3660 if (big_utf8 && offset > 0)
3661 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3667 else if (offset > (SSize_t)biglen)
3669 if (!(little_p = is_index
3670 ? fbm_instr((unsigned char*)big_p + offset,
3671 (unsigned char*)big_p + biglen, little, 0)
3672 : rninstr(big_p, big_p + offset,
3673 little_p, little_p + llen)))
3676 retval = little_p - big_p;
3677 if (retval > 1 && big_utf8)
3678 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3688 dSP; dMARK; dORIGMARK; dTARGET;
3689 SvTAINTED_off(TARG);
3690 do_sprintf(TARG, SP-MARK, MARK+1);
3691 TAINT_IF(SvTAINTED(TARG));
3703 const U8 *s = (U8*)SvPV_const(argsv, len);
3705 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3706 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3707 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3708 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
3713 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3727 if (UNLIKELY(SvAMAGIC(top)))
3729 if (UNLIKELY(isinfnansv(top)))
3730 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3732 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3733 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3735 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3736 && SvNV_nomg(top) < 0.0)))
3738 if (ckWARN(WARN_UTF8)) {
3739 if (SvGMAGICAL(top)) {
3740 SV *top2 = sv_newmortal();
3741 sv_setsv_nomg(top2, top);
3744 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3745 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3747 value = UNICODE_REPLACEMENT;
3749 value = SvUV_nomg(top);
3753 SvUPGRADE(TARG,SVt_PV);
3755 if (value > 255 && !IN_BYTES) {
3756 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3757 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3758 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3760 (void)SvPOK_only(TARG);
3769 *tmps++ = (char)value;
3771 (void)SvPOK_only(TARG);
3773 if (IN_ENCODING && !IN_BYTES) {
3774 sv_recode_to_utf8(TARG, _get_encoding());
3776 if (SvCUR(TARG) == 0
3777 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3778 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3783 *tmps++ = (char)value;
3799 const char *tmps = SvPV_const(left, len);
3801 if (DO_UTF8(left)) {
3802 /* If Unicode, try to downgrade.
3803 * If not possible, croak.
3804 * Yes, we made this up. */
3805 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3807 sv_utf8_downgrade(tsv, FALSE);
3808 tmps = SvPV_const(tsv, len);
3810 # ifdef USE_ITHREADS
3812 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3813 /* This should be threadsafe because in ithreads there is only
3814 * one thread per interpreter. If this would not be true,
3815 * we would need a mutex to protect this malloc. */
3816 PL_reentrant_buffer->_crypt_struct_buffer =
3817 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3818 #if defined(__GLIBC__) || defined(__EMX__)
3819 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3820 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3821 /* work around glibc-2.2.5 bug */
3822 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3826 # endif /* HAS_CRYPT_R */
3827 # endif /* USE_ITHREADS */
3829 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3831 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3838 "The crypt() function is unimplemented due to excessive paranoia.");
3842 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3843 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3846 /* also used for: pp_lcfirst() */
3850 /* Actually is both lcfirst() and ucfirst(). Only the first character
3851 * changes. This means that possibly we can change in-place, ie., just
3852 * take the source and change that one character and store it back, but not
3853 * if read-only etc, or if the length changes */
3857 STRLEN slen; /* slen is the byte length of the whole SV. */
3860 bool inplace; /* ? Convert first char only, in-place */
3861 bool doing_utf8 = FALSE; /* ? using utf8 */
3862 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3863 const int op_type = PL_op->op_type;
3866 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3867 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3868 * stored as UTF-8 at s. */
3869 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3870 * lowercased) character stored in tmpbuf. May be either
3871 * UTF-8 or not, but in either case is the number of bytes */
3873 s = (const U8*)SvPV_const(source, slen);
3875 /* We may be able to get away with changing only the first character, in
3876 * place, but not if read-only, etc. Later we may discover more reasons to
3877 * not convert in-place. */
3878 inplace = !SvREADONLY(source) && SvPADTMP(source);
3880 /* First calculate what the changed first character should be. This affects
3881 * whether we can just swap it out, leaving the rest of the string unchanged,
3882 * or even if have to convert the dest to UTF-8 when the source isn't */
3884 if (! slen) { /* If empty */
3885 need = 1; /* still need a trailing NUL */
3888 else if (DO_UTF8(source)) { /* Is the source utf8? */
3891 if (op_type == OP_UCFIRST) {
3892 #ifdef USE_LOCALE_CTYPE
3893 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3895 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3899 #ifdef USE_LOCALE_CTYPE
3900 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3902 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3906 /* we can't do in-place if the length changes. */
3907 if (ulen != tculen) inplace = FALSE;
3908 need = slen + 1 - ulen + tculen;
3910 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3911 * latin1 is treated as caseless. Note that a locale takes
3913 ulen = 1; /* Original character is 1 byte */
3914 tculen = 1; /* Most characters will require one byte, but this will
3915 * need to be overridden for the tricky ones */
3918 if (op_type == OP_LCFIRST) {
3920 /* lower case the first letter: no trickiness for any character */
3921 #ifdef USE_LOCALE_CTYPE
3922 if (IN_LC_RUNTIME(LC_CTYPE)) {
3923 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3924 *tmpbuf = toLOWER_LC(*s);
3929 *tmpbuf = (IN_UNI_8_BIT)
3930 ? toLOWER_LATIN1(*s)
3934 #ifdef USE_LOCALE_CTYPE
3936 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3937 if (IN_UTF8_CTYPE_LOCALE) {
3941 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3942 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3943 locales have upper and title case
3947 else if (! IN_UNI_8_BIT) {
3948 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3949 * on EBCDIC machines whatever the
3950 * native function does */
3953 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3954 * UTF-8, which we treat as not in locale), and cased latin1 */
3956 #ifdef USE_LOCALE_CTYPE
3960 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3962 assert(tculen == 2);
3964 /* If the result is an upper Latin1-range character, it can
3965 * still be represented in one byte, which is its ordinal */
3966 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3967 *tmpbuf = (U8) title_ord;
3971 /* Otherwise it became more than one ASCII character (in
3972 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3973 * beyond Latin1, so the number of bytes changed, so can't
3974 * replace just the first character in place. */
3977 /* If the result won't fit in a byte, the entire result
3978 * will have to be in UTF-8. Assume worst case sizing in
3979 * conversion. (all latin1 characters occupy at most two
3981 if (title_ord > 255) {
3983 convert_source_to_utf8 = TRUE;
3984 need = slen * 2 + 1;
3986 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3987 * (both) characters whose title case is above 255 is
3991 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3992 need = slen + 1 + 1;
3996 } /* End of use Unicode (Latin1) semantics */
3997 } /* End of changing the case of the first character */
3999 /* Here, have the first character's changed case stored in tmpbuf. Ready to
4000 * generate the result */
4003 /* We can convert in place. This means we change just the first
4004 * character without disturbing the rest; no need to grow */
4006 s = d = (U8*)SvPV_force_nomg(source, slen);
4012 /* Here, we can't convert in place; we earlier calculated how much
4013 * space we will need, so grow to accommodate that */
4014 SvUPGRADE(dest, SVt_PV);
4015 d = (U8*)SvGROW(dest, need);
4016 (void)SvPOK_only(dest);
4023 if (! convert_source_to_utf8) {
4025 /* Here both source and dest are in UTF-8, but have to create
4026 * the entire output. We initialize the result to be the
4027 * title/lower cased first character, and then append the rest
4029 sv_setpvn(dest, (char*)tmpbuf, tculen);
4031 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4035 const U8 *const send = s + slen;
4037 /* Here the dest needs to be in UTF-8, but the source isn't,
4038 * except we earlier UTF-8'd the first character of the source
4039 * into tmpbuf. First put that into dest, and then append the
4040 * rest of the source, converting it to UTF-8 as we go. */
4042 /* Assert tculen is 2 here because the only two characters that
4043 * get to this part of the code have 2-byte UTF-8 equivalents */
4045 *d++ = *(tmpbuf + 1);
4046 s++; /* We have just processed the 1st char */
4048 for (; s < send; s++) {
4049 d = uvchr_to_utf8(d, *s);
4052 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4056 else { /* in-place UTF-8. Just overwrite the first character */
4057 Copy(tmpbuf, d, tculen, U8);
4058 SvCUR_set(dest, need - 1);
4062 else { /* Neither source nor dest are in or need to be UTF-8 */
4064 if (inplace) { /* in-place, only need to change the 1st char */
4067 else { /* Not in-place */
4069 /* Copy the case-changed character(s) from tmpbuf */
4070 Copy(tmpbuf, d, tculen, U8);
4071 d += tculen - 1; /* Code below expects d to point to final
4072 * character stored */
4075 else { /* empty source */
4076 /* See bug #39028: Don't taint if empty */
4080 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4081 * the destination to retain that flag */
4082 if (SvUTF8(source) && ! IN_BYTES)
4085 if (!inplace) { /* Finish the rest of the string, unchanged */
4086 /* This will copy the trailing NUL */
4087 Copy(s + 1, d + 1, slen, U8);
4088 SvCUR_set(dest, need - 1);
4091 #ifdef USE_LOCALE_CTYPE
4092 if (IN_LC_RUNTIME(LC_CTYPE)) {
4097 if (dest != source && SvTAINTED(source))
4103 /* There's so much setup/teardown code common between uc and lc, I wonder if
4104 it would be worth merging the two, and just having a switch outside each
4105 of the three tight loops. There is less and less commonality though */
4118 if ( SvPADTMP(source)
4119 && !SvREADONLY(source) && SvPOK(source)
4122 #ifdef USE_LOCALE_CTYPE
4123 (IN_LC_RUNTIME(LC_CTYPE))
4124 ? ! IN_UTF8_CTYPE_LOCALE
4130 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4131 * make the loop tight, so we overwrite the source with the dest before
4132 * looking at it, and we need to look at the original source
4133 * afterwards. There would also need to be code added to handle
4134 * switching to not in-place in midstream if we run into characters
4135 * that change the length. Since being in locale overrides UNI_8_BIT,
4136 * that latter becomes irrelevant in the above test; instead for
4137 * locale, the size can't normally change, except if the locale is a
4140 s = d = (U8*)SvPV_force_nomg(source, len);
4147 s = (const U8*)SvPV_nomg_const(source, len);
4150 SvUPGRADE(dest, SVt_PV);
4151 d = (U8*)SvGROW(dest, min);
4152 (void)SvPOK_only(dest);
4157 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4158 to check DO_UTF8 again here. */
4160 if (DO_UTF8(source)) {
4161 const U8 *const send = s + len;
4162 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4164 /* All occurrences of these are to be moved to follow any other marks.
4165 * This is context-dependent. We may not be passed enough context to
4166 * move the iota subscript beyond all of them, but we do the best we can
4167 * with what we're given. The result is always better than if we
4168 * hadn't done this. And, the problem would only arise if we are
4169 * passed a character without all its combining marks, which would be
4170 * the caller's mistake. The information this is based on comes from a
4171 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4172 * itself) and so can't be checked properly to see if it ever gets
4173 * revised. But the likelihood of it changing is remote */
4174 bool in_iota_subscript = FALSE;
4180 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4182 /* A non-mark. Time to output the iota subscript */
4183 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4184 d += capital_iota_len;
4185 in_iota_subscript = FALSE;
4188 /* Then handle the current character. Get the changed case value
4189 * and copy it to the output buffer */
4192 #ifdef USE_LOCALE_CTYPE
4193 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4195 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4197 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4198 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4199 if (uv == GREEK_CAPITAL_LETTER_IOTA
4200 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4202 in_iota_subscript = TRUE;
4205 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4206 /* If the eventually required minimum size outgrows the
4207 * available space, we need to grow. */
4208 const UV o = d - (U8*)SvPVX_const(dest);
4210 /* If someone uppercases one million U+03B0s we SvGROW()
4211 * one million times. Or we could try guessing how much to
4212 * allocate without allocating too much. Such is life.
4213 * See corresponding comment in lc code for another option
4216 d = (U8*)SvPVX(dest) + o;
4218 Copy(tmpbuf, d, ulen, U8);
4223 if (in_iota_subscript) {
4224 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4225 d += capital_iota_len;
4230 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4232 else { /* Not UTF-8 */
4234 const U8 *const send = s + len;
4236 /* Use locale casing if in locale; regular style if not treating
4237 * latin1 as having case; otherwise the latin1 casing. Do the
4238 * whole thing in a tight loop, for speed, */
4239 #ifdef USE_LOCALE_CTYPE
4240 if (IN_LC_RUNTIME(LC_CTYPE)) {
4241 if (IN_UTF8_CTYPE_LOCALE) {
4244 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4245 for (; s < send; d++, s++)
4246 *d = (U8) toUPPER_LC(*s);
4250 if (! IN_UNI_8_BIT) {
4251 for (; s < send; d++, s++) {
4256 #ifdef USE_LOCALE_CTYPE
4259 for (; s < send; d++, s++) {
4260 *d = toUPPER_LATIN1_MOD(*s);
4261 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4265 /* The mainstream case is the tight loop above. To avoid
4266 * extra tests in that, all three characters that require
4267 * special handling are mapped by the MOD to the one tested
4269 * Use the source to distinguish between the three cases */
4271 #if UNICODE_MAJOR_VERSION > 2 \
4272 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4273 && UNICODE_DOT_DOT_VERSION >= 8)
4274 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4276 /* uc() of this requires 2 characters, but they are
4277 * ASCII. If not enough room, grow the string */
4278 if (SvLEN(dest) < ++min) {
4279 const UV o = d - (U8*)SvPVX_const(dest);
4281 d = (U8*)SvPVX(dest) + o;
4283 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4284 continue; /* Back to the tight loop; still in ASCII */
4288 /* The other two special handling characters have their
4289 * upper cases outside the latin1 range, hence need to be
4290 * in UTF-8, so the whole result needs to be in UTF-8. So,
4291 * here we are somewhere in the middle of processing a
4292 * non-UTF-8 string, and realize that we will have to convert
4293 * the whole thing to UTF-8. What to do? There are
4294 * several possibilities. The simplest to code is to
4295 * convert what we have so far, set a flag, and continue on
4296 * in the loop. The flag would be tested each time through
4297 * the loop, and if set, the next character would be
4298 * converted to UTF-8 and stored. But, I (khw) didn't want
4299 * to slow down the mainstream case at all for this fairly
4300 * rare case, so I didn't want to add a test that didn't
4301 * absolutely have to be there in the loop, besides the
4302 * possibility that it would get too complicated for
4303 * optimizers to deal with. Another possibility is to just
4304 * give up, convert the source to UTF-8, and restart the
4305 * function that way. Another possibility is to convert
4306 * both what has already been processed and what is yet to
4307 * come separately to UTF-8, then jump into the loop that
4308 * handles UTF-8. But the most efficient time-wise of the
4309 * ones I could think of is what follows, and turned out to
4310 * not require much extra code. */
4312 /* Convert what we have so far into UTF-8, telling the
4313 * function that we know it should be converted, and to
4314 * allow extra space for what we haven't processed yet.
4315 * Assume the worst case space requirements for converting
4316 * what we haven't processed so far: that it will require
4317 * two bytes for each remaining source character, plus the
4318 * NUL at the end. This may cause the string pointer to
4319 * move, so re-find it. */
4321 len = d - (U8*)SvPVX_const(dest);
4322 SvCUR_set(dest, len);
4323 len = sv_utf8_upgrade_flags_grow(dest,
4324 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4326 d = (U8*)SvPVX(dest) + len;
4328 /* Now process the remainder of the source, converting to
4329 * upper and UTF-8. If a resulting byte is invariant in
4330 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4331 * append it to the output. */
4332 for (; s < send; s++) {
4333 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4337 /* Here have processed the whole source; no need to continue
4338 * with the outer loop. Each character has been converted
4339 * to upper case and converted to UTF-8 */
4342 } /* End of processing all latin1-style chars */
4343 } /* End of processing all chars */
4344 } /* End of source is not empty */
4346 if (source != dest) {
4347 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4348 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4350 } /* End of isn't utf8 */
4351 #ifdef USE_LOCALE_CTYPE
4352 if (IN_LC_RUNTIME(LC_CTYPE)) {
4357 if (dest != source && SvTAINTED(source))
4375 if ( SvPADTMP(source)
4376 && !SvREADONLY(source) && SvPOK(source)
4377 && !DO_UTF8(source)) {
4379 /* We can convert in place, as lowercasing anything in the latin1 range
4380 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4382 s = d = (U8*)SvPV_force_nomg(source, len);
4389 s = (const U8*)SvPV_nomg_const(source, len);
4392 SvUPGRADE(dest, SVt_PV);
4393 d = (U8*)SvGROW(dest, min);
4394 (void)SvPOK_only(dest);
4399 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4400 to check DO_UTF8 again here. */
4402 if (DO_UTF8(source)) {
4403 const U8 *const send = s + len;
4404 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4407 const STRLEN u = UTF8SKIP(s);
4410 #ifdef USE_LOCALE_CTYPE
4411 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4413 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4416 /* Here is where we would do context-sensitive actions. See the
4417 * commit message for 86510fb15 for why there isn't any */
4419 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4421 /* If the eventually required minimum size outgrows the
4422 * available space, we need to grow. */
4423 const UV o = d - (U8*)SvPVX_const(dest);
4425 /* If someone lowercases one million U+0130s we SvGROW() one
4426 * million times. Or we could try guessing how much to
4427 * allocate without allocating too much. Such is life.
4428 * Another option would be to grow an extra byte or two more
4429 * each time we need to grow, which would cut down the million
4430 * to 500K, with little waste */
4432 d = (U8*)SvPVX(dest) + o;
4435 /* Copy the newly lowercased letter to the output buffer we're
4437 Copy(tmpbuf, d, ulen, U8);
4440 } /* End of looping through the source string */
4443 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4444 } else { /* Not utf8 */
4446 const U8 *const send = s + len;
4448 /* Use locale casing if in locale; regular style if not treating
4449 * latin1 as having case; otherwise the latin1 casing. Do the
4450 * whole thing in a tight loop, for speed, */
4451 #ifdef USE_LOCALE_CTYPE
4452 if (IN_LC_RUNTIME(LC_CTYPE)) {
4453 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4454 for (; s < send; d++, s++)
4455 *d = toLOWER_LC(*s);
4459 if (! IN_UNI_8_BIT) {
4460 for (; s < send; d++, s++) {
4465 for (; s < send; d++, s++) {
4466 *d = toLOWER_LATIN1(*s);
4470 if (source != dest) {
4472 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4475 #ifdef USE_LOCALE_CTYPE
4476 if (IN_LC_RUNTIME(LC_CTYPE)) {
4481 if (dest != source && SvTAINTED(source))
4490 SV * const sv = TOPs;
4492 const char *s = SvPV_const(sv,len);
4494 SvUTF8_off(TARG); /* decontaminate */
4497 SvUPGRADE(TARG, SVt_PV);
4498 SvGROW(TARG, (len * 2) + 1);
4502 STRLEN ulen = UTF8SKIP(s);
4503 bool to_quote = FALSE;
4505 if (UTF8_IS_INVARIANT(*s)) {
4506 if (_isQUOTEMETA(*s)) {
4510 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4512 #ifdef USE_LOCALE_CTYPE
4513 /* In locale, we quote all non-ASCII Latin1 chars.
4514 * Otherwise use the quoting rules */
4516 IN_LC_RUNTIME(LC_CTYPE)
4519 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4524 else if (is_QUOTEMETA_high(s)) {
4539 else if (IN_UNI_8_BIT) {
4541 if (_isQUOTEMETA(*s))
4547 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4548 * including everything above ASCII */
4550 if (!isWORDCHAR_A(*s))
4556 SvCUR_set(TARG, d - SvPVX_const(TARG));
4557 (void)SvPOK_only_UTF8(TARG);
4560 sv_setpvn(TARG, s, len);
4576 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4577 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4578 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4579 || UNICODE_DOT_DOT_VERSION > 0)
4580 const bool full_folding = TRUE; /* This variable is here so we can easily
4581 move to more generality later */
4583 const bool full_folding = FALSE;
4585 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4586 #ifdef USE_LOCALE_CTYPE
4587 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4591 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4592 * You are welcome(?) -Hugmeir
4600 s = (const U8*)SvPV_nomg_const(source, len);
4602 if (ckWARN(WARN_UNINITIALIZED))
4603 report_uninit(source);
4610 SvUPGRADE(dest, SVt_PV);
4611 d = (U8*)SvGROW(dest, min);
4612 (void)SvPOK_only(dest);
4617 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4619 const STRLEN u = UTF8SKIP(s);
4622 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4624 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4625 const UV o = d - (U8*)SvPVX_const(dest);
4627 d = (U8*)SvPVX(dest) + o;
4630 Copy(tmpbuf, d, ulen, U8);
4635 } /* Unflagged string */
4637 #ifdef USE_LOCALE_CTYPE
4638 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4639 if (IN_UTF8_CTYPE_LOCALE) {
4640 goto do_uni_folding;
4642 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4643 for (; s < send; d++, s++)
4644 *d = (U8) toFOLD_LC(*s);
4648 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4649 for (; s < send; d++, s++)
4653 #ifdef USE_LOCALE_CTYPE
4656 /* For ASCII and the Latin-1 range, there's only two troublesome
4657 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4658 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4659 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4660 * For the rest, the casefold is their lowercase. */
4661 for (; s < send; d++, s++) {
4662 if (*s == MICRO_SIGN) {
4663 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4664 * which is outside of the latin-1 range. There's a couple
4665 * of ways to deal with this -- khw discusses them in
4666 * pp_lc/uc, so go there :) What we do here is upgrade what
4667 * we had already casefolded, then enter an inner loop that
4668 * appends the rest of the characters as UTF-8. */
4669 len = d - (U8*)SvPVX_const(dest);
4670 SvCUR_set(dest, len);
4671 len = sv_utf8_upgrade_flags_grow(dest,
4672 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4673 /* The max expansion for latin1
4674 * chars is 1 byte becomes 2 */
4676 d = (U8*)SvPVX(dest) + len;
4678 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4681 for (; s < send; s++) {
4683 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4684 if UVCHR_IS_INVARIANT(fc) {
4686 && *s == LATIN_SMALL_LETTER_SHARP_S)
4695 Copy(tmpbuf, d, ulen, U8);
4701 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4702 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4703 * becomes "ss", which may require growing the SV. */
4704 if (SvLEN(dest) < ++min) {
4705 const UV o = d - (U8*)SvPVX_const(dest);
4707 d = (U8*)SvPVX(dest) + o;
4712 else { /* If it's not one of those two, the fold is their lower
4714 *d = toLOWER_LATIN1(*s);
4720 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4722 #ifdef USE_LOCALE_CTYPE
4723 if (IN_LC_RUNTIME(LC_CTYPE)) {
4728 if (SvTAINTED(source))
4738 dSP; dMARK; dORIGMARK;
4739 AV *const av = MUTABLE_AV(POPs);
4740 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4742 if (SvTYPE(av) == SVt_PVAV) {
4743 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4744 bool can_preserve = FALSE;
4750 can_preserve = SvCANEXISTDELETE(av);
4753 if (lval && localizing) {
4756 for (svp = MARK + 1; svp <= SP; svp++) {
4757 const SSize_t elem = SvIV(*svp);
4761 if (max > AvMAX(av))
4765 while (++MARK <= SP) {
4767 SSize_t elem = SvIV(*MARK);
4768 bool preeminent = TRUE;
4770 if (localizing && can_preserve) {
4771 /* If we can determine whether the element exist,
4772 * Try to preserve the existenceness of a tied array
4773 * element by using EXISTS and DELETE if possible.
4774 * Fallback to FETCH and STORE otherwise. */
4775 preeminent = av_exists(av, elem);
4778 svp = av_fetch(av, elem, lval);
4781 DIE(aTHX_ PL_no_aelem, elem);
4784 save_aelem(av, elem, svp);
4786 SAVEADELETE(av, elem);
4789 *MARK = svp ? *svp : &PL_sv_undef;
4792 if (GIMME_V != G_ARRAY) {
4794 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4803 AV *const av = MUTABLE_AV(POPs);
4804 I32 lval = (PL_op->op_flags & OPf_MOD);
4805 SSize_t items = SP - MARK;
4807 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4808 const I32 flags = is_lvalue_sub();
4810 if (!(flags & OPpENTERSUB_INARGS))
4811 /* diag_listed_as: Can't modify %s in %s */
4812 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4819 *(MARK+items*2-1) = *(MARK+items);
4825 while (++MARK <= SP) {
4828 svp = av_fetch(av, SvIV(*MARK), lval);
4830 if (!svp || !*svp || *svp == &PL_sv_undef) {
4831 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4833 *MARK = sv_mortalcopy(*MARK);
4835 *++MARK = svp ? *svp : &PL_sv_undef;
4837 if (GIMME_V != G_ARRAY) {
4838 MARK = SP - items*2;
4839 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4849 AV *array = MUTABLE_AV(POPs);
4850 const U8 gimme = GIMME_V;
4851 IV *iterp = Perl_av_iter_p(aTHX_ array);
4852 const IV current = (*iterp)++;
4854 if (current > av_tindex(array)) {
4856 if (gimme == G_SCALAR)
4864 if (gimme == G_ARRAY) {
4865 SV **const element = av_fetch(array, current, 0);
4866 PUSHs(element ? *element : &PL_sv_undef);
4871 /* also used for: pp_avalues()*/
4875 AV *array = MUTABLE_AV(POPs);
4876 const U8 gimme = GIMME_V;
4878 *Perl_av_iter_p(aTHX_ array) = 0;
4880 if (gimme == G_SCALAR) {
4882 PUSHi(av_tindex(array) + 1);
4884 else if (gimme == G_ARRAY) {
4885 IV n = Perl_av_len(aTHX_ array);
4890 if (PL_op->op_type == OP_AKEYS) {
4891 for (i = 0; i <= n; i++) {
4896 for (i = 0; i <= n; i++) {
4897 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4898 PUSHs(elem ? *elem : &PL_sv_undef);
4905 /* Associative arrays. */
4910 HV * hash = MUTABLE_HV(POPs);
4912 const U8 gimme = GIMME_V;
4914 entry = hv_iternext(hash);
4918 SV* const sv = hv_iterkeysv(entry);
4920 if (gimme == G_ARRAY) {
4922 val = hv_iterval(hash, entry);
4926 else if (gimme == G_SCALAR)
4933 S_do_delete_local(pTHX)
4936 const U8 gimme = GIMME_V;
4939 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4940 SV **unsliced_keysv = sliced ? NULL : sp--;
4941 SV * const osv = POPs;
4942 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4944 const bool tied = SvRMAGICAL(osv)
4945 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4946 const bool can_preserve = SvCANEXISTDELETE(osv);
4947 const U32 type = SvTYPE(osv);
4948 SV ** const end = sliced ? SP : unsliced_keysv;
4950 if (type == SVt_PVHV) { /* hash element */
4951 HV * const hv = MUTABLE_HV(osv);
4952 while (++MARK <= end) {
4953 SV * const keysv = *MARK;
4955 bool preeminent = TRUE;
4957 preeminent = hv_exists_ent(hv, keysv, 0);
4959 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4966 sv = hv_delete_ent(hv, keysv, 0, 0);
4968 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4971 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4972 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4974 *MARK = sv_mortalcopy(sv);
4980 SAVEHDELETE(hv, keysv);
4981 *MARK = &PL_sv_undef;
4985 else if (type == SVt_PVAV) { /* array element */
4986 if (PL_op->op_flags & OPf_SPECIAL) {
4987 AV * const av = MUTABLE_AV(osv);
4988 while (++MARK <= end) {
4989 SSize_t idx = SvIV(*MARK);
4991 bool preeminent = TRUE;
4993 preeminent = av_exists(av, idx);
4995 SV **svp = av_fetch(av, idx, 1);
5002 sv = av_delete(av, idx, 0);
5004 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5007 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5009 *MARK = sv_mortalcopy(sv);
5015 SAVEADELETE(av, idx);
5016 *MARK = &PL_sv_undef;
5021 DIE(aTHX_ "panic: avhv_delete no longer supported");
5024 DIE(aTHX_ "Not a HASH reference");
5026 if (gimme == G_VOID)
5028 else if (gimme == G_SCALAR) {
5033 *++MARK = &PL_sv_undef;
5037 else if (gimme != G_VOID)
5038 PUSHs(*unsliced_keysv);
5049 if (PL_op->op_private & OPpLVAL_INTRO)
5050 return do_delete_local();
5053 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5055 if (PL_op->op_private & OPpSLICE) {
5057 HV * const hv = MUTABLE_HV(POPs);
5058 const U32 hvtype = SvTYPE(hv);
5059 if (hvtype == SVt_PVHV) { /* hash element */
5060 while (++MARK <= SP) {
5061 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5062 *MARK = sv ? sv : &PL_sv_undef;
5065 else if (hvtype == SVt_PVAV) { /* array element */
5066 if (PL_op->op_flags & OPf_SPECIAL) {
5067 while (++MARK <= SP) {
5068 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5069 *MARK = sv ? sv : &PL_sv_undef;
5074 DIE(aTHX_ "Not a HASH reference");
5077 else if (gimme == G_SCALAR) {
5082 *++MARK = &PL_sv_undef;
5088 HV * const hv = MUTABLE_HV(POPs);
5090 if (SvTYPE(hv) == SVt_PVHV)
5091 sv = hv_delete_ent(hv, keysv, discard, 0);
5092 else if (SvTYPE(hv) == SVt_PVAV) {
5093 if (PL_op->op_flags & OPf_SPECIAL)
5094 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5096 DIE(aTHX_ "panic: avhv_delete no longer supported");
5099 DIE(aTHX_ "Not a HASH reference");
5114 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5116 SV * const sv = POPs;
5117 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5120 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5125 hv = MUTABLE_HV(POPs);
5126 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5127 if (hv_exists_ent(hv, tmpsv, 0))
5130 else if (SvTYPE(hv) == SVt_PVAV) {
5131 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5132 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5137 DIE(aTHX_ "Not a HASH reference");
5144 dSP; dMARK; dORIGMARK;
5145 HV * const hv = MUTABLE_HV(POPs);
5146 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5147 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5148 bool can_preserve = FALSE;
5154 if (SvCANEXISTDELETE(hv))
5155 can_preserve = TRUE;
5158 while (++MARK <= SP) {
5159 SV * const keysv = *MARK;
5162 bool preeminent = TRUE;
5164 if (localizing && can_preserve) {
5165 /* If we can determine whether the element exist,
5166 * try to preserve the existenceness of a tied hash
5167 * element by using EXISTS and DELETE if possible.
5168 * Fallback to FETCH and STORE otherwise. */
5169 preeminent = hv_exists_ent(hv, keysv, 0);
5172 he = hv_fetch_ent(hv, keysv, lval, 0);
5173 svp = he ? &HeVAL(he) : NULL;
5176 if (!svp || !*svp || *svp == &PL_sv_undef) {
5177 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5180 if (HvNAME_get(hv) && isGV(*svp))
5181 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5182 else if (preeminent)
5183 save_helem_flags(hv, keysv, svp,
5184 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5186 SAVEHDELETE(hv, keysv);
5189 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5191 if (GIMME_V != G_ARRAY) {
5193 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5202 HV * const hv = MUTABLE_HV(POPs);
5203 I32 lval = (PL_op->op_flags & OPf_MOD);
5204 SSize_t items = SP - MARK;
5206 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5207 const I32 flags = is_lvalue_sub();
5209 if (!(flags & OPpENTERSUB_INARGS))
5210 /* diag_listed_as: Can't modify %s in %s */
5211 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
5218 *(MARK+items*2-1) = *(MARK+items);
5224 while (++MARK <= SP) {
5225 SV * const keysv = *MARK;
5229 he = hv_fetch_ent(hv, keysv, lval, 0);
5230 svp = he ? &HeVAL(he) : NULL;
5233 if (!svp || !*svp || *svp == &PL_sv_undef) {
5234 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5236 *MARK = sv_mortalcopy(*MARK);
5238 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5240 if (GIMME_V != G_ARRAY) {
5241 MARK = SP - items*2;
5242 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5248 /* List operators. */
5252 I32 markidx = POPMARK;
5253 if (GIMME_V != G_ARRAY) {
5254 SV **mark = PL_stack_base + markidx;
5257 *MARK = *SP; /* unwanted list, return last item */
5259 *MARK = &PL_sv_undef;
5269 SV ** const lastrelem = PL_stack_sp;
5270 SV ** const lastlelem = PL_stack_base + POPMARK;
5271 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5272 SV ** const firstrelem = lastlelem + 1;
5273 const U8 mod = PL_op->op_flags & OPf_MOD;
5275 const I32 max = lastrelem - lastlelem;
5278 if (GIMME_V != G_ARRAY) {
5279 if (lastlelem < firstlelem) {
5280 *firstlelem = &PL_sv_undef;
5283 I32 ix = SvIV(*lastlelem);
5286 if (ix < 0 || ix >= max)
5287 *firstlelem = &PL_sv_undef;
5289 *firstlelem = firstrelem[ix];
5296 SP = firstlelem - 1;
5300 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5301 I32 ix = SvIV(*lelem);
5304 if (ix < 0 || ix >= max)
5305 *lelem = &PL_sv_undef;
5307 if (!(*lelem = firstrelem[ix]))
5308 *lelem = &PL_sv_undef;
5309 else if (mod && SvPADTMP(*lelem)) {
5310 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5321 const I32 items = SP - MARK;
5322 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5324 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5325 ? newRV_noinc(av) : av);
5331 dSP; dMARK; dORIGMARK;
5332 HV* const hv = newHV();
5333 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5334 ? newRV_noinc(MUTABLE_SV(hv))
5339 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5346 sv_setsv_nomg(val, *MARK);
5350 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5353 (void)hv_store_ent(hv,key,val,0);
5361 S_deref_plain_array(pTHX_ AV *ary)
5363 if (SvTYPE(ary) == SVt_PVAV) return ary;
5364 SvGETMAGIC((SV *)ary);
5365 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5366 Perl_die(aTHX_ "Not an ARRAY reference");
5367 else if (SvOBJECT(SvRV(ary)))
5368 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5369 return (AV *)SvRV(ary);
5372 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5373 # define DEREF_PLAIN_ARRAY(ary) \
5376 SvTYPE(aRrRay) == SVt_PVAV \
5378 : S_deref_plain_array(aTHX_ aRrRay); \
5381 # define DEREF_PLAIN_ARRAY(ary) \
5383 PL_Sv = (SV *)(ary), \
5384 SvTYPE(PL_Sv) == SVt_PVAV \
5386 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5392 dSP; dMARK; dORIGMARK;
5393 int num_args = (SP - MARK);
5394 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5403 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5406 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5407 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5414 offset = i = SvIV(*MARK);
5416 offset += AvFILLp(ary) + 1;
5418 DIE(aTHX_ PL_no_aelem, i);
5420 length = SvIVx(*MARK++);
5422 length += AvFILLp(ary) - offset + 1;
5428 length = AvMAX(ary) + 1; /* close enough to infinity */
5432 length = AvMAX(ary) + 1;
5434 if (offset > AvFILLp(ary) + 1) {
5436 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5437 offset = AvFILLp(ary) + 1;
5439 after = AvFILLp(ary) + 1 - (offset + length);
5440 if (after < 0) { /* not that much array */
5441 length += after; /* offset+length now in array */
5447 /* At this point, MARK .. SP-1 is our new LIST */
5450 diff = newlen - length;
5451 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5454 /* make new elements SVs now: avoid problems if they're from the array */
5455 for (dst = MARK, i = newlen; i; i--) {
5456 SV * const h = *dst;
5457 *dst++ = newSVsv(h);
5460 if (diff < 0) { /* shrinking the area */
5461 SV **tmparyval = NULL;
5463 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5464 Copy(MARK, tmparyval, newlen, SV*);
5467 MARK = ORIGMARK + 1;
5468 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5469 const bool real = cBOOL(AvREAL(ary));
5470 MEXTEND(MARK, length);
5472 EXTEND_MORTAL(length);
5473 for (i = 0, dst = MARK; i < length; i++) {
5474 if ((*dst = AvARRAY(ary)[i+offset])) {
5476 sv_2mortal(*dst); /* free them eventually */
5479 *dst = &PL_sv_undef;
5485 *MARK = AvARRAY(ary)[offset+length-1];
5488 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5489 SvREFCNT_dec(*dst++); /* free them now */
5492 AvFILLp(ary) += diff;
5494 /* pull up or down? */
5496 if (offset < after) { /* easier to pull up */
5497 if (offset) { /* esp. if nothing to pull */
5498 src = &AvARRAY(ary)[offset-1];
5499 dst = src - diff; /* diff is negative */
5500 for (i = offset; i > 0; i--) /* can't trust Copy */
5504 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5508 if (after) { /* anything to pull down? */
5509 src = AvARRAY(ary) + offset + length;
5510 dst = src + diff; /* diff is negative */
5511 Move(src, dst, after, SV*);
5513 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5514 /* avoid later double free */
5521 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5522 Safefree(tmparyval);
5525 else { /* no, expanding (or same) */
5526 SV** tmparyval = NULL;
5528 Newx(tmparyval, length, SV*); /* so remember deletion */
5529 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5532 if (diff > 0) { /* expanding */
5533 /* push up or down? */
5534 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5538 Move(src, dst, offset, SV*);
5540 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5542 AvFILLp(ary) += diff;
5545 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5546 av_extend(ary, AvFILLp(ary) + diff);
5547 AvFILLp(ary) += diff;
5550 dst = AvARRAY(ary) + AvFILLp(ary);
5552 for (i = after; i; i--) {
5560 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5563 MARK = ORIGMARK + 1;
5564 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5566 const bool real = cBOOL(AvREAL(ary));
5568 EXTEND_MORTAL(length);
5569 for (i = 0, dst = MARK; i < length; i++) {
5570 if ((*dst = tmparyval[i])) {
5572 sv_2mortal(*dst); /* free them eventually */
5574 else *dst = &PL_sv_undef;
5580 else if (length--) {
5581 *MARK = tmparyval[length];
5584 while (length-- > 0)
5585 SvREFCNT_dec(tmparyval[length]);
5589 *MARK = &PL_sv_undef;
5590 Safefree(tmparyval);
5594 mg_set(MUTABLE_SV(ary));
5602 dSP; dMARK; dORIGMARK; dTARGET;
5603 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5604 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5607 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5610 ENTER_with_name("call_PUSH");
5611 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5612 LEAVE_with_name("call_PUSH");
5613 /* SPAGAIN; not needed: SP is assigned to immediately below */
5616 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5617 * only need to save locally, not on the save stack */
5618 U16 old_delaymagic = PL_delaymagic;
5620 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5621 PL_delaymagic = DM_DELAY;
5622 for (++MARK; MARK <= SP; MARK++) {
5624 if (*MARK) SvGETMAGIC(*MARK);
5627 sv_setsv_nomg(sv, *MARK);
5628 av_store(ary, AvFILLp(ary)+1, sv);
5630 if (PL_delaymagic & DM_ARRAY_ISA)
5631 mg_set(MUTABLE_SV(ary));
5632 PL_delaymagic = old_delaymagic;
5635 if (OP_GIMME(PL_op, 0) != G_VOID) {
5636 PUSHi( AvFILL(ary) + 1 );
5641 /* also used for: pp_pop()*/
5645 AV * const av = PL_op->op_flags & OPf_SPECIAL
5646 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5647 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5651 (void)sv_2mortal(sv);
5658 dSP; dMARK; dORIGMARK; dTARGET;
5659 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5660 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5663 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5666 ENTER_with_name("call_UNSHIFT");
5667 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5668 LEAVE_with_name("call_UNSHIFT");
5669 /* SPAGAIN; not needed: SP is assigned to immediately below */
5672 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5673 * only need to save locally, not on the save stack */
5674 U16 old_delaymagic = PL_delaymagic;
5677 av_unshift(ary, SP - MARK);
5678 PL_delaymagic = DM_DELAY;
5680 SV * const sv = newSVsv(*++MARK);
5681 (void)av_store(ary, i++, sv);
5683 if (PL_delaymagic & DM_ARRAY_ISA)
5684 mg_set(MUTABLE_SV(ary));
5685 PL_delaymagic = old_delaymagic;
5688 if (OP_GIMME(PL_op, 0) != G_VOID) {
5689 PUSHi( AvFILL(ary) + 1 );
5698 if (GIMME_V == G_ARRAY) {
5699 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5703 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5704 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5705 av = MUTABLE_AV((*SP));
5706 /* In-place reversing only happens in void context for the array
5707 * assignment. We don't need to push anything on the stack. */
5710 if (SvMAGICAL(av)) {
5712 SV *tmp = sv_newmortal();
5713 /* For SvCANEXISTDELETE */
5716 bool can_preserve = SvCANEXISTDELETE(av);
5718 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5722 if (!av_exists(av, i)) {
5723 if (av_exists(av, j)) {
5724 SV *sv = av_delete(av, j, 0);
5725 begin = *av_fetch(av, i, TRUE);
5726 sv_setsv_mg(begin, sv);
5730 else if (!av_exists(av, j)) {
5731 SV *sv = av_delete(av, i, 0);
5732 end = *av_fetch(av, j, TRUE);
5733 sv_setsv_mg(end, sv);
5738 begin = *av_fetch(av, i, TRUE);
5739 end = *av_fetch(av, j, TRUE);
5740 sv_setsv(tmp, begin);
5741 sv_setsv_mg(begin, end);
5742 sv_setsv_mg(end, tmp);
5746 SV **begin = AvARRAY(av);
5749 SV **end = begin + AvFILLp(av);
5751 while (begin < end) {
5752 SV * const tmp = *begin;
5763 SV * const tmp = *MARK;
5767 /* safe as long as stack cannot get extended in the above */
5778 SvUTF8_off(TARG); /* decontaminate */
5780 do_join(TARG, &PL_sv_no, MARK, SP);
5782 sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5785 up = SvPV_force(TARG, len);
5787 if (DO_UTF8(TARG)) { /* first reverse each character */
5788 U8* s = (U8*)SvPVX(TARG);
5789 const U8* send = (U8*)(s + len);
5791 if (UTF8_IS_INVARIANT(*s)) {
5796 if (!utf8_to_uvchr_buf(s, send, 0))
5800 down = (char*)(s - 1);
5801 /* reverse this character */
5805 *down-- = (char)tmp;
5811 down = SvPVX(TARG) + len - 1;
5815 *down-- = (char)tmp;
5817 (void)SvPOK_only_UTF8(TARG);
5828 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5829 IV limit = POPi; /* note, negative is forever */
5830 SV * const sv = POPs;
5832 const char *s = SvPV_const(sv, len);
5833 const bool do_utf8 = DO_UTF8(sv);
5834 const char *strend = s + len;
5840 const STRLEN slen = do_utf8
5841 ? utf8_length((U8*)s, (U8*)strend)
5842 : (STRLEN)(strend - s);
5843 SSize_t maxiters = slen + 10;
5844 I32 trailing_empty = 0;
5846 const IV origlimit = limit;
5849 const U8 gimme = GIMME_V;
5851 const I32 oldsave = PL_savestack_ix;
5852 U32 make_mortal = SVs_TEMP;
5857 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5862 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5865 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5866 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5869 if (pm->op_pmreplrootu.op_pmtargetoff) {
5870 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5874 if (pm->op_pmreplrootu.op_pmtargetgv) {
5875 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5879 else if (pm->op_targ)
5880 ary = (AV *)PAD_SVl(pm->op_targ);
5886 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5889 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5891 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5898 for (i = AvFILLp(ary); i >= 0; i--)
5899 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5901 /* temporarily switch stacks */
5902 SAVESWITCHSTACK(PL_curstack, ary);
5906 base = SP - PL_stack_base;
5908 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5910 while (isSPACE_utf8(s))
5913 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5914 while (isSPACE_LC(*s))
5922 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5926 gimme_scalar = gimme == G_SCALAR && !ary;
5929 limit = maxiters + 2;
5930 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5933 /* this one uses 'm' and is a negative test */
5935 while (m < strend && ! isSPACE_utf8(m) ) {
5936 const int t = UTF8SKIP(m);
5937 /* isSPACE_utf8 returns FALSE for malform utf8 */
5944 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5946 while (m < strend && !isSPACE_LC(*m))
5949 while (m < strend && !isSPACE(*m))
5962 dstr = newSVpvn_flags(s, m-s,
5963 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5967 /* skip the whitespace found last */
5969 s = m + UTF8SKIP(m);
5973 /* this one uses 's' and is a positive test */
5975 while (s < strend && isSPACE_utf8(s) )
5978 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5980 while (s < strend && isSPACE_LC(*s))
5983 while (s < strend && isSPACE(*s))
5988 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5990 for (m = s; m < strend && *m != '\n'; m++)
6003 dstr = newSVpvn_flags(s, m-s,
6004 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6010 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6012 Pre-extend the stack, either the number of bytes or
6013 characters in the string or a limited amount, triggered by:
6015 my ($x, $y) = split //, $str;
6019 if (!gimme_scalar) {
6020 const IV items = limit - 1;
6021 /* setting it to -1 will trigger a panic in EXTEND() */
6022 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
6023 if (items >=0 && items < sslen)
6031 /* keep track of how many bytes we skip over */
6041 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6054 dstr = newSVpvn(s, 1);
6070 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6071 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6072 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6073 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6074 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6075 SV * const csv = CALLREG_INTUIT_STRING(rx);
6077 len = RX_MINLENRET(rx);
6078 if (len == 1 && !RX_UTF8(rx) && !tail) {
6079 const char c = *SvPV_nolen_const(csv);
6081 for (m = s; m < strend && *m != c; m++)
6092 dstr = newSVpvn_flags(s, m-s,
6093 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6096 /* The rx->minlen is in characters but we want to step
6097 * s ahead by bytes. */
6099 s = (char*)utf8_hop((U8*)m, len);
6101 s = m + len; /* Fake \n at the end */
6105 while (s < strend && --limit &&
6106 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6107 csv, multiline ? FBMrf_MULTILINE : 0)) )
6116 dstr = newSVpvn_flags(s, m-s,
6117 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6120 /* The rx->minlen is in characters but we want to step
6121 * s ahead by bytes. */
6123 s = (char*)utf8_hop((U8*)m, len);
6125 s = m + len; /* Fake \n at the end */
6130 maxiters += slen * RX_NPARENS(rx);
6131 while (s < strend && --limit)
6135 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6138 if (rex_return == 0)
6140 TAINT_IF(RX_MATCH_TAINTED(rx));
6141 /* we never pass the REXEC_COPY_STR flag, so it should
6142 * never get copied */
6143 assert(!RX_MATCH_COPIED(rx));
6144 m = RX_OFFS(rx)[0].start + orig;
6153 dstr = newSVpvn_flags(s, m-s,
6154 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6157 if (RX_NPARENS(rx)) {
6159 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6160 s = RX_OFFS(rx)[i].start + orig;
6161 m = RX_OFFS(rx)[i].end + orig;
6163 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6164 parens that didn't match -- they should be set to
6165 undef, not the empty string */
6173 if (m >= orig && s >= orig) {
6174 dstr = newSVpvn_flags(s, m-s,
6175 (do_utf8 ? SVf_UTF8 : 0)
6179 dstr = &PL_sv_undef; /* undef, not "" */
6185 s = RX_OFFS(rx)[0].end + orig;
6189 if (!gimme_scalar) {
6190 iters = (SP - PL_stack_base) - base;
6192 if (iters > maxiters)
6193 DIE(aTHX_ "Split loop");
6195 /* keep field after final delim? */
6196 if (s < strend || (iters && origlimit)) {
6197 if (!gimme_scalar) {
6198 const STRLEN l = strend - s;
6199 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6204 else if (!origlimit) {
6206 iters -= trailing_empty;
6208 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6209 if (TOPs && !make_mortal)
6211 *SP-- = &PL_sv_undef;
6218 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6222 if (SvSMAGICAL(ary)) {
6224 mg_set(MUTABLE_SV(ary));
6227 if (gimme == G_ARRAY) {
6229 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6236 ENTER_with_name("call_PUSH");
6237 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6238 LEAVE_with_name("call_PUSH");
6240 if (gimme == G_ARRAY) {
6242 /* EXTEND should not be needed - we just popped them */
6244 for (i=0; i < iters; i++) {
6245 SV **svp = av_fetch(ary, i, FALSE);
6246 PUSHs((svp) ? *svp : &PL_sv_undef);
6253 if (gimme == G_ARRAY)
6265 SV *const sv = PAD_SVl(PL_op->op_targ);
6267 if (SvPADSTALE(sv)) {
6270 RETURNOP(cLOGOP->op_other);
6272 RETURNOP(cLOGOP->op_next);
6281 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6282 || SvTYPE(retsv) == SVt_PVCV) {
6283 retsv = refto(retsv);
6290 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
6291 * that aren't implemented on a particular platform */
6293 PP(unimplemented_op)
6295 const Optype op_type = PL_op->op_type;
6296 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6297 with out of range op numbers - it only "special" cases op_custom.
6298 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6299 if we get here for a custom op then that means that the custom op didn't
6300 have an implementation. Given that OP_NAME() looks up the custom op
6301 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6302 registers &PL_unimplemented_op as the address of their custom op.
6303 NULL doesn't generate a useful error message. "custom" does. */
6304 const char *const name = op_type >= OP_max
6305 ? "[out of range]" : PL_op_name[PL_op->op_type];
6306 if(OP_IS_SOCKET(op_type))
6307 DIE(aTHX_ PL_no_sock_func, name);
6308 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6311 /* For sorting out arguments passed to a &CORE:: subroutine */
6315 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6316 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6317 AV * const at_ = GvAV(PL_defgv);
6318 SV **svp = at_ ? AvARRAY(at_) : NULL;
6319 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6320 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6321 bool seen_question = 0;
6322 const char *err = NULL;
6323 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6325 /* Count how many args there are first, to get some idea how far to
6326 extend the stack. */
6328 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6330 if (oa & OA_OPTIONAL) seen_question = 1;
6331 if (!seen_question) minargs++;
6335 if(numargs < minargs) err = "Not enough";
6336 else if(numargs > maxargs) err = "Too many";
6338 /* diag_listed_as: Too many arguments for %s */
6340 "%s arguments for %s", err,
6341 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6344 /* Reset the stack pointer. Without this, we end up returning our own
6345 arguments in list context, in addition to the values we are supposed
6346 to return. nextstate usually does this on sub entry, but we need
6347 to run the next op with the caller's hints, so we cannot have a
6349 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6351 if(!maxargs) RETURN;
6353 /* We do this here, rather than with a separate pushmark op, as it has
6354 to come in between two things this function does (stack reset and
6355 arg pushing). This seems the easiest way to do it. */
6358 (void)Perl_pp_pushmark(aTHX);
6361 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6362 PUTBACK; /* The code below can die in various places. */
6364 oa = PL_opargs[opnum] >> OASHIFT;
6365 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6370 if (!numargs && defgv && whicharg == minargs + 1) {
6373 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6377 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6382 if (!svp || !*svp || !SvROK(*svp)
6383 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6385 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6386 "Type of arg %d to &CORE::%s must be hash reference",
6387 whicharg, OP_DESC(PL_op->op_next)
6392 if (!numargs) PUSHs(NULL);
6393 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6394 /* no magic here, as the prototype will have added an extra
6395 refgen and we just want what was there before that */
6398 const bool constr = PL_op->op_private & whicharg;
6400 svp && *svp ? *svp : &PL_sv_undef,
6401 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6407 if (!numargs) goto try_defsv;
6409 const bool wantscalar =
6410 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6411 if (!svp || !*svp || !SvROK(*svp)
6412 /* We have to permit globrefs even for the \$ proto, as
6413 *foo is indistinguishable from ${\*foo}, and the proto-
6414 type permits the latter. */
6415 || SvTYPE(SvRV(*svp)) > (
6416 wantscalar ? SVt_PVLV
6417 : opnum == OP_LOCK || opnum == OP_UNDEF
6423 "Type of arg %d to &CORE::%s must be %s",
6424 whicharg, PL_op_name[opnum],
6426 ? "scalar reference"
6427 : opnum == OP_LOCK || opnum == OP_UNDEF
6428 ? "reference to one of [$@%&*]"
6429 : "reference to one of [$@%*]"
6432 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6433 && CX_CUR()->cx_type & CXp_HASARGS) {
6434 /* Undo @_ localisation, so that sub exit does not undo
6435 part of our undeffing. */
6436 PERL_CONTEXT *cx = CX_CUR();
6438 assert(CxHASARGS(cx));
6439 cx_popsub_args(cx);;
6440 cx->cx_type &= ~CXp_HASARGS;
6445 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6457 if (PL_op->op_private & OPpOFFBYONE) {
6458 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6460 else cv = find_runcv(NULL);
6461 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6466 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6467 const bool can_preserve)
6469 const SSize_t ix = SvIV(keysv);
6470 if (can_preserve ? av_exists(av, ix) : TRUE) {
6471 SV ** const svp = av_fetch(av, ix, 1);
6473 Perl_croak(aTHX_ PL_no_aelem, ix);
6474 save_aelem(av, ix, svp);
6477 SAVEADELETE(av, ix);
6481 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6482 const bool can_preserve)
6484 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6485 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6486 SV ** const svp = he ? &HeVAL(he) : NULL;
6488 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6489 save_helem_flags(hv, keysv, svp, 0);
6492 SAVEHDELETE(hv, keysv);
6496 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6498 if (type == OPpLVREF_SV) {
6499 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6502 else if (type == OPpLVREF_AV)
6503 /* XXX Inefficient, as it creates a new AV, which we are
6504 about to clobber. */
6507 assert(type == OPpLVREF_HV);
6508 /* XXX Likewise inefficient. */
6517 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6518 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6520 const char *bad = NULL;
6521 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6522 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6525 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6529 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6533 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6537 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6541 /* diag_listed_as: Assigned value is not %s reference */
6542 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6546 switch (left ? SvTYPE(left) : 0) {
6549 SV * const old = PAD_SV(ARGTARG);
6550 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6552 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6554 SAVECLEARSV(PAD_SVl(ARGTARG));
6558 if (PL_op->op_private & OPpLVAL_INTRO) {
6559 S_localise_gv_slot(aTHX_ (GV *)left, type);
6561 gv_setref(left, sv);
6566 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6567 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6568 SvCANEXISTDELETE(left));
6570 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6573 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6575 S_localise_helem_lval(aTHX_ (HV *)left, key,
6576 SvCANEXISTDELETE(left));
6578 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6580 if (PL_op->op_flags & OPf_MOD)
6581 SETs(sv_2mortal(newSVsv(sv)));
6582 /* XXX else can weak references go stale before they are read, e.g.,
6591 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6592 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6593 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6594 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6595 &PL_vtbl_lvref, (char *)elem,
6596 elem ? HEf_SVKEY : (I32)ARGTARG);
6597 mg->mg_private = PL_op->op_private;
6598 if (PL_op->op_private & OPpLVREF_ITER)
6599 mg->mg_flags |= MGf_PERSIST;
6600 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6606 const bool can_preserve = SvCANEXISTDELETE(arg);
6607 if (SvTYPE(arg) == SVt_PVAV)
6608 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6610 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6614 S_localise_gv_slot(aTHX_ (GV *)arg,
6615 PL_op->op_private & OPpLVREF_TYPE);
6617 else if (!(PL_op->op_private & OPpPAD_STATE))
6618 SAVECLEARSV(PAD_SVl(ARGTARG));
6627 AV * const av = (AV *)POPs;
6628 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6629 bool can_preserve = FALSE;
6631 if (UNLIKELY(localizing)) {
6636 can_preserve = SvCANEXISTDELETE(av);
6638 if (SvTYPE(av) == SVt_PVAV) {
6641 for (svp = MARK + 1; svp <= SP; svp++) {
6642 const SSize_t elem = SvIV(*svp);
6646 if (max > AvMAX(av))
6651 while (++MARK <= SP) {
6652 SV * const elemsv = *MARK;
6653 if (SvTYPE(av) == SVt_PVAV)
6654 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6656 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6657 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6658 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6665 if (PL_op->op_flags & OPf_STACKED)
6666 Perl_pp_rv2av(aTHX);
6668 Perl_pp_padav(aTHX);
6672 SETs(0); /* special alias marker that aassign recognises */
6682 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6683 ? CopSTASH(PL_curcop)
6685 NULL, SvREFCNT_inc_simple_NN(sv))));
6690 * ex: set ts=8 sts=4 sw=4 et: