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);
3547 temp = newSVpvn(little_p, llen);
3549 sv_utf8_upgrade(temp);
3551 little_p = SvPV_const(little, llen);
3554 if (SvGAMAGIC(big)) {
3555 /* Life just becomes a lot easier if I use a temporary here.
3556 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3557 will trigger magic and overloading again, as will fbm_instr()
3559 big = newSVpvn_flags(big_p, biglen,
3560 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3563 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3564 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3565 warn on undef, and we've already triggered a warning with the
3566 SvPV_const some lines above. We can't remove that, as we need to
3567 call some SvPV to trigger overloading early and find out if the
3569 This is all getting too messy. The API isn't quite clean enough,
3570 because data access has side effects.
3572 little = newSVpvn_flags(little_p, llen,
3573 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3574 little_p = SvPVX(little);
3578 offset = is_index ? 0 : biglen;
3580 if (big_utf8 && offset > 0)
3581 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3587 else if (offset > (SSize_t)biglen)
3589 if (!(little_p = is_index
3590 ? fbm_instr((unsigned char*)big_p + offset,
3591 (unsigned char*)big_p + biglen, little, 0)
3592 : rninstr(big_p, big_p + offset,
3593 little_p, little_p + llen)))
3596 retval = little_p - big_p;
3597 if (retval > 1 && big_utf8)
3598 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3608 dSP; dMARK; dORIGMARK; dTARGET;
3609 SvTAINTED_off(TARG);
3610 do_sprintf(TARG, SP-MARK, MARK+1);
3611 TAINT_IF(SvTAINTED(TARG));
3623 const U8 *s = (U8*)SvPV_const(argsv, len);
3626 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3640 if (UNLIKELY(SvAMAGIC(top)))
3642 if (UNLIKELY(isinfnansv(top)))
3643 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3645 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3646 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3648 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3649 && SvNV_nomg(top) < 0.0)))
3651 if (ckWARN(WARN_UTF8)) {
3652 if (SvGMAGICAL(top)) {
3653 SV *top2 = sv_newmortal();
3654 sv_setsv_nomg(top2, top);
3657 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3658 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3660 value = UNICODE_REPLACEMENT;
3662 value = SvUV_nomg(top);
3666 SvUPGRADE(TARG,SVt_PV);
3668 if (value > 255 && !IN_BYTES) {
3669 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3670 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3671 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3673 (void)SvPOK_only(TARG);
3682 *tmps++ = (char)value;
3684 (void)SvPOK_only(TARG);
3696 const char *tmps = SvPV_const(left, len);
3698 if (DO_UTF8(left)) {
3699 /* If Unicode, try to downgrade.
3700 * If not possible, croak.
3701 * Yes, we made this up. */
3702 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3704 sv_utf8_downgrade(tsv, FALSE);
3705 tmps = SvPV_const(tsv, len);
3707 # ifdef USE_ITHREADS
3709 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3710 /* This should be threadsafe because in ithreads there is only
3711 * one thread per interpreter. If this would not be true,
3712 * we would need a mutex to protect this malloc. */
3713 PL_reentrant_buffer->_crypt_struct_buffer =
3714 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3715 #if defined(__GLIBC__) || defined(__EMX__)
3716 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3717 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3718 /* work around glibc-2.2.5 bug */
3719 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3723 # endif /* HAS_CRYPT_R */
3724 # endif /* USE_ITHREADS */
3726 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3728 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3735 "The crypt() function is unimplemented due to excessive paranoia.");
3739 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3740 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3743 /* also used for: pp_lcfirst() */
3747 /* Actually is both lcfirst() and ucfirst(). Only the first character
3748 * changes. This means that possibly we can change in-place, ie., just
3749 * take the source and change that one character and store it back, but not
3750 * if read-only etc, or if the length changes */
3754 STRLEN slen; /* slen is the byte length of the whole SV. */
3757 bool inplace; /* ? Convert first char only, in-place */
3758 bool doing_utf8 = FALSE; /* ? using utf8 */
3759 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3760 const int op_type = PL_op->op_type;
3763 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3764 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3765 * stored as UTF-8 at s. */
3766 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3767 * lowercased) character stored in tmpbuf. May be either
3768 * UTF-8 or not, but in either case is the number of bytes */
3770 s = (const U8*)SvPV_const(source, slen);
3772 /* We may be able to get away with changing only the first character, in
3773 * place, but not if read-only, etc. Later we may discover more reasons to
3774 * not convert in-place. */
3775 inplace = !SvREADONLY(source) && SvPADTMP(source);
3777 /* First calculate what the changed first character should be. This affects
3778 * whether we can just swap it out, leaving the rest of the string unchanged,
3779 * or even if have to convert the dest to UTF-8 when the source isn't */
3781 if (! slen) { /* If empty */
3782 need = 1; /* still need a trailing NUL */
3785 else if (DO_UTF8(source)) { /* Is the source utf8? */
3788 if (op_type == OP_UCFIRST) {
3789 #ifdef USE_LOCALE_CTYPE
3790 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3792 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3796 #ifdef USE_LOCALE_CTYPE
3797 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3799 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3803 /* we can't do in-place if the length changes. */
3804 if (ulen != tculen) inplace = FALSE;
3805 need = slen + 1 - ulen + tculen;
3807 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3808 * latin1 is treated as caseless. Note that a locale takes
3810 ulen = 1; /* Original character is 1 byte */
3811 tculen = 1; /* Most characters will require one byte, but this will
3812 * need to be overridden for the tricky ones */
3815 if (op_type == OP_LCFIRST) {
3817 /* lower case the first letter: no trickiness for any character */
3818 #ifdef USE_LOCALE_CTYPE
3819 if (IN_LC_RUNTIME(LC_CTYPE)) {
3820 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3821 *tmpbuf = toLOWER_LC(*s);
3826 *tmpbuf = (IN_UNI_8_BIT)
3827 ? toLOWER_LATIN1(*s)
3831 #ifdef USE_LOCALE_CTYPE
3833 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3834 if (IN_UTF8_CTYPE_LOCALE) {
3838 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3839 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3840 locales have upper and title case
3844 else if (! IN_UNI_8_BIT) {
3845 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3846 * on EBCDIC machines whatever the
3847 * native function does */
3850 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3851 * UTF-8, which we treat as not in locale), and cased latin1 */
3853 #ifdef USE_LOCALE_CTYPE
3857 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3859 assert(tculen == 2);
3861 /* If the result is an upper Latin1-range character, it can
3862 * still be represented in one byte, which is its ordinal */
3863 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3864 *tmpbuf = (U8) title_ord;
3868 /* Otherwise it became more than one ASCII character (in
3869 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3870 * beyond Latin1, so the number of bytes changed, so can't
3871 * replace just the first character in place. */
3874 /* If the result won't fit in a byte, the entire result
3875 * will have to be in UTF-8. Assume worst case sizing in
3876 * conversion. (all latin1 characters occupy at most two
3878 if (title_ord > 255) {
3880 convert_source_to_utf8 = TRUE;
3881 need = slen * 2 + 1;
3883 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3884 * (both) characters whose title case is above 255 is
3888 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3889 need = slen + 1 + 1;
3893 } /* End of use Unicode (Latin1) semantics */
3894 } /* End of changing the case of the first character */
3896 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3897 * generate the result */
3900 /* We can convert in place. This means we change just the first
3901 * character without disturbing the rest; no need to grow */
3903 s = d = (U8*)SvPV_force_nomg(source, slen);
3909 /* Here, we can't convert in place; we earlier calculated how much
3910 * space we will need, so grow to accommodate that */
3911 SvUPGRADE(dest, SVt_PV);
3912 d = (U8*)SvGROW(dest, need);
3913 (void)SvPOK_only(dest);
3920 if (! convert_source_to_utf8) {
3922 /* Here both source and dest are in UTF-8, but have to create
3923 * the entire output. We initialize the result to be the
3924 * title/lower cased first character, and then append the rest
3926 sv_setpvn(dest, (char*)tmpbuf, tculen);
3928 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3932 const U8 *const send = s + slen;
3934 /* Here the dest needs to be in UTF-8, but the source isn't,
3935 * except we earlier UTF-8'd the first character of the source
3936 * into tmpbuf. First put that into dest, and then append the
3937 * rest of the source, converting it to UTF-8 as we go. */
3939 /* Assert tculen is 2 here because the only two characters that
3940 * get to this part of the code have 2-byte UTF-8 equivalents */
3942 *d++ = *(tmpbuf + 1);
3943 s++; /* We have just processed the 1st char */
3945 for (; s < send; s++) {
3946 d = uvchr_to_utf8(d, *s);
3949 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3953 else { /* in-place UTF-8. Just overwrite the first character */
3954 Copy(tmpbuf, d, tculen, U8);
3955 SvCUR_set(dest, need - 1);
3959 else { /* Neither source nor dest are in or need to be UTF-8 */
3961 if (inplace) { /* in-place, only need to change the 1st char */
3964 else { /* Not in-place */
3966 /* Copy the case-changed character(s) from tmpbuf */
3967 Copy(tmpbuf, d, tculen, U8);
3968 d += tculen - 1; /* Code below expects d to point to final
3969 * character stored */
3972 else { /* empty source */
3973 /* See bug #39028: Don't taint if empty */
3977 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3978 * the destination to retain that flag */
3979 if (SvUTF8(source) && ! IN_BYTES)
3982 if (!inplace) { /* Finish the rest of the string, unchanged */
3983 /* This will copy the trailing NUL */
3984 Copy(s + 1, d + 1, slen, U8);
3985 SvCUR_set(dest, need - 1);
3988 #ifdef USE_LOCALE_CTYPE
3989 if (IN_LC_RUNTIME(LC_CTYPE)) {
3994 if (dest != source && SvTAINTED(source))
4000 /* There's so much setup/teardown code common between uc and lc, I wonder if
4001 it would be worth merging the two, and just having a switch outside each
4002 of the three tight loops. There is less and less commonality though */
4015 if ( SvPADTMP(source)
4016 && !SvREADONLY(source) && SvPOK(source)
4019 #ifdef USE_LOCALE_CTYPE
4020 (IN_LC_RUNTIME(LC_CTYPE))
4021 ? ! IN_UTF8_CTYPE_LOCALE
4027 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4028 * make the loop tight, so we overwrite the source with the dest before
4029 * looking at it, and we need to look at the original source
4030 * afterwards. There would also need to be code added to handle
4031 * switching to not in-place in midstream if we run into characters
4032 * that change the length. Since being in locale overrides UNI_8_BIT,
4033 * that latter becomes irrelevant in the above test; instead for
4034 * locale, the size can't normally change, except if the locale is a
4037 s = d = (U8*)SvPV_force_nomg(source, len);
4044 s = (const U8*)SvPV_nomg_const(source, len);
4047 SvUPGRADE(dest, SVt_PV);
4048 d = (U8*)SvGROW(dest, min);
4049 (void)SvPOK_only(dest);
4054 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4055 to check DO_UTF8 again here. */
4057 if (DO_UTF8(source)) {
4058 const U8 *const send = s + len;
4059 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4061 /* All occurrences of these are to be moved to follow any other marks.
4062 * This is context-dependent. We may not be passed enough context to
4063 * move the iota subscript beyond all of them, but we do the best we can
4064 * with what we're given. The result is always better than if we
4065 * hadn't done this. And, the problem would only arise if we are
4066 * passed a character without all its combining marks, which would be
4067 * the caller's mistake. The information this is based on comes from a
4068 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4069 * itself) and so can't be checked properly to see if it ever gets
4070 * revised. But the likelihood of it changing is remote */
4071 bool in_iota_subscript = FALSE;
4077 if (in_iota_subscript && ! _is_utf8_mark(s)) {
4079 /* A non-mark. Time to output the iota subscript */
4080 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4081 d += capital_iota_len;
4082 in_iota_subscript = FALSE;
4085 /* Then handle the current character. Get the changed case value
4086 * and copy it to the output buffer */
4089 #ifdef USE_LOCALE_CTYPE
4090 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4092 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4094 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4095 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4096 if (uv == GREEK_CAPITAL_LETTER_IOTA
4097 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4099 in_iota_subscript = TRUE;
4102 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4103 /* If the eventually required minimum size outgrows the
4104 * available space, we need to grow. */
4105 const UV o = d - (U8*)SvPVX_const(dest);
4107 /* If someone uppercases one million U+03B0s we SvGROW()
4108 * one million times. Or we could try guessing how much to
4109 * allocate without allocating too much. Such is life.
4110 * See corresponding comment in lc code for another option
4112 d = o + (U8*) SvGROW(dest, min);
4114 Copy(tmpbuf, d, ulen, U8);
4119 if (in_iota_subscript) {
4120 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4121 d += capital_iota_len;
4126 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4128 else { /* Not UTF-8 */
4130 const U8 *const send = s + len;
4132 /* Use locale casing if in locale; regular style if not treating
4133 * latin1 as having case; otherwise the latin1 casing. Do the
4134 * whole thing in a tight loop, for speed, */
4135 #ifdef USE_LOCALE_CTYPE
4136 if (IN_LC_RUNTIME(LC_CTYPE)) {
4137 if (IN_UTF8_CTYPE_LOCALE) {
4140 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4141 for (; s < send; d++, s++)
4142 *d = (U8) toUPPER_LC(*s);
4146 if (! IN_UNI_8_BIT) {
4147 for (; s < send; d++, s++) {
4152 #ifdef USE_LOCALE_CTYPE
4155 for (; s < send; d++, s++) {
4156 *d = toUPPER_LATIN1_MOD(*s);
4157 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4161 /* The mainstream case is the tight loop above. To avoid
4162 * extra tests in that, all three characters that require
4163 * special handling are mapped by the MOD to the one tested
4165 * Use the source to distinguish between the three cases */
4167 #if UNICODE_MAJOR_VERSION > 2 \
4168 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4169 && UNICODE_DOT_DOT_VERSION >= 8)
4170 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4172 /* uc() of this requires 2 characters, but they are
4173 * ASCII. If not enough room, grow the string */
4174 if (SvLEN(dest) < ++min) {
4175 const UV o = d - (U8*)SvPVX_const(dest);
4176 d = o + (U8*) SvGROW(dest, min);
4178 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4179 continue; /* Back to the tight loop; still in ASCII */
4183 /* The other two special handling characters have their
4184 * upper cases outside the latin1 range, hence need to be
4185 * in UTF-8, so the whole result needs to be in UTF-8. So,
4186 * here we are somewhere in the middle of processing a
4187 * non-UTF-8 string, and realize that we will have to convert
4188 * the whole thing to UTF-8. What to do? There are
4189 * several possibilities. The simplest to code is to
4190 * convert what we have so far, set a flag, and continue on
4191 * in the loop. The flag would be tested each time through
4192 * the loop, and if set, the next character would be
4193 * converted to UTF-8 and stored. But, I (khw) didn't want
4194 * to slow down the mainstream case at all for this fairly
4195 * rare case, so I didn't want to add a test that didn't
4196 * absolutely have to be there in the loop, besides the
4197 * possibility that it would get too complicated for
4198 * optimizers to deal with. Another possibility is to just
4199 * give up, convert the source to UTF-8, and restart the
4200 * function that way. Another possibility is to convert
4201 * both what has already been processed and what is yet to
4202 * come separately to UTF-8, then jump into the loop that
4203 * handles UTF-8. But the most efficient time-wise of the
4204 * ones I could think of is what follows, and turned out to
4205 * not require much extra code. */
4207 /* Convert what we have so far into UTF-8, telling the
4208 * function that we know it should be converted, and to
4209 * allow extra space for what we haven't processed yet.
4210 * Assume the worst case space requirements for converting
4211 * what we haven't processed so far: that it will require
4212 * two bytes for each remaining source character, plus the
4213 * NUL at the end. This may cause the string pointer to
4214 * move, so re-find it. */
4216 len = d - (U8*)SvPVX_const(dest);
4217 SvCUR_set(dest, len);
4218 len = sv_utf8_upgrade_flags_grow(dest,
4219 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4221 d = (U8*)SvPVX(dest) + len;
4223 /* Now process the remainder of the source, converting to
4224 * upper and UTF-8. If a resulting byte is invariant in
4225 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4226 * append it to the output. */
4227 for (; s < send; s++) {
4228 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4232 /* Here have processed the whole source; no need to continue
4233 * with the outer loop. Each character has been converted
4234 * to upper case and converted to UTF-8 */
4237 } /* End of processing all latin1-style chars */
4238 } /* End of processing all chars */
4239 } /* End of source is not empty */
4241 if (source != dest) {
4242 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4243 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4245 } /* End of isn't utf8 */
4246 #ifdef USE_LOCALE_CTYPE
4247 if (IN_LC_RUNTIME(LC_CTYPE)) {
4252 if (dest != source && SvTAINTED(source))
4270 if ( SvPADTMP(source)
4271 && !SvREADONLY(source) && SvPOK(source)
4272 && !DO_UTF8(source)) {
4274 /* We can convert in place, as lowercasing anything in the latin1 range
4275 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4277 s = d = (U8*)SvPV_force_nomg(source, len);
4284 s = (const U8*)SvPV_nomg_const(source, len);
4287 SvUPGRADE(dest, SVt_PV);
4288 d = (U8*)SvGROW(dest, min);
4289 (void)SvPOK_only(dest);
4294 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4295 to check DO_UTF8 again here. */
4297 if (DO_UTF8(source)) {
4298 const U8 *const send = s + len;
4299 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4302 const STRLEN u = UTF8SKIP(s);
4305 #ifdef USE_LOCALE_CTYPE
4306 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4308 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4311 /* Here is where we would do context-sensitive actions. See the
4312 * commit message for 86510fb15 for why there isn't any */
4314 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4316 /* If the eventually required minimum size outgrows the
4317 * available space, we need to grow. */
4318 const UV o = d - (U8*)SvPVX_const(dest);
4320 /* If someone lowercases one million U+0130s we SvGROW() one
4321 * million times. Or we could try guessing how much to
4322 * allocate without allocating too much. Such is life.
4323 * Another option would be to grow an extra byte or two more
4324 * each time we need to grow, which would cut down the million
4325 * to 500K, with little waste */
4326 d = o + (U8*) SvGROW(dest, min);
4329 /* Copy the newly lowercased letter to the output buffer we're
4331 Copy(tmpbuf, d, ulen, U8);
4334 } /* End of looping through the source string */
4337 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4338 } else { /* Not utf8 */
4340 const U8 *const send = s + len;
4342 /* Use locale casing if in locale; regular style if not treating
4343 * latin1 as having case; otherwise the latin1 casing. Do the
4344 * whole thing in a tight loop, for speed, */
4345 #ifdef USE_LOCALE_CTYPE
4346 if (IN_LC_RUNTIME(LC_CTYPE)) {
4347 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4348 for (; s < send; d++, s++)
4349 *d = toLOWER_LC(*s);
4353 if (! IN_UNI_8_BIT) {
4354 for (; s < send; d++, s++) {
4359 for (; s < send; d++, s++) {
4360 *d = toLOWER_LATIN1(*s);
4364 if (source != dest) {
4366 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4369 #ifdef USE_LOCALE_CTYPE
4370 if (IN_LC_RUNTIME(LC_CTYPE)) {
4375 if (dest != source && SvTAINTED(source))
4384 SV * const sv = TOPs;
4386 const char *s = SvPV_const(sv,len);
4388 SvUTF8_off(TARG); /* decontaminate */
4391 SvUPGRADE(TARG, SVt_PV);
4392 SvGROW(TARG, (len * 2) + 1);
4396 STRLEN ulen = UTF8SKIP(s);
4397 bool to_quote = FALSE;
4399 if (UTF8_IS_INVARIANT(*s)) {
4400 if (_isQUOTEMETA(*s)) {
4404 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4406 #ifdef USE_LOCALE_CTYPE
4407 /* In locale, we quote all non-ASCII Latin1 chars.
4408 * Otherwise use the quoting rules */
4410 IN_LC_RUNTIME(LC_CTYPE)
4413 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4418 else if (is_QUOTEMETA_high(s)) {
4433 else if (IN_UNI_8_BIT) {
4435 if (_isQUOTEMETA(*s))
4441 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4442 * including everything above ASCII */
4444 if (!isWORDCHAR_A(*s))
4450 SvCUR_set(TARG, d - SvPVX_const(TARG));
4451 (void)SvPOK_only_UTF8(TARG);
4454 sv_setpvn(TARG, s, len);
4470 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4471 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4472 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4473 || UNICODE_DOT_DOT_VERSION > 0)
4474 const bool full_folding = TRUE; /* This variable is here so we can easily
4475 move to more generality later */
4477 const bool full_folding = FALSE;
4479 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4480 #ifdef USE_LOCALE_CTYPE
4481 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4485 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4486 * You are welcome(?) -Hugmeir
4494 s = (const U8*)SvPV_nomg_const(source, len);
4496 if (ckWARN(WARN_UNINITIALIZED))
4497 report_uninit(source);
4504 SvUPGRADE(dest, SVt_PV);
4505 d = (U8*)SvGROW(dest, min);
4506 (void)SvPOK_only(dest);
4511 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4513 const STRLEN u = UTF8SKIP(s);
4516 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4518 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4519 const UV o = d - (U8*)SvPVX_const(dest);
4520 d = o + (U8*) SvGROW(dest, min);
4523 Copy(tmpbuf, d, ulen, U8);
4528 } /* Unflagged string */
4530 #ifdef USE_LOCALE_CTYPE
4531 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4532 if (IN_UTF8_CTYPE_LOCALE) {
4533 goto do_uni_folding;
4535 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4536 for (; s < send; d++, s++)
4537 *d = (U8) toFOLD_LC(*s);
4541 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4542 for (; s < send; d++, s++)
4546 #ifdef USE_LOCALE_CTYPE
4549 /* For ASCII and the Latin-1 range, there's only two troublesome
4550 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4551 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4552 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4553 * For the rest, the casefold is their lowercase. */
4554 for (; s < send; d++, s++) {
4555 if (*s == MICRO_SIGN) {
4556 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4557 * which is outside of the latin-1 range. There's a couple
4558 * of ways to deal with this -- khw discusses them in
4559 * pp_lc/uc, so go there :) What we do here is upgrade what
4560 * we had already casefolded, then enter an inner loop that
4561 * appends the rest of the characters as UTF-8. */
4562 len = d - (U8*)SvPVX_const(dest);
4563 SvCUR_set(dest, len);
4564 len = sv_utf8_upgrade_flags_grow(dest,
4565 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4566 /* The max expansion for latin1
4567 * chars is 1 byte becomes 2 */
4569 d = (U8*)SvPVX(dest) + len;
4571 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4574 for (; s < send; s++) {
4576 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4577 if UVCHR_IS_INVARIANT(fc) {
4579 && *s == LATIN_SMALL_LETTER_SHARP_S)
4588 Copy(tmpbuf, d, ulen, U8);
4594 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4595 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4596 * becomes "ss", which may require growing the SV. */
4597 if (SvLEN(dest) < ++min) {
4598 const UV o = d - (U8*)SvPVX_const(dest);
4599 d = o + (U8*) SvGROW(dest, min);
4604 else { /* If it's not one of those two, the fold is their lower
4606 *d = toLOWER_LATIN1(*s);
4612 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4614 #ifdef USE_LOCALE_CTYPE
4615 if (IN_LC_RUNTIME(LC_CTYPE)) {
4620 if (SvTAINTED(source))
4630 dSP; dMARK; dORIGMARK;
4631 AV *const av = MUTABLE_AV(POPs);
4632 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4634 if (SvTYPE(av) == SVt_PVAV) {
4635 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4636 bool can_preserve = FALSE;
4642 can_preserve = SvCANEXISTDELETE(av);
4645 if (lval && localizing) {
4648 for (svp = MARK + 1; svp <= SP; svp++) {
4649 const SSize_t elem = SvIV(*svp);
4653 if (max > AvMAX(av))
4657 while (++MARK <= SP) {
4659 SSize_t elem = SvIV(*MARK);
4660 bool preeminent = TRUE;
4662 if (localizing && can_preserve) {
4663 /* If we can determine whether the element exist,
4664 * Try to preserve the existenceness of a tied array
4665 * element by using EXISTS and DELETE if possible.
4666 * Fallback to FETCH and STORE otherwise. */
4667 preeminent = av_exists(av, elem);
4670 svp = av_fetch(av, elem, lval);
4673 DIE(aTHX_ PL_no_aelem, elem);
4676 save_aelem(av, elem, svp);
4678 SAVEADELETE(av, elem);
4681 *MARK = svp ? *svp : &PL_sv_undef;
4684 if (GIMME_V != G_ARRAY) {
4686 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4695 AV *const av = MUTABLE_AV(POPs);
4696 I32 lval = (PL_op->op_flags & OPf_MOD);
4697 SSize_t items = SP - MARK;
4699 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4700 const I32 flags = is_lvalue_sub();
4702 if (!(flags & OPpENTERSUB_INARGS))
4703 /* diag_listed_as: Can't modify %s in %s */
4704 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4711 *(MARK+items*2-1) = *(MARK+items);
4717 while (++MARK <= SP) {
4720 svp = av_fetch(av, SvIV(*MARK), lval);
4722 if (!svp || !*svp || *svp == &PL_sv_undef) {
4723 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4725 *MARK = sv_mortalcopy(*MARK);
4727 *++MARK = svp ? *svp : &PL_sv_undef;
4729 if (GIMME_V != G_ARRAY) {
4730 MARK = SP - items*2;
4731 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4741 AV *array = MUTABLE_AV(POPs);
4742 const U8 gimme = GIMME_V;
4743 IV *iterp = Perl_av_iter_p(aTHX_ array);
4744 const IV current = (*iterp)++;
4746 if (current > av_tindex(array)) {
4748 if (gimme == G_SCALAR)
4756 if (gimme == G_ARRAY) {
4757 SV **const element = av_fetch(array, current, 0);
4758 PUSHs(element ? *element : &PL_sv_undef);
4763 /* also used for: pp_avalues()*/
4767 AV *array = MUTABLE_AV(POPs);
4768 const U8 gimme = GIMME_V;
4770 *Perl_av_iter_p(aTHX_ array) = 0;
4772 if (gimme == G_SCALAR) {
4774 PUSHi(av_tindex(array) + 1);
4776 else if (gimme == G_ARRAY) {
4777 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4778 const I32 flags = is_lvalue_sub();
4779 if (flags && !(flags & OPpENTERSUB_INARGS))
4780 /* diag_listed_as: Can't modify %s in %s */
4782 "Can't modify keys on array in list assignment");
4785 IV n = Perl_av_len(aTHX_ array);
4790 if ( PL_op->op_type == OP_AKEYS
4791 || ( PL_op->op_type == OP_AVHVSWITCH
4792 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
4794 for (i = 0; i <= n; i++) {
4799 for (i = 0; i <= n; i++) {
4800 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4801 PUSHs(elem ? *elem : &PL_sv_undef);
4809 /* Associative arrays. */
4814 HV * hash = MUTABLE_HV(POPs);
4816 const U8 gimme = GIMME_V;
4818 entry = hv_iternext(hash);
4822 SV* const sv = hv_iterkeysv(entry);
4824 if (gimme == G_ARRAY) {
4826 val = hv_iterval(hash, entry);
4830 else if (gimme == G_SCALAR)
4837 S_do_delete_local(pTHX)
4840 const U8 gimme = GIMME_V;
4843 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4844 SV **unsliced_keysv = sliced ? NULL : sp--;
4845 SV * const osv = POPs;
4846 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4848 const bool tied = SvRMAGICAL(osv)
4849 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4850 const bool can_preserve = SvCANEXISTDELETE(osv);
4851 const U32 type = SvTYPE(osv);
4852 SV ** const end = sliced ? SP : unsliced_keysv;
4854 if (type == SVt_PVHV) { /* hash element */
4855 HV * const hv = MUTABLE_HV(osv);
4856 while (++MARK <= end) {
4857 SV * const keysv = *MARK;
4859 bool preeminent = TRUE;
4861 preeminent = hv_exists_ent(hv, keysv, 0);
4863 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4870 sv = hv_delete_ent(hv, keysv, 0, 0);
4872 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4875 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4876 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4878 *MARK = sv_mortalcopy(sv);
4884 SAVEHDELETE(hv, keysv);
4885 *MARK = &PL_sv_undef;
4889 else if (type == SVt_PVAV) { /* array element */
4890 if (PL_op->op_flags & OPf_SPECIAL) {
4891 AV * const av = MUTABLE_AV(osv);
4892 while (++MARK <= end) {
4893 SSize_t idx = SvIV(*MARK);
4895 bool preeminent = TRUE;
4897 preeminent = av_exists(av, idx);
4899 SV **svp = av_fetch(av, idx, 1);
4906 sv = av_delete(av, idx, 0);
4908 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4911 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4913 *MARK = sv_mortalcopy(sv);
4919 SAVEADELETE(av, idx);
4920 *MARK = &PL_sv_undef;
4925 DIE(aTHX_ "panic: avhv_delete no longer supported");
4928 DIE(aTHX_ "Not a HASH reference");
4930 if (gimme == G_VOID)
4932 else if (gimme == G_SCALAR) {
4937 *++MARK = &PL_sv_undef;
4941 else if (gimme != G_VOID)
4942 PUSHs(*unsliced_keysv);
4953 if (PL_op->op_private & OPpLVAL_INTRO)
4954 return do_delete_local();
4957 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4959 if (PL_op->op_private & OPpSLICE) {
4961 HV * const hv = MUTABLE_HV(POPs);
4962 const U32 hvtype = SvTYPE(hv);
4963 if (hvtype == SVt_PVHV) { /* hash element */
4964 while (++MARK <= SP) {
4965 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4966 *MARK = sv ? sv : &PL_sv_undef;
4969 else if (hvtype == SVt_PVAV) { /* array element */
4970 if (PL_op->op_flags & OPf_SPECIAL) {
4971 while (++MARK <= SP) {
4972 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4973 *MARK = sv ? sv : &PL_sv_undef;
4978 DIE(aTHX_ "Not a HASH reference");
4981 else if (gimme == G_SCALAR) {
4986 *++MARK = &PL_sv_undef;
4992 HV * const hv = MUTABLE_HV(POPs);
4994 if (SvTYPE(hv) == SVt_PVHV)
4995 sv = hv_delete_ent(hv, keysv, discard, 0);
4996 else if (SvTYPE(hv) == SVt_PVAV) {
4997 if (PL_op->op_flags & OPf_SPECIAL)
4998 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5000 DIE(aTHX_ "panic: avhv_delete no longer supported");
5003 DIE(aTHX_ "Not a HASH reference");
5018 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5020 SV * const sv = POPs;
5021 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5024 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5029 hv = MUTABLE_HV(POPs);
5030 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5031 if (hv_exists_ent(hv, tmpsv, 0))
5034 else if (SvTYPE(hv) == SVt_PVAV) {
5035 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5036 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5041 DIE(aTHX_ "Not a HASH reference");
5048 dSP; dMARK; dORIGMARK;
5049 HV * const hv = MUTABLE_HV(POPs);
5050 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5051 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5052 bool can_preserve = FALSE;
5058 if (SvCANEXISTDELETE(hv))
5059 can_preserve = TRUE;
5062 while (++MARK <= SP) {
5063 SV * const keysv = *MARK;
5066 bool preeminent = TRUE;
5068 if (localizing && can_preserve) {
5069 /* If we can determine whether the element exist,
5070 * try to preserve the existenceness of a tied hash
5071 * element by using EXISTS and DELETE if possible.
5072 * Fallback to FETCH and STORE otherwise. */
5073 preeminent = hv_exists_ent(hv, keysv, 0);
5076 he = hv_fetch_ent(hv, keysv, lval, 0);
5077 svp = he ? &HeVAL(he) : NULL;
5080 if (!svp || !*svp || *svp == &PL_sv_undef) {
5081 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5084 if (HvNAME_get(hv) && isGV(*svp))
5085 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5086 else if (preeminent)
5087 save_helem_flags(hv, keysv, svp,
5088 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5090 SAVEHDELETE(hv, keysv);
5093 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5095 if (GIMME_V != G_ARRAY) {
5097 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5106 HV * const hv = MUTABLE_HV(POPs);
5107 I32 lval = (PL_op->op_flags & OPf_MOD);
5108 SSize_t items = SP - MARK;
5110 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5111 const I32 flags = is_lvalue_sub();
5113 if (!(flags & OPpENTERSUB_INARGS))
5114 /* diag_listed_as: Can't modify %s in %s */
5115 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5116 GIMME_V == G_ARRAY ? "list" : "scalar");
5123 *(MARK+items*2-1) = *(MARK+items);
5129 while (++MARK <= SP) {
5130 SV * const keysv = *MARK;
5134 he = hv_fetch_ent(hv, keysv, lval, 0);
5135 svp = he ? &HeVAL(he) : NULL;
5138 if (!svp || !*svp || *svp == &PL_sv_undef) {
5139 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5141 *MARK = sv_mortalcopy(*MARK);
5143 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5145 if (GIMME_V != G_ARRAY) {
5146 MARK = SP - items*2;
5147 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5153 /* List operators. */
5157 I32 markidx = POPMARK;
5158 if (GIMME_V != G_ARRAY) {
5159 SV **mark = PL_stack_base + markidx;
5162 *MARK = *SP; /* unwanted list, return last item */
5164 *MARK = &PL_sv_undef;
5174 SV ** const lastrelem = PL_stack_sp;
5175 SV ** const lastlelem = PL_stack_base + POPMARK;
5176 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5177 SV ** const firstrelem = lastlelem + 1;
5178 const U8 mod = PL_op->op_flags & OPf_MOD;
5180 const I32 max = lastrelem - lastlelem;
5183 if (GIMME_V != G_ARRAY) {
5184 if (lastlelem < firstlelem) {
5185 *firstlelem = &PL_sv_undef;
5188 I32 ix = SvIV(*lastlelem);
5191 if (ix < 0 || ix >= max)
5192 *firstlelem = &PL_sv_undef;
5194 *firstlelem = firstrelem[ix];
5201 SP = firstlelem - 1;
5205 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5206 I32 ix = SvIV(*lelem);
5209 if (ix < 0 || ix >= max)
5210 *lelem = &PL_sv_undef;
5212 if (!(*lelem = firstrelem[ix]))
5213 *lelem = &PL_sv_undef;
5214 else if (mod && SvPADTMP(*lelem)) {
5215 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5226 const I32 items = SP - MARK;
5227 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5229 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5230 ? newRV_noinc(av) : av);
5236 dSP; dMARK; dORIGMARK;
5237 HV* const hv = newHV();
5238 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5239 ? newRV_noinc(MUTABLE_SV(hv))
5244 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5251 sv_setsv_nomg(val, *MARK);
5255 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5258 (void)hv_store_ent(hv,key,val,0);
5267 dSP; dMARK; dORIGMARK;
5268 int num_args = (SP - MARK);
5269 AV *ary = MUTABLE_AV(*++MARK);
5278 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5281 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5282 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5289 offset = i = SvIV(*MARK);
5291 offset += AvFILLp(ary) + 1;
5293 DIE(aTHX_ PL_no_aelem, i);
5295 length = SvIVx(*MARK++);
5297 length += AvFILLp(ary) - offset + 1;
5303 length = AvMAX(ary) + 1; /* close enough to infinity */
5307 length = AvMAX(ary) + 1;
5309 if (offset > AvFILLp(ary) + 1) {
5311 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5312 offset = AvFILLp(ary) + 1;
5314 after = AvFILLp(ary) + 1 - (offset + length);
5315 if (after < 0) { /* not that much array */
5316 length += after; /* offset+length now in array */
5322 /* At this point, MARK .. SP-1 is our new LIST */
5325 diff = newlen - length;
5326 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5329 /* make new elements SVs now: avoid problems if they're from the array */
5330 for (dst = MARK, i = newlen; i; i--) {
5331 SV * const h = *dst;
5332 *dst++ = newSVsv(h);
5335 if (diff < 0) { /* shrinking the area */
5336 SV **tmparyval = NULL;
5338 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5339 Copy(MARK, tmparyval, newlen, SV*);
5342 MARK = ORIGMARK + 1;
5343 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5344 const bool real = cBOOL(AvREAL(ary));
5345 MEXTEND(MARK, length);
5347 EXTEND_MORTAL(length);
5348 for (i = 0, dst = MARK; i < length; i++) {
5349 if ((*dst = AvARRAY(ary)[i+offset])) {
5351 sv_2mortal(*dst); /* free them eventually */
5354 *dst = &PL_sv_undef;
5360 *MARK = AvARRAY(ary)[offset+length-1];
5363 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5364 SvREFCNT_dec(*dst++); /* free them now */
5367 *MARK = &PL_sv_undef;
5369 AvFILLp(ary) += diff;
5371 /* pull up or down? */
5373 if (offset < after) { /* easier to pull up */
5374 if (offset) { /* esp. if nothing to pull */
5375 src = &AvARRAY(ary)[offset-1];
5376 dst = src - diff; /* diff is negative */
5377 for (i = offset; i > 0; i--) /* can't trust Copy */
5381 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5385 if (after) { /* anything to pull down? */
5386 src = AvARRAY(ary) + offset + length;
5387 dst = src + diff; /* diff is negative */
5388 Move(src, dst, after, SV*);
5390 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5391 /* avoid later double free */
5398 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5399 Safefree(tmparyval);
5402 else { /* no, expanding (or same) */
5403 SV** tmparyval = NULL;
5405 Newx(tmparyval, length, SV*); /* so remember deletion */
5406 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5409 if (diff > 0) { /* expanding */
5410 /* push up or down? */
5411 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5415 Move(src, dst, offset, SV*);
5417 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5419 AvFILLp(ary) += diff;
5422 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5423 av_extend(ary, AvFILLp(ary) + diff);
5424 AvFILLp(ary) += diff;
5427 dst = AvARRAY(ary) + AvFILLp(ary);
5429 for (i = after; i; i--) {
5437 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5440 MARK = ORIGMARK + 1;
5441 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5443 const bool real = cBOOL(AvREAL(ary));
5445 EXTEND_MORTAL(length);
5446 for (i = 0, dst = MARK; i < length; i++) {
5447 if ((*dst = tmparyval[i])) {
5449 sv_2mortal(*dst); /* free them eventually */
5451 else *dst = &PL_sv_undef;
5457 else if (length--) {
5458 *MARK = tmparyval[length];
5461 while (length-- > 0)
5462 SvREFCNT_dec(tmparyval[length]);
5465 *MARK = &PL_sv_undef;
5468 *MARK = &PL_sv_undef;
5469 Safefree(tmparyval);
5473 mg_set(MUTABLE_SV(ary));
5481 dSP; dMARK; dORIGMARK; dTARGET;
5482 AV * const ary = MUTABLE_AV(*++MARK);
5483 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5486 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5489 ENTER_with_name("call_PUSH");
5490 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5491 LEAVE_with_name("call_PUSH");
5492 /* SPAGAIN; not needed: SP is assigned to immediately below */
5495 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5496 * only need to save locally, not on the save stack */
5497 U16 old_delaymagic = PL_delaymagic;
5499 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5500 PL_delaymagic = DM_DELAY;
5501 for (++MARK; MARK <= SP; MARK++) {
5503 if (*MARK) SvGETMAGIC(*MARK);
5506 sv_setsv_nomg(sv, *MARK);
5507 av_store(ary, AvFILLp(ary)+1, sv);
5509 if (PL_delaymagic & DM_ARRAY_ISA)
5510 mg_set(MUTABLE_SV(ary));
5511 PL_delaymagic = old_delaymagic;
5514 if (OP_GIMME(PL_op, 0) != G_VOID) {
5515 PUSHi( AvFILL(ary) + 1 );
5520 /* also used for: pp_pop()*/
5524 AV * const av = PL_op->op_flags & OPf_SPECIAL
5525 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5526 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5530 (void)sv_2mortal(sv);
5537 dSP; dMARK; dORIGMARK; dTARGET;
5538 AV *ary = MUTABLE_AV(*++MARK);
5539 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5542 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5545 ENTER_with_name("call_UNSHIFT");
5546 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5547 LEAVE_with_name("call_UNSHIFT");
5548 /* SPAGAIN; not needed: SP is assigned to immediately below */
5551 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5552 * only need to save locally, not on the save stack */
5553 U16 old_delaymagic = PL_delaymagic;
5556 av_unshift(ary, SP - MARK);
5557 PL_delaymagic = DM_DELAY;
5559 SV * const sv = newSVsv(*++MARK);
5560 (void)av_store(ary, i++, sv);
5562 if (PL_delaymagic & DM_ARRAY_ISA)
5563 mg_set(MUTABLE_SV(ary));
5564 PL_delaymagic = old_delaymagic;
5567 if (OP_GIMME(PL_op, 0) != G_VOID) {
5568 PUSHi( AvFILL(ary) + 1 );
5577 if (GIMME_V == G_ARRAY) {
5578 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5582 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5583 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5584 av = MUTABLE_AV((*SP));
5585 /* In-place reversing only happens in void context for the array
5586 * assignment. We don't need to push anything on the stack. */
5589 if (SvMAGICAL(av)) {
5591 SV *tmp = sv_newmortal();
5592 /* For SvCANEXISTDELETE */
5595 bool can_preserve = SvCANEXISTDELETE(av);
5597 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5601 if (!av_exists(av, i)) {
5602 if (av_exists(av, j)) {
5603 SV *sv = av_delete(av, j, 0);
5604 begin = *av_fetch(av, i, TRUE);
5605 sv_setsv_mg(begin, sv);
5609 else if (!av_exists(av, j)) {
5610 SV *sv = av_delete(av, i, 0);
5611 end = *av_fetch(av, j, TRUE);
5612 sv_setsv_mg(end, sv);
5617 begin = *av_fetch(av, i, TRUE);
5618 end = *av_fetch(av, j, TRUE);
5619 sv_setsv(tmp, begin);
5620 sv_setsv_mg(begin, end);
5621 sv_setsv_mg(end, tmp);
5625 SV **begin = AvARRAY(av);
5628 SV **end = begin + AvFILLp(av);
5630 while (begin < end) {
5631 SV * const tmp = *begin;
5642 SV * const tmp = *MARK;
5646 /* safe as long as stack cannot get extended in the above */
5657 SvUTF8_off(TARG); /* decontaminate */
5659 do_join(TARG, &PL_sv_no, MARK, SP);
5661 sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5664 up = SvPV_force(TARG, len);
5666 if (DO_UTF8(TARG)) { /* first reverse each character */
5667 U8* s = (U8*)SvPVX(TARG);
5668 const U8* send = (U8*)(s + len);
5670 if (UTF8_IS_INVARIANT(*s)) {
5675 if (!utf8_to_uvchr_buf(s, send, 0))
5679 down = (char*)(s - 1);
5680 /* reverse this character */
5684 *down-- = (char)tmp;
5690 down = SvPVX(TARG) + len - 1;
5694 *down-- = (char)tmp;
5696 (void)SvPOK_only_UTF8(TARG);
5707 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
5708 IV limit = POPi; /* note, negative is forever */
5709 SV * const sv = POPs;
5711 const char *s = SvPV_const(sv, len);
5712 const bool do_utf8 = DO_UTF8(sv);
5713 const char *strend = s + len;
5719 const STRLEN slen = do_utf8
5720 ? utf8_length((U8*)s, (U8*)strend)
5721 : (STRLEN)(strend - s);
5722 SSize_t maxiters = slen + 10;
5723 I32 trailing_empty = 0;
5725 const IV origlimit = limit;
5728 const U8 gimme = GIMME_V;
5730 const I32 oldsave = PL_savestack_ix;
5731 U32 make_mortal = SVs_TEMP;
5736 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5741 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5744 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5745 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5748 if (pm->op_pmreplrootu.op_pmtargetoff) {
5749 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5753 if (pm->op_pmreplrootu.op_pmtargetgv) {
5754 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5758 else if (pm->op_targ)
5759 ary = (AV *)PAD_SVl(pm->op_targ);
5765 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5768 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5770 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5777 for (i = AvFILLp(ary); i >= 0; i--)
5778 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5780 /* temporarily switch stacks */
5781 SAVESWITCHSTACK(PL_curstack, ary);
5785 base = SP - PL_stack_base;
5787 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5789 while (isSPACE_utf8(s))
5792 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5793 while (isSPACE_LC(*s))
5801 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5805 gimme_scalar = gimme == G_SCALAR && !ary;
5808 limit = maxiters + 2;
5809 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5812 /* this one uses 'm' and is a negative test */
5814 while (m < strend && ! isSPACE_utf8(m) ) {
5815 const int t = UTF8SKIP(m);
5816 /* isSPACE_utf8 returns FALSE for malform utf8 */
5823 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5825 while (m < strend && !isSPACE_LC(*m))
5828 while (m < strend && !isSPACE(*m))
5841 dstr = newSVpvn_flags(s, m-s,
5842 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5846 /* skip the whitespace found last */
5848 s = m + UTF8SKIP(m);
5852 /* this one uses 's' and is a positive test */
5854 while (s < strend && isSPACE_utf8(s) )
5857 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5859 while (s < strend && isSPACE_LC(*s))
5862 while (s < strend && isSPACE(*s))
5867 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5869 for (m = s; m < strend && *m != '\n'; m++)
5882 dstr = newSVpvn_flags(s, m-s,
5883 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5889 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5891 Pre-extend the stack, either the number of bytes or
5892 characters in the string or a limited amount, triggered by:
5894 my ($x, $y) = split //, $str;
5898 if (!gimme_scalar) {
5899 const IV items = limit - 1;
5900 /* setting it to -1 will trigger a panic in EXTEND() */
5901 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
5902 if (items >=0 && items < sslen)
5910 /* keep track of how many bytes we skip over */
5920 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5933 dstr = newSVpvn(s, 1);
5949 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5950 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5951 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5952 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5953 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5954 SV * const csv = CALLREG_INTUIT_STRING(rx);
5956 len = RX_MINLENRET(rx);
5957 if (len == 1 && !RX_UTF8(rx) && !tail) {
5958 const char c = *SvPV_nolen_const(csv);
5960 for (m = s; m < strend && *m != c; m++)
5971 dstr = newSVpvn_flags(s, m-s,
5972 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5975 /* The rx->minlen is in characters but we want to step
5976 * s ahead by bytes. */
5978 s = (char*)utf8_hop((U8*)m, len);
5980 s = m + len; /* Fake \n at the end */
5984 while (s < strend && --limit &&
5985 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5986 csv, multiline ? FBMrf_MULTILINE : 0)) )
5995 dstr = newSVpvn_flags(s, m-s,
5996 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5999 /* The rx->minlen is in characters but we want to step
6000 * s ahead by bytes. */
6002 s = (char*)utf8_hop((U8*)m, len);
6004 s = m + len; /* Fake \n at the end */
6009 maxiters += slen * RX_NPARENS(rx);
6010 while (s < strend && --limit)
6014 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6017 if (rex_return == 0)
6019 TAINT_IF(RX_MATCH_TAINTED(rx));
6020 /* we never pass the REXEC_COPY_STR flag, so it should
6021 * never get copied */
6022 assert(!RX_MATCH_COPIED(rx));
6023 m = RX_OFFS(rx)[0].start + orig;
6032 dstr = newSVpvn_flags(s, m-s,
6033 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6036 if (RX_NPARENS(rx)) {
6038 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6039 s = RX_OFFS(rx)[i].start + orig;
6040 m = RX_OFFS(rx)[i].end + orig;
6042 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6043 parens that didn't match -- they should be set to
6044 undef, not the empty string */
6052 if (m >= orig && s >= orig) {
6053 dstr = newSVpvn_flags(s, m-s,
6054 (do_utf8 ? SVf_UTF8 : 0)
6058 dstr = &PL_sv_undef; /* undef, not "" */
6064 s = RX_OFFS(rx)[0].end + orig;
6068 if (!gimme_scalar) {
6069 iters = (SP - PL_stack_base) - base;
6071 if (iters > maxiters)
6072 DIE(aTHX_ "Split loop");
6074 /* keep field after final delim? */
6075 if (s < strend || (iters && origlimit)) {
6076 if (!gimme_scalar) {
6077 const STRLEN l = strend - s;
6078 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6083 else if (!origlimit) {
6085 iters -= trailing_empty;
6087 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6088 if (TOPs && !make_mortal)
6090 *SP-- = &PL_sv_undef;
6097 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6101 if (SvSMAGICAL(ary)) {
6103 mg_set(MUTABLE_SV(ary));
6106 if (gimme == G_ARRAY) {
6108 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6115 ENTER_with_name("call_PUSH");
6116 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6117 LEAVE_with_name("call_PUSH");
6119 if (gimme == G_ARRAY) {
6121 /* EXTEND should not be needed - we just popped them */
6123 for (i=0; i < iters; i++) {
6124 SV **svp = av_fetch(ary, i, FALSE);
6125 PUSHs((svp) ? *svp : &PL_sv_undef);
6132 if (gimme == G_ARRAY)
6144 SV *const sv = PAD_SVl(PL_op->op_targ);
6146 if (SvPADSTALE(sv)) {
6149 RETURNOP(cLOGOP->op_other);
6151 RETURNOP(cLOGOP->op_next);
6160 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6161 || SvTYPE(retsv) == SVt_PVCV) {
6162 retsv = refto(retsv);
6169 /* used for: pp_padany(), pp_custom(); plus any system ops
6170 * that aren't implemented on a particular platform */
6172 PP(unimplemented_op)
6174 const Optype op_type = PL_op->op_type;
6175 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6176 with out of range op numbers - it only "special" cases op_custom.
6177 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6178 if we get here for a custom op then that means that the custom op didn't
6179 have an implementation. Given that OP_NAME() looks up the custom op
6180 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6181 registers &PL_unimplemented_op as the address of their custom op.
6182 NULL doesn't generate a useful error message. "custom" does. */
6183 const char *const name = op_type >= OP_max
6184 ? "[out of range]" : PL_op_name[PL_op->op_type];
6185 if(OP_IS_SOCKET(op_type))
6186 DIE(aTHX_ PL_no_sock_func, name);
6187 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6191 S_maybe_unwind_defav(pTHX)
6193 if (CX_CUR()->cx_type & CXp_HASARGS) {
6194 PERL_CONTEXT *cx = CX_CUR();
6196 assert(CxHASARGS(cx));
6198 cx->cx_type &= ~CXp_HASARGS;
6202 /* For sorting out arguments passed to a &CORE:: subroutine */
6206 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6207 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6208 AV * const at_ = GvAV(PL_defgv);
6209 SV **svp = at_ ? AvARRAY(at_) : NULL;
6210 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6211 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6212 bool seen_question = 0;
6213 const char *err = NULL;
6214 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6216 /* Count how many args there are first, to get some idea how far to
6217 extend the stack. */
6219 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6221 if (oa & OA_OPTIONAL) seen_question = 1;
6222 if (!seen_question) minargs++;
6226 if(numargs < minargs) err = "Not enough";
6227 else if(numargs > maxargs) err = "Too many";
6229 /* diag_listed_as: Too many arguments for %s */
6231 "%s arguments for %s", err,
6232 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6235 /* Reset the stack pointer. Without this, we end up returning our own
6236 arguments in list context, in addition to the values we are supposed
6237 to return. nextstate usually does this on sub entry, but we need
6238 to run the next op with the caller's hints, so we cannot have a
6240 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6242 if(!maxargs) RETURN;
6244 /* We do this here, rather than with a separate pushmark op, as it has
6245 to come in between two things this function does (stack reset and
6246 arg pushing). This seems the easiest way to do it. */
6249 (void)Perl_pp_pushmark(aTHX);
6252 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6253 PUTBACK; /* The code below can die in various places. */
6255 oa = PL_opargs[opnum] >> OASHIFT;
6256 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6261 if (!numargs && defgv && whicharg == minargs + 1) {
6264 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6268 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6275 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6278 S_maybe_unwind_defav(aTHX);
6281 PUSHs((SV *)GvAVn(gv));
6284 if (!svp || !*svp || !SvROK(*svp)
6285 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6287 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6288 "Type of arg %d to &CORE::%s must be array reference",
6289 whicharg, PL_op_desc[opnum]
6294 if (!svp || !*svp || !SvROK(*svp)
6295 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6296 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6297 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6299 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6300 "Type of arg %d to &CORE::%s must be hash%s reference",
6301 whicharg, PL_op_desc[opnum],
6302 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6309 if (!numargs) PUSHs(NULL);
6310 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6311 /* no magic here, as the prototype will have added an extra
6312 refgen and we just want what was there before that */
6315 const bool constr = PL_op->op_private & whicharg;
6317 svp && *svp ? *svp : &PL_sv_undef,
6318 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6324 if (!numargs) goto try_defsv;
6326 const bool wantscalar =
6327 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6328 if (!svp || !*svp || !SvROK(*svp)
6329 /* We have to permit globrefs even for the \$ proto, as
6330 *foo is indistinguishable from ${\*foo}, and the proto-
6331 type permits the latter. */
6332 || SvTYPE(SvRV(*svp)) > (
6333 wantscalar ? SVt_PVLV
6334 : opnum == OP_LOCK || opnum == OP_UNDEF
6340 "Type of arg %d to &CORE::%s must be %s",
6341 whicharg, PL_op_name[opnum],
6343 ? "scalar reference"
6344 : opnum == OP_LOCK || opnum == OP_UNDEF
6345 ? "reference to one of [$@%&*]"
6346 : "reference to one of [$@%*]"
6349 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6350 /* Undo @_ localisation, so that sub exit does not undo
6351 part of our undeffing. */
6352 S_maybe_unwind_defav(aTHX);
6357 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6369 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6370 + (PL_op->op_private & 3)
6378 if (PL_op->op_private & OPpOFFBYONE) {
6379 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6381 else cv = find_runcv(NULL);
6382 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6387 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6388 const bool can_preserve)
6390 const SSize_t ix = SvIV(keysv);
6391 if (can_preserve ? av_exists(av, ix) : TRUE) {
6392 SV ** const svp = av_fetch(av, ix, 1);
6394 Perl_croak(aTHX_ PL_no_aelem, ix);
6395 save_aelem(av, ix, svp);
6398 SAVEADELETE(av, ix);
6402 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6403 const bool can_preserve)
6405 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6406 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6407 SV ** const svp = he ? &HeVAL(he) : NULL;
6409 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6410 save_helem_flags(hv, keysv, svp, 0);
6413 SAVEHDELETE(hv, keysv);
6417 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6419 if (type == OPpLVREF_SV) {
6420 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6423 else if (type == OPpLVREF_AV)
6424 /* XXX Inefficient, as it creates a new AV, which we are
6425 about to clobber. */
6428 assert(type == OPpLVREF_HV);
6429 /* XXX Likewise inefficient. */
6438 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6439 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6441 const char *bad = NULL;
6442 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6443 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6446 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6450 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6454 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6458 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6462 /* diag_listed_as: Assigned value is not %s reference */
6463 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6467 switch (left ? SvTYPE(left) : 0) {
6470 SV * const old = PAD_SV(ARGTARG);
6471 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6473 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6475 SAVECLEARSV(PAD_SVl(ARGTARG));
6479 if (PL_op->op_private & OPpLVAL_INTRO) {
6480 S_localise_gv_slot(aTHX_ (GV *)left, type);
6482 gv_setref(left, sv);
6487 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6488 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6489 SvCANEXISTDELETE(left));
6491 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6494 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6496 S_localise_helem_lval(aTHX_ (HV *)left, key,
6497 SvCANEXISTDELETE(left));
6499 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6501 if (PL_op->op_flags & OPf_MOD)
6502 SETs(sv_2mortal(newSVsv(sv)));
6503 /* XXX else can weak references go stale before they are read, e.g.,
6512 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6513 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6514 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6515 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6516 &PL_vtbl_lvref, (char *)elem,
6517 elem ? HEf_SVKEY : (I32)ARGTARG);
6518 mg->mg_private = PL_op->op_private;
6519 if (PL_op->op_private & OPpLVREF_ITER)
6520 mg->mg_flags |= MGf_PERSIST;
6521 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6527 const bool can_preserve = SvCANEXISTDELETE(arg);
6528 if (SvTYPE(arg) == SVt_PVAV)
6529 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6531 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6535 S_localise_gv_slot(aTHX_ (GV *)arg,
6536 PL_op->op_private & OPpLVREF_TYPE);
6538 else if (!(PL_op->op_private & OPpPAD_STATE))
6539 SAVECLEARSV(PAD_SVl(ARGTARG));
6548 AV * const av = (AV *)POPs;
6549 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6550 bool can_preserve = FALSE;
6552 if (UNLIKELY(localizing)) {
6557 can_preserve = SvCANEXISTDELETE(av);
6559 if (SvTYPE(av) == SVt_PVAV) {
6562 for (svp = MARK + 1; svp <= SP; svp++) {
6563 const SSize_t elem = SvIV(*svp);
6567 if (max > AvMAX(av))
6572 while (++MARK <= SP) {
6573 SV * const elemsv = *MARK;
6574 if (SvTYPE(av) == SVt_PVAV)
6575 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6577 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6578 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6579 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6586 if (PL_op->op_flags & OPf_STACKED)
6587 Perl_pp_rv2av(aTHX);
6589 Perl_pp_padav(aTHX);
6593 SETs(0); /* special alias marker that aassign recognises */
6603 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6604 ? CopSTASH(PL_curcop)
6606 NULL, SvREFCNT_inc_simple_NN(sv))));
6611 /* process one subroutine argument - typically when the sub has a signature:
6612 * introduce PL_curpad[op_targ] and assign to it the value
6613 * for $: (OPf_STACKED ? *sp : $_[N])
6614 * for @/%: @_[N..$#_]
6616 * It's equivalent to
6619 * my $foo = (value-on-stack)
6621 * my @foo = @_[N..$#_]
6631 AV *defav = GvAV(PL_defgv); /* @_ */
6632 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6635 /* do 'my $var, @var or %var' action */
6636 padentry = &(PAD_SVl(o->op_targ));
6637 save_clearsv(padentry);
6640 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6641 if (o->op_flags & OPf_STACKED) {
6648 /* should already have been checked */
6650 #if IVSIZE > PTRSIZE
6651 assert(ix <= SSize_t_MAX);
6654 svp = av_fetch(defav, ix, FALSE);
6655 val = svp ? *svp : &PL_sv_undef;
6660 /* cargo-culted from pp_sassign */
6661 assert(TAINTING_get || !TAINT_get);
6662 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6665 SvSetMagicSV(targ, val);
6669 /* must be AV or HV */
6671 assert(!(o->op_flags & OPf_STACKED));
6672 argc = ((IV)AvFILL(defav) + 1) - ix;
6674 /* This is a copy of the relevant parts of pp_aassign().
6676 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6679 if (AvFILL((AV*)targ) > -1) {
6680 /* target should usually be empty. If we get get
6681 * here, someone's been doing some weird closure tricks.
6682 * Make a copy of all args before clearing the array,
6683 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6684 * elements. See similar code in pp_aassign.
6686 for (i = 0; i < argc; i++) {
6687 SV **svp = av_fetch(defav, ix + i, FALSE);
6688 SV *newsv = newSV(0);
6689 sv_setsv_flags(newsv,
6690 svp ? *svp : &PL_sv_undef,
6691 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6692 if (!av_store(defav, ix + i, newsv))
6693 SvREFCNT_dec_NN(newsv);
6695 av_clear((AV*)targ);
6701 av_extend((AV*)targ, argc);
6706 SV **svp = av_fetch(defav, ix + i, FALSE);
6707 SV *val = svp ? *svp : &PL_sv_undef;
6709 sv_setsv(tmpsv, val);
6710 av_store((AV*)targ, i++, tmpsv);
6718 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6720 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6721 /* see "target should usually be empty" comment above */
6722 for (i = 0; i < argc; i++) {
6723 SV **svp = av_fetch(defav, ix + i, FALSE);
6724 SV *newsv = newSV(0);
6725 sv_setsv_flags(newsv,
6726 svp ? *svp : &PL_sv_undef,
6727 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6728 if (!av_store(defav, ix + i, newsv))
6729 SvREFCNT_dec_NN(newsv);
6731 hv_clear((HV*)targ);
6736 assert(argc % 2 == 0);
6745 svp = av_fetch(defav, ix + i++, FALSE);
6746 key = svp ? *svp : &PL_sv_undef;
6747 svp = av_fetch(defav, ix + i++, FALSE);
6748 val = svp ? *svp : &PL_sv_undef;
6751 if (UNLIKELY(SvGMAGICAL(key)))
6752 key = sv_mortalcopy(key);
6754 sv_setsv(tmpsv, val);
6755 hv_store_ent((HV*)targ, key, tmpsv, 0);
6763 /* Handle a default value for one subroutine argument (typically as part
6764 * of a subroutine signature).
6765 * It's equivalent to
6766 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
6768 * Intended to be used where op_next is an OP_ARGELEM
6770 * We abuse the op_targ field slightly: it's an index into @_ rather than
6776 OP * const o = PL_op;
6777 AV *defav = GvAV(PL_defgv); /* @_ */
6778 IV ix = (IV)o->op_targ;
6781 #if IVSIZE > PTRSIZE
6782 assert(ix <= SSize_t_MAX);
6785 if (AvFILL(defav) >= ix) {
6787 SV **svp = av_fetch(defav, ix, FALSE);
6788 SV *val = svp ? *svp : &PL_sv_undef;
6792 return cLOGOPo->op_other;
6797 /* Check a a subs arguments - i.e. that it has the correct number of args
6798 * (and anything else we might think of in future). Typically used with
6804 OP * const o = PL_op;
6805 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6806 IV params = aux[0].iv;
6807 IV opt_params = aux[1].iv;
6808 char slurpy = (char)(aux[2].iv);
6809 AV *defav = GvAV(PL_defgv); /* @_ */
6813 assert(!SvMAGICAL(defav));
6814 argc = (AvFILLp(defav) + 1);
6815 too_few = (argc < (params - opt_params));
6817 if (UNLIKELY(too_few || (!slurpy && argc > params)))
6818 /* diag_listed_as: Too few arguments for subroutine */
6819 /* diag_listed_as: Too many arguments for subroutine */
6820 Perl_croak_caller("Too %s arguments for subroutine",
6821 too_few ? "few" : "many");
6823 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6824 Perl_croak_caller("Odd name/value argument for subroutine");
6831 * ex: set ts=8 sts=4 sw=4 et: