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();
815 char *temp_buffer = NULL;
820 goto nope_free_nothing;
822 while (len && s[-1] == '\n') {
829 STRLEN rslen, rs_charlen;
830 const char *rsptr = SvPV_const(PL_rs, rslen);
832 rs_charlen = SvUTF8(PL_rs)
836 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
837 /* Assumption is that rs is shorter than the scalar. */
839 /* RS is utf8, scalar is 8 bit. */
841 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
844 /* Cannot downgrade, therefore cannot possibly match.
845 At this point, temp_buffer is not alloced, and
846 is the buffer inside PL_rs, so dont free it.
848 assert (temp_buffer == rsptr);
854 /* RS is 8 bit, scalar is utf8. */
855 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
869 if (memNE(s, rsptr, rslen))
874 SvPV_force_nomg_nolen(sv);
881 Safefree(temp_buffer);
883 SvREFCNT_dec(svrecode);
887 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
888 s = SvPV_force_nomg(sv, len);
891 char * const send = s + len;
892 char * const start = s;
894 while (s > start && UTF8_IS_CONTINUATION(*s))
896 if (is_utf8_string((U8*)s, send - s)) {
897 sv_setpvn(retval, s, send - s);
899 SvCUR_set(sv, s - start);
905 sv_setpvs(retval, "");
909 sv_setpvn(retval, s, 1);
916 sv_setpvs(retval, "");
923 /* also used for: pp_schomp() */
928 const bool chomping = PL_op->op_type == OP_SCHOMP;
930 const size_t count = do_chomp(TARG, TOPs, chomping);
932 sv_setiv(TARG, count);
938 /* also used for: pp_chomp() */
942 dSP; dMARK; dTARGET; dORIGMARK;
943 const bool chomping = PL_op->op_type == OP_CHOMP;
947 count += do_chomp(TARG, *++MARK, chomping);
949 sv_setiv(TARG, count);
960 if (!PL_op->op_private) {
972 if (SvTHINKFIRST(sv))
973 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
975 switch (SvTYPE(sv)) {
979 av_undef(MUTABLE_AV(sv));
982 hv_undef(MUTABLE_HV(sv));
985 if (cv_const_sv((const CV *)sv))
986 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
987 "Constant subroutine %"SVf" undefined",
988 SVfARG(CvANON((const CV *)sv)
989 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
990 : sv_2mortal(newSVhek(
992 ? CvNAME_HEK((CV *)sv)
993 : GvENAME_HEK(CvGV((const CV *)sv))
998 /* let user-undef'd sub keep its identity */
999 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1002 assert(isGV_with_GP(sv));
1003 assert(!SvFAKE(sv));
1008 /* undef *Pkg::meth_name ... */
1010 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1011 && HvENAME_get(stash);
1013 if((stash = GvHV((const GV *)sv))) {
1014 if(HvENAME_get(stash))
1015 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1019 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1020 gp_free(MUTABLE_GV(sv));
1022 GvGP_set(sv, gp_ref(gp));
1023 #ifndef PERL_DONT_CREATE_GVSV
1024 GvSV(sv) = newSV(0);
1026 GvLINE(sv) = CopLINE(PL_curcop);
1027 GvEGV(sv) = MUTABLE_GV(sv);
1031 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1033 /* undef *Foo::ISA */
1034 if( strEQ(GvNAME((const GV *)sv), "ISA")
1035 && (stash = GvSTASH((const GV *)sv))
1036 && (method_changed || HvENAME(stash)) )
1037 mro_isa_changed_in(stash);
1038 else if(method_changed)
1039 mro_method_changed_in(
1040 GvSTASH((const GV *)sv)
1046 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1060 /* common "slow" code for pp_postinc and pp_postdec */
1063 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1067 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1070 TARG = sv_newmortal();
1077 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1078 if (inc && !SvOK(TARG))
1085 /* also used for: pp_i_postinc() */
1092 /* special-case sv being a simple integer */
1093 if (LIKELY(((sv->sv_flags &
1094 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1095 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1097 && SvIVX(sv) != IV_MAX)
1100 SvIV_set(sv, iv + 1);
1101 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1106 return S_postincdec_common(aTHX_ sv, TARG);
1110 /* also used for: pp_i_postdec() */
1117 /* special-case sv being a simple integer */
1118 if (LIKELY(((sv->sv_flags &
1119 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1120 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1122 && SvIVX(sv) != IV_MIN)
1125 SvIV_set(sv, iv - 1);
1126 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1131 return S_postincdec_common(aTHX_ sv, TARG);
1135 /* Ordinary operators. */
1139 dSP; dATARGET; SV *svl, *svr;
1140 #ifdef PERL_PRESERVE_IVUV
1143 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1146 #ifdef PERL_PRESERVE_IVUV
1147 /* For integer to integer power, we do the calculation by hand wherever
1148 we're sure it is safe; otherwise we call pow() and try to convert to
1149 integer afterwards. */
1150 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1158 const IV iv = SvIVX(svr);
1162 goto float_it; /* Can't do negative powers this way. */
1166 baseuok = SvUOK(svl);
1168 baseuv = SvUVX(svl);
1170 const IV iv = SvIVX(svl);
1173 baseuok = TRUE; /* effectively it's a UV now */
1175 baseuv = -iv; /* abs, baseuok == false records sign */
1178 /* now we have integer ** positive integer. */
1181 /* foo & (foo - 1) is zero only for a power of 2. */
1182 if (!(baseuv & (baseuv - 1))) {
1183 /* We are raising power-of-2 to a positive integer.
1184 The logic here will work for any base (even non-integer
1185 bases) but it can be less accurate than
1186 pow (base,power) or exp (power * log (base)) when the
1187 intermediate values start to spill out of the mantissa.
1188 With powers of 2 we know this can't happen.
1189 And powers of 2 are the favourite thing for perl
1190 programmers to notice ** not doing what they mean. */
1192 NV base = baseuok ? baseuv : -(NV)baseuv;
1197 while (power >>= 1) {
1205 SvIV_please_nomg(svr);
1208 unsigned int highbit = 8 * sizeof(UV);
1209 unsigned int diff = 8 * sizeof(UV);
1210 while (diff >>= 1) {
1212 if (baseuv >> highbit) {
1216 /* we now have baseuv < 2 ** highbit */
1217 if (power * highbit <= 8 * sizeof(UV)) {
1218 /* result will definitely fit in UV, so use UV math
1219 on same algorithm as above */
1222 const bool odd_power = cBOOL(power & 1);
1226 while (power >>= 1) {
1233 if (baseuok || !odd_power)
1234 /* answer is positive */
1236 else if (result <= (UV)IV_MAX)
1237 /* answer negative, fits in IV */
1238 SETi( -(IV)result );
1239 else if (result == (UV)IV_MIN)
1240 /* 2's complement assumption: special case IV_MIN */
1243 /* answer negative, doesn't fit */
1244 SETn( -(NV)result );
1252 NV right = SvNV_nomg(svr);
1253 NV left = SvNV_nomg(svl);
1256 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1258 We are building perl with long double support and are on an AIX OS
1259 afflicted with a powl() function that wrongly returns NaNQ for any
1260 negative base. This was reported to IBM as PMR #23047-379 on
1261 03/06/2006. The problem exists in at least the following versions
1262 of AIX and the libm fileset, and no doubt others as well:
1264 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1265 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1266 AIX 5.2.0 bos.adt.libm 5.2.0.85
1268 So, until IBM fixes powl(), we provide the following workaround to
1269 handle the problem ourselves. Our logic is as follows: for
1270 negative bases (left), we use fmod(right, 2) to check if the
1271 exponent is an odd or even integer:
1273 - if odd, powl(left, right) == -powl(-left, right)
1274 - if even, powl(left, right) == powl(-left, right)
1276 If the exponent is not an integer, the result is rightly NaNQ, so
1277 we just return that (as NV_NAN).
1281 NV mod2 = Perl_fmod( right, 2.0 );
1282 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1283 SETn( -Perl_pow( -left, right) );
1284 } else if (mod2 == 0.0) { /* even integer */
1285 SETn( Perl_pow( -left, right) );
1286 } else { /* fractional power */
1290 SETn( Perl_pow( left, right) );
1293 SETn( Perl_pow( left, right) );
1294 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1296 #ifdef PERL_PRESERVE_IVUV
1298 SvIV_please_nomg(svr);
1306 dSP; dATARGET; SV *svl, *svr;
1307 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1311 #ifdef PERL_PRESERVE_IVUV
1313 /* special-case some simple common cases */
1314 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1316 U32 flags = (svl->sv_flags & svr->sv_flags);
1317 if (flags & SVf_IOK) {
1318 /* both args are simple IVs */
1323 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1324 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1326 /* if both are in a range that can't under/overflow, do a
1327 * simple integer multiply: if the top halves(*) of both numbers
1328 * are 00...00 or 11...11, then it's safe.
1329 * (*) for 32-bits, the "top half" is the top 17 bits,
1330 * for 64-bits, its 33 bits */
1332 ((topl+1) | (topr+1))
1333 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1336 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1342 else if (flags & SVf_NOK) {
1343 /* both args are NVs */
1349 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1350 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1351 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1353 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1356 /* nothing was lost by converting to IVs */
1360 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1361 if (Perl_isinf(result)) {
1362 Zero((U8*)&result + 8, 8, U8);
1365 TARGn(result, 0); /* args not GMG, so can't be tainted */
1373 if (SvIV_please_nomg(svr)) {
1374 /* Unless the left argument is integer in range we are going to have to
1375 use NV maths. Hence only attempt to coerce the right argument if
1376 we know the left is integer. */
1377 /* Left operand is defined, so is it IV? */
1378 if (SvIV_please_nomg(svl)) {
1379 bool auvok = SvUOK(svl);
1380 bool buvok = SvUOK(svr);
1381 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1382 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1391 const IV aiv = SvIVX(svl);
1394 auvok = TRUE; /* effectively it's a UV now */
1396 /* abs, auvok == false records sign */
1397 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1403 const IV biv = SvIVX(svr);
1406 buvok = TRUE; /* effectively it's a UV now */
1408 /* abs, buvok == false records sign */
1409 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1413 /* If this does sign extension on unsigned it's time for plan B */
1414 ahigh = alow >> (4 * sizeof (UV));
1416 bhigh = blow >> (4 * sizeof (UV));
1418 if (ahigh && bhigh) {
1420 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1421 which is overflow. Drop to NVs below. */
1422 } else if (!ahigh && !bhigh) {
1423 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1424 so the unsigned multiply cannot overflow. */
1425 const UV product = alow * blow;
1426 if (auvok == buvok) {
1427 /* -ve * -ve or +ve * +ve gives a +ve result. */
1431 } else if (product <= (UV)IV_MIN) {
1432 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1433 /* -ve result, which could overflow an IV */
1435 /* can't negate IV_MIN, but there are aren't two
1436 * integers such that !ahigh && !bhigh, where the
1437 * product equals 0x800....000 */
1438 assert(product != (UV)IV_MIN);
1439 SETi( -(IV)product );
1441 } /* else drop to NVs below. */
1443 /* One operand is large, 1 small */
1446 /* swap the operands */
1448 bhigh = blow; /* bhigh now the temp var for the swap */
1452 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1453 multiplies can't overflow. shift can, add can, -ve can. */
1454 product_middle = ahigh * blow;
1455 if (!(product_middle & topmask)) {
1456 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1458 product_middle <<= (4 * sizeof (UV));
1459 product_low = alow * blow;
1461 /* as for pp_add, UV + something mustn't get smaller.
1462 IIRC ANSI mandates this wrapping *behaviour* for
1463 unsigned whatever the actual representation*/
1464 product_low += product_middle;
1465 if (product_low >= product_middle) {
1466 /* didn't overflow */
1467 if (auvok == buvok) {
1468 /* -ve * -ve or +ve * +ve gives a +ve result. */
1470 SETu( product_low );
1472 } else if (product_low <= (UV)IV_MIN) {
1473 /* 2s complement assumption again */
1474 /* -ve result, which could overflow an IV */
1476 SETi(product_low == (UV)IV_MIN
1477 ? IV_MIN : -(IV)product_low);
1479 } /* else drop to NVs below. */
1481 } /* product_middle too large */
1482 } /* ahigh && bhigh */
1487 NV right = SvNV_nomg(svr);
1488 NV left = SvNV_nomg(svl);
1489 NV result = left * right;
1492 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1493 if (Perl_isinf(result)) {
1494 Zero((U8*)&result + 8, 8, U8);
1504 dSP; dATARGET; SV *svl, *svr;
1505 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1508 /* Only try to do UV divide first
1509 if ((SLOPPYDIVIDE is true) or
1510 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1512 The assumption is that it is better to use floating point divide
1513 whenever possible, only doing integer divide first if we can't be sure.
1514 If NV_PRESERVES_UV is true then we know at compile time that no UV
1515 can be too large to preserve, so don't need to compile the code to
1516 test the size of UVs. */
1519 # define PERL_TRY_UV_DIVIDE
1520 /* ensure that 20./5. == 4. */
1522 # ifdef PERL_PRESERVE_IVUV
1523 # ifndef NV_PRESERVES_UV
1524 # define PERL_TRY_UV_DIVIDE
1529 #ifdef PERL_TRY_UV_DIVIDE
1530 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1531 bool left_non_neg = SvUOK(svl);
1532 bool right_non_neg = SvUOK(svr);
1536 if (right_non_neg) {
1540 const IV biv = SvIVX(svr);
1543 right_non_neg = TRUE; /* effectively it's a UV now */
1546 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1549 /* historically undef()/0 gives a "Use of uninitialized value"
1550 warning before dieing, hence this test goes here.
1551 If it were immediately before the second SvIV_please, then
1552 DIE() would be invoked before left was even inspected, so
1553 no inspection would give no warning. */
1555 DIE(aTHX_ "Illegal division by zero");
1561 const IV aiv = SvIVX(svl);
1564 left_non_neg = TRUE; /* effectively it's a UV now */
1567 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1573 /* For sloppy divide we always attempt integer division. */
1575 /* Otherwise we only attempt it if either or both operands
1576 would not be preserved by an NV. If both fit in NVs
1577 we fall through to the NV divide code below. However,
1578 as left >= right to ensure integer result here, we know that
1579 we can skip the test on the right operand - right big
1580 enough not to be preserved can't get here unless left is
1583 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1586 /* Integer division can't overflow, but it can be imprecise. */
1587 const UV result = left / right;
1588 if (result * right == left) {
1589 SP--; /* result is valid */
1590 if (left_non_neg == right_non_neg) {
1591 /* signs identical, result is positive. */
1595 /* 2s complement assumption */
1596 if (result <= (UV)IV_MIN)
1597 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1599 /* It's exact but too negative for IV. */
1600 SETn( -(NV)result );
1603 } /* tried integer divide but it was not an integer result */
1604 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1605 } /* one operand wasn't SvIOK */
1606 #endif /* PERL_TRY_UV_DIVIDE */
1608 NV right = SvNV_nomg(svr);
1609 NV left = SvNV_nomg(svl);
1610 (void)POPs;(void)POPs;
1611 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1612 if (! Perl_isnan(right) && right == 0.0)
1616 DIE(aTHX_ "Illegal division by zero");
1617 PUSHn( left / right );
1625 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1629 bool left_neg = FALSE;
1630 bool right_neg = FALSE;
1631 bool use_double = FALSE;
1632 bool dright_valid = FALSE;
1635 SV * const svr = TOPs;
1636 SV * const svl = TOPm1s;
1637 if (SvIV_please_nomg(svr)) {
1638 right_neg = !SvUOK(svr);
1642 const IV biv = SvIVX(svr);
1645 right_neg = FALSE; /* effectively it's a UV now */
1647 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1652 dright = SvNV_nomg(svr);
1653 right_neg = dright < 0;
1656 if (dright < UV_MAX_P1) {
1657 right = U_V(dright);
1658 dright_valid = TRUE; /* In case we need to use double below. */
1664 /* At this point use_double is only true if right is out of range for
1665 a UV. In range NV has been rounded down to nearest UV and
1666 use_double false. */
1667 if (!use_double && SvIV_please_nomg(svl)) {
1668 left_neg = !SvUOK(svl);
1672 const IV aiv = SvIVX(svl);
1675 left_neg = FALSE; /* effectively it's a UV now */
1677 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1682 dleft = SvNV_nomg(svl);
1683 left_neg = dleft < 0;
1687 /* This should be exactly the 5.6 behaviour - if left and right are
1688 both in range for UV then use U_V() rather than floor. */
1690 if (dleft < UV_MAX_P1) {
1691 /* right was in range, so is dleft, so use UVs not double.
1695 /* left is out of range for UV, right was in range, so promote
1696 right (back) to double. */
1698 /* The +0.5 is used in 5.6 even though it is not strictly
1699 consistent with the implicit +0 floor in the U_V()
1700 inside the #if 1. */
1701 dleft = Perl_floor(dleft + 0.5);
1704 dright = Perl_floor(dright + 0.5);
1715 DIE(aTHX_ "Illegal modulus zero");
1717 dans = Perl_fmod(dleft, dright);
1718 if ((left_neg != right_neg) && dans)
1719 dans = dright - dans;
1722 sv_setnv(TARG, dans);
1728 DIE(aTHX_ "Illegal modulus zero");
1731 if ((left_neg != right_neg) && ans)
1734 /* XXX may warn: unary minus operator applied to unsigned type */
1735 /* could change -foo to be (~foo)+1 instead */
1736 if (ans <= ~((UV)IV_MAX)+1)
1737 sv_setiv(TARG, ~ans+1);
1739 sv_setnv(TARG, -(NV)ans);
1742 sv_setuv(TARG, ans);
1754 bool infnan = FALSE;
1756 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1757 /* TODO: think of some way of doing list-repeat overloading ??? */
1762 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1763 /* The parser saw this as a list repeat, and there
1764 are probably several items on the stack. But we're
1765 in scalar/void context, and there's no pp_list to save us
1766 now. So drop the rest of the items -- robin@kitsite.com
1769 if (MARK + 1 < SP) {
1775 ASSUME(MARK + 1 == SP);
1777 MARK[1] = &PL_sv_undef;
1781 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1787 const UV uv = SvUV_nomg(sv);
1789 count = IV_MAX; /* The best we can do? */
1793 count = SvIV_nomg(sv);
1796 else if (SvNOKp(sv)) {
1797 const NV nv = SvNV_nomg(sv);
1798 infnan = Perl_isinfnan(nv);
1799 if (UNLIKELY(infnan)) {
1803 count = -1; /* An arbitrary negative integer */
1809 count = SvIV_nomg(sv);
1812 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1813 "Non-finite repeat count does nothing");
1814 } else if (count < 0) {
1816 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1817 "Negative repeat count does nothing");
1820 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1822 const SSize_t items = SP - MARK;
1823 const U8 mod = PL_op->op_flags & OPf_MOD;
1828 if ( items > SSize_t_MAX / count /* max would overflow */
1829 /* repeatcpy would overflow */
1830 || items > I32_MAX / (I32)sizeof(SV *)
1832 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1833 max = items * count;
1838 if (mod && SvPADTMP(*SP)) {
1839 *SP = sv_mortalcopy(*SP);
1846 repeatcpy((char*)(MARK + items), (char*)MARK,
1847 items * sizeof(const SV *), count - 1);
1850 else if (count <= 0)
1853 else { /* Note: mark already snarfed by pp_list */
1854 SV * const tmpstr = POPs;
1859 sv_setsv_nomg(TARG, tmpstr);
1860 SvPV_force_nomg(TARG, len);
1861 isutf = DO_UTF8(TARG);
1868 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1869 || len > (U32)I32_MAX /* repeatcpy would overflow */
1871 Perl_croak(aTHX_ "%s",
1872 "Out of memory during string extend");
1873 max = (UV)count * len + 1;
1876 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1877 SvCUR_set(TARG, SvCUR(TARG) * count);
1879 *SvEND(TARG) = '\0';
1882 (void)SvPOK_only_UTF8(TARG);
1884 (void)SvPOK_only(TARG);
1893 dSP; dATARGET; bool useleft; SV *svl, *svr;
1894 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1898 #ifdef PERL_PRESERVE_IVUV
1900 /* special-case some simple common cases */
1901 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1903 U32 flags = (svl->sv_flags & svr->sv_flags);
1904 if (flags & SVf_IOK) {
1905 /* both args are simple IVs */
1910 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1911 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1913 /* if both are in a range that can't under/overflow, do a
1914 * simple integer subtract: if the top of both numbers
1915 * are 00 or 11, then it's safe */
1916 if (!( ((topl+1) | (topr+1)) & 2)) {
1918 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1924 else if (flags & SVf_NOK) {
1925 /* both args are NVs */
1930 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1931 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1932 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1934 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1937 /* nothing was lost by converting to IVs */
1940 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1948 useleft = USE_LEFT(svl);
1949 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1950 "bad things" happen if you rely on signed integers wrapping. */
1951 if (SvIV_please_nomg(svr)) {
1952 /* Unless the left argument is integer in range we are going to have to
1953 use NV maths. Hence only attempt to coerce the right argument if
1954 we know the left is integer. */
1961 a_valid = auvok = 1;
1962 /* left operand is undef, treat as zero. */
1964 /* Left operand is defined, so is it IV? */
1965 if (SvIV_please_nomg(svl)) {
1966 if ((auvok = SvUOK(svl)))
1969 const IV aiv = SvIVX(svl);
1972 auvok = 1; /* Now acting as a sign flag. */
1973 } else { /* 2s complement assumption for IV_MIN */
1974 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1981 bool result_good = 0;
1984 bool buvok = SvUOK(svr);
1989 const IV biv = SvIVX(svr);
1994 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
1996 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1997 else "IV" now, independent of how it came in.
1998 if a, b represents positive, A, B negative, a maps to -A etc
2003 all UV maths. negate result if A negative.
2004 subtract if signs same, add if signs differ. */
2006 if (auvok ^ buvok) {
2015 /* Must get smaller */
2020 if (result <= buv) {
2021 /* result really should be -(auv-buv). as its negation
2022 of true value, need to swap our result flag */
2034 if (result <= (UV)IV_MIN)
2035 SETi(result == (UV)IV_MIN
2036 ? IV_MIN : -(IV)result);
2038 /* result valid, but out of range for IV. */
2039 SETn( -(NV)result );
2043 } /* Overflow, drop through to NVs. */
2047 useleft = USE_LEFT(svl);
2050 NV value = SvNV_nomg(svr);
2054 /* left operand is undef, treat as zero - value */
2058 SETn( SvNV_nomg(svl) - value );
2063 #define IV_BITS (IVSIZE * 8)
2065 static UV S_uv_shift(UV uv, int shift, bool left)
2071 if (shift >= IV_BITS) {
2074 return left ? uv << shift : uv >> shift;
2077 static IV S_iv_shift(IV iv, int shift, bool left)
2083 if (shift >= IV_BITS) {
2084 return iv < 0 && !left ? -1 : 0;
2086 return left ? iv << shift : iv >> shift;
2089 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2090 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2091 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2092 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2096 dSP; dATARGET; SV *svl, *svr;
2097 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2101 const IV shift = SvIV_nomg(svr);
2102 if (PL_op->op_private & HINT_INTEGER) {
2103 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2106 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2114 dSP; dATARGET; SV *svl, *svr;
2115 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2119 const IV shift = SvIV_nomg(svr);
2120 if (PL_op->op_private & HINT_INTEGER) {
2121 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2124 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2135 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2139 (SvIOK_notUV(left) && SvIOK_notUV(right))
2140 ? (SvIVX(left) < SvIVX(right))
2141 : (do_ncmp(left, right) == -1)
2151 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2155 (SvIOK_notUV(left) && SvIOK_notUV(right))
2156 ? (SvIVX(left) > SvIVX(right))
2157 : (do_ncmp(left, right) == 1)
2167 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2171 (SvIOK_notUV(left) && SvIOK_notUV(right))
2172 ? (SvIVX(left) <= SvIVX(right))
2173 : (do_ncmp(left, right) <= 0)
2183 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2187 (SvIOK_notUV(left) && SvIOK_notUV(right))
2188 ? (SvIVX(left) >= SvIVX(right))
2189 : ( (do_ncmp(left, right) & 2) == 0)
2199 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2203 (SvIOK_notUV(left) && SvIOK_notUV(right))
2204 ? (SvIVX(left) != SvIVX(right))
2205 : (do_ncmp(left, right) != 0)
2210 /* compare left and right SVs. Returns:
2214 * 2: left or right was a NaN
2217 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2219 PERL_ARGS_ASSERT_DO_NCMP;
2220 #ifdef PERL_PRESERVE_IVUV
2221 /* Fortunately it seems NaN isn't IOK */
2222 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2224 const IV leftiv = SvIVX(left);
2225 if (!SvUOK(right)) {
2226 /* ## IV <=> IV ## */
2227 const IV rightiv = SvIVX(right);
2228 return (leftiv > rightiv) - (leftiv < rightiv);
2230 /* ## IV <=> UV ## */
2232 /* As (b) is a UV, it's >=0, so it must be < */
2235 const UV rightuv = SvUVX(right);
2236 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2241 /* ## UV <=> UV ## */
2242 const UV leftuv = SvUVX(left);
2243 const UV rightuv = SvUVX(right);
2244 return (leftuv > rightuv) - (leftuv < rightuv);
2246 /* ## UV <=> IV ## */
2248 const IV rightiv = SvIVX(right);
2250 /* As (a) is a UV, it's >=0, so it cannot be < */
2253 const UV leftuv = SvUVX(left);
2254 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2257 NOT_REACHED; /* NOTREACHED */
2261 NV const rnv = SvNV_nomg(right);
2262 NV const lnv = SvNV_nomg(left);
2264 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2265 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2268 return (lnv > rnv) - (lnv < rnv);
2287 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2290 value = do_ncmp(left, right);
2302 /* also used for: pp_sge() pp_sgt() pp_slt() */
2308 int amg_type = sle_amg;
2312 switch (PL_op->op_type) {
2331 tryAMAGICbin_MG(amg_type, AMGf_set);
2335 #ifdef USE_LOCALE_COLLATE
2336 (IN_LC_RUNTIME(LC_COLLATE))
2337 ? sv_cmp_locale_flags(left, right, 0)
2340 sv_cmp_flags(left, right, 0);
2341 SETs(boolSV(cmp * multiplier < rhs));
2349 tryAMAGICbin_MG(seq_amg, AMGf_set);
2352 SETs(boolSV(sv_eq_flags(left, right, 0)));
2360 tryAMAGICbin_MG(sne_amg, AMGf_set);
2363 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2371 tryAMAGICbin_MG(scmp_amg, 0);
2375 #ifdef USE_LOCALE_COLLATE
2376 (IN_LC_RUNTIME(LC_COLLATE))
2377 ? sv_cmp_locale_flags(left, right, 0)
2380 sv_cmp_flags(left, right, 0);
2389 tryAMAGICbin_MG(band_amg, AMGf_assign);
2392 if (SvNIOKp(left) || SvNIOKp(right)) {
2393 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2394 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2395 if (PL_op->op_private & HINT_INTEGER) {
2396 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2400 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2403 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2404 if (right_ro_nonnum) SvNIOK_off(right);
2407 do_vop(PL_op->op_type, TARG, left, right);
2417 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2419 dATARGET; dPOPTOPssrl;
2420 if (PL_op->op_private & HINT_INTEGER) {
2421 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2425 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2435 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2437 dATARGET; dPOPTOPssrl;
2438 do_vop(OP_BIT_AND, TARG, left, right);
2443 /* also used for: pp_bit_xor() */
2448 const int op_type = PL_op->op_type;
2450 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2453 if (SvNIOKp(left) || SvNIOKp(right)) {
2454 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2455 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2456 if (PL_op->op_private & HINT_INTEGER) {
2457 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2458 const IV r = SvIV_nomg(right);
2459 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2463 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2464 const UV r = SvUV_nomg(right);
2465 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2468 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2469 if (right_ro_nonnum) SvNIOK_off(right);
2472 do_vop(op_type, TARG, left, right);
2479 /* also used for: pp_nbit_xor() */
2484 const int op_type = PL_op->op_type;
2486 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2487 AMGf_assign|AMGf_numarg);
2489 dATARGET; dPOPTOPssrl;
2490 if (PL_op->op_private & HINT_INTEGER) {
2491 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2492 const IV r = SvIV_nomg(right);
2493 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2497 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2498 const UV r = SvUV_nomg(right);
2499 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2506 /* also used for: pp_sbit_xor() */
2511 const int op_type = PL_op->op_type;
2513 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2516 dATARGET; dPOPTOPssrl;
2517 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2523 PERL_STATIC_INLINE bool
2524 S_negate_string(pTHX)
2529 SV * const sv = TOPs;
2530 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2532 s = SvPV_nomg_const(sv, len);
2533 if (isIDFIRST(*s)) {
2534 sv_setpvs(TARG, "-");
2537 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2538 sv_setsv_nomg(TARG, sv);
2539 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2549 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2550 if (S_negate_string(aTHX)) return NORMAL;
2552 SV * const sv = TOPs;
2555 /* It's publicly an integer */
2558 if (SvIVX(sv) == IV_MIN) {
2559 /* 2s complement assumption. */
2560 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2564 else if (SvUVX(sv) <= IV_MAX) {
2569 else if (SvIVX(sv) != IV_MIN) {
2573 #ifdef PERL_PRESERVE_IVUV
2580 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2581 SETn(-SvNV_nomg(sv));
2582 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2583 goto oops_its_an_int;
2585 SETn(-SvNV_nomg(sv));
2593 tryAMAGICun_MG(not_amg, AMGf_set);
2594 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2599 S_scomplement(pTHX_ SV *targ, SV *sv)
2605 sv_copypv_nomg(TARG, sv);
2606 tmps = (U8*)SvPV_nomg(TARG, len);
2609 /* Calculate exact length, let's not estimate. */
2614 U8 * const send = tmps + len;
2615 U8 * const origtmps = tmps;
2616 const UV utf8flags = UTF8_ALLOW_ANYUV;
2618 while (tmps < send) {
2619 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2621 targlen += UVCHR_SKIP(~c);
2627 /* Now rewind strings and write them. */
2634 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2635 deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
2636 Newx(result, targlen + 1, U8);
2638 while (tmps < send) {
2639 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2641 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2644 sv_usepvn_flags(TARG, (char*)result, targlen,
2645 SV_HAS_TRAILING_NUL);
2652 Newx(result, nchar + 1, U8);
2654 while (tmps < send) {
2655 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2660 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2668 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2671 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2676 for ( ; anum > 0; anum--, tmps++)
2683 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2687 if (PL_op->op_private & HINT_INTEGER) {
2688 const IV i = ~SvIV_nomg(sv);
2692 const UV u = ~SvUV_nomg(sv);
2697 S_scomplement(aTHX_ TARG, sv);
2707 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2710 if (PL_op->op_private & HINT_INTEGER) {
2711 const IV i = ~SvIV_nomg(sv);
2715 const UV u = ~SvUV_nomg(sv);
2725 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2728 S_scomplement(aTHX_ TARG, sv);
2734 /* integer versions of some of the above */
2739 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2742 SETi( left * right );
2751 tryAMAGICbin_MG(div_amg, AMGf_assign);
2754 IV value = SvIV_nomg(right);
2756 DIE(aTHX_ "Illegal division by zero");
2757 num = SvIV_nomg(left);
2759 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2763 value = num / value;
2771 /* This is the vanilla old i_modulo. */
2773 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2777 DIE(aTHX_ "Illegal modulus zero");
2778 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2782 SETi( left % right );
2787 #if defined(__GLIBC__) && IVSIZE == 8 \
2788 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2790 PP(pp_i_modulo_glibc_bugfix)
2792 /* This is the i_modulo with the workaround for the _moddi3 bug
2793 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2794 * See below for pp_i_modulo. */
2796 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2800 DIE(aTHX_ "Illegal modulus zero");
2801 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2805 SETi( left % PERL_ABS(right) );
2814 tryAMAGICbin_MG(add_amg, AMGf_assign);
2816 dPOPTOPiirl_ul_nomg;
2817 SETi( left + right );
2825 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2827 dPOPTOPiirl_ul_nomg;
2828 SETi( left - right );
2836 tryAMAGICbin_MG(lt_amg, AMGf_set);
2839 SETs(boolSV(left < right));
2847 tryAMAGICbin_MG(gt_amg, AMGf_set);
2850 SETs(boolSV(left > right));
2858 tryAMAGICbin_MG(le_amg, AMGf_set);
2861 SETs(boolSV(left <= right));
2869 tryAMAGICbin_MG(ge_amg, AMGf_set);
2872 SETs(boolSV(left >= right));
2880 tryAMAGICbin_MG(eq_amg, AMGf_set);
2883 SETs(boolSV(left == right));
2891 tryAMAGICbin_MG(ne_amg, AMGf_set);
2894 SETs(boolSV(left != right));
2902 tryAMAGICbin_MG(ncmp_amg, 0);
2909 else if (left < right)
2921 tryAMAGICun_MG(neg_amg, 0);
2922 if (S_negate_string(aTHX)) return NORMAL;
2924 SV * const sv = TOPs;
2925 IV const i = SvIV_nomg(sv);
2931 /* High falutin' math. */
2936 tryAMAGICbin_MG(atan2_amg, 0);
2939 SETn(Perl_atan2(left, right));
2945 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2950 int amg_type = fallback_amg;
2951 const char *neg_report = NULL;
2952 const int op_type = PL_op->op_type;
2955 case OP_SIN: amg_type = sin_amg; break;
2956 case OP_COS: amg_type = cos_amg; break;
2957 case OP_EXP: amg_type = exp_amg; break;
2958 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2959 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2962 assert(amg_type != fallback_amg);
2964 tryAMAGICun_MG(amg_type, 0);
2966 SV * const arg = TOPs;
2967 const NV value = SvNV_nomg(arg);
2969 if (neg_report) { /* log or sqrt */
2971 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2972 ! Perl_isnan(value) &&
2974 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2975 SET_NUMERIC_STANDARD();
2976 /* diag_listed_as: Can't take log of %g */
2977 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2982 case OP_SIN: result = Perl_sin(value); break;
2983 case OP_COS: result = Perl_cos(value); break;
2984 case OP_EXP: result = Perl_exp(value); break;
2985 case OP_LOG: result = Perl_log(value); break;
2986 case OP_SQRT: result = Perl_sqrt(value); break;
2993 /* Support Configure command-line overrides for rand() functions.
2994 After 5.005, perhaps we should replace this by Configure support
2995 for drand48(), random(), or rand(). For 5.005, though, maintain
2996 compatibility by calling rand() but allow the user to override it.
2997 See INSTALL for details. --Andy Dougherty 15 July 1998
2999 /* Now it's after 5.005, and Configure supports drand48() and random(),
3000 in addition to rand(). So the overrides should not be needed any more.
3001 --Jarkko Hietaniemi 27 September 1998
3006 if (!PL_srand_called) {
3007 (void)seedDrand01((Rand_seed_t)seed());
3008 PL_srand_called = TRUE;
3020 SV * const sv = POPs;
3026 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3027 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3028 if (! Perl_isnan(value) && value == 0.0)
3038 sv_setnv_mg(TARG, value);
3049 if (MAXARG >= 1 && (TOPs || POPs)) {
3056 pv = SvPV(top, len);
3057 flags = grok_number(pv, len, &anum);
3059 if (!(flags & IS_NUMBER_IN_UV)) {
3060 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3061 "Integer overflow in srand");
3069 (void)seedDrand01((Rand_seed_t)anum);
3070 PL_srand_called = TRUE;
3074 /* Historically srand always returned true. We can avoid breaking
3076 sv_setpvs(TARG, "0 but true");
3085 tryAMAGICun_MG(int_amg, AMGf_numeric);
3087 SV * const sv = TOPs;
3088 const IV iv = SvIV_nomg(sv);
3089 /* XXX it's arguable that compiler casting to IV might be subtly
3090 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3091 else preferring IV has introduced a subtle behaviour change bug. OTOH
3092 relying on floating point to be accurate is a bug. */
3097 else if (SvIOK(sv)) {
3099 SETu(SvUV_nomg(sv));
3104 const NV value = SvNV_nomg(sv);
3105 if (UNLIKELY(Perl_isinfnan(value)))
3107 else if (value >= 0.0) {
3108 if (value < (NV)UV_MAX + 0.5) {
3111 SETn(Perl_floor(value));
3115 if (value > (NV)IV_MIN - 0.5) {
3118 SETn(Perl_ceil(value));
3129 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3131 SV * const sv = TOPs;
3132 /* This will cache the NV value if string isn't actually integer */
3133 const IV iv = SvIV_nomg(sv);
3138 else if (SvIOK(sv)) {
3139 /* IVX is precise */
3141 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3149 /* 2s complement assumption. Also, not really needed as
3150 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3156 const NV value = SvNV_nomg(sv);
3167 /* also used for: pp_hex() */
3173 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3177 SV* const sv = TOPs;
3179 tmps = (SvPV_const(sv, len));
3181 /* If Unicode, try to downgrade
3182 * If not possible, croak. */
3183 SV* const tsv = sv_2mortal(newSVsv(sv));
3186 sv_utf8_downgrade(tsv, FALSE);
3187 tmps = SvPV_const(tsv, len);
3189 if (PL_op->op_type == OP_HEX)
3192 while (*tmps && len && isSPACE(*tmps))
3196 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3198 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3200 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3201 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3203 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3205 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3219 SV * const sv = TOPs;
3221 U32 in_bytes = IN_BYTES;
3222 /* simplest case shortcut */
3223 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3224 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3225 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3228 if(LIKELY(svflags == SVf_POK))
3230 if(svflags & SVs_GMG)
3233 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3234 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3238 /* unrolled SvPV_nomg_const(sv,len) */
3243 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3245 sv_setiv(TARG, (IV)(len));
3248 if (!SvPADTMP(TARG)) {
3249 sv_setsv_nomg(TARG, &PL_sv_undef);
3250 } else { /* TARG is on stack at this point and is overwriten by SETs.
3251 This branch is the odd one out, so put TARG by default on
3252 stack earlier to let local SP go out of liveness sooner */
3259 return NORMAL; /* no putback, SP didn't move in this opcode */
3262 /* Returns false if substring is completely outside original string.
3263 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3264 always be true for an explicit 0.
3267 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3268 bool pos1_is_uv, IV len_iv,
3269 bool len_is_uv, STRLEN *posp,
3275 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3277 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3278 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3281 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3284 if (len_iv || len_is_uv) {
3285 if (!len_is_uv && len_iv < 0) {
3286 pos2_iv = curlen + len_iv;
3288 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3291 } else { /* len_iv >= 0 */
3292 if (!pos1_is_uv && pos1_iv < 0) {
3293 pos2_iv = pos1_iv + len_iv;
3294 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3296 if ((UV)len_iv > curlen-(UV)pos1_iv)
3299 pos2_iv = pos1_iv+len_iv;
3309 if (!pos2_is_uv && pos2_iv < 0) {
3310 if (!pos1_is_uv && pos1_iv < 0)
3314 else if (!pos1_is_uv && pos1_iv < 0)
3317 if ((UV)pos2_iv < (UV)pos1_iv)
3319 if ((UV)pos2_iv > curlen)
3322 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3323 *posp = (STRLEN)( (UV)pos1_iv );
3324 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3341 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3342 const bool rvalue = (GIMME_V != G_VOID);
3345 const char *repl = NULL;
3347 int num_args = PL_op->op_private & 7;
3348 bool repl_need_utf8_upgrade = FALSE;
3352 if(!(repl_sv = POPs)) num_args--;
3354 if ((len_sv = POPs)) {
3355 len_iv = SvIV(len_sv);
3356 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3361 pos1_iv = SvIV(pos_sv);
3362 pos1_is_uv = SvIOK_UV(pos_sv);
3364 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3368 if (lvalue && !repl_sv) {
3370 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3371 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3373 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3375 pos1_is_uv || pos1_iv >= 0
3376 ? (STRLEN)(UV)pos1_iv
3377 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3379 len_is_uv || len_iv > 0
3380 ? (STRLEN)(UV)len_iv
3381 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3383 PUSHs(ret); /* avoid SvSETMAGIC here */
3387 repl = SvPV_const(repl_sv, repl_len);
3390 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3391 "Attempt to use reference as lvalue in substr"
3393 tmps = SvPV_force_nomg(sv, curlen);
3394 if (DO_UTF8(repl_sv) && repl_len) {
3396 sv_utf8_upgrade_nomg(sv);
3400 else if (DO_UTF8(sv))
3401 repl_need_utf8_upgrade = TRUE;
3403 else tmps = SvPV_const(sv, curlen);
3405 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3406 if (utf8_curlen == curlen)
3409 curlen = utf8_curlen;
3415 STRLEN pos, len, byte_len, byte_pos;
3417 if (!translate_substr_offsets(
3418 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3422 byte_pos = utf8_curlen
3423 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3428 SvTAINTED_off(TARG); /* decontaminate */
3429 SvUTF8_off(TARG); /* decontaminate */
3430 sv_setpvn(TARG, tmps, byte_len);
3431 #ifdef USE_LOCALE_COLLATE
3432 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3439 SV* repl_sv_copy = NULL;
3441 if (repl_need_utf8_upgrade) {
3442 repl_sv_copy = newSVsv(repl_sv);
3443 sv_utf8_upgrade(repl_sv_copy);
3444 repl = SvPV_const(repl_sv_copy, repl_len);
3448 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3449 SvREFCNT_dec(repl_sv_copy);
3452 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3462 Perl_croak(aTHX_ "substr outside of string");
3463 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3470 const IV size = POPi;
3471 const IV offset = POPi;
3472 SV * const src = POPs;
3473 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3476 if (lvalue) { /* it's an lvalue! */
3477 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3478 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3480 LvTARG(ret) = SvREFCNT_inc_simple(src);
3481 LvTARGOFF(ret) = offset;
3482 LvTARGLEN(ret) = size;
3486 SvTAINTED_off(TARG); /* decontaminate */
3490 sv_setuv(ret, do_vecget(src, offset, size));
3498 /* also used for: pp_rindex() */
3511 const char *little_p;
3514 const bool is_index = PL_op->op_type == OP_INDEX;
3515 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3521 big_p = SvPV_const(big, biglen);
3522 little_p = SvPV_const(little, llen);
3524 big_utf8 = DO_UTF8(big);
3525 little_utf8 = DO_UTF8(little);
3526 if (big_utf8 ^ little_utf8) {
3527 /* One needs to be upgraded. */
3529 /* Well, maybe instead we might be able to downgrade the small
3531 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3534 /* If the large string is ISO-8859-1, and it's not possible to
3535 convert the small string to ISO-8859-1, then there is no
3536 way that it could be found anywhere by index. */
3541 /* At this point, pv is a malloc()ed string. So donate it to temp
3542 to ensure it will get free()d */
3543 little = temp = newSV(0);
3544 sv_usepvn(temp, pv, llen);
3545 little_p = SvPVX(little);
3548 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3550 sv_utf8_upgrade(temp);
3554 big_p = SvPV_const(big, biglen);
3557 little_p = SvPV_const(little, llen);
3561 if (SvGAMAGIC(big)) {
3562 /* Life just becomes a lot easier if I use a temporary here.
3563 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3564 will trigger magic and overloading again, as will fbm_instr()
3566 big = newSVpvn_flags(big_p, biglen,
3567 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3570 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3571 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3572 warn on undef, and we've already triggered a warning with the
3573 SvPV_const some lines above. We can't remove that, as we need to
3574 call some SvPV to trigger overloading early and find out if the
3576 This is all getting too messy. The API isn't quite clean enough,
3577 because data access has side effects.
3579 little = newSVpvn_flags(little_p, llen,
3580 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3581 little_p = SvPVX(little);
3585 offset = is_index ? 0 : biglen;
3587 if (big_utf8 && offset > 0)
3588 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3594 else if (offset > (SSize_t)biglen)
3596 if (!(little_p = is_index
3597 ? fbm_instr((unsigned char*)big_p + offset,
3598 (unsigned char*)big_p + biglen, little, 0)
3599 : rninstr(big_p, big_p + offset,
3600 little_p, little_p + llen)))
3603 retval = little_p - big_p;
3604 if (retval > 1 && big_utf8)
3605 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3615 dSP; dMARK; dORIGMARK; dTARGET;
3616 SvTAINTED_off(TARG);
3617 do_sprintf(TARG, SP-MARK, MARK+1);
3618 TAINT_IF(SvTAINTED(TARG));
3630 const U8 *s = (U8*)SvPV_const(argsv, len);
3633 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3647 if (UNLIKELY(SvAMAGIC(top)))
3649 if (UNLIKELY(isinfnansv(top)))
3650 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3652 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3653 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3655 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3656 && SvNV_nomg(top) < 0.0)))
3658 if (ckWARN(WARN_UTF8)) {
3659 if (SvGMAGICAL(top)) {
3660 SV *top2 = sv_newmortal();
3661 sv_setsv_nomg(top2, top);
3664 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3665 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3667 value = UNICODE_REPLACEMENT;
3669 value = SvUV_nomg(top);
3673 SvUPGRADE(TARG,SVt_PV);
3675 if (value > 255 && !IN_BYTES) {
3676 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3677 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3678 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3680 (void)SvPOK_only(TARG);
3689 *tmps++ = (char)value;
3691 (void)SvPOK_only(TARG);
3703 const char *tmps = SvPV_const(left, len);
3705 if (DO_UTF8(left)) {
3706 /* If Unicode, try to downgrade.
3707 * If not possible, croak.
3708 * Yes, we made this up. */
3709 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3711 sv_utf8_downgrade(tsv, FALSE);
3712 tmps = SvPV_const(tsv, len);
3714 # ifdef USE_ITHREADS
3716 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3717 /* This should be threadsafe because in ithreads there is only
3718 * one thread per interpreter. If this would not be true,
3719 * we would need a mutex to protect this malloc. */
3720 PL_reentrant_buffer->_crypt_struct_buffer =
3721 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3722 #if defined(__GLIBC__) || defined(__EMX__)
3723 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3724 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3725 /* work around glibc-2.2.5 bug */
3726 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3730 # endif /* HAS_CRYPT_R */
3731 # endif /* USE_ITHREADS */
3733 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3735 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3742 "The crypt() function is unimplemented due to excessive paranoia.");
3746 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3747 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3750 /* also used for: pp_lcfirst() */
3754 /* Actually is both lcfirst() and ucfirst(). Only the first character
3755 * changes. This means that possibly we can change in-place, ie., just
3756 * take the source and change that one character and store it back, but not
3757 * if read-only etc, or if the length changes */
3761 STRLEN slen; /* slen is the byte length of the whole SV. */
3764 bool inplace; /* ? Convert first char only, in-place */
3765 bool doing_utf8 = FALSE; /* ? using utf8 */
3766 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3767 const int op_type = PL_op->op_type;
3770 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3771 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3772 * stored as UTF-8 at s. */
3773 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3774 * lowercased) character stored in tmpbuf. May be either
3775 * UTF-8 or not, but in either case is the number of bytes */
3777 s = (const U8*)SvPV_const(source, slen);
3779 /* We may be able to get away with changing only the first character, in
3780 * place, but not if read-only, etc. Later we may discover more reasons to
3781 * not convert in-place. */
3782 inplace = !SvREADONLY(source) && SvPADTMP(source);
3784 /* First calculate what the changed first character should be. This affects
3785 * whether we can just swap it out, leaving the rest of the string unchanged,
3786 * or even if have to convert the dest to UTF-8 when the source isn't */
3788 if (! slen) { /* If empty */
3789 need = 1; /* still need a trailing NUL */
3792 else if (DO_UTF8(source)) { /* Is the source utf8? */
3795 if (op_type == OP_UCFIRST) {
3796 #ifdef USE_LOCALE_CTYPE
3797 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3799 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3803 #ifdef USE_LOCALE_CTYPE
3804 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3806 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3810 /* we can't do in-place if the length changes. */
3811 if (ulen != tculen) inplace = FALSE;
3812 need = slen + 1 - ulen + tculen;
3814 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3815 * latin1 is treated as caseless. Note that a locale takes
3817 ulen = 1; /* Original character is 1 byte */
3818 tculen = 1; /* Most characters will require one byte, but this will
3819 * need to be overridden for the tricky ones */
3822 if (op_type == OP_LCFIRST) {
3824 /* lower case the first letter: no trickiness for any character */
3825 #ifdef USE_LOCALE_CTYPE
3826 if (IN_LC_RUNTIME(LC_CTYPE)) {
3827 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3828 *tmpbuf = toLOWER_LC(*s);
3833 *tmpbuf = (IN_UNI_8_BIT)
3834 ? toLOWER_LATIN1(*s)
3838 #ifdef USE_LOCALE_CTYPE
3840 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3841 if (IN_UTF8_CTYPE_LOCALE) {
3845 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3846 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3847 locales have upper and title case
3851 else if (! IN_UNI_8_BIT) {
3852 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3853 * on EBCDIC machines whatever the
3854 * native function does */
3857 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3858 * UTF-8, which we treat as not in locale), and cased latin1 */
3860 #ifdef USE_LOCALE_CTYPE
3864 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3866 assert(tculen == 2);
3868 /* If the result is an upper Latin1-range character, it can
3869 * still be represented in one byte, which is its ordinal */
3870 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3871 *tmpbuf = (U8) title_ord;
3875 /* Otherwise it became more than one ASCII character (in
3876 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3877 * beyond Latin1, so the number of bytes changed, so can't
3878 * replace just the first character in place. */
3881 /* If the result won't fit in a byte, the entire result
3882 * will have to be in UTF-8. Assume worst case sizing in
3883 * conversion. (all latin1 characters occupy at most two
3885 if (title_ord > 255) {
3887 convert_source_to_utf8 = TRUE;
3888 need = slen * 2 + 1;
3890 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3891 * (both) characters whose title case is above 255 is
3895 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3896 need = slen + 1 + 1;
3900 } /* End of use Unicode (Latin1) semantics */
3901 } /* End of changing the case of the first character */
3903 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3904 * generate the result */
3907 /* We can convert in place. This means we change just the first
3908 * character without disturbing the rest; no need to grow */
3910 s = d = (U8*)SvPV_force_nomg(source, slen);
3916 /* Here, we can't convert in place; we earlier calculated how much
3917 * space we will need, so grow to accommodate that */
3918 SvUPGRADE(dest, SVt_PV);
3919 d = (U8*)SvGROW(dest, need);
3920 (void)SvPOK_only(dest);
3927 if (! convert_source_to_utf8) {
3929 /* Here both source and dest are in UTF-8, but have to create
3930 * the entire output. We initialize the result to be the
3931 * title/lower cased first character, and then append the rest
3933 sv_setpvn(dest, (char*)tmpbuf, tculen);
3935 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3939 const U8 *const send = s + slen;
3941 /* Here the dest needs to be in UTF-8, but the source isn't,
3942 * except we earlier UTF-8'd the first character of the source
3943 * into tmpbuf. First put that into dest, and then append the
3944 * rest of the source, converting it to UTF-8 as we go. */
3946 /* Assert tculen is 2 here because the only two characters that
3947 * get to this part of the code have 2-byte UTF-8 equivalents */
3949 *d++ = *(tmpbuf + 1);
3950 s++; /* We have just processed the 1st char */
3952 for (; s < send; s++) {
3953 d = uvchr_to_utf8(d, *s);
3956 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3960 else { /* in-place UTF-8. Just overwrite the first character */
3961 Copy(tmpbuf, d, tculen, U8);
3962 SvCUR_set(dest, need - 1);
3966 else { /* Neither source nor dest are in or need to be UTF-8 */
3968 if (inplace) { /* in-place, only need to change the 1st char */
3971 else { /* Not in-place */
3973 /* Copy the case-changed character(s) from tmpbuf */
3974 Copy(tmpbuf, d, tculen, U8);
3975 d += tculen - 1; /* Code below expects d to point to final
3976 * character stored */
3979 else { /* empty source */
3980 /* See bug #39028: Don't taint if empty */
3984 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3985 * the destination to retain that flag */
3986 if (SvUTF8(source) && ! IN_BYTES)
3989 if (!inplace) { /* Finish the rest of the string, unchanged */
3990 /* This will copy the trailing NUL */
3991 Copy(s + 1, d + 1, slen, U8);
3992 SvCUR_set(dest, need - 1);
3995 #ifdef USE_LOCALE_CTYPE
3996 if (IN_LC_RUNTIME(LC_CTYPE)) {
4001 if (dest != source && SvTAINTED(source))
4007 /* There's so much setup/teardown code common between uc and lc, I wonder if
4008 it would be worth merging the two, and just having a switch outside each
4009 of the three tight loops. There is less and less commonality though */
4022 if ( SvPADTMP(source)
4023 && !SvREADONLY(source) && SvPOK(source)
4026 #ifdef USE_LOCALE_CTYPE
4027 (IN_LC_RUNTIME(LC_CTYPE))
4028 ? ! IN_UTF8_CTYPE_LOCALE
4034 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4035 * make the loop tight, so we overwrite the source with the dest before
4036 * looking at it, and we need to look at the original source
4037 * afterwards. There would also need to be code added to handle
4038 * switching to not in-place in midstream if we run into characters
4039 * that change the length. Since being in locale overrides UNI_8_BIT,
4040 * that latter becomes irrelevant in the above test; instead for
4041 * locale, the size can't normally change, except if the locale is a
4044 s = d = (U8*)SvPV_force_nomg(source, len);
4051 s = (const U8*)SvPV_nomg_const(source, len);
4054 SvUPGRADE(dest, SVt_PV);
4055 d = (U8*)SvGROW(dest, min);
4056 (void)SvPOK_only(dest);
4061 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4062 to check DO_UTF8 again here. */
4064 if (DO_UTF8(source)) {
4065 const U8 *const send = s + len;
4066 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4068 /* All occurrences of these are to be moved to follow any other marks.
4069 * This is context-dependent. We may not be passed enough context to
4070 * move the iota subscript beyond all of them, but we do the best we can
4071 * with what we're given. The result is always better than if we
4072 * hadn't done this. And, the problem would only arise if we are
4073 * passed a character without all its combining marks, which would be
4074 * the caller's mistake. The information this is based on comes from a
4075 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4076 * itself) and so can't be checked properly to see if it ever gets
4077 * revised. But the likelihood of it changing is remote */
4078 bool in_iota_subscript = FALSE;
4084 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4086 /* A non-mark. Time to output the iota subscript */
4087 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4088 d += capital_iota_len;
4089 in_iota_subscript = FALSE;
4092 /* Then handle the current character. Get the changed case value
4093 * and copy it to the output buffer */
4096 #ifdef USE_LOCALE_CTYPE
4097 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4099 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4101 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4102 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4103 if (uv == GREEK_CAPITAL_LETTER_IOTA
4104 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4106 in_iota_subscript = TRUE;
4109 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4110 /* If the eventually required minimum size outgrows the
4111 * available space, we need to grow. */
4112 const UV o = d - (U8*)SvPVX_const(dest);
4114 /* If someone uppercases one million U+03B0s we SvGROW()
4115 * one million times. Or we could try guessing how much to
4116 * allocate without allocating too much. Such is life.
4117 * See corresponding comment in lc code for another option
4120 d = (U8*)SvPVX(dest) + o;
4122 Copy(tmpbuf, d, ulen, U8);
4127 if (in_iota_subscript) {
4128 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4129 d += capital_iota_len;
4134 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4136 else { /* Not UTF-8 */
4138 const U8 *const send = s + len;
4140 /* Use locale casing if in locale; regular style if not treating
4141 * latin1 as having case; otherwise the latin1 casing. Do the
4142 * whole thing in a tight loop, for speed, */
4143 #ifdef USE_LOCALE_CTYPE
4144 if (IN_LC_RUNTIME(LC_CTYPE)) {
4145 if (IN_UTF8_CTYPE_LOCALE) {
4148 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4149 for (; s < send; d++, s++)
4150 *d = (U8) toUPPER_LC(*s);
4154 if (! IN_UNI_8_BIT) {
4155 for (; s < send; d++, s++) {
4160 #ifdef USE_LOCALE_CTYPE
4163 for (; s < send; d++, s++) {
4164 *d = toUPPER_LATIN1_MOD(*s);
4165 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4169 /* The mainstream case is the tight loop above. To avoid
4170 * extra tests in that, all three characters that require
4171 * special handling are mapped by the MOD to the one tested
4173 * Use the source to distinguish between the three cases */
4175 #if UNICODE_MAJOR_VERSION > 2 \
4176 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4177 && UNICODE_DOT_DOT_VERSION >= 8)
4178 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4180 /* uc() of this requires 2 characters, but they are
4181 * ASCII. If not enough room, grow the string */
4182 if (SvLEN(dest) < ++min) {
4183 const UV o = d - (U8*)SvPVX_const(dest);
4185 d = (U8*)SvPVX(dest) + o;
4187 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4188 continue; /* Back to the tight loop; still in ASCII */
4192 /* The other two special handling characters have their
4193 * upper cases outside the latin1 range, hence need to be
4194 * in UTF-8, so the whole result needs to be in UTF-8. So,
4195 * here we are somewhere in the middle of processing a
4196 * non-UTF-8 string, and realize that we will have to convert
4197 * the whole thing to UTF-8. What to do? There are
4198 * several possibilities. The simplest to code is to
4199 * convert what we have so far, set a flag, and continue on
4200 * in the loop. The flag would be tested each time through
4201 * the loop, and if set, the next character would be
4202 * converted to UTF-8 and stored. But, I (khw) didn't want
4203 * to slow down the mainstream case at all for this fairly
4204 * rare case, so I didn't want to add a test that didn't
4205 * absolutely have to be there in the loop, besides the
4206 * possibility that it would get too complicated for
4207 * optimizers to deal with. Another possibility is to just
4208 * give up, convert the source to UTF-8, and restart the
4209 * function that way. Another possibility is to convert
4210 * both what has already been processed and what is yet to
4211 * come separately to UTF-8, then jump into the loop that
4212 * handles UTF-8. But the most efficient time-wise of the
4213 * ones I could think of is what follows, and turned out to
4214 * not require much extra code. */
4216 /* Convert what we have so far into UTF-8, telling the
4217 * function that we know it should be converted, and to
4218 * allow extra space for what we haven't processed yet.
4219 * Assume the worst case space requirements for converting
4220 * what we haven't processed so far: that it will require
4221 * two bytes for each remaining source character, plus the
4222 * NUL at the end. This may cause the string pointer to
4223 * move, so re-find it. */
4225 len = d - (U8*)SvPVX_const(dest);
4226 SvCUR_set(dest, len);
4227 len = sv_utf8_upgrade_flags_grow(dest,
4228 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4230 d = (U8*)SvPVX(dest) + len;
4232 /* Now process the remainder of the source, converting to
4233 * upper and UTF-8. If a resulting byte is invariant in
4234 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4235 * append it to the output. */
4236 for (; s < send; s++) {
4237 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4241 /* Here have processed the whole source; no need to continue
4242 * with the outer loop. Each character has been converted
4243 * to upper case and converted to UTF-8 */
4246 } /* End of processing all latin1-style chars */
4247 } /* End of processing all chars */
4248 } /* End of source is not empty */
4250 if (source != dest) {
4251 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4252 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4254 } /* End of isn't utf8 */
4255 #ifdef USE_LOCALE_CTYPE
4256 if (IN_LC_RUNTIME(LC_CTYPE)) {
4261 if (dest != source && SvTAINTED(source))
4279 if ( SvPADTMP(source)
4280 && !SvREADONLY(source) && SvPOK(source)
4281 && !DO_UTF8(source)) {
4283 /* We can convert in place, as lowercasing anything in the latin1 range
4284 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4286 s = d = (U8*)SvPV_force_nomg(source, len);
4293 s = (const U8*)SvPV_nomg_const(source, len);
4296 SvUPGRADE(dest, SVt_PV);
4297 d = (U8*)SvGROW(dest, min);
4298 (void)SvPOK_only(dest);
4303 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4304 to check DO_UTF8 again here. */
4306 if (DO_UTF8(source)) {
4307 const U8 *const send = s + len;
4308 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4311 const STRLEN u = UTF8SKIP(s);
4314 #ifdef USE_LOCALE_CTYPE
4315 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4317 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4320 /* Here is where we would do context-sensitive actions. See the
4321 * commit message for 86510fb15 for why there isn't any */
4323 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4325 /* If the eventually required minimum size outgrows the
4326 * available space, we need to grow. */
4327 const UV o = d - (U8*)SvPVX_const(dest);
4329 /* If someone lowercases one million U+0130s we SvGROW() one
4330 * million times. Or we could try guessing how much to
4331 * allocate without allocating too much. Such is life.
4332 * Another option would be to grow an extra byte or two more
4333 * each time we need to grow, which would cut down the million
4334 * to 500K, with little waste */
4336 d = (U8*)SvPVX(dest) + o;
4339 /* Copy the newly lowercased letter to the output buffer we're
4341 Copy(tmpbuf, d, ulen, U8);
4344 } /* End of looping through the source string */
4347 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4348 } else { /* Not utf8 */
4350 const U8 *const send = s + len;
4352 /* Use locale casing if in locale; regular style if not treating
4353 * latin1 as having case; otherwise the latin1 casing. Do the
4354 * whole thing in a tight loop, for speed, */
4355 #ifdef USE_LOCALE_CTYPE
4356 if (IN_LC_RUNTIME(LC_CTYPE)) {
4357 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4358 for (; s < send; d++, s++)
4359 *d = toLOWER_LC(*s);
4363 if (! IN_UNI_8_BIT) {
4364 for (; s < send; d++, s++) {
4369 for (; s < send; d++, s++) {
4370 *d = toLOWER_LATIN1(*s);
4374 if (source != dest) {
4376 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4379 #ifdef USE_LOCALE_CTYPE
4380 if (IN_LC_RUNTIME(LC_CTYPE)) {
4385 if (dest != source && SvTAINTED(source))
4394 SV * const sv = TOPs;
4396 const char *s = SvPV_const(sv,len);
4398 SvUTF8_off(TARG); /* decontaminate */
4401 SvUPGRADE(TARG, SVt_PV);
4402 SvGROW(TARG, (len * 2) + 1);
4406 STRLEN ulen = UTF8SKIP(s);
4407 bool to_quote = FALSE;
4409 if (UTF8_IS_INVARIANT(*s)) {
4410 if (_isQUOTEMETA(*s)) {
4414 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4416 #ifdef USE_LOCALE_CTYPE
4417 /* In locale, we quote all non-ASCII Latin1 chars.
4418 * Otherwise use the quoting rules */
4420 IN_LC_RUNTIME(LC_CTYPE)
4423 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4428 else if (is_QUOTEMETA_high(s)) {
4443 else if (IN_UNI_8_BIT) {
4445 if (_isQUOTEMETA(*s))
4451 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4452 * including everything above ASCII */
4454 if (!isWORDCHAR_A(*s))
4460 SvCUR_set(TARG, d - SvPVX_const(TARG));
4461 (void)SvPOK_only_UTF8(TARG);
4464 sv_setpvn(TARG, s, len);
4480 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4481 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4482 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4483 || UNICODE_DOT_DOT_VERSION > 0)
4484 const bool full_folding = TRUE; /* This variable is here so we can easily
4485 move to more generality later */
4487 const bool full_folding = FALSE;
4489 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4490 #ifdef USE_LOCALE_CTYPE
4491 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4495 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4496 * You are welcome(?) -Hugmeir
4504 s = (const U8*)SvPV_nomg_const(source, len);
4506 if (ckWARN(WARN_UNINITIALIZED))
4507 report_uninit(source);
4514 SvUPGRADE(dest, SVt_PV);
4515 d = (U8*)SvGROW(dest, min);
4516 (void)SvPOK_only(dest);
4521 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4523 const STRLEN u = UTF8SKIP(s);
4526 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4528 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4529 const UV o = d - (U8*)SvPVX_const(dest);
4531 d = (U8*)SvPVX(dest) + o;
4534 Copy(tmpbuf, d, ulen, U8);
4539 } /* Unflagged string */
4541 #ifdef USE_LOCALE_CTYPE
4542 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4543 if (IN_UTF8_CTYPE_LOCALE) {
4544 goto do_uni_folding;
4546 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4547 for (; s < send; d++, s++)
4548 *d = (U8) toFOLD_LC(*s);
4552 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4553 for (; s < send; d++, s++)
4557 #ifdef USE_LOCALE_CTYPE
4560 /* For ASCII and the Latin-1 range, there's only two troublesome
4561 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4562 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4563 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4564 * For the rest, the casefold is their lowercase. */
4565 for (; s < send; d++, s++) {
4566 if (*s == MICRO_SIGN) {
4567 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4568 * which is outside of the latin-1 range. There's a couple
4569 * of ways to deal with this -- khw discusses them in
4570 * pp_lc/uc, so go there :) What we do here is upgrade what
4571 * we had already casefolded, then enter an inner loop that
4572 * appends the rest of the characters as UTF-8. */
4573 len = d - (U8*)SvPVX_const(dest);
4574 SvCUR_set(dest, len);
4575 len = sv_utf8_upgrade_flags_grow(dest,
4576 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4577 /* The max expansion for latin1
4578 * chars is 1 byte becomes 2 */
4580 d = (U8*)SvPVX(dest) + len;
4582 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4585 for (; s < send; s++) {
4587 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4588 if UVCHR_IS_INVARIANT(fc) {
4590 && *s == LATIN_SMALL_LETTER_SHARP_S)
4599 Copy(tmpbuf, d, ulen, U8);
4605 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4606 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4607 * becomes "ss", which may require growing the SV. */
4608 if (SvLEN(dest) < ++min) {
4609 const UV o = d - (U8*)SvPVX_const(dest);
4611 d = (U8*)SvPVX(dest) + o;
4616 else { /* If it's not one of those two, the fold is their lower
4618 *d = toLOWER_LATIN1(*s);
4624 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4626 #ifdef USE_LOCALE_CTYPE
4627 if (IN_LC_RUNTIME(LC_CTYPE)) {
4632 if (SvTAINTED(source))
4642 dSP; dMARK; dORIGMARK;
4643 AV *const av = MUTABLE_AV(POPs);
4644 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4646 if (SvTYPE(av) == SVt_PVAV) {
4647 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4648 bool can_preserve = FALSE;
4654 can_preserve = SvCANEXISTDELETE(av);
4657 if (lval && localizing) {
4660 for (svp = MARK + 1; svp <= SP; svp++) {
4661 const SSize_t elem = SvIV(*svp);
4665 if (max > AvMAX(av))
4669 while (++MARK <= SP) {
4671 SSize_t elem = SvIV(*MARK);
4672 bool preeminent = TRUE;
4674 if (localizing && can_preserve) {
4675 /* If we can determine whether the element exist,
4676 * Try to preserve the existenceness of a tied array
4677 * element by using EXISTS and DELETE if possible.
4678 * Fallback to FETCH and STORE otherwise. */
4679 preeminent = av_exists(av, elem);
4682 svp = av_fetch(av, elem, lval);
4685 DIE(aTHX_ PL_no_aelem, elem);
4688 save_aelem(av, elem, svp);
4690 SAVEADELETE(av, elem);
4693 *MARK = svp ? *svp : &PL_sv_undef;
4696 if (GIMME_V != G_ARRAY) {
4698 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4707 AV *const av = MUTABLE_AV(POPs);
4708 I32 lval = (PL_op->op_flags & OPf_MOD);
4709 SSize_t items = SP - MARK;
4711 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4712 const I32 flags = is_lvalue_sub();
4714 if (!(flags & OPpENTERSUB_INARGS))
4715 /* diag_listed_as: Can't modify %s in %s */
4716 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4723 *(MARK+items*2-1) = *(MARK+items);
4729 while (++MARK <= SP) {
4732 svp = av_fetch(av, SvIV(*MARK), lval);
4734 if (!svp || !*svp || *svp == &PL_sv_undef) {
4735 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4737 *MARK = sv_mortalcopy(*MARK);
4739 *++MARK = svp ? *svp : &PL_sv_undef;
4741 if (GIMME_V != G_ARRAY) {
4742 MARK = SP - items*2;
4743 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4753 AV *array = MUTABLE_AV(POPs);
4754 const U8 gimme = GIMME_V;
4755 IV *iterp = Perl_av_iter_p(aTHX_ array);
4756 const IV current = (*iterp)++;
4758 if (current > av_tindex(array)) {
4760 if (gimme == G_SCALAR)
4768 if (gimme == G_ARRAY) {
4769 SV **const element = av_fetch(array, current, 0);
4770 PUSHs(element ? *element : &PL_sv_undef);
4775 /* also used for: pp_avalues()*/
4779 AV *array = MUTABLE_AV(POPs);
4780 const U8 gimme = GIMME_V;
4782 *Perl_av_iter_p(aTHX_ array) = 0;
4784 if (gimme == G_SCALAR) {
4786 PUSHi(av_tindex(array) + 1);
4788 else if (gimme == G_ARRAY) {
4789 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4790 const I32 flags = is_lvalue_sub();
4791 if (flags && !(flags & OPpENTERSUB_INARGS))
4792 /* diag_listed_as: Can't modify %s in %s */
4794 "Can't modify keys on array in list assignment");
4797 IV n = Perl_av_len(aTHX_ array);
4802 if ( PL_op->op_type == OP_AKEYS
4803 || ( PL_op->op_type == OP_AVHVSWITCH
4804 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
4806 for (i = 0; i <= n; i++) {
4811 for (i = 0; i <= n; i++) {
4812 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4813 PUSHs(elem ? *elem : &PL_sv_undef);
4821 /* Associative arrays. */
4826 HV * hash = MUTABLE_HV(POPs);
4828 const U8 gimme = GIMME_V;
4830 entry = hv_iternext(hash);
4834 SV* const sv = hv_iterkeysv(entry);
4836 if (gimme == G_ARRAY) {
4838 val = hv_iterval(hash, entry);
4842 else if (gimme == G_SCALAR)
4849 S_do_delete_local(pTHX)
4852 const U8 gimme = GIMME_V;
4855 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4856 SV **unsliced_keysv = sliced ? NULL : sp--;
4857 SV * const osv = POPs;
4858 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4860 const bool tied = SvRMAGICAL(osv)
4861 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4862 const bool can_preserve = SvCANEXISTDELETE(osv);
4863 const U32 type = SvTYPE(osv);
4864 SV ** const end = sliced ? SP : unsliced_keysv;
4866 if (type == SVt_PVHV) { /* hash element */
4867 HV * const hv = MUTABLE_HV(osv);
4868 while (++MARK <= end) {
4869 SV * const keysv = *MARK;
4871 bool preeminent = TRUE;
4873 preeminent = hv_exists_ent(hv, keysv, 0);
4875 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4882 sv = hv_delete_ent(hv, keysv, 0, 0);
4884 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4887 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4888 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4890 *MARK = sv_mortalcopy(sv);
4896 SAVEHDELETE(hv, keysv);
4897 *MARK = &PL_sv_undef;
4901 else if (type == SVt_PVAV) { /* array element */
4902 if (PL_op->op_flags & OPf_SPECIAL) {
4903 AV * const av = MUTABLE_AV(osv);
4904 while (++MARK <= end) {
4905 SSize_t idx = SvIV(*MARK);
4907 bool preeminent = TRUE;
4909 preeminent = av_exists(av, idx);
4911 SV **svp = av_fetch(av, idx, 1);
4918 sv = av_delete(av, idx, 0);
4920 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4923 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4925 *MARK = sv_mortalcopy(sv);
4931 SAVEADELETE(av, idx);
4932 *MARK = &PL_sv_undef;
4937 DIE(aTHX_ "panic: avhv_delete no longer supported");
4940 DIE(aTHX_ "Not a HASH reference");
4942 if (gimme == G_VOID)
4944 else if (gimme == G_SCALAR) {
4949 *++MARK = &PL_sv_undef;
4953 else if (gimme != G_VOID)
4954 PUSHs(*unsliced_keysv);
4965 if (PL_op->op_private & OPpLVAL_INTRO)
4966 return do_delete_local();
4969 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4971 if (PL_op->op_private & OPpSLICE) {
4973 HV * const hv = MUTABLE_HV(POPs);
4974 const U32 hvtype = SvTYPE(hv);
4975 if (hvtype == SVt_PVHV) { /* hash element */
4976 while (++MARK <= SP) {
4977 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4978 *MARK = sv ? sv : &PL_sv_undef;
4981 else if (hvtype == SVt_PVAV) { /* array element */
4982 if (PL_op->op_flags & OPf_SPECIAL) {
4983 while (++MARK <= SP) {
4984 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4985 *MARK = sv ? sv : &PL_sv_undef;
4990 DIE(aTHX_ "Not a HASH reference");
4993 else if (gimme == G_SCALAR) {
4998 *++MARK = &PL_sv_undef;
5004 HV * const hv = MUTABLE_HV(POPs);
5006 if (SvTYPE(hv) == SVt_PVHV)
5007 sv = hv_delete_ent(hv, keysv, discard, 0);
5008 else if (SvTYPE(hv) == SVt_PVAV) {
5009 if (PL_op->op_flags & OPf_SPECIAL)
5010 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5012 DIE(aTHX_ "panic: avhv_delete no longer supported");
5015 DIE(aTHX_ "Not a HASH reference");
5030 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5032 SV * const sv = POPs;
5033 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5036 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5041 hv = MUTABLE_HV(POPs);
5042 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5043 if (hv_exists_ent(hv, tmpsv, 0))
5046 else if (SvTYPE(hv) == SVt_PVAV) {
5047 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5048 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5053 DIE(aTHX_ "Not a HASH reference");
5060 dSP; dMARK; dORIGMARK;
5061 HV * const hv = MUTABLE_HV(POPs);
5062 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5063 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5064 bool can_preserve = FALSE;
5070 if (SvCANEXISTDELETE(hv))
5071 can_preserve = TRUE;
5074 while (++MARK <= SP) {
5075 SV * const keysv = *MARK;
5078 bool preeminent = TRUE;
5080 if (localizing && can_preserve) {
5081 /* If we can determine whether the element exist,
5082 * try to preserve the existenceness of a tied hash
5083 * element by using EXISTS and DELETE if possible.
5084 * Fallback to FETCH and STORE otherwise. */
5085 preeminent = hv_exists_ent(hv, keysv, 0);
5088 he = hv_fetch_ent(hv, keysv, lval, 0);
5089 svp = he ? &HeVAL(he) : NULL;
5092 if (!svp || !*svp || *svp == &PL_sv_undef) {
5093 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5096 if (HvNAME_get(hv) && isGV(*svp))
5097 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5098 else if (preeminent)
5099 save_helem_flags(hv, keysv, svp,
5100 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5102 SAVEHDELETE(hv, keysv);
5105 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5107 if (GIMME_V != G_ARRAY) {
5109 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5118 HV * const hv = MUTABLE_HV(POPs);
5119 I32 lval = (PL_op->op_flags & OPf_MOD);
5120 SSize_t items = SP - MARK;
5122 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5123 const I32 flags = is_lvalue_sub();
5125 if (!(flags & OPpENTERSUB_INARGS))
5126 /* diag_listed_as: Can't modify %s in %s */
5127 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5128 GIMME_V == G_ARRAY ? "list" : "scalar");
5135 *(MARK+items*2-1) = *(MARK+items);
5141 while (++MARK <= SP) {
5142 SV * const keysv = *MARK;
5146 he = hv_fetch_ent(hv, keysv, lval, 0);
5147 svp = he ? &HeVAL(he) : NULL;
5150 if (!svp || !*svp || *svp == &PL_sv_undef) {
5151 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5153 *MARK = sv_mortalcopy(*MARK);
5155 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5157 if (GIMME_V != G_ARRAY) {
5158 MARK = SP - items*2;
5159 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5165 /* List operators. */
5169 I32 markidx = POPMARK;
5170 if (GIMME_V != G_ARRAY) {
5171 SV **mark = PL_stack_base + markidx;
5174 *MARK = *SP; /* unwanted list, return last item */
5176 *MARK = &PL_sv_undef;
5186 SV ** const lastrelem = PL_stack_sp;
5187 SV ** const lastlelem = PL_stack_base + POPMARK;
5188 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5189 SV ** const firstrelem = lastlelem + 1;
5190 const U8 mod = PL_op->op_flags & OPf_MOD;
5192 const I32 max = lastrelem - lastlelem;
5195 if (GIMME_V != G_ARRAY) {
5196 if (lastlelem < firstlelem) {
5197 *firstlelem = &PL_sv_undef;
5200 I32 ix = SvIV(*lastlelem);
5203 if (ix < 0 || ix >= max)
5204 *firstlelem = &PL_sv_undef;
5206 *firstlelem = firstrelem[ix];
5213 SP = firstlelem - 1;
5217 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5218 I32 ix = SvIV(*lelem);
5221 if (ix < 0 || ix >= max)
5222 *lelem = &PL_sv_undef;
5224 if (!(*lelem = firstrelem[ix]))
5225 *lelem = &PL_sv_undef;
5226 else if (mod && SvPADTMP(*lelem)) {
5227 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5238 const I32 items = SP - MARK;
5239 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5241 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5242 ? newRV_noinc(av) : av);
5248 dSP; dMARK; dORIGMARK;
5249 HV* const hv = newHV();
5250 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5251 ? newRV_noinc(MUTABLE_SV(hv))
5256 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5263 sv_setsv_nomg(val, *MARK);
5267 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5270 (void)hv_store_ent(hv,key,val,0);
5279 dSP; dMARK; dORIGMARK;
5280 int num_args = (SP - MARK);
5281 AV *ary = MUTABLE_AV(*++MARK);
5290 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5293 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5294 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5301 offset = i = SvIV(*MARK);
5303 offset += AvFILLp(ary) + 1;
5305 DIE(aTHX_ PL_no_aelem, i);
5307 length = SvIVx(*MARK++);
5309 length += AvFILLp(ary) - offset + 1;
5315 length = AvMAX(ary) + 1; /* close enough to infinity */
5319 length = AvMAX(ary) + 1;
5321 if (offset > AvFILLp(ary) + 1) {
5323 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5324 offset = AvFILLp(ary) + 1;
5326 after = AvFILLp(ary) + 1 - (offset + length);
5327 if (after < 0) { /* not that much array */
5328 length += after; /* offset+length now in array */
5334 /* At this point, MARK .. SP-1 is our new LIST */
5337 diff = newlen - length;
5338 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5341 /* make new elements SVs now: avoid problems if they're from the array */
5342 for (dst = MARK, i = newlen; i; i--) {
5343 SV * const h = *dst;
5344 *dst++ = newSVsv(h);
5347 if (diff < 0) { /* shrinking the area */
5348 SV **tmparyval = NULL;
5350 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5351 Copy(MARK, tmparyval, newlen, SV*);
5354 MARK = ORIGMARK + 1;
5355 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5356 const bool real = cBOOL(AvREAL(ary));
5357 MEXTEND(MARK, length);
5359 EXTEND_MORTAL(length);
5360 for (i = 0, dst = MARK; i < length; i++) {
5361 if ((*dst = AvARRAY(ary)[i+offset])) {
5363 sv_2mortal(*dst); /* free them eventually */
5366 *dst = &PL_sv_undef;
5372 *MARK = AvARRAY(ary)[offset+length-1];
5375 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5376 SvREFCNT_dec(*dst++); /* free them now */
5379 AvFILLp(ary) += diff;
5381 /* pull up or down? */
5383 if (offset < after) { /* easier to pull up */
5384 if (offset) { /* esp. if nothing to pull */
5385 src = &AvARRAY(ary)[offset-1];
5386 dst = src - diff; /* diff is negative */
5387 for (i = offset; i > 0; i--) /* can't trust Copy */
5391 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5395 if (after) { /* anything to pull down? */
5396 src = AvARRAY(ary) + offset + length;
5397 dst = src + diff; /* diff is negative */
5398 Move(src, dst, after, SV*);
5400 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5401 /* avoid later double free */
5408 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5409 Safefree(tmparyval);
5412 else { /* no, expanding (or same) */
5413 SV** tmparyval = NULL;
5415 Newx(tmparyval, length, SV*); /* so remember deletion */
5416 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5419 if (diff > 0) { /* expanding */
5420 /* push up or down? */
5421 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5425 Move(src, dst, offset, SV*);
5427 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5429 AvFILLp(ary) += diff;
5432 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5433 av_extend(ary, AvFILLp(ary) + diff);
5434 AvFILLp(ary) += diff;
5437 dst = AvARRAY(ary) + AvFILLp(ary);
5439 for (i = after; i; i--) {
5447 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5450 MARK = ORIGMARK + 1;
5451 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5453 const bool real = cBOOL(AvREAL(ary));
5455 EXTEND_MORTAL(length);
5456 for (i = 0, dst = MARK; i < length; i++) {
5457 if ((*dst = tmparyval[i])) {
5459 sv_2mortal(*dst); /* free them eventually */
5461 else *dst = &PL_sv_undef;
5467 else if (length--) {
5468 *MARK = tmparyval[length];
5471 while (length-- > 0)
5472 SvREFCNT_dec(tmparyval[length]);
5476 *MARK = &PL_sv_undef;
5477 Safefree(tmparyval);
5481 mg_set(MUTABLE_SV(ary));
5489 dSP; dMARK; dORIGMARK; dTARGET;
5490 AV * const ary = MUTABLE_AV(*++MARK);
5491 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5494 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5497 ENTER_with_name("call_PUSH");
5498 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5499 LEAVE_with_name("call_PUSH");
5500 /* SPAGAIN; not needed: SP is assigned to immediately below */
5503 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5504 * only need to save locally, not on the save stack */
5505 U16 old_delaymagic = PL_delaymagic;
5507 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5508 PL_delaymagic = DM_DELAY;
5509 for (++MARK; MARK <= SP; MARK++) {
5511 if (*MARK) SvGETMAGIC(*MARK);
5514 sv_setsv_nomg(sv, *MARK);
5515 av_store(ary, AvFILLp(ary)+1, sv);
5517 if (PL_delaymagic & DM_ARRAY_ISA)
5518 mg_set(MUTABLE_SV(ary));
5519 PL_delaymagic = old_delaymagic;
5522 if (OP_GIMME(PL_op, 0) != G_VOID) {
5523 PUSHi( AvFILL(ary) + 1 );
5528 /* also used for: pp_pop()*/
5532 AV * const av = PL_op->op_flags & OPf_SPECIAL
5533 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5534 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5538 (void)sv_2mortal(sv);
5545 dSP; dMARK; dORIGMARK; dTARGET;
5546 AV *ary = MUTABLE_AV(*++MARK);
5547 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5550 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5553 ENTER_with_name("call_UNSHIFT");
5554 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5555 LEAVE_with_name("call_UNSHIFT");
5556 /* SPAGAIN; not needed: SP is assigned to immediately below */
5559 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5560 * only need to save locally, not on the save stack */
5561 U16 old_delaymagic = PL_delaymagic;
5564 av_unshift(ary, SP - MARK);
5565 PL_delaymagic = DM_DELAY;
5567 SV * const sv = newSVsv(*++MARK);
5568 (void)av_store(ary, i++, sv);
5570 if (PL_delaymagic & DM_ARRAY_ISA)
5571 mg_set(MUTABLE_SV(ary));
5572 PL_delaymagic = old_delaymagic;
5575 if (OP_GIMME(PL_op, 0) != G_VOID) {
5576 PUSHi( AvFILL(ary) + 1 );
5585 if (GIMME_V == G_ARRAY) {
5586 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5590 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5591 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5592 av = MUTABLE_AV((*SP));
5593 /* In-place reversing only happens in void context for the array
5594 * assignment. We don't need to push anything on the stack. */
5597 if (SvMAGICAL(av)) {
5599 SV *tmp = sv_newmortal();
5600 /* For SvCANEXISTDELETE */
5603 bool can_preserve = SvCANEXISTDELETE(av);
5605 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5609 if (!av_exists(av, i)) {
5610 if (av_exists(av, j)) {
5611 SV *sv = av_delete(av, j, 0);
5612 begin = *av_fetch(av, i, TRUE);
5613 sv_setsv_mg(begin, sv);
5617 else if (!av_exists(av, j)) {
5618 SV *sv = av_delete(av, i, 0);
5619 end = *av_fetch(av, j, TRUE);
5620 sv_setsv_mg(end, sv);
5625 begin = *av_fetch(av, i, TRUE);
5626 end = *av_fetch(av, j, TRUE);
5627 sv_setsv(tmp, begin);
5628 sv_setsv_mg(begin, end);
5629 sv_setsv_mg(end, tmp);
5633 SV **begin = AvARRAY(av);
5636 SV **end = begin + AvFILLp(av);
5638 while (begin < end) {
5639 SV * const tmp = *begin;
5650 SV * const tmp = *MARK;
5654 /* safe as long as stack cannot get extended in the above */
5665 SvUTF8_off(TARG); /* decontaminate */
5667 do_join(TARG, &PL_sv_no, MARK, SP);
5669 sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5672 up = SvPV_force(TARG, len);
5674 if (DO_UTF8(TARG)) { /* first reverse each character */
5675 U8* s = (U8*)SvPVX(TARG);
5676 const U8* send = (U8*)(s + len);
5678 if (UTF8_IS_INVARIANT(*s)) {
5683 if (!utf8_to_uvchr_buf(s, send, 0))
5687 down = (char*)(s - 1);
5688 /* reverse this character */
5692 *down-- = (char)tmp;
5698 down = SvPVX(TARG) + len - 1;
5702 *down-- = (char)tmp;
5704 (void)SvPOK_only_UTF8(TARG);
5715 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5716 IV limit = POPi; /* note, negative is forever */
5717 SV * const sv = POPs;
5719 const char *s = SvPV_const(sv, len);
5720 const bool do_utf8 = DO_UTF8(sv);
5721 const char *strend = s + len;
5727 const STRLEN slen = do_utf8
5728 ? utf8_length((U8*)s, (U8*)strend)
5729 : (STRLEN)(strend - s);
5730 SSize_t maxiters = slen + 10;
5731 I32 trailing_empty = 0;
5733 const IV origlimit = limit;
5736 const U8 gimme = GIMME_V;
5738 const I32 oldsave = PL_savestack_ix;
5739 U32 make_mortal = SVs_TEMP;
5744 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5749 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5752 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5753 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5756 if (pm->op_pmreplrootu.op_pmtargetoff) {
5757 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5761 if (pm->op_pmreplrootu.op_pmtargetgv) {
5762 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5766 else if (pm->op_targ)
5767 ary = (AV *)PAD_SVl(pm->op_targ);
5773 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5776 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5778 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5785 for (i = AvFILLp(ary); i >= 0; i--)
5786 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5788 /* temporarily switch stacks */
5789 SAVESWITCHSTACK(PL_curstack, ary);
5793 base = SP - PL_stack_base;
5795 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5797 while (isSPACE_utf8(s))
5800 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5801 while (isSPACE_LC(*s))
5809 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5813 gimme_scalar = gimme == G_SCALAR && !ary;
5816 limit = maxiters + 2;
5817 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5820 /* this one uses 'm' and is a negative test */
5822 while (m < strend && ! isSPACE_utf8(m) ) {
5823 const int t = UTF8SKIP(m);
5824 /* isSPACE_utf8 returns FALSE for malform utf8 */
5831 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5833 while (m < strend && !isSPACE_LC(*m))
5836 while (m < strend && !isSPACE(*m))
5849 dstr = newSVpvn_flags(s, m-s,
5850 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5854 /* skip the whitespace found last */
5856 s = m + UTF8SKIP(m);
5860 /* this one uses 's' and is a positive test */
5862 while (s < strend && isSPACE_utf8(s) )
5865 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5867 while (s < strend && isSPACE_LC(*s))
5870 while (s < strend && isSPACE(*s))
5875 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5877 for (m = s; m < strend && *m != '\n'; m++)
5890 dstr = newSVpvn_flags(s, m-s,
5891 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5897 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5899 Pre-extend the stack, either the number of bytes or
5900 characters in the string or a limited amount, triggered by:
5902 my ($x, $y) = split //, $str;
5906 if (!gimme_scalar) {
5907 const IV items = limit - 1;
5908 /* setting it to -1 will trigger a panic in EXTEND() */
5909 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
5910 if (items >=0 && items < sslen)
5918 /* keep track of how many bytes we skip over */
5928 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5941 dstr = newSVpvn(s, 1);
5957 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5958 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5959 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5960 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5961 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5962 SV * const csv = CALLREG_INTUIT_STRING(rx);
5964 len = RX_MINLENRET(rx);
5965 if (len == 1 && !RX_UTF8(rx) && !tail) {
5966 const char c = *SvPV_nolen_const(csv);
5968 for (m = s; m < strend && *m != c; m++)
5979 dstr = newSVpvn_flags(s, m-s,
5980 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5983 /* The rx->minlen is in characters but we want to step
5984 * s ahead by bytes. */
5986 s = (char*)utf8_hop((U8*)m, len);
5988 s = m + len; /* Fake \n at the end */
5992 while (s < strend && --limit &&
5993 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5994 csv, multiline ? FBMrf_MULTILINE : 0)) )
6003 dstr = newSVpvn_flags(s, m-s,
6004 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6007 /* The rx->minlen is in characters but we want to step
6008 * s ahead by bytes. */
6010 s = (char*)utf8_hop((U8*)m, len);
6012 s = m + len; /* Fake \n at the end */
6017 maxiters += slen * RX_NPARENS(rx);
6018 while (s < strend && --limit)
6022 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6025 if (rex_return == 0)
6027 TAINT_IF(RX_MATCH_TAINTED(rx));
6028 /* we never pass the REXEC_COPY_STR flag, so it should
6029 * never get copied */
6030 assert(!RX_MATCH_COPIED(rx));
6031 m = RX_OFFS(rx)[0].start + orig;
6040 dstr = newSVpvn_flags(s, m-s,
6041 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6044 if (RX_NPARENS(rx)) {
6046 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6047 s = RX_OFFS(rx)[i].start + orig;
6048 m = RX_OFFS(rx)[i].end + orig;
6050 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6051 parens that didn't match -- they should be set to
6052 undef, not the empty string */
6060 if (m >= orig && s >= orig) {
6061 dstr = newSVpvn_flags(s, m-s,
6062 (do_utf8 ? SVf_UTF8 : 0)
6066 dstr = &PL_sv_undef; /* undef, not "" */
6072 s = RX_OFFS(rx)[0].end + orig;
6076 if (!gimme_scalar) {
6077 iters = (SP - PL_stack_base) - base;
6079 if (iters > maxiters)
6080 DIE(aTHX_ "Split loop");
6082 /* keep field after final delim? */
6083 if (s < strend || (iters && origlimit)) {
6084 if (!gimme_scalar) {
6085 const STRLEN l = strend - s;
6086 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6091 else if (!origlimit) {
6093 iters -= trailing_empty;
6095 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6096 if (TOPs && !make_mortal)
6098 *SP-- = &PL_sv_undef;
6105 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6109 if (SvSMAGICAL(ary)) {
6111 mg_set(MUTABLE_SV(ary));
6114 if (gimme == G_ARRAY) {
6116 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6123 ENTER_with_name("call_PUSH");
6124 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6125 LEAVE_with_name("call_PUSH");
6127 if (gimme == G_ARRAY) {
6129 /* EXTEND should not be needed - we just popped them */
6131 for (i=0; i < iters; i++) {
6132 SV **svp = av_fetch(ary, i, FALSE);
6133 PUSHs((svp) ? *svp : &PL_sv_undef);
6140 if (gimme == G_ARRAY)
6152 SV *const sv = PAD_SVl(PL_op->op_targ);
6154 if (SvPADSTALE(sv)) {
6157 RETURNOP(cLOGOP->op_other);
6159 RETURNOP(cLOGOP->op_next);
6168 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6169 || SvTYPE(retsv) == SVt_PVCV) {
6170 retsv = refto(retsv);
6177 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
6178 * that aren't implemented on a particular platform */
6180 PP(unimplemented_op)
6182 const Optype op_type = PL_op->op_type;
6183 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6184 with out of range op numbers - it only "special" cases op_custom.
6185 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6186 if we get here for a custom op then that means that the custom op didn't
6187 have an implementation. Given that OP_NAME() looks up the custom op
6188 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6189 registers &PL_unimplemented_op as the address of their custom op.
6190 NULL doesn't generate a useful error message. "custom" does. */
6191 const char *const name = op_type >= OP_max
6192 ? "[out of range]" : PL_op_name[PL_op->op_type];
6193 if(OP_IS_SOCKET(op_type))
6194 DIE(aTHX_ PL_no_sock_func, name);
6195 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6199 S_maybe_unwind_defav(pTHX)
6201 if (CX_CUR()->cx_type & CXp_HASARGS) {
6202 PERL_CONTEXT *cx = CX_CUR();
6204 assert(CxHASARGS(cx));
6206 cx->cx_type &= ~CXp_HASARGS;
6210 /* For sorting out arguments passed to a &CORE:: subroutine */
6214 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6215 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6216 AV * const at_ = GvAV(PL_defgv);
6217 SV **svp = at_ ? AvARRAY(at_) : NULL;
6218 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6219 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6220 bool seen_question = 0;
6221 const char *err = NULL;
6222 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6224 /* Count how many args there are first, to get some idea how far to
6225 extend the stack. */
6227 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6229 if (oa & OA_OPTIONAL) seen_question = 1;
6230 if (!seen_question) minargs++;
6234 if(numargs < minargs) err = "Not enough";
6235 else if(numargs > maxargs) err = "Too many";
6237 /* diag_listed_as: Too many arguments for %s */
6239 "%s arguments for %s", err,
6240 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6243 /* Reset the stack pointer. Without this, we end up returning our own
6244 arguments in list context, in addition to the values we are supposed
6245 to return. nextstate usually does this on sub entry, but we need
6246 to run the next op with the caller's hints, so we cannot have a
6248 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6250 if(!maxargs) RETURN;
6252 /* We do this here, rather than with a separate pushmark op, as it has
6253 to come in between two things this function does (stack reset and
6254 arg pushing). This seems the easiest way to do it. */
6257 (void)Perl_pp_pushmark(aTHX);
6260 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6261 PUTBACK; /* The code below can die in various places. */
6263 oa = PL_opargs[opnum] >> OASHIFT;
6264 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6269 if (!numargs && defgv && whicharg == minargs + 1) {
6272 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6276 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6283 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6286 S_maybe_unwind_defav(aTHX);
6289 PUSHs((SV *)GvAVn(gv));
6292 if (!svp || !*svp || !SvROK(*svp)
6293 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6295 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6296 "Type of arg %d to &CORE::%s must be array reference",
6297 whicharg, PL_op_desc[opnum]
6302 if (!svp || !*svp || !SvROK(*svp)
6303 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6304 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6305 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6307 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6308 "Type of arg %d to &CORE::%s must be hash%s reference",
6309 whicharg, PL_op_desc[opnum],
6310 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6317 if (!numargs) PUSHs(NULL);
6318 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6319 /* no magic here, as the prototype will have added an extra
6320 refgen and we just want what was there before that */
6323 const bool constr = PL_op->op_private & whicharg;
6325 svp && *svp ? *svp : &PL_sv_undef,
6326 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6332 if (!numargs) goto try_defsv;
6334 const bool wantscalar =
6335 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6336 if (!svp || !*svp || !SvROK(*svp)
6337 /* We have to permit globrefs even for the \$ proto, as
6338 *foo is indistinguishable from ${\*foo}, and the proto-
6339 type permits the latter. */
6340 || SvTYPE(SvRV(*svp)) > (
6341 wantscalar ? SVt_PVLV
6342 : opnum == OP_LOCK || opnum == OP_UNDEF
6348 "Type of arg %d to &CORE::%s must be %s",
6349 whicharg, PL_op_name[opnum],
6351 ? "scalar reference"
6352 : opnum == OP_LOCK || opnum == OP_UNDEF
6353 ? "reference to one of [$@%&*]"
6354 : "reference to one of [$@%*]"
6357 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6358 /* Undo @_ localisation, so that sub exit does not undo
6359 part of our undeffing. */
6360 S_maybe_unwind_defav(aTHX);
6365 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6377 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6378 + (PL_op->op_private & 3)
6386 if (PL_op->op_private & OPpOFFBYONE) {
6387 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6389 else cv = find_runcv(NULL);
6390 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6395 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6396 const bool can_preserve)
6398 const SSize_t ix = SvIV(keysv);
6399 if (can_preserve ? av_exists(av, ix) : TRUE) {
6400 SV ** const svp = av_fetch(av, ix, 1);
6402 Perl_croak(aTHX_ PL_no_aelem, ix);
6403 save_aelem(av, ix, svp);
6406 SAVEADELETE(av, ix);
6410 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6411 const bool can_preserve)
6413 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6414 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6415 SV ** const svp = he ? &HeVAL(he) : NULL;
6417 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6418 save_helem_flags(hv, keysv, svp, 0);
6421 SAVEHDELETE(hv, keysv);
6425 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6427 if (type == OPpLVREF_SV) {
6428 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6431 else if (type == OPpLVREF_AV)
6432 /* XXX Inefficient, as it creates a new AV, which we are
6433 about to clobber. */
6436 assert(type == OPpLVREF_HV);
6437 /* XXX Likewise inefficient. */
6446 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6447 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6449 const char *bad = NULL;
6450 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6451 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6454 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6458 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6462 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6466 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6470 /* diag_listed_as: Assigned value is not %s reference */
6471 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6475 switch (left ? SvTYPE(left) : 0) {
6478 SV * const old = PAD_SV(ARGTARG);
6479 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6481 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6483 SAVECLEARSV(PAD_SVl(ARGTARG));
6487 if (PL_op->op_private & OPpLVAL_INTRO) {
6488 S_localise_gv_slot(aTHX_ (GV *)left, type);
6490 gv_setref(left, sv);
6495 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6496 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6497 SvCANEXISTDELETE(left));
6499 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6502 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6504 S_localise_helem_lval(aTHX_ (HV *)left, key,
6505 SvCANEXISTDELETE(left));
6507 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6509 if (PL_op->op_flags & OPf_MOD)
6510 SETs(sv_2mortal(newSVsv(sv)));
6511 /* XXX else can weak references go stale before they are read, e.g.,
6520 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6521 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6522 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6523 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6524 &PL_vtbl_lvref, (char *)elem,
6525 elem ? HEf_SVKEY : (I32)ARGTARG);
6526 mg->mg_private = PL_op->op_private;
6527 if (PL_op->op_private & OPpLVREF_ITER)
6528 mg->mg_flags |= MGf_PERSIST;
6529 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6535 const bool can_preserve = SvCANEXISTDELETE(arg);
6536 if (SvTYPE(arg) == SVt_PVAV)
6537 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6539 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6543 S_localise_gv_slot(aTHX_ (GV *)arg,
6544 PL_op->op_private & OPpLVREF_TYPE);
6546 else if (!(PL_op->op_private & OPpPAD_STATE))
6547 SAVECLEARSV(PAD_SVl(ARGTARG));
6556 AV * const av = (AV *)POPs;
6557 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6558 bool can_preserve = FALSE;
6560 if (UNLIKELY(localizing)) {
6565 can_preserve = SvCANEXISTDELETE(av);
6567 if (SvTYPE(av) == SVt_PVAV) {
6570 for (svp = MARK + 1; svp <= SP; svp++) {
6571 const SSize_t elem = SvIV(*svp);
6575 if (max > AvMAX(av))
6580 while (++MARK <= SP) {
6581 SV * const elemsv = *MARK;
6582 if (SvTYPE(av) == SVt_PVAV)
6583 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6585 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6586 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6587 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6594 if (PL_op->op_flags & OPf_STACKED)
6595 Perl_pp_rv2av(aTHX);
6597 Perl_pp_padav(aTHX);
6601 SETs(0); /* special alias marker that aassign recognises */
6611 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6612 ? CopSTASH(PL_curcop)
6614 NULL, SvREFCNT_inc_simple_NN(sv))));
6619 * ex: set ts=8 sts=4 sw=4 et: