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 */
1369 if (nl == (NV)il && nr == (NV)ir)
1370 /* nothing was lost by converting to IVs */
1374 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1375 if (Perl_isinf(result)) {
1376 Zero((U8*)&result + 8, 8, U8);
1379 TARGn(result, 0); /* args not GMG, so can't be tainted */
1387 if (SvIV_please_nomg(svr)) {
1388 /* Unless the left argument is integer in range we are going to have to
1389 use NV maths. Hence only attempt to coerce the right argument if
1390 we know the left is integer. */
1391 /* Left operand is defined, so is it IV? */
1392 if (SvIV_please_nomg(svl)) {
1393 bool auvok = SvUOK(svl);
1394 bool buvok = SvUOK(svr);
1395 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1396 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1405 const IV aiv = SvIVX(svl);
1408 auvok = TRUE; /* effectively it's a UV now */
1410 /* abs, auvok == false records sign */
1411 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1417 const IV biv = SvIVX(svr);
1420 buvok = TRUE; /* effectively it's a UV now */
1422 /* abs, buvok == false records sign */
1423 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1427 /* If this does sign extension on unsigned it's time for plan B */
1428 ahigh = alow >> (4 * sizeof (UV));
1430 bhigh = blow >> (4 * sizeof (UV));
1432 if (ahigh && bhigh) {
1434 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1435 which is overflow. Drop to NVs below. */
1436 } else if (!ahigh && !bhigh) {
1437 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1438 so the unsigned multiply cannot overflow. */
1439 const UV product = alow * blow;
1440 if (auvok == buvok) {
1441 /* -ve * -ve or +ve * +ve gives a +ve result. */
1445 } else if (product <= (UV)IV_MIN) {
1446 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1447 /* -ve result, which could overflow an IV */
1449 /* can't negate IV_MIN, but there are aren't two
1450 * integers such that !ahigh && !bhigh, where the
1451 * product equals 0x800....000 */
1452 assert(product != (UV)IV_MIN);
1453 SETi( -(IV)product );
1455 } /* else drop to NVs below. */
1457 /* One operand is large, 1 small */
1460 /* swap the operands */
1462 bhigh = blow; /* bhigh now the temp var for the swap */
1466 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1467 multiplies can't overflow. shift can, add can, -ve can. */
1468 product_middle = ahigh * blow;
1469 if (!(product_middle & topmask)) {
1470 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1472 product_middle <<= (4 * sizeof (UV));
1473 product_low = alow * blow;
1475 /* as for pp_add, UV + something mustn't get smaller.
1476 IIRC ANSI mandates this wrapping *behaviour* for
1477 unsigned whatever the actual representation*/
1478 product_low += product_middle;
1479 if (product_low >= product_middle) {
1480 /* didn't overflow */
1481 if (auvok == buvok) {
1482 /* -ve * -ve or +ve * +ve gives a +ve result. */
1484 SETu( product_low );
1486 } else if (product_low <= (UV)IV_MIN) {
1487 /* 2s complement assumption again */
1488 /* -ve result, which could overflow an IV */
1490 SETi(product_low == (UV)IV_MIN
1491 ? IV_MIN : -(IV)product_low);
1493 } /* else drop to NVs below. */
1495 } /* product_middle too large */
1496 } /* ahigh && bhigh */
1501 NV right = SvNV_nomg(svr);
1502 NV left = SvNV_nomg(svl);
1503 NV result = left * right;
1506 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1507 if (Perl_isinf(result)) {
1508 Zero((U8*)&result + 8, 8, U8);
1518 dSP; dATARGET; SV *svl, *svr;
1519 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1522 /* Only try to do UV divide first
1523 if ((SLOPPYDIVIDE is true) or
1524 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1526 The assumption is that it is better to use floating point divide
1527 whenever possible, only doing integer divide first if we can't be sure.
1528 If NV_PRESERVES_UV is true then we know at compile time that no UV
1529 can be too large to preserve, so don't need to compile the code to
1530 test the size of UVs. */
1533 # define PERL_TRY_UV_DIVIDE
1534 /* ensure that 20./5. == 4. */
1536 # ifdef PERL_PRESERVE_IVUV
1537 # ifndef NV_PRESERVES_UV
1538 # define PERL_TRY_UV_DIVIDE
1543 #ifdef PERL_TRY_UV_DIVIDE
1544 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1545 bool left_non_neg = SvUOK(svl);
1546 bool right_non_neg = SvUOK(svr);
1550 if (right_non_neg) {
1554 const IV biv = SvIVX(svr);
1557 right_non_neg = TRUE; /* effectively it's a UV now */
1560 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1563 /* historically undef()/0 gives a "Use of uninitialized value"
1564 warning before dieing, hence this test goes here.
1565 If it were immediately before the second SvIV_please, then
1566 DIE() would be invoked before left was even inspected, so
1567 no inspection would give no warning. */
1569 DIE(aTHX_ "Illegal division by zero");
1575 const IV aiv = SvIVX(svl);
1578 left_non_neg = TRUE; /* effectively it's a UV now */
1581 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1587 /* For sloppy divide we always attempt integer division. */
1589 /* Otherwise we only attempt it if either or both operands
1590 would not be preserved by an NV. If both fit in NVs
1591 we fall through to the NV divide code below. However,
1592 as left >= right to ensure integer result here, we know that
1593 we can skip the test on the right operand - right big
1594 enough not to be preserved can't get here unless left is
1597 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1600 /* Integer division can't overflow, but it can be imprecise. */
1601 const UV result = left / right;
1602 if (result * right == left) {
1603 SP--; /* result is valid */
1604 if (left_non_neg == right_non_neg) {
1605 /* signs identical, result is positive. */
1609 /* 2s complement assumption */
1610 if (result <= (UV)IV_MIN)
1611 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1613 /* It's exact but too negative for IV. */
1614 SETn( -(NV)result );
1617 } /* tried integer divide but it was not an integer result */
1618 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1619 } /* one operand wasn't SvIOK */
1620 #endif /* PERL_TRY_UV_DIVIDE */
1622 NV right = SvNV_nomg(svr);
1623 NV left = SvNV_nomg(svl);
1624 (void)POPs;(void)POPs;
1625 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1626 if (! Perl_isnan(right) && right == 0.0)
1630 DIE(aTHX_ "Illegal division by zero");
1631 PUSHn( left / right );
1639 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1643 bool left_neg = FALSE;
1644 bool right_neg = FALSE;
1645 bool use_double = FALSE;
1646 bool dright_valid = FALSE;
1649 SV * const svr = TOPs;
1650 SV * const svl = TOPm1s;
1651 if (SvIV_please_nomg(svr)) {
1652 right_neg = !SvUOK(svr);
1656 const IV biv = SvIVX(svr);
1659 right_neg = FALSE; /* effectively it's a UV now */
1661 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1666 dright = SvNV_nomg(svr);
1667 right_neg = dright < 0;
1670 if (dright < UV_MAX_P1) {
1671 right = U_V(dright);
1672 dright_valid = TRUE; /* In case we need to use double below. */
1678 /* At this point use_double is only true if right is out of range for
1679 a UV. In range NV has been rounded down to nearest UV and
1680 use_double false. */
1681 if (!use_double && SvIV_please_nomg(svl)) {
1682 left_neg = !SvUOK(svl);
1686 const IV aiv = SvIVX(svl);
1689 left_neg = FALSE; /* effectively it's a UV now */
1691 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1696 dleft = SvNV_nomg(svl);
1697 left_neg = dleft < 0;
1701 /* This should be exactly the 5.6 behaviour - if left and right are
1702 both in range for UV then use U_V() rather than floor. */
1704 if (dleft < UV_MAX_P1) {
1705 /* right was in range, so is dleft, so use UVs not double.
1709 /* left is out of range for UV, right was in range, so promote
1710 right (back) to double. */
1712 /* The +0.5 is used in 5.6 even though it is not strictly
1713 consistent with the implicit +0 floor in the U_V()
1714 inside the #if 1. */
1715 dleft = Perl_floor(dleft + 0.5);
1718 dright = Perl_floor(dright + 0.5);
1729 DIE(aTHX_ "Illegal modulus zero");
1731 dans = Perl_fmod(dleft, dright);
1732 if ((left_neg != right_neg) && dans)
1733 dans = dright - dans;
1736 sv_setnv(TARG, dans);
1742 DIE(aTHX_ "Illegal modulus zero");
1745 if ((left_neg != right_neg) && ans)
1748 /* XXX may warn: unary minus operator applied to unsigned type */
1749 /* could change -foo to be (~foo)+1 instead */
1750 if (ans <= ~((UV)IV_MAX)+1)
1751 sv_setiv(TARG, ~ans+1);
1753 sv_setnv(TARG, -(NV)ans);
1756 sv_setuv(TARG, ans);
1768 bool infnan = FALSE;
1770 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1771 /* TODO: think of some way of doing list-repeat overloading ??? */
1776 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1777 /* The parser saw this as a list repeat, and there
1778 are probably several items on the stack. But we're
1779 in scalar/void context, and there's no pp_list to save us
1780 now. So drop the rest of the items -- robin@kitsite.com
1783 if (MARK + 1 < SP) {
1789 ASSUME(MARK + 1 == SP);
1791 MARK[1] = &PL_sv_undef;
1795 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1801 const UV uv = SvUV_nomg(sv);
1803 count = IV_MAX; /* The best we can do? */
1807 count = SvIV_nomg(sv);
1810 else if (SvNOKp(sv)) {
1811 const NV nv = SvNV_nomg(sv);
1812 infnan = Perl_isinfnan(nv);
1813 if (UNLIKELY(infnan)) {
1817 count = -1; /* An arbitrary negative integer */
1823 count = SvIV_nomg(sv);
1826 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1827 "Non-finite repeat count does nothing");
1828 } else if (count < 0) {
1830 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1831 "Negative repeat count does nothing");
1834 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1836 const SSize_t items = SP - MARK;
1837 const U8 mod = PL_op->op_flags & OPf_MOD;
1842 if ( items > SSize_t_MAX / count /* max would overflow */
1843 /* repeatcpy would overflow */
1844 || items > I32_MAX / (I32)sizeof(SV *)
1846 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1847 max = items * count;
1852 if (mod && SvPADTMP(*SP)) {
1853 *SP = sv_mortalcopy(*SP);
1860 repeatcpy((char*)(MARK + items), (char*)MARK,
1861 items * sizeof(const SV *), count - 1);
1864 else if (count <= 0)
1867 else { /* Note: mark already snarfed by pp_list */
1868 SV * const tmpstr = POPs;
1873 sv_setsv_nomg(TARG, tmpstr);
1874 SvPV_force_nomg(TARG, len);
1875 isutf = DO_UTF8(TARG);
1882 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1883 || len > (U32)I32_MAX /* repeatcpy would overflow */
1885 Perl_croak(aTHX_ "%s",
1886 "Out of memory during string extend");
1887 max = (UV)count * len + 1;
1890 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1891 SvCUR_set(TARG, SvCUR(TARG) * count);
1893 *SvEND(TARG) = '\0';
1896 (void)SvPOK_only_UTF8(TARG);
1898 (void)SvPOK_only(TARG);
1907 dSP; dATARGET; bool useleft; SV *svl, *svr;
1908 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1912 #ifdef PERL_PRESERVE_IVUV
1914 /* special-case some simple common cases */
1915 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1917 U32 flags = (svl->sv_flags & svr->sv_flags);
1918 if (flags & SVf_IOK) {
1919 /* both args are simple IVs */
1924 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1925 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1927 /* if both are in a range that can't under/overflow, do a
1928 * simple integer subtract: if the top of both numbers
1929 * are 00 or 11, then it's safe */
1930 if (!( ((topl+1) | (topr+1)) & 2)) {
1932 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1938 else if (flags & SVf_NOK) {
1939 /* both args are NVs */
1945 if (nl == (NV)il && nr == (NV)ir)
1946 /* nothing was lost by converting to IVs */
1949 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1957 useleft = USE_LEFT(svl);
1958 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1959 "bad things" happen if you rely on signed integers wrapping. */
1960 if (SvIV_please_nomg(svr)) {
1961 /* Unless the left argument is integer in range we are going to have to
1962 use NV maths. Hence only attempt to coerce the right argument if
1963 we know the left is integer. */
1970 a_valid = auvok = 1;
1971 /* left operand is undef, treat as zero. */
1973 /* Left operand is defined, so is it IV? */
1974 if (SvIV_please_nomg(svl)) {
1975 if ((auvok = SvUOK(svl)))
1978 const IV aiv = SvIVX(svl);
1981 auvok = 1; /* Now acting as a sign flag. */
1982 } else { /* 2s complement assumption for IV_MIN */
1983 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1990 bool result_good = 0;
1993 bool buvok = SvUOK(svr);
1998 const IV biv = SvIVX(svr);
2003 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
2005 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
2006 else "IV" now, independent of how it came in.
2007 if a, b represents positive, A, B negative, a maps to -A etc
2012 all UV maths. negate result if A negative.
2013 subtract if signs same, add if signs differ. */
2015 if (auvok ^ buvok) {
2024 /* Must get smaller */
2029 if (result <= buv) {
2030 /* result really should be -(auv-buv). as its negation
2031 of true value, need to swap our result flag */
2043 if (result <= (UV)IV_MIN)
2044 SETi(result == (UV)IV_MIN
2045 ? IV_MIN : -(IV)result);
2047 /* result valid, but out of range for IV. */
2048 SETn( -(NV)result );
2052 } /* Overflow, drop through to NVs. */
2056 useleft = USE_LEFT(svl);
2059 NV value = SvNV_nomg(svr);
2063 /* left operand is undef, treat as zero - value */
2067 SETn( SvNV_nomg(svl) - value );
2072 #define IV_BITS (IVSIZE * 8)
2074 static UV S_uv_shift(UV uv, int shift, bool left)
2080 if (shift >= IV_BITS) {
2083 return left ? uv << shift : uv >> shift;
2086 static IV S_iv_shift(IV iv, int shift, bool left)
2092 if (shift >= IV_BITS) {
2093 return iv < 0 && !left ? -1 : 0;
2095 return left ? iv << shift : iv >> shift;
2098 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2099 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2100 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2101 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2105 dSP; dATARGET; SV *svl, *svr;
2106 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2110 const IV shift = SvIV_nomg(svr);
2111 if (PL_op->op_private & HINT_INTEGER) {
2112 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2115 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2123 dSP; dATARGET; SV *svl, *svr;
2124 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2128 const IV shift = SvIV_nomg(svr);
2129 if (PL_op->op_private & HINT_INTEGER) {
2130 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2133 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2144 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2148 (SvIOK_notUV(left) && SvIOK_notUV(right))
2149 ? (SvIVX(left) < SvIVX(right))
2150 : (do_ncmp(left, right) == -1)
2160 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2164 (SvIOK_notUV(left) && SvIOK_notUV(right))
2165 ? (SvIVX(left) > SvIVX(right))
2166 : (do_ncmp(left, right) == 1)
2176 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2180 (SvIOK_notUV(left) && SvIOK_notUV(right))
2181 ? (SvIVX(left) <= SvIVX(right))
2182 : (do_ncmp(left, right) <= 0)
2192 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2196 (SvIOK_notUV(left) && SvIOK_notUV(right))
2197 ? (SvIVX(left) >= SvIVX(right))
2198 : ( (do_ncmp(left, right) & 2) == 0)
2208 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2212 (SvIOK_notUV(left) && SvIOK_notUV(right))
2213 ? (SvIVX(left) != SvIVX(right))
2214 : (do_ncmp(left, right) != 0)
2219 /* compare left and right SVs. Returns:
2223 * 2: left or right was a NaN
2226 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2228 PERL_ARGS_ASSERT_DO_NCMP;
2229 #ifdef PERL_PRESERVE_IVUV
2230 /* Fortunately it seems NaN isn't IOK */
2231 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2233 const IV leftiv = SvIVX(left);
2234 if (!SvUOK(right)) {
2235 /* ## IV <=> IV ## */
2236 const IV rightiv = SvIVX(right);
2237 return (leftiv > rightiv) - (leftiv < rightiv);
2239 /* ## IV <=> UV ## */
2241 /* As (b) is a UV, it's >=0, so it must be < */
2244 const UV rightuv = SvUVX(right);
2245 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2250 /* ## UV <=> UV ## */
2251 const UV leftuv = SvUVX(left);
2252 const UV rightuv = SvUVX(right);
2253 return (leftuv > rightuv) - (leftuv < rightuv);
2255 /* ## UV <=> IV ## */
2257 const IV rightiv = SvIVX(right);
2259 /* As (a) is a UV, it's >=0, so it cannot be < */
2262 const UV leftuv = SvUVX(left);
2263 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2266 NOT_REACHED; /* NOTREACHED */
2270 NV const rnv = SvNV_nomg(right);
2271 NV const lnv = SvNV_nomg(left);
2273 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2274 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2277 return (lnv > rnv) - (lnv < rnv);
2296 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2299 value = do_ncmp(left, right);
2311 /* also used for: pp_sge() pp_sgt() pp_slt() */
2317 int amg_type = sle_amg;
2321 switch (PL_op->op_type) {
2340 tryAMAGICbin_MG(amg_type, AMGf_set);
2344 #ifdef USE_LOCALE_COLLATE
2345 (IN_LC_RUNTIME(LC_COLLATE))
2346 ? sv_cmp_locale_flags(left, right, 0)
2349 sv_cmp_flags(left, right, 0);
2350 SETs(boolSV(cmp * multiplier < rhs));
2358 tryAMAGICbin_MG(seq_amg, AMGf_set);
2361 SETs(boolSV(sv_eq_flags(left, right, 0)));
2369 tryAMAGICbin_MG(sne_amg, AMGf_set);
2372 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2380 tryAMAGICbin_MG(scmp_amg, 0);
2384 #ifdef USE_LOCALE_COLLATE
2385 (IN_LC_RUNTIME(LC_COLLATE))
2386 ? sv_cmp_locale_flags(left, right, 0)
2389 sv_cmp_flags(left, right, 0);
2398 tryAMAGICbin_MG(band_amg, AMGf_assign);
2401 if (SvNIOKp(left) || SvNIOKp(right)) {
2402 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2403 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2404 if (PL_op->op_private & HINT_INTEGER) {
2405 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2409 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2412 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2413 if (right_ro_nonnum) SvNIOK_off(right);
2416 do_vop(PL_op->op_type, TARG, left, right);
2426 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2428 dATARGET; dPOPTOPssrl;
2429 if (PL_op->op_private & HINT_INTEGER) {
2430 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2434 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2444 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2446 dATARGET; dPOPTOPssrl;
2447 do_vop(OP_BIT_AND, TARG, left, right);
2452 /* also used for: pp_bit_xor() */
2457 const int op_type = PL_op->op_type;
2459 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2462 if (SvNIOKp(left) || SvNIOKp(right)) {
2463 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2464 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2465 if (PL_op->op_private & HINT_INTEGER) {
2466 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2467 const IV r = SvIV_nomg(right);
2468 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2472 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2473 const UV r = SvUV_nomg(right);
2474 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2477 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2478 if (right_ro_nonnum) SvNIOK_off(right);
2481 do_vop(op_type, TARG, left, right);
2488 /* also used for: pp_nbit_xor() */
2493 const int op_type = PL_op->op_type;
2495 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2496 AMGf_assign|AMGf_numarg);
2498 dATARGET; dPOPTOPssrl;
2499 if (PL_op->op_private & HINT_INTEGER) {
2500 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2501 const IV r = SvIV_nomg(right);
2502 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2506 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2507 const UV r = SvUV_nomg(right);
2508 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2515 /* also used for: pp_sbit_xor() */
2520 const int op_type = PL_op->op_type;
2522 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2525 dATARGET; dPOPTOPssrl;
2526 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2532 PERL_STATIC_INLINE bool
2533 S_negate_string(pTHX)
2538 SV * const sv = TOPs;
2539 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2541 s = SvPV_nomg_const(sv, len);
2542 if (isIDFIRST(*s)) {
2543 sv_setpvs(TARG, "-");
2546 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2547 sv_setsv_nomg(TARG, sv);
2548 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2558 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2559 if (S_negate_string(aTHX)) return NORMAL;
2561 SV * const sv = TOPs;
2564 /* It's publicly an integer */
2567 if (SvIVX(sv) == IV_MIN) {
2568 /* 2s complement assumption. */
2569 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2573 else if (SvUVX(sv) <= IV_MAX) {
2578 else if (SvIVX(sv) != IV_MIN) {
2582 #ifdef PERL_PRESERVE_IVUV
2589 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2590 SETn(-SvNV_nomg(sv));
2591 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2592 goto oops_its_an_int;
2594 SETn(-SvNV_nomg(sv));
2602 tryAMAGICun_MG(not_amg, AMGf_set);
2603 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2608 S_scomplement(pTHX_ SV *targ, SV *sv)
2614 sv_copypv_nomg(TARG, sv);
2615 tmps = (U8*)SvPV_nomg(TARG, len);
2618 /* Calculate exact length, let's not estimate. */
2623 U8 * const send = tmps + len;
2624 U8 * const origtmps = tmps;
2625 const UV utf8flags = UTF8_ALLOW_ANYUV;
2627 while (tmps < send) {
2628 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2630 targlen += UVCHR_SKIP(~c);
2636 /* Now rewind strings and write them. */
2643 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2644 deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
2645 Newx(result, targlen + 1, U8);
2647 while (tmps < send) {
2648 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2650 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2653 sv_usepvn_flags(TARG, (char*)result, targlen,
2654 SV_HAS_TRAILING_NUL);
2661 Newx(result, nchar + 1, U8);
2663 while (tmps < send) {
2664 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2669 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2677 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2680 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2685 for ( ; anum > 0; anum--, tmps++)
2692 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2696 if (PL_op->op_private & HINT_INTEGER) {
2697 const IV i = ~SvIV_nomg(sv);
2701 const UV u = ~SvUV_nomg(sv);
2706 S_scomplement(aTHX_ TARG, sv);
2716 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2719 if (PL_op->op_private & HINT_INTEGER) {
2720 const IV i = ~SvIV_nomg(sv);
2724 const UV u = ~SvUV_nomg(sv);
2734 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2737 S_scomplement(aTHX_ TARG, sv);
2743 /* integer versions of some of the above */
2748 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2751 SETi( left * right );
2760 tryAMAGICbin_MG(div_amg, AMGf_assign);
2763 IV value = SvIV_nomg(right);
2765 DIE(aTHX_ "Illegal division by zero");
2766 num = SvIV_nomg(left);
2768 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2772 value = num / value;
2778 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2779 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2786 /* This is the vanilla old i_modulo. */
2788 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2792 DIE(aTHX_ "Illegal modulus zero");
2793 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2797 SETi( left % right );
2802 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2803 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2808 /* This is the i_modulo with the workaround for the _moddi3 bug
2809 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2810 * See below for pp_i_modulo. */
2812 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2816 DIE(aTHX_ "Illegal modulus zero");
2817 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2821 SETi( left % PERL_ABS(right) );
2828 dVAR; dSP; dATARGET;
2829 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2833 DIE(aTHX_ "Illegal modulus zero");
2834 /* The assumption is to use hereafter the old vanilla version... */
2836 PL_ppaddr[OP_I_MODULO] =
2838 /* .. but if we have glibc, we might have a buggy _moddi3
2839 * (at least glibc 2.2.5 is known to have this bug), in other
2840 * words our integer modulus with negative quad as the second
2841 * argument might be broken. Test for this and re-patch the
2842 * opcode dispatch table if that is the case, remembering to
2843 * also apply the workaround so that this first round works
2844 * right, too. See [perl #9402] for more information. */
2848 /* Cannot do this check with inlined IV constants since
2849 * that seems to work correctly even with the buggy glibc. */
2851 /* Yikes, we have the bug.
2852 * Patch in the workaround version. */
2854 PL_ppaddr[OP_I_MODULO] =
2855 &Perl_pp_i_modulo_1;
2856 /* Make certain we work right this time, too. */
2857 right = PERL_ABS(right);
2860 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2864 SETi( left % right );
2873 tryAMAGICbin_MG(add_amg, AMGf_assign);
2875 dPOPTOPiirl_ul_nomg;
2876 SETi( left + right );
2884 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2886 dPOPTOPiirl_ul_nomg;
2887 SETi( left - right );
2895 tryAMAGICbin_MG(lt_amg, AMGf_set);
2898 SETs(boolSV(left < right));
2906 tryAMAGICbin_MG(gt_amg, AMGf_set);
2909 SETs(boolSV(left > right));
2917 tryAMAGICbin_MG(le_amg, AMGf_set);
2920 SETs(boolSV(left <= right));
2928 tryAMAGICbin_MG(ge_amg, AMGf_set);
2931 SETs(boolSV(left >= right));
2939 tryAMAGICbin_MG(eq_amg, AMGf_set);
2942 SETs(boolSV(left == right));
2950 tryAMAGICbin_MG(ne_amg, AMGf_set);
2953 SETs(boolSV(left != right));
2961 tryAMAGICbin_MG(ncmp_amg, 0);
2968 else if (left < right)
2980 tryAMAGICun_MG(neg_amg, 0);
2981 if (S_negate_string(aTHX)) return NORMAL;
2983 SV * const sv = TOPs;
2984 IV const i = SvIV_nomg(sv);
2990 /* High falutin' math. */
2995 tryAMAGICbin_MG(atan2_amg, 0);
2998 SETn(Perl_atan2(left, right));
3004 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
3009 int amg_type = fallback_amg;
3010 const char *neg_report = NULL;
3011 const int op_type = PL_op->op_type;
3014 case OP_SIN: amg_type = sin_amg; break;
3015 case OP_COS: amg_type = cos_amg; break;
3016 case OP_EXP: amg_type = exp_amg; break;
3017 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
3018 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
3021 assert(amg_type != fallback_amg);
3023 tryAMAGICun_MG(amg_type, 0);
3025 SV * const arg = TOPs;
3026 const NV value = SvNV_nomg(arg);
3028 if (neg_report) { /* log or sqrt */
3030 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3031 ! Perl_isnan(value) &&
3033 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
3034 SET_NUMERIC_STANDARD();
3035 /* diag_listed_as: Can't take log of %g */
3036 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3041 case OP_SIN: result = Perl_sin(value); break;
3042 case OP_COS: result = Perl_cos(value); break;
3043 case OP_EXP: result = Perl_exp(value); break;
3044 case OP_LOG: result = Perl_log(value); break;
3045 case OP_SQRT: result = Perl_sqrt(value); break;
3052 /* Support Configure command-line overrides for rand() functions.
3053 After 5.005, perhaps we should replace this by Configure support
3054 for drand48(), random(), or rand(). For 5.005, though, maintain
3055 compatibility by calling rand() but allow the user to override it.
3056 See INSTALL for details. --Andy Dougherty 15 July 1998
3058 /* Now it's after 5.005, and Configure supports drand48() and random(),
3059 in addition to rand(). So the overrides should not be needed any more.
3060 --Jarkko Hietaniemi 27 September 1998
3065 if (!PL_srand_called) {
3066 (void)seedDrand01((Rand_seed_t)seed());
3067 PL_srand_called = TRUE;
3079 SV * const sv = POPs;
3085 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3086 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3087 if (! Perl_isnan(value) && value == 0.0)
3097 sv_setnv_mg(TARG, value);
3108 if (MAXARG >= 1 && (TOPs || POPs)) {
3115 pv = SvPV(top, len);
3116 flags = grok_number(pv, len, &anum);
3118 if (!(flags & IS_NUMBER_IN_UV)) {
3119 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3120 "Integer overflow in srand");
3128 (void)seedDrand01((Rand_seed_t)anum);
3129 PL_srand_called = TRUE;
3133 /* Historically srand always returned true. We can avoid breaking
3135 sv_setpvs(TARG, "0 but true");
3144 tryAMAGICun_MG(int_amg, AMGf_numeric);
3146 SV * const sv = TOPs;
3147 const IV iv = SvIV_nomg(sv);
3148 /* XXX it's arguable that compiler casting to IV might be subtly
3149 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3150 else preferring IV has introduced a subtle behaviour change bug. OTOH
3151 relying on floating point to be accurate is a bug. */
3156 else if (SvIOK(sv)) {
3158 SETu(SvUV_nomg(sv));
3163 const NV value = SvNV_nomg(sv);
3164 if (UNLIKELY(Perl_isinfnan(value)))
3166 else if (value >= 0.0) {
3167 if (value < (NV)UV_MAX + 0.5) {
3170 SETn(Perl_floor(value));
3174 if (value > (NV)IV_MIN - 0.5) {
3177 SETn(Perl_ceil(value));
3188 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3190 SV * const sv = TOPs;
3191 /* This will cache the NV value if string isn't actually integer */
3192 const IV iv = SvIV_nomg(sv);
3197 else if (SvIOK(sv)) {
3198 /* IVX is precise */
3200 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3208 /* 2s complement assumption. Also, not really needed as
3209 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3215 const NV value = SvNV_nomg(sv);
3226 /* also used for: pp_hex() */
3232 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3236 SV* const sv = TOPs;
3238 tmps = (SvPV_const(sv, len));
3240 /* If Unicode, try to downgrade
3241 * If not possible, croak. */
3242 SV* const tsv = sv_2mortal(newSVsv(sv));
3245 sv_utf8_downgrade(tsv, FALSE);
3246 tmps = SvPV_const(tsv, len);
3248 if (PL_op->op_type == OP_HEX)
3251 while (*tmps && len && isSPACE(*tmps))
3255 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3257 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3259 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3260 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3262 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3264 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3278 SV * const sv = TOPs;
3280 U32 in_bytes = IN_BYTES;
3281 /* simplest case shortcut */
3282 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3283 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3284 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3287 if(LIKELY(svflags == SVf_POK))
3289 if(svflags & SVs_GMG)
3292 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3293 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3297 /* unrolled SvPV_nomg_const(sv,len) */
3302 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3304 sv_setiv(TARG, (IV)(len));
3307 if (!SvPADTMP(TARG)) {
3308 sv_setsv_nomg(TARG, &PL_sv_undef);
3309 } else { /* TARG is on stack at this point and is overwriten by SETs.
3310 This branch is the odd one out, so put TARG by default on
3311 stack earlier to let local SP go out of liveness sooner */
3318 return NORMAL; /* no putback, SP didn't move in this opcode */
3321 /* Returns false if substring is completely outside original string.
3322 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3323 always be true for an explicit 0.
3326 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3327 bool pos1_is_uv, IV len_iv,
3328 bool len_is_uv, STRLEN *posp,
3334 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3336 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3337 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3340 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3343 if (len_iv || len_is_uv) {
3344 if (!len_is_uv && len_iv < 0) {
3345 pos2_iv = curlen + len_iv;
3347 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3350 } else { /* len_iv >= 0 */
3351 if (!pos1_is_uv && pos1_iv < 0) {
3352 pos2_iv = pos1_iv + len_iv;
3353 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3355 if ((UV)len_iv > curlen-(UV)pos1_iv)
3358 pos2_iv = pos1_iv+len_iv;
3368 if (!pos2_is_uv && pos2_iv < 0) {
3369 if (!pos1_is_uv && pos1_iv < 0)
3373 else if (!pos1_is_uv && pos1_iv < 0)
3376 if ((UV)pos2_iv < (UV)pos1_iv)
3378 if ((UV)pos2_iv > curlen)
3381 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3382 *posp = (STRLEN)( (UV)pos1_iv );
3383 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3400 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3401 const bool rvalue = (GIMME_V != G_VOID);
3404 const char *repl = NULL;
3406 int num_args = PL_op->op_private & 7;
3407 bool repl_need_utf8_upgrade = FALSE;
3411 if(!(repl_sv = POPs)) num_args--;
3413 if ((len_sv = POPs)) {
3414 len_iv = SvIV(len_sv);
3415 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3420 pos1_iv = SvIV(pos_sv);
3421 pos1_is_uv = SvIOK_UV(pos_sv);
3423 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3427 if (lvalue && !repl_sv) {
3429 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3430 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3432 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3434 pos1_is_uv || pos1_iv >= 0
3435 ? (STRLEN)(UV)pos1_iv
3436 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3438 len_is_uv || len_iv > 0
3439 ? (STRLEN)(UV)len_iv
3440 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3442 PUSHs(ret); /* avoid SvSETMAGIC here */
3446 repl = SvPV_const(repl_sv, repl_len);
3449 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3450 "Attempt to use reference as lvalue in substr"
3452 tmps = SvPV_force_nomg(sv, curlen);
3453 if (DO_UTF8(repl_sv) && repl_len) {
3455 sv_utf8_upgrade_nomg(sv);
3459 else if (DO_UTF8(sv))
3460 repl_need_utf8_upgrade = TRUE;
3462 else tmps = SvPV_const(sv, curlen);
3464 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3465 if (utf8_curlen == curlen)
3468 curlen = utf8_curlen;
3474 STRLEN pos, len, byte_len, byte_pos;
3476 if (!translate_substr_offsets(
3477 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3481 byte_pos = utf8_curlen
3482 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3487 SvTAINTED_off(TARG); /* decontaminate */
3488 SvUTF8_off(TARG); /* decontaminate */
3489 sv_setpvn(TARG, tmps, byte_len);
3490 #ifdef USE_LOCALE_COLLATE
3491 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3498 SV* repl_sv_copy = NULL;
3500 if (repl_need_utf8_upgrade) {
3501 repl_sv_copy = newSVsv(repl_sv);
3502 sv_utf8_upgrade(repl_sv_copy);
3503 repl = SvPV_const(repl_sv_copy, repl_len);
3507 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3508 SvREFCNT_dec(repl_sv_copy);
3511 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3521 Perl_croak(aTHX_ "substr outside of string");
3522 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3529 const IV size = POPi;
3530 const IV offset = POPi;
3531 SV * const src = POPs;
3532 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3535 if (lvalue) { /* it's an lvalue! */
3536 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3537 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3539 LvTARG(ret) = SvREFCNT_inc_simple(src);
3540 LvTARGOFF(ret) = offset;
3541 LvTARGLEN(ret) = size;
3545 SvTAINTED_off(TARG); /* decontaminate */
3549 sv_setuv(ret, do_vecget(src, offset, size));
3557 /* also used for: pp_rindex() */
3570 const char *little_p;
3573 const bool is_index = PL_op->op_type == OP_INDEX;
3574 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3580 big_p = SvPV_const(big, biglen);
3581 little_p = SvPV_const(little, llen);
3583 big_utf8 = DO_UTF8(big);
3584 little_utf8 = DO_UTF8(little);
3585 if (big_utf8 ^ little_utf8) {
3586 /* One needs to be upgraded. */
3587 if (little_utf8 && !IN_ENCODING) {
3588 /* Well, maybe instead we might be able to downgrade the small
3590 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3593 /* If the large string is ISO-8859-1, and it's not possible to
3594 convert the small string to ISO-8859-1, then there is no
3595 way that it could be found anywhere by index. */
3600 /* At this point, pv is a malloc()ed string. So donate it to temp
3601 to ensure it will get free()d */
3602 little = temp = newSV(0);
3603 sv_usepvn(temp, pv, llen);
3604 little_p = SvPVX(little);
3607 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3610 sv_recode_to_utf8(temp, _get_encoding());
3612 sv_utf8_upgrade(temp);
3617 big_p = SvPV_const(big, biglen);
3620 little_p = SvPV_const(little, llen);
3624 if (SvGAMAGIC(big)) {
3625 /* Life just becomes a lot easier if I use a temporary here.
3626 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3627 will trigger magic and overloading again, as will fbm_instr()
3629 big = newSVpvn_flags(big_p, biglen,
3630 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3633 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3634 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3635 warn on undef, and we've already triggered a warning with the
3636 SvPV_const some lines above. We can't remove that, as we need to
3637 call some SvPV to trigger overloading early and find out if the
3639 This is all getting too messy. The API isn't quite clean enough,
3640 because data access has side effects.
3642 little = newSVpvn_flags(little_p, llen,
3643 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3644 little_p = SvPVX(little);
3648 offset = is_index ? 0 : biglen;
3650 if (big_utf8 && offset > 0)
3651 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3657 else if (offset > (SSize_t)biglen)
3659 if (!(little_p = is_index
3660 ? fbm_instr((unsigned char*)big_p + offset,
3661 (unsigned char*)big_p + biglen, little, 0)
3662 : rninstr(big_p, big_p + offset,
3663 little_p, little_p + llen)))
3666 retval = little_p - big_p;
3667 if (retval > 1 && big_utf8)
3668 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3678 dSP; dMARK; dORIGMARK; dTARGET;
3679 SvTAINTED_off(TARG);
3680 do_sprintf(TARG, SP-MARK, MARK+1);
3681 TAINT_IF(SvTAINTED(TARG));
3693 const U8 *s = (U8*)SvPV_const(argsv, len);
3695 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
3696 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3697 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
3698 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
3703 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3717 if (UNLIKELY(SvAMAGIC(top)))
3719 if (UNLIKELY(isinfnansv(top)))
3720 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3722 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3723 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3725 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3726 && SvNV_nomg(top) < 0.0)))
3728 if (ckWARN(WARN_UTF8)) {
3729 if (SvGMAGICAL(top)) {
3730 SV *top2 = sv_newmortal();
3731 sv_setsv_nomg(top2, top);
3734 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3735 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3737 value = UNICODE_REPLACEMENT;
3739 value = SvUV_nomg(top);
3743 SvUPGRADE(TARG,SVt_PV);
3745 if (value > 255 && !IN_BYTES) {
3746 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3747 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3748 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3750 (void)SvPOK_only(TARG);
3759 *tmps++ = (char)value;
3761 (void)SvPOK_only(TARG);
3763 if (IN_ENCODING && !IN_BYTES) {
3764 sv_recode_to_utf8(TARG, _get_encoding());
3766 if (SvCUR(TARG) == 0
3767 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3768 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3773 *tmps++ = (char)value;
3789 const char *tmps = SvPV_const(left, len);
3791 if (DO_UTF8(left)) {
3792 /* If Unicode, try to downgrade.
3793 * If not possible, croak.
3794 * Yes, we made this up. */
3795 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3797 sv_utf8_downgrade(tsv, FALSE);
3798 tmps = SvPV_const(tsv, len);
3800 # ifdef USE_ITHREADS
3802 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3803 /* This should be threadsafe because in ithreads there is only
3804 * one thread per interpreter. If this would not be true,
3805 * we would need a mutex to protect this malloc. */
3806 PL_reentrant_buffer->_crypt_struct_buffer =
3807 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3808 #if defined(__GLIBC__) || defined(__EMX__)
3809 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3810 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3811 /* work around glibc-2.2.5 bug */
3812 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3816 # endif /* HAS_CRYPT_R */
3817 # endif /* USE_ITHREADS */
3819 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3821 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3828 "The crypt() function is unimplemented due to excessive paranoia.");
3832 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3833 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3836 /* also used for: pp_lcfirst() */
3840 /* Actually is both lcfirst() and ucfirst(). Only the first character
3841 * changes. This means that possibly we can change in-place, ie., just
3842 * take the source and change that one character and store it back, but not
3843 * if read-only etc, or if the length changes */
3847 STRLEN slen; /* slen is the byte length of the whole SV. */
3850 bool inplace; /* ? Convert first char only, in-place */
3851 bool doing_utf8 = FALSE; /* ? using utf8 */
3852 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3853 const int op_type = PL_op->op_type;
3856 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3857 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3858 * stored as UTF-8 at s. */
3859 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3860 * lowercased) character stored in tmpbuf. May be either
3861 * UTF-8 or not, but in either case is the number of bytes */
3863 s = (const U8*)SvPV_const(source, slen);
3865 /* We may be able to get away with changing only the first character, in
3866 * place, but not if read-only, etc. Later we may discover more reasons to
3867 * not convert in-place. */
3868 inplace = !SvREADONLY(source)
3869 && ( SvPADTMP(source)
3870 || ( SvTEMP(source) && !SvSMAGICAL(source)
3871 && SvREFCNT(source) == 1));
3873 /* First calculate what the changed first character should be. This affects
3874 * whether we can just swap it out, leaving the rest of the string unchanged,
3875 * or even if have to convert the dest to UTF-8 when the source isn't */
3877 if (! slen) { /* If empty */
3878 need = 1; /* still need a trailing NUL */
3881 else if (DO_UTF8(source)) { /* Is the source utf8? */
3884 if (op_type == OP_UCFIRST) {
3885 #ifdef USE_LOCALE_CTYPE
3886 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3888 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3892 #ifdef USE_LOCALE_CTYPE
3893 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3895 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3899 /* we can't do in-place if the length changes. */
3900 if (ulen != tculen) inplace = FALSE;
3901 need = slen + 1 - ulen + tculen;
3903 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3904 * latin1 is treated as caseless. Note that a locale takes
3906 ulen = 1; /* Original character is 1 byte */
3907 tculen = 1; /* Most characters will require one byte, but this will
3908 * need to be overridden for the tricky ones */
3911 if (op_type == OP_LCFIRST) {
3913 /* lower case the first letter: no trickiness for any character */
3914 #ifdef USE_LOCALE_CTYPE
3915 if (IN_LC_RUNTIME(LC_CTYPE)) {
3916 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3917 *tmpbuf = toLOWER_LC(*s);
3922 *tmpbuf = (IN_UNI_8_BIT)
3923 ? toLOWER_LATIN1(*s)
3927 #ifdef USE_LOCALE_CTYPE
3929 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3930 if (IN_UTF8_CTYPE_LOCALE) {
3934 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3935 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3936 locales have upper and title case
3940 else if (! IN_UNI_8_BIT) {
3941 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3942 * on EBCDIC machines whatever the
3943 * native function does */
3946 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3947 * UTF-8, which we treat as not in locale), and cased latin1 */
3949 #ifdef USE_LOCALE_CTYPE
3953 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3955 assert(tculen == 2);
3957 /* If the result is an upper Latin1-range character, it can
3958 * still be represented in one byte, which is its ordinal */
3959 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3960 *tmpbuf = (U8) title_ord;
3964 /* Otherwise it became more than one ASCII character (in
3965 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3966 * beyond Latin1, so the number of bytes changed, so can't
3967 * replace just the first character in place. */
3970 /* If the result won't fit in a byte, the entire result
3971 * will have to be in UTF-8. Assume worst case sizing in
3972 * conversion. (all latin1 characters occupy at most two
3974 if (title_ord > 255) {
3976 convert_source_to_utf8 = TRUE;
3977 need = slen * 2 + 1;
3979 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3980 * (both) characters whose title case is above 255 is
3984 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3985 need = slen + 1 + 1;
3989 } /* End of use Unicode (Latin1) semantics */
3990 } /* End of changing the case of the first character */
3992 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3993 * generate the result */
3996 /* We can convert in place. This means we change just the first
3997 * character without disturbing the rest; no need to grow */
3999 s = d = (U8*)SvPV_force_nomg(source, slen);
4005 /* Here, we can't convert in place; we earlier calculated how much
4006 * space we will need, so grow to accommodate that */
4007 SvUPGRADE(dest, SVt_PV);
4008 d = (U8*)SvGROW(dest, need);
4009 (void)SvPOK_only(dest);
4016 if (! convert_source_to_utf8) {
4018 /* Here both source and dest are in UTF-8, but have to create
4019 * the entire output. We initialize the result to be the
4020 * title/lower cased first character, and then append the rest
4022 sv_setpvn(dest, (char*)tmpbuf, tculen);
4024 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4028 const U8 *const send = s + slen;
4030 /* Here the dest needs to be in UTF-8, but the source isn't,
4031 * except we earlier UTF-8'd the first character of the source
4032 * into tmpbuf. First put that into dest, and then append the
4033 * rest of the source, converting it to UTF-8 as we go. */
4035 /* Assert tculen is 2 here because the only two characters that
4036 * get to this part of the code have 2-byte UTF-8 equivalents */
4038 *d++ = *(tmpbuf + 1);
4039 s++; /* We have just processed the 1st char */
4041 for (; s < send; s++) {
4042 d = uvchr_to_utf8(d, *s);
4045 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4049 else { /* in-place UTF-8. Just overwrite the first character */
4050 Copy(tmpbuf, d, tculen, U8);
4051 SvCUR_set(dest, need - 1);
4055 else { /* Neither source nor dest are in or need to be UTF-8 */
4057 if (inplace) { /* in-place, only need to change the 1st char */
4060 else { /* Not in-place */
4062 /* Copy the case-changed character(s) from tmpbuf */
4063 Copy(tmpbuf, d, tculen, U8);
4064 d += tculen - 1; /* Code below expects d to point to final
4065 * character stored */
4068 else { /* empty source */
4069 /* See bug #39028: Don't taint if empty */
4073 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4074 * the destination to retain that flag */
4075 if (SvUTF8(source) && ! IN_BYTES)
4078 if (!inplace) { /* Finish the rest of the string, unchanged */
4079 /* This will copy the trailing NUL */
4080 Copy(s + 1, d + 1, slen, U8);
4081 SvCUR_set(dest, need - 1);
4084 #ifdef USE_LOCALE_CTYPE
4085 if (IN_LC_RUNTIME(LC_CTYPE)) {
4090 if (dest != source && SvTAINTED(source))
4096 /* There's so much setup/teardown code common between uc and lc, I wonder if
4097 it would be worth merging the two, and just having a switch outside each
4098 of the three tight loops. There is less and less commonality though */
4111 if ((SvPADTMP(source)
4113 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
4114 && !SvREADONLY(source) && SvPOK(source)
4117 #ifdef USE_LOCALE_CTYPE
4118 (IN_LC_RUNTIME(LC_CTYPE))
4119 ? ! IN_UTF8_CTYPE_LOCALE
4125 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4126 * make the loop tight, so we overwrite the source with the dest before
4127 * looking at it, and we need to look at the original source
4128 * afterwards. There would also need to be code added to handle
4129 * switching to not in-place in midstream if we run into characters
4130 * that change the length. Since being in locale overrides UNI_8_BIT,
4131 * that latter becomes irrelevant in the above test; instead for
4132 * locale, the size can't normally change, except if the locale is a
4135 s = d = (U8*)SvPV_force_nomg(source, len);
4142 s = (const U8*)SvPV_nomg_const(source, len);
4145 SvUPGRADE(dest, SVt_PV);
4146 d = (U8*)SvGROW(dest, min);
4147 (void)SvPOK_only(dest);
4152 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4153 to check DO_UTF8 again here. */
4155 if (DO_UTF8(source)) {
4156 const U8 *const send = s + len;
4157 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4159 /* All occurrences of these are to be moved to follow any other marks.
4160 * This is context-dependent. We may not be passed enough context to
4161 * move the iota subscript beyond all of them, but we do the best we can
4162 * with what we're given. The result is always better than if we
4163 * hadn't done this. And, the problem would only arise if we are
4164 * passed a character without all its combining marks, which would be
4165 * the caller's mistake. The information this is based on comes from a
4166 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4167 * itself) and so can't be checked properly to see if it ever gets
4168 * revised. But the likelihood of it changing is remote */
4169 bool in_iota_subscript = FALSE;
4175 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4177 /* A non-mark. Time to output the iota subscript */
4178 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4179 d += capital_iota_len;
4180 in_iota_subscript = FALSE;
4183 /* Then handle the current character. Get the changed case value
4184 * and copy it to the output buffer */
4187 #ifdef USE_LOCALE_CTYPE
4188 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4190 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4192 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4193 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4194 if (uv == GREEK_CAPITAL_LETTER_IOTA
4195 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4197 in_iota_subscript = TRUE;
4200 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4201 /* If the eventually required minimum size outgrows the
4202 * available space, we need to grow. */
4203 const UV o = d - (U8*)SvPVX_const(dest);
4205 /* If someone uppercases one million U+03B0s we SvGROW()
4206 * one million times. Or we could try guessing how much to
4207 * allocate without allocating too much. Such is life.
4208 * See corresponding comment in lc code for another option
4211 d = (U8*)SvPVX(dest) + o;
4213 Copy(tmpbuf, d, ulen, U8);
4218 if (in_iota_subscript) {
4219 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4220 d += capital_iota_len;
4225 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4227 else { /* Not UTF-8 */
4229 const U8 *const send = s + len;
4231 /* Use locale casing if in locale; regular style if not treating
4232 * latin1 as having case; otherwise the latin1 casing. Do the
4233 * whole thing in a tight loop, for speed, */
4234 #ifdef USE_LOCALE_CTYPE
4235 if (IN_LC_RUNTIME(LC_CTYPE)) {
4236 if (IN_UTF8_CTYPE_LOCALE) {
4239 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4240 for (; s < send; d++, s++)
4241 *d = (U8) toUPPER_LC(*s);
4245 if (! IN_UNI_8_BIT) {
4246 for (; s < send; d++, s++) {
4251 #ifdef USE_LOCALE_CTYPE
4254 for (; s < send; d++, s++) {
4255 *d = toUPPER_LATIN1_MOD(*s);
4256 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4260 /* The mainstream case is the tight loop above. To avoid
4261 * extra tests in that, all three characters that require
4262 * special handling are mapped by the MOD to the one tested
4264 * Use the source to distinguish between the three cases */
4266 #if UNICODE_MAJOR_VERSION > 2 \
4267 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4268 && UNICODE_DOT_DOT_VERSION >= 8)
4269 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4271 /* uc() of this requires 2 characters, but they are
4272 * ASCII. If not enough room, grow the string */
4273 if (SvLEN(dest) < ++min) {
4274 const UV o = d - (U8*)SvPVX_const(dest);
4276 d = (U8*)SvPVX(dest) + o;
4278 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4279 continue; /* Back to the tight loop; still in ASCII */
4283 /* The other two special handling characters have their
4284 * upper cases outside the latin1 range, hence need to be
4285 * in UTF-8, so the whole result needs to be in UTF-8. So,
4286 * here we are somewhere in the middle of processing a
4287 * non-UTF-8 string, and realize that we will have to convert
4288 * the whole thing to UTF-8. What to do? There are
4289 * several possibilities. The simplest to code is to
4290 * convert what we have so far, set a flag, and continue on
4291 * in the loop. The flag would be tested each time through
4292 * the loop, and if set, the next character would be
4293 * converted to UTF-8 and stored. But, I (khw) didn't want
4294 * to slow down the mainstream case at all for this fairly
4295 * rare case, so I didn't want to add a test that didn't
4296 * absolutely have to be there in the loop, besides the
4297 * possibility that it would get too complicated for
4298 * optimizers to deal with. Another possibility is to just
4299 * give up, convert the source to UTF-8, and restart the
4300 * function that way. Another possibility is to convert
4301 * both what has already been processed and what is yet to
4302 * come separately to UTF-8, then jump into the loop that
4303 * handles UTF-8. But the most efficient time-wise of the
4304 * ones I could think of is what follows, and turned out to
4305 * not require much extra code. */
4307 /* Convert what we have so far into UTF-8, telling the
4308 * function that we know it should be converted, and to
4309 * allow extra space for what we haven't processed yet.
4310 * Assume the worst case space requirements for converting
4311 * what we haven't processed so far: that it will require
4312 * two bytes for each remaining source character, plus the
4313 * NUL at the end. This may cause the string pointer to
4314 * move, so re-find it. */
4316 len = d - (U8*)SvPVX_const(dest);
4317 SvCUR_set(dest, len);
4318 len = sv_utf8_upgrade_flags_grow(dest,
4319 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4321 d = (U8*)SvPVX(dest) + len;
4323 /* Now process the remainder of the source, converting to
4324 * upper and UTF-8. If a resulting byte is invariant in
4325 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4326 * append it to the output. */
4327 for (; s < send; s++) {
4328 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4332 /* Here have processed the whole source; no need to continue
4333 * with the outer loop. Each character has been converted
4334 * to upper case and converted to UTF-8 */
4337 } /* End of processing all latin1-style chars */
4338 } /* End of processing all chars */
4339 } /* End of source is not empty */
4341 if (source != dest) {
4342 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4343 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4345 } /* End of isn't utf8 */
4346 #ifdef USE_LOCALE_CTYPE
4347 if (IN_LC_RUNTIME(LC_CTYPE)) {
4352 if (dest != source && SvTAINTED(source))
4370 if ( ( SvPADTMP(source)
4371 || ( SvTEMP(source) && !SvSMAGICAL(source)
4372 && SvREFCNT(source) == 1 )
4374 && !SvREADONLY(source) && SvPOK(source)
4375 && !DO_UTF8(source)) {
4377 /* We can convert in place, as lowercasing anything in the latin1 range
4378 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4380 s = d = (U8*)SvPV_force_nomg(source, len);
4387 s = (const U8*)SvPV_nomg_const(source, len);
4390 SvUPGRADE(dest, SVt_PV);
4391 d = (U8*)SvGROW(dest, min);
4392 (void)SvPOK_only(dest);
4397 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4398 to check DO_UTF8 again here. */
4400 if (DO_UTF8(source)) {
4401 const U8 *const send = s + len;
4402 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4405 const STRLEN u = UTF8SKIP(s);
4408 #ifdef USE_LOCALE_CTYPE
4409 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4411 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4414 /* Here is where we would do context-sensitive actions. See the
4415 * commit message for 86510fb15 for why there isn't any */
4417 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4419 /* If the eventually required minimum size outgrows the
4420 * available space, we need to grow. */
4421 const UV o = d - (U8*)SvPVX_const(dest);
4423 /* If someone lowercases one million U+0130s we SvGROW() one
4424 * million times. Or we could try guessing how much to
4425 * allocate without allocating too much. Such is life.
4426 * Another option would be to grow an extra byte or two more
4427 * each time we need to grow, which would cut down the million
4428 * to 500K, with little waste */
4430 d = (U8*)SvPVX(dest) + o;
4433 /* Copy the newly lowercased letter to the output buffer we're
4435 Copy(tmpbuf, d, ulen, U8);
4438 } /* End of looping through the source string */
4441 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4442 } else { /* Not utf8 */
4444 const U8 *const send = s + len;
4446 /* Use locale casing if in locale; regular style if not treating
4447 * latin1 as having case; otherwise the latin1 casing. Do the
4448 * whole thing in a tight loop, for speed, */
4449 #ifdef USE_LOCALE_CTYPE
4450 if (IN_LC_RUNTIME(LC_CTYPE)) {
4451 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4452 for (; s < send; d++, s++)
4453 *d = toLOWER_LC(*s);
4457 if (! IN_UNI_8_BIT) {
4458 for (; s < send; d++, s++) {
4463 for (; s < send; d++, s++) {
4464 *d = toLOWER_LATIN1(*s);
4468 if (source != dest) {
4470 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4473 #ifdef USE_LOCALE_CTYPE
4474 if (IN_LC_RUNTIME(LC_CTYPE)) {
4479 if (dest != source && SvTAINTED(source))
4488 SV * const sv = TOPs;
4490 const char *s = SvPV_const(sv,len);
4492 SvUTF8_off(TARG); /* decontaminate */
4495 SvUPGRADE(TARG, SVt_PV);
4496 SvGROW(TARG, (len * 2) + 1);
4500 STRLEN ulen = UTF8SKIP(s);
4501 bool to_quote = FALSE;
4503 if (UTF8_IS_INVARIANT(*s)) {
4504 if (_isQUOTEMETA(*s)) {
4508 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4510 #ifdef USE_LOCALE_CTYPE
4511 /* In locale, we quote all non-ASCII Latin1 chars.
4512 * Otherwise use the quoting rules */
4514 IN_LC_RUNTIME(LC_CTYPE)
4517 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4522 else if (is_QUOTEMETA_high(s)) {
4537 else if (IN_UNI_8_BIT) {
4539 if (_isQUOTEMETA(*s))
4545 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4546 * including everything above ASCII */
4548 if (!isWORDCHAR_A(*s))
4554 SvCUR_set(TARG, d - SvPVX_const(TARG));
4555 (void)SvPOK_only_UTF8(TARG);
4558 sv_setpvn(TARG, s, len);
4574 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4575 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4576 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4577 || UNICODE_DOT_DOT_VERSION > 0)
4578 const bool full_folding = TRUE; /* This variable is here so we can easily
4579 move to more generality later */
4581 const bool full_folding = FALSE;
4583 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4584 #ifdef USE_LOCALE_CTYPE
4585 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4589 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4590 * You are welcome(?) -Hugmeir
4598 s = (const U8*)SvPV_nomg_const(source, len);
4600 if (ckWARN(WARN_UNINITIALIZED))
4601 report_uninit(source);
4608 SvUPGRADE(dest, SVt_PV);
4609 d = (U8*)SvGROW(dest, min);
4610 (void)SvPOK_only(dest);
4615 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4617 const STRLEN u = UTF8SKIP(s);
4620 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4622 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4623 const UV o = d - (U8*)SvPVX_const(dest);
4625 d = (U8*)SvPVX(dest) + o;
4628 Copy(tmpbuf, d, ulen, U8);
4633 } /* Unflagged string */
4635 #ifdef USE_LOCALE_CTYPE
4636 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4637 if (IN_UTF8_CTYPE_LOCALE) {
4638 goto do_uni_folding;
4640 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4641 for (; s < send; d++, s++)
4642 *d = (U8) toFOLD_LC(*s);
4646 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4647 for (; s < send; d++, s++)
4651 #ifdef USE_LOCALE_CTYPE
4654 /* For ASCII and the Latin-1 range, there's only two troublesome
4655 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4656 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4657 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4658 * For the rest, the casefold is their lowercase. */
4659 for (; s < send; d++, s++) {
4660 if (*s == MICRO_SIGN) {
4661 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4662 * which is outside of the latin-1 range. There's a couple
4663 * of ways to deal with this -- khw discusses them in
4664 * pp_lc/uc, so go there :) What we do here is upgrade what
4665 * we had already casefolded, then enter an inner loop that
4666 * appends the rest of the characters as UTF-8. */
4667 len = d - (U8*)SvPVX_const(dest);
4668 SvCUR_set(dest, len);
4669 len = sv_utf8_upgrade_flags_grow(dest,
4670 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4671 /* The max expansion for latin1
4672 * chars is 1 byte becomes 2 */
4674 d = (U8*)SvPVX(dest) + len;
4676 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4679 for (; s < send; s++) {
4681 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4682 if UVCHR_IS_INVARIANT(fc) {
4684 && *s == LATIN_SMALL_LETTER_SHARP_S)
4693 Copy(tmpbuf, d, ulen, U8);
4699 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4700 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4701 * becomes "ss", which may require growing the SV. */
4702 if (SvLEN(dest) < ++min) {
4703 const UV o = d - (U8*)SvPVX_const(dest);
4705 d = (U8*)SvPVX(dest) + o;
4710 else { /* If it's not one of those two, the fold is their lower
4712 *d = toLOWER_LATIN1(*s);
4718 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4720 #ifdef USE_LOCALE_CTYPE
4721 if (IN_LC_RUNTIME(LC_CTYPE)) {
4726 if (SvTAINTED(source))
4736 dSP; dMARK; dORIGMARK;
4737 AV *const av = MUTABLE_AV(POPs);
4738 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4740 if (SvTYPE(av) == SVt_PVAV) {
4741 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4742 bool can_preserve = FALSE;
4748 can_preserve = SvCANEXISTDELETE(av);
4751 if (lval && localizing) {
4754 for (svp = MARK + 1; svp <= SP; svp++) {
4755 const SSize_t elem = SvIV(*svp);
4759 if (max > AvMAX(av))
4763 while (++MARK <= SP) {
4765 SSize_t elem = SvIV(*MARK);
4766 bool preeminent = TRUE;
4768 if (localizing && can_preserve) {
4769 /* If we can determine whether the element exist,
4770 * Try to preserve the existenceness of a tied array
4771 * element by using EXISTS and DELETE if possible.
4772 * Fallback to FETCH and STORE otherwise. */
4773 preeminent = av_exists(av, elem);
4776 svp = av_fetch(av, elem, lval);
4779 DIE(aTHX_ PL_no_aelem, elem);
4782 save_aelem(av, elem, svp);
4784 SAVEADELETE(av, elem);
4787 *MARK = svp ? *svp : &PL_sv_undef;
4790 if (GIMME_V != G_ARRAY) {
4792 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4801 AV *const av = MUTABLE_AV(POPs);
4802 I32 lval = (PL_op->op_flags & OPf_MOD);
4803 SSize_t items = SP - MARK;
4805 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4806 const I32 flags = is_lvalue_sub();
4808 if (!(flags & OPpENTERSUB_INARGS))
4809 /* diag_listed_as: Can't modify %s in %s */
4810 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4817 *(MARK+items*2-1) = *(MARK+items);
4823 while (++MARK <= SP) {
4826 svp = av_fetch(av, SvIV(*MARK), lval);
4828 if (!svp || !*svp || *svp == &PL_sv_undef) {
4829 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4831 *MARK = sv_mortalcopy(*MARK);
4833 *++MARK = svp ? *svp : &PL_sv_undef;
4835 if (GIMME_V != G_ARRAY) {
4836 MARK = SP - items*2;
4837 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4847 AV *array = MUTABLE_AV(POPs);
4848 const I32 gimme = GIMME_V;
4849 IV *iterp = Perl_av_iter_p(aTHX_ array);
4850 const IV current = (*iterp)++;
4852 if (current > av_tindex(array)) {
4854 if (gimme == G_SCALAR)
4862 if (gimme == G_ARRAY) {
4863 SV **const element = av_fetch(array, current, 0);
4864 PUSHs(element ? *element : &PL_sv_undef);
4869 /* also used for: pp_avalues()*/
4873 AV *array = MUTABLE_AV(POPs);
4874 const I32 gimme = GIMME_V;
4876 *Perl_av_iter_p(aTHX_ array) = 0;
4878 if (gimme == G_SCALAR) {
4880 PUSHi(av_tindex(array) + 1);
4882 else if (gimme == G_ARRAY) {
4883 IV n = Perl_av_len(aTHX_ array);
4888 if (PL_op->op_type == OP_AKEYS) {
4889 for (i = 0; i <= n; i++) {
4894 for (i = 0; i <= n; i++) {
4895 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4896 PUSHs(elem ? *elem : &PL_sv_undef);
4903 /* Associative arrays. */
4908 HV * hash = MUTABLE_HV(POPs);
4910 const I32 gimme = GIMME_V;
4912 entry = hv_iternext(hash);
4916 SV* const sv = hv_iterkeysv(entry);
4918 if (gimme == G_ARRAY) {
4920 val = hv_iterval(hash, entry);
4924 else if (gimme == G_SCALAR)
4931 S_do_delete_local(pTHX)
4934 const I32 gimme = GIMME_V;
4937 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4938 SV **unsliced_keysv = sliced ? NULL : sp--;
4939 SV * const osv = POPs;
4940 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4942 const bool tied = SvRMAGICAL(osv)
4943 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4944 const bool can_preserve = SvCANEXISTDELETE(osv);
4945 const U32 type = SvTYPE(osv);
4946 SV ** const end = sliced ? SP : unsliced_keysv;
4948 if (type == SVt_PVHV) { /* hash element */
4949 HV * const hv = MUTABLE_HV(osv);
4950 while (++MARK <= end) {
4951 SV * const keysv = *MARK;
4953 bool preeminent = TRUE;
4955 preeminent = hv_exists_ent(hv, keysv, 0);
4957 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4964 sv = hv_delete_ent(hv, keysv, 0, 0);
4966 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4969 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4970 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4972 *MARK = sv_mortalcopy(sv);
4978 SAVEHDELETE(hv, keysv);
4979 *MARK = &PL_sv_undef;
4983 else if (type == SVt_PVAV) { /* array element */
4984 if (PL_op->op_flags & OPf_SPECIAL) {
4985 AV * const av = MUTABLE_AV(osv);
4986 while (++MARK <= end) {
4987 SSize_t idx = SvIV(*MARK);
4989 bool preeminent = TRUE;
4991 preeminent = av_exists(av, idx);
4993 SV **svp = av_fetch(av, idx, 1);
5000 sv = av_delete(av, idx, 0);
5002 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5005 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5007 *MARK = sv_mortalcopy(sv);
5013 SAVEADELETE(av, idx);
5014 *MARK = &PL_sv_undef;
5019 DIE(aTHX_ "panic: avhv_delete no longer supported");
5022 DIE(aTHX_ "Not a HASH reference");
5024 if (gimme == G_VOID)
5026 else if (gimme == G_SCALAR) {
5031 *++MARK = &PL_sv_undef;
5035 else if (gimme != G_VOID)
5036 PUSHs(*unsliced_keysv);
5047 if (PL_op->op_private & OPpLVAL_INTRO)
5048 return do_delete_local();
5051 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5053 if (PL_op->op_private & OPpSLICE) {
5055 HV * const hv = MUTABLE_HV(POPs);
5056 const U32 hvtype = SvTYPE(hv);
5057 if (hvtype == SVt_PVHV) { /* hash element */
5058 while (++MARK <= SP) {
5059 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5060 *MARK = sv ? sv : &PL_sv_undef;
5063 else if (hvtype == SVt_PVAV) { /* array element */
5064 if (PL_op->op_flags & OPf_SPECIAL) {
5065 while (++MARK <= SP) {
5066 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5067 *MARK = sv ? sv : &PL_sv_undef;
5072 DIE(aTHX_ "Not a HASH reference");
5075 else if (gimme == G_SCALAR) {
5080 *++MARK = &PL_sv_undef;
5086 HV * const hv = MUTABLE_HV(POPs);
5088 if (SvTYPE(hv) == SVt_PVHV)
5089 sv = hv_delete_ent(hv, keysv, discard, 0);
5090 else if (SvTYPE(hv) == SVt_PVAV) {
5091 if (PL_op->op_flags & OPf_SPECIAL)
5092 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5094 DIE(aTHX_ "panic: avhv_delete no longer supported");
5097 DIE(aTHX_ "Not a HASH reference");
5112 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5114 SV * const sv = POPs;
5115 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5118 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5123 hv = MUTABLE_HV(POPs);
5124 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5125 if (hv_exists_ent(hv, tmpsv, 0))
5128 else if (SvTYPE(hv) == SVt_PVAV) {
5129 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5130 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5135 DIE(aTHX_ "Not a HASH reference");
5142 dSP; dMARK; dORIGMARK;
5143 HV * const hv = MUTABLE_HV(POPs);
5144 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5145 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5146 bool can_preserve = FALSE;
5152 if (SvCANEXISTDELETE(hv))
5153 can_preserve = TRUE;
5156 while (++MARK <= SP) {
5157 SV * const keysv = *MARK;
5160 bool preeminent = TRUE;
5162 if (localizing && can_preserve) {
5163 /* If we can determine whether the element exist,
5164 * try to preserve the existenceness of a tied hash
5165 * element by using EXISTS and DELETE if possible.
5166 * Fallback to FETCH and STORE otherwise. */
5167 preeminent = hv_exists_ent(hv, keysv, 0);
5170 he = hv_fetch_ent(hv, keysv, lval, 0);
5171 svp = he ? &HeVAL(he) : NULL;
5174 if (!svp || !*svp || *svp == &PL_sv_undef) {
5175 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5178 if (HvNAME_get(hv) && isGV(*svp))
5179 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5180 else if (preeminent)
5181 save_helem_flags(hv, keysv, svp,
5182 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5184 SAVEHDELETE(hv, keysv);
5187 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5189 if (GIMME_V != G_ARRAY) {
5191 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5200 HV * const hv = MUTABLE_HV(POPs);
5201 I32 lval = (PL_op->op_flags & OPf_MOD);
5202 SSize_t items = SP - MARK;
5204 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5205 const I32 flags = is_lvalue_sub();
5207 if (!(flags & OPpENTERSUB_INARGS))
5208 /* diag_listed_as: Can't modify %s in %s */
5209 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
5216 *(MARK+items*2-1) = *(MARK+items);
5222 while (++MARK <= SP) {
5223 SV * const keysv = *MARK;
5227 he = hv_fetch_ent(hv, keysv, lval, 0);
5228 svp = he ? &HeVAL(he) : NULL;
5231 if (!svp || !*svp || *svp == &PL_sv_undef) {
5232 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5234 *MARK = sv_mortalcopy(*MARK);
5236 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5238 if (GIMME_V != G_ARRAY) {
5239 MARK = SP - items*2;
5240 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5246 /* List operators. */
5250 I32 markidx = POPMARK;
5251 if (GIMME_V != G_ARRAY) {
5252 SV **mark = PL_stack_base + markidx;
5255 *MARK = *SP; /* unwanted list, return last item */
5257 *MARK = &PL_sv_undef;
5267 SV ** const lastrelem = PL_stack_sp;
5268 SV ** const lastlelem = PL_stack_base + POPMARK;
5269 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5270 SV ** const firstrelem = lastlelem + 1;
5271 const U8 mod = PL_op->op_flags & OPf_MOD;
5273 const I32 max = lastrelem - lastlelem;
5276 if (GIMME_V != G_ARRAY) {
5277 if (lastlelem < firstlelem) {
5278 *firstlelem = &PL_sv_undef;
5281 I32 ix = SvIV(*lastlelem);
5284 if (ix < 0 || ix >= max)
5285 *firstlelem = &PL_sv_undef;
5287 *firstlelem = firstrelem[ix];
5294 SP = firstlelem - 1;
5298 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5299 I32 ix = SvIV(*lelem);
5302 if (ix < 0 || ix >= max)
5303 *lelem = &PL_sv_undef;
5305 if (!(*lelem = firstrelem[ix]))
5306 *lelem = &PL_sv_undef;
5307 else if (mod && SvPADTMP(*lelem)) {
5308 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5319 const I32 items = SP - MARK;
5320 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5322 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5323 ? newRV_noinc(av) : av);
5329 dSP; dMARK; dORIGMARK;
5330 HV* const hv = newHV();
5331 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5332 ? newRV_noinc(MUTABLE_SV(hv))
5337 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5344 sv_setsv_nomg(val, *MARK);
5348 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5351 (void)hv_store_ent(hv,key,val,0);
5359 S_deref_plain_array(pTHX_ AV *ary)
5361 if (SvTYPE(ary) == SVt_PVAV) return ary;
5362 SvGETMAGIC((SV *)ary);
5363 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5364 Perl_die(aTHX_ "Not an ARRAY reference");
5365 else if (SvOBJECT(SvRV(ary)))
5366 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5367 return (AV *)SvRV(ary);
5370 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5371 # define DEREF_PLAIN_ARRAY(ary) \
5374 SvTYPE(aRrRay) == SVt_PVAV \
5376 : S_deref_plain_array(aTHX_ aRrRay); \
5379 # define DEREF_PLAIN_ARRAY(ary) \
5381 PL_Sv = (SV *)(ary), \
5382 SvTYPE(PL_Sv) == SVt_PVAV \
5384 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5390 dSP; dMARK; dORIGMARK;
5391 int num_args = (SP - MARK);
5392 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5401 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5404 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5405 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5412 offset = i = SvIV(*MARK);
5414 offset += AvFILLp(ary) + 1;
5416 DIE(aTHX_ PL_no_aelem, i);
5418 length = SvIVx(*MARK++);
5420 length += AvFILLp(ary) - offset + 1;
5426 length = AvMAX(ary) + 1; /* close enough to infinity */
5430 length = AvMAX(ary) + 1;
5432 if (offset > AvFILLp(ary) + 1) {
5434 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5435 offset = AvFILLp(ary) + 1;
5437 after = AvFILLp(ary) + 1 - (offset + length);
5438 if (after < 0) { /* not that much array */
5439 length += after; /* offset+length now in array */
5445 /* At this point, MARK .. SP-1 is our new LIST */
5448 diff = newlen - length;
5449 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5452 /* make new elements SVs now: avoid problems if they're from the array */
5453 for (dst = MARK, i = newlen; i; i--) {
5454 SV * const h = *dst;
5455 *dst++ = newSVsv(h);
5458 if (diff < 0) { /* shrinking the area */
5459 SV **tmparyval = NULL;
5461 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5462 Copy(MARK, tmparyval, newlen, SV*);
5465 MARK = ORIGMARK + 1;
5466 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5467 const bool real = cBOOL(AvREAL(ary));
5468 MEXTEND(MARK, length);
5470 EXTEND_MORTAL(length);
5471 for (i = 0, dst = MARK; i < length; i++) {
5472 if ((*dst = AvARRAY(ary)[i+offset])) {
5474 sv_2mortal(*dst); /* free them eventually */
5477 *dst = &PL_sv_undef;
5483 *MARK = AvARRAY(ary)[offset+length-1];
5486 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5487 SvREFCNT_dec(*dst++); /* free them now */
5490 AvFILLp(ary) += diff;
5492 /* pull up or down? */
5494 if (offset < after) { /* easier to pull up */
5495 if (offset) { /* esp. if nothing to pull */
5496 src = &AvARRAY(ary)[offset-1];
5497 dst = src - diff; /* diff is negative */
5498 for (i = offset; i > 0; i--) /* can't trust Copy */
5502 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5506 if (after) { /* anything to pull down? */
5507 src = AvARRAY(ary) + offset + length;
5508 dst = src + diff; /* diff is negative */
5509 Move(src, dst, after, SV*);
5511 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5512 /* avoid later double free */
5519 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5520 Safefree(tmparyval);
5523 else { /* no, expanding (or same) */
5524 SV** tmparyval = NULL;
5526 Newx(tmparyval, length, SV*); /* so remember deletion */
5527 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5530 if (diff > 0) { /* expanding */
5531 /* push up or down? */
5532 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5536 Move(src, dst, offset, SV*);
5538 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5540 AvFILLp(ary) += diff;
5543 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5544 av_extend(ary, AvFILLp(ary) + diff);
5545 AvFILLp(ary) += diff;
5548 dst = AvARRAY(ary) + AvFILLp(ary);
5550 for (i = after; i; i--) {
5558 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5561 MARK = ORIGMARK + 1;
5562 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5564 const bool real = cBOOL(AvREAL(ary));
5566 EXTEND_MORTAL(length);
5567 for (i = 0, dst = MARK; i < length; i++) {
5568 if ((*dst = tmparyval[i])) {
5570 sv_2mortal(*dst); /* free them eventually */
5572 else *dst = &PL_sv_undef;
5578 else if (length--) {
5579 *MARK = tmparyval[length];
5582 while (length-- > 0)
5583 SvREFCNT_dec(tmparyval[length]);
5587 *MARK = &PL_sv_undef;
5588 Safefree(tmparyval);
5592 mg_set(MUTABLE_SV(ary));
5600 dSP; dMARK; dORIGMARK; dTARGET;
5601 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5602 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5605 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5608 ENTER_with_name("call_PUSH");
5609 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5610 LEAVE_with_name("call_PUSH");
5611 /* SPAGAIN; not needed: SP is assigned to immediately below */
5614 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5615 * only need to save locally, not on the save stack */
5616 U16 old_delaymagic = PL_delaymagic;
5618 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5619 PL_delaymagic = DM_DELAY;
5620 for (++MARK; MARK <= SP; MARK++) {
5622 if (*MARK) SvGETMAGIC(*MARK);
5625 sv_setsv_nomg(sv, *MARK);
5626 av_store(ary, AvFILLp(ary)+1, sv);
5628 if (PL_delaymagic & DM_ARRAY_ISA)
5629 mg_set(MUTABLE_SV(ary));
5630 PL_delaymagic = old_delaymagic;
5633 if (OP_GIMME(PL_op, 0) != G_VOID) {
5634 PUSHi( AvFILL(ary) + 1 );
5639 /* also used for: pp_pop()*/
5643 AV * const av = PL_op->op_flags & OPf_SPECIAL
5644 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5645 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5649 (void)sv_2mortal(sv);
5656 dSP; dMARK; dORIGMARK; dTARGET;
5657 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5658 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5661 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5664 ENTER_with_name("call_UNSHIFT");
5665 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5666 LEAVE_with_name("call_UNSHIFT");
5667 /* SPAGAIN; not needed: SP is assigned to immediately below */
5670 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5671 * only need to save locally, not on the save stack */
5672 U16 old_delaymagic = PL_delaymagic;
5675 av_unshift(ary, SP - MARK);
5676 PL_delaymagic = DM_DELAY;
5678 SV * const sv = newSVsv(*++MARK);
5679 (void)av_store(ary, i++, sv);
5681 if (PL_delaymagic & DM_ARRAY_ISA)
5682 mg_set(MUTABLE_SV(ary));
5683 PL_delaymagic = old_delaymagic;
5686 if (OP_GIMME(PL_op, 0) != G_VOID) {
5687 PUSHi( AvFILL(ary) + 1 );
5696 if (GIMME_V == G_ARRAY) {
5697 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5701 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5702 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5703 av = MUTABLE_AV((*SP));
5704 /* In-place reversing only happens in void context for the array
5705 * assignment. We don't need to push anything on the stack. */
5708 if (SvMAGICAL(av)) {
5710 SV *tmp = sv_newmortal();
5711 /* For SvCANEXISTDELETE */
5714 bool can_preserve = SvCANEXISTDELETE(av);
5716 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5720 if (!av_exists(av, i)) {
5721 if (av_exists(av, j)) {
5722 SV *sv = av_delete(av, j, 0);
5723 begin = *av_fetch(av, i, TRUE);
5724 sv_setsv_mg(begin, sv);
5728 else if (!av_exists(av, j)) {
5729 SV *sv = av_delete(av, i, 0);
5730 end = *av_fetch(av, j, TRUE);
5731 sv_setsv_mg(end, sv);
5736 begin = *av_fetch(av, i, TRUE);
5737 end = *av_fetch(av, j, TRUE);
5738 sv_setsv(tmp, begin);
5739 sv_setsv_mg(begin, end);
5740 sv_setsv_mg(end, tmp);
5744 SV **begin = AvARRAY(av);
5747 SV **end = begin + AvFILLp(av);
5749 while (begin < end) {
5750 SV * const tmp = *begin;
5761 SV * const tmp = *MARK;
5765 /* safe as long as stack cannot get extended in the above */
5776 SvUTF8_off(TARG); /* decontaminate */
5778 do_join(TARG, &PL_sv_no, MARK, SP);
5780 sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5783 up = SvPV_force(TARG, len);
5785 if (DO_UTF8(TARG)) { /* first reverse each character */
5786 U8* s = (U8*)SvPVX(TARG);
5787 const U8* send = (U8*)(s + len);
5789 if (UTF8_IS_INVARIANT(*s)) {
5794 if (!utf8_to_uvchr_buf(s, send, 0))
5798 down = (char*)(s - 1);
5799 /* reverse this character */
5803 *down-- = (char)tmp;
5809 down = SvPVX(TARG) + len - 1;
5813 *down-- = (char)tmp;
5815 (void)SvPOK_only_UTF8(TARG);
5826 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5827 IV limit = POPi; /* note, negative is forever */
5828 SV * const sv = POPs;
5830 const char *s = SvPV_const(sv, len);
5831 const bool do_utf8 = DO_UTF8(sv);
5832 const char *strend = s + len;
5838 const STRLEN slen = do_utf8
5839 ? utf8_length((U8*)s, (U8*)strend)
5840 : (STRLEN)(strend - s);
5841 SSize_t maxiters = slen + 10;
5842 I32 trailing_empty = 0;
5844 const IV origlimit = limit;
5847 const I32 gimme = GIMME_V;
5849 const I32 oldsave = PL_savestack_ix;
5850 U32 make_mortal = SVs_TEMP;
5855 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5860 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5863 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5864 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5867 if (pm->op_pmreplrootu.op_pmtargetoff) {
5868 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5872 if (pm->op_pmreplrootu.op_pmtargetgv) {
5873 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5877 else if (pm->op_targ)
5878 ary = (AV *)PAD_SVl(pm->op_targ);
5884 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5887 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5889 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5896 for (i = AvFILLp(ary); i >= 0; i--)
5897 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5899 /* temporarily switch stacks */
5900 SAVESWITCHSTACK(PL_curstack, ary);
5904 base = SP - PL_stack_base;
5906 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5908 while (isSPACE_utf8(s))
5911 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5912 while (isSPACE_LC(*s))
5920 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5924 gimme_scalar = gimme == G_SCALAR && !ary;
5927 limit = maxiters + 2;
5928 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5931 /* this one uses 'm' and is a negative test */
5933 while (m < strend && ! isSPACE_utf8(m) ) {
5934 const int t = UTF8SKIP(m);
5935 /* isSPACE_utf8 returns FALSE for malform utf8 */
5942 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5944 while (m < strend && !isSPACE_LC(*m))
5947 while (m < strend && !isSPACE(*m))
5960 dstr = newSVpvn_flags(s, m-s,
5961 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5965 /* skip the whitespace found last */
5967 s = m + UTF8SKIP(m);
5971 /* this one uses 's' and is a positive test */
5973 while (s < strend && isSPACE_utf8(s) )
5976 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5978 while (s < strend && isSPACE_LC(*s))
5981 while (s < strend && isSPACE(*s))
5986 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5988 for (m = s; m < strend && *m != '\n'; m++)
6001 dstr = newSVpvn_flags(s, m-s,
6002 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6008 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6010 Pre-extend the stack, either the number of bytes or
6011 characters in the string or a limited amount, triggered by:
6013 my ($x, $y) = split //, $str;
6017 if (!gimme_scalar) {
6018 const IV items = limit - 1;
6019 /* setting it to -1 will trigger a panic in EXTEND() */
6020 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
6021 if (items >=0 && items < sslen)
6029 /* keep track of how many bytes we skip over */
6039 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6052 dstr = newSVpvn(s, 1);
6068 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6069 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6070 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6071 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6072 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6073 SV * const csv = CALLREG_INTUIT_STRING(rx);
6075 len = RX_MINLENRET(rx);
6076 if (len == 1 && !RX_UTF8(rx) && !tail) {
6077 const char c = *SvPV_nolen_const(csv);
6079 for (m = s; m < strend && *m != c; m++)
6090 dstr = newSVpvn_flags(s, m-s,
6091 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6094 /* The rx->minlen is in characters but we want to step
6095 * s ahead by bytes. */
6097 s = (char*)utf8_hop((U8*)m, len);
6099 s = m + len; /* Fake \n at the end */
6103 while (s < strend && --limit &&
6104 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6105 csv, multiline ? FBMrf_MULTILINE : 0)) )
6114 dstr = newSVpvn_flags(s, m-s,
6115 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6118 /* The rx->minlen is in characters but we want to step
6119 * s ahead by bytes. */
6121 s = (char*)utf8_hop((U8*)m, len);
6123 s = m + len; /* Fake \n at the end */
6128 maxiters += slen * RX_NPARENS(rx);
6129 while (s < strend && --limit)
6133 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6136 if (rex_return == 0)
6138 TAINT_IF(RX_MATCH_TAINTED(rx));
6139 /* we never pass the REXEC_COPY_STR flag, so it should
6140 * never get copied */
6141 assert(!RX_MATCH_COPIED(rx));
6142 m = RX_OFFS(rx)[0].start + orig;
6151 dstr = newSVpvn_flags(s, m-s,
6152 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6155 if (RX_NPARENS(rx)) {
6157 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6158 s = RX_OFFS(rx)[i].start + orig;
6159 m = RX_OFFS(rx)[i].end + orig;
6161 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6162 parens that didn't match -- they should be set to
6163 undef, not the empty string */
6171 if (m >= orig && s >= orig) {
6172 dstr = newSVpvn_flags(s, m-s,
6173 (do_utf8 ? SVf_UTF8 : 0)
6177 dstr = &PL_sv_undef; /* undef, not "" */
6183 s = RX_OFFS(rx)[0].end + orig;
6187 if (!gimme_scalar) {
6188 iters = (SP - PL_stack_base) - base;
6190 if (iters > maxiters)
6191 DIE(aTHX_ "Split loop");
6193 /* keep field after final delim? */
6194 if (s < strend || (iters && origlimit)) {
6195 if (!gimme_scalar) {
6196 const STRLEN l = strend - s;
6197 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6202 else if (!origlimit) {
6204 iters -= trailing_empty;
6206 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6207 if (TOPs && !make_mortal)
6209 *SP-- = &PL_sv_undef;
6216 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6220 if (SvSMAGICAL(ary)) {
6222 mg_set(MUTABLE_SV(ary));
6225 if (gimme == G_ARRAY) {
6227 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6234 ENTER_with_name("call_PUSH");
6235 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6236 LEAVE_with_name("call_PUSH");
6238 if (gimme == G_ARRAY) {
6240 /* EXTEND should not be needed - we just popped them */
6242 for (i=0; i < iters; i++) {
6243 SV **svp = av_fetch(ary, i, FALSE);
6244 PUSHs((svp) ? *svp : &PL_sv_undef);
6251 if (gimme == G_ARRAY)
6263 SV *const sv = PAD_SVl(PL_op->op_targ);
6265 if (SvPADSTALE(sv)) {
6268 RETURNOP(cLOGOP->op_other);
6270 RETURNOP(cLOGOP->op_next);
6279 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6280 || SvTYPE(retsv) == SVt_PVCV) {
6281 retsv = refto(retsv);
6288 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
6289 * that aren't implemented on a particular platform */
6291 PP(unimplemented_op)
6293 const Optype op_type = PL_op->op_type;
6294 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6295 with out of range op numbers - it only "special" cases op_custom.
6296 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6297 if we get here for a custom op then that means that the custom op didn't
6298 have an implementation. Given that OP_NAME() looks up the custom op
6299 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6300 registers &PL_unimplemented_op as the address of their custom op.
6301 NULL doesn't generate a useful error message. "custom" does. */
6302 const char *const name = op_type >= OP_max
6303 ? "[out of range]" : PL_op_name[PL_op->op_type];
6304 if(OP_IS_SOCKET(op_type))
6305 DIE(aTHX_ PL_no_sock_func, name);
6306 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6309 /* For sorting out arguments passed to a &CORE:: subroutine */
6313 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6314 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6315 AV * const at_ = GvAV(PL_defgv);
6316 SV **svp = at_ ? AvARRAY(at_) : NULL;
6317 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6318 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6319 bool seen_question = 0;
6320 const char *err = NULL;
6321 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6323 /* Count how many args there are first, to get some idea how far to
6324 extend the stack. */
6326 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6328 if (oa & OA_OPTIONAL) seen_question = 1;
6329 if (!seen_question) minargs++;
6333 if(numargs < minargs) err = "Not enough";
6334 else if(numargs > maxargs) err = "Too many";
6336 /* diag_listed_as: Too many arguments for %s */
6338 "%s arguments for %s", err,
6339 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6342 /* Reset the stack pointer. Without this, we end up returning our own
6343 arguments in list context, in addition to the values we are supposed
6344 to return. nextstate usually does this on sub entry, but we need
6345 to run the next op with the caller's hints, so we cannot have a
6347 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6349 if(!maxargs) RETURN;
6351 /* We do this here, rather than with a separate pushmark op, as it has
6352 to come in between two things this function does (stack reset and
6353 arg pushing). This seems the easiest way to do it. */
6356 (void)Perl_pp_pushmark(aTHX);
6359 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6360 PUTBACK; /* The code below can die in various places. */
6362 oa = PL_opargs[opnum] >> OASHIFT;
6363 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6368 if (!numargs && defgv && whicharg == minargs + 1) {
6371 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6375 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6380 if (!svp || !*svp || !SvROK(*svp)
6381 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6383 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6384 "Type of arg %d to &CORE::%s must be hash reference",
6385 whicharg, OP_DESC(PL_op->op_next)
6390 if (!numargs) PUSHs(NULL);
6391 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6392 /* no magic here, as the prototype will have added an extra
6393 refgen and we just want what was there before that */
6396 const bool constr = PL_op->op_private & whicharg;
6398 svp && *svp ? *svp : &PL_sv_undef,
6399 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6405 if (!numargs) goto try_defsv;
6407 const bool wantscalar =
6408 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6409 if (!svp || !*svp || !SvROK(*svp)
6410 /* We have to permit globrefs even for the \$ proto, as
6411 *foo is indistinguishable from ${\*foo}, and the proto-
6412 type permits the latter. */
6413 || SvTYPE(SvRV(*svp)) > (
6414 wantscalar ? SVt_PVLV
6415 : opnum == OP_LOCK || opnum == OP_UNDEF
6421 "Type of arg %d to &CORE::%s must be %s",
6422 whicharg, PL_op_name[opnum],
6424 ? "scalar reference"
6425 : opnum == OP_LOCK || opnum == OP_UNDEF
6426 ? "reference to one of [$@%&*]"
6427 : "reference to one of [$@%*]"
6430 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6431 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6432 /* Undo @_ localisation, so that sub exit does not undo
6433 part of our undeffing. */
6434 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6436 cx->cx_type &= ~ CXp_HASARGS;
6437 assert(!AvREAL(cx->blk_sub.argarray));
6442 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6454 if (PL_op->op_private & OPpOFFBYONE) {
6455 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6457 else cv = find_runcv(NULL);
6458 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6463 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6464 const bool can_preserve)
6466 const SSize_t ix = SvIV(keysv);
6467 if (can_preserve ? av_exists(av, ix) : TRUE) {
6468 SV ** const svp = av_fetch(av, ix, 1);
6470 Perl_croak(aTHX_ PL_no_aelem, ix);
6471 save_aelem(av, ix, svp);
6474 SAVEADELETE(av, ix);
6478 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6479 const bool can_preserve)
6481 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6482 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6483 SV ** const svp = he ? &HeVAL(he) : NULL;
6485 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6486 save_helem_flags(hv, keysv, svp, 0);
6489 SAVEHDELETE(hv, keysv);
6493 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6495 if (type == OPpLVREF_SV) {
6496 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6499 else if (type == OPpLVREF_AV)
6500 /* XXX Inefficient, as it creates a new AV, which we are
6501 about to clobber. */
6504 assert(type == OPpLVREF_HV);
6505 /* XXX Likewise inefficient. */
6514 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6515 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6517 const char *bad = NULL;
6518 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6519 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6522 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6526 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6530 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6534 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6538 /* diag_listed_as: Assigned value is not %s reference */
6539 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6543 switch (left ? SvTYPE(left) : 0) {
6546 SV * const old = PAD_SV(ARGTARG);
6547 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6549 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6551 SAVECLEARSV(PAD_SVl(ARGTARG));
6555 if (PL_op->op_private & OPpLVAL_INTRO) {
6556 S_localise_gv_slot(aTHX_ (GV *)left, type);
6558 gv_setref(left, sv);
6563 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6564 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6565 SvCANEXISTDELETE(left));
6567 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6570 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6572 S_localise_helem_lval(aTHX_ (HV *)left, key,
6573 SvCANEXISTDELETE(left));
6575 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6577 if (PL_op->op_flags & OPf_MOD)
6578 SETs(sv_2mortal(newSVsv(sv)));
6579 /* XXX else can weak references go stale before they are read, e.g.,
6588 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6589 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6590 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6591 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6592 &PL_vtbl_lvref, (char *)elem,
6593 elem ? HEf_SVKEY : (I32)ARGTARG);
6594 mg->mg_private = PL_op->op_private;
6595 if (PL_op->op_private & OPpLVREF_ITER)
6596 mg->mg_flags |= MGf_PERSIST;
6597 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6603 const bool can_preserve = SvCANEXISTDELETE(arg);
6604 if (SvTYPE(arg) == SVt_PVAV)
6605 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6607 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6611 S_localise_gv_slot(aTHX_ (GV *)arg,
6612 PL_op->op_private & OPpLVREF_TYPE);
6614 else if (!(PL_op->op_private & OPpPAD_STATE))
6615 SAVECLEARSV(PAD_SVl(ARGTARG));
6624 AV * const av = (AV *)POPs;
6625 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6626 bool can_preserve = FALSE;
6628 if (UNLIKELY(localizing)) {
6633 can_preserve = SvCANEXISTDELETE(av);
6635 if (SvTYPE(av) == SVt_PVAV) {
6638 for (svp = MARK + 1; svp <= SP; svp++) {
6639 const SSize_t elem = SvIV(*svp);
6643 if (max > AvMAX(av))
6648 while (++MARK <= SP) {
6649 SV * const elemsv = *MARK;
6650 if (SvTYPE(av) == SVt_PVAV)
6651 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6653 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6654 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6655 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6662 if (PL_op->op_flags & OPf_STACKED)
6663 Perl_pp_rv2av(aTHX);
6665 Perl_pp_padav(aTHX);
6669 SETs(0); /* special alias marker that aassign recognises */
6679 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6680 ? CopSTASH(PL_curcop)
6682 NULL, SvREFCNT_inc_simple_NN(sv))));
6687 * ex: set ts=8 sts=4 sw=4 et: