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 */
59 if (GIMME_V == G_SCALAR)
70 assert(SvTYPE(TARG) == SVt_PVAV);
71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
75 if (PL_op->op_flags & OPf_REF) {
78 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 const I32 flags = is_lvalue_sub();
80 if (flags && !(flags & OPpENTERSUB_INARGS)) {
81 if (GIMME == G_SCALAR)
82 /* diag_listed_as: Can't return %s to lvalue scalar context */
83 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
89 if (gimme == G_ARRAY) {
90 /* XXX see also S_pushav in pp_hot.c */
91 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
93 if (SvMAGICAL(TARG)) {
95 for (i=0; i < (U32)maxarg; i++) {
96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
101 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
105 else if (gimme == G_SCALAR) {
106 SV* const sv = sv_newmortal();
107 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
108 sv_setiv(sv, maxarg);
119 assert(SvTYPE(TARG) == SVt_PVHV);
121 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
122 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
123 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
124 if (PL_op->op_flags & OPf_REF)
126 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
127 const I32 flags = is_lvalue_sub();
128 if (flags && !(flags & OPpENTERSUB_INARGS)) {
129 if (GIMME == G_SCALAR)
130 /* diag_listed_as: Can't return %s to lvalue scalar context */
131 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136 if (gimme == G_ARRAY) {
137 RETURNOP(Perl_do_kv(aTHX));
139 else if ((PL_op->op_private & OPpTRUEBOOL
140 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
141 && block_gimme() == G_VOID ))
142 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
143 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
144 else if (gimme == G_SCALAR) {
145 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
154 assert(SvTYPE(TARG) == SVt_PVCV);
162 SvPADSTALE_off(TARG);
170 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
172 assert(SvTYPE(TARG) == SVt_PVCV);
175 if (CvISXSUB(mg->mg_obj)) { /* constant */
176 /* XXX Should we clone it here? */
177 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
178 to introcv and remove the SvPADSTALE_off. */
179 SAVEPADSVANDMORTALIZE(ARGTARG);
180 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
183 if (CvROOT(mg->mg_obj)) {
184 assert(CvCLONE(mg->mg_obj));
185 assert(!CvCLONED(mg->mg_obj));
187 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
188 SAVECLEARSV(PAD_SVl(ARGTARG));
195 static const char S_no_symref_sv[] =
196 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
198 /* In some cases this function inspects PL_op. If this function is called
199 for new op types, more bool parameters may need to be added in place of
202 When noinit is true, the absence of a gv will cause a retval of undef.
203 This is unrelated to the cv-to-gv assignment case.
207 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
211 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
214 sv = amagic_deref_call(sv, to_gv_amg);
218 if (SvTYPE(sv) == SVt_PVIO) {
219 GV * const gv = MUTABLE_GV(sv_newmortal());
220 gv_init(gv, 0, "__ANONIO__", 10, 0);
221 GvIOp(gv) = MUTABLE_IO(sv);
222 SvREFCNT_inc_void_NN(sv);
225 else if (!isGV_with_GP(sv))
226 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
229 if (!isGV_with_GP(sv)) {
231 /* If this is a 'my' scalar and flag is set then vivify
234 if (vivify_sv && sv != &PL_sv_undef) {
237 Perl_croak_no_modify();
238 if (cUNOP->op_targ) {
239 SV * const namesv = PAD_SV(cUNOP->op_targ);
240 HV *stash = CopSTASH(PL_curcop);
241 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
242 gv = MUTABLE_GV(newSV(0));
243 gv_init_sv(gv, stash, namesv, 0);
246 const char * const name = CopSTASHPV(PL_curcop);
247 gv = newGVgen_flags(name,
248 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
250 prepare_SV_for_RV(sv);
251 SvRV_set(sv, MUTABLE_SV(gv));
256 if (PL_op->op_flags & OPf_REF || strict)
257 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
258 if (ckWARN(WARN_UNINITIALIZED))
264 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
265 sv, GV_ADDMG, SVt_PVGV
275 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
278 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
279 == OPpDONT_INIT_GV) {
280 /* We are the target of a coderef assignment. Return
281 the scalar unchanged, and let pp_sasssign deal with
285 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
287 /* FAKE globs in the symbol table cause weird bugs (#77810) */
291 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
292 SV *newsv = sv_newmortal();
293 sv_setsv_flags(newsv, sv, 0);
305 sv, PL_op->op_private & OPpDEREF,
306 PL_op->op_private & HINT_STRICT_REFS,
307 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
308 || PL_op->op_type == OP_READLINE
310 if (PL_op->op_private & OPpLVAL_INTRO)
311 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
316 /* Helper function for pp_rv2sv and pp_rv2av */
318 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
319 const svtype type, SV ***spp)
324 PERL_ARGS_ASSERT_SOFTREF2XV;
326 if (PL_op->op_private & HINT_STRICT_REFS) {
328 Perl_die(aTHX_ S_no_symref_sv, sv,
329 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
331 Perl_die(aTHX_ PL_no_usym, what);
335 PL_op->op_flags & OPf_REF
337 Perl_die(aTHX_ PL_no_usym, what);
338 if (ckWARN(WARN_UNINITIALIZED))
340 if (type != SVt_PV && GIMME_V == G_ARRAY) {
344 **spp = &PL_sv_undef;
347 if ((PL_op->op_flags & OPf_SPECIAL) &&
348 !(PL_op->op_flags & OPf_MOD))
350 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
352 **spp = &PL_sv_undef;
357 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
370 sv = amagic_deref_call(sv, to_sv_amg);
374 switch (SvTYPE(sv)) {
380 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 sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
418 *sv = newSV_type(SVt_PVMG);
419 sv_magic(*sv, 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 PUSHs(ret); /* no SvSETMAGIC */
441 const MAGIC * const mg = mg_find_mglob(sv);
442 if (mg && mg->mg_len != -1) {
444 STRLEN i = mg->mg_len;
446 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)) {
474 cv = MUTABLE_CV(&PL_sv_undef);
475 SETs(MUTABLE_SV(cv));
485 SV *ret = &PL_sv_undef;
487 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
488 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
489 const char * s = SvPVX_const(TOPs);
490 if (strnEQ(s, "CORE::", 6)) {
491 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
492 if (!code || code == -KEY_CORE)
493 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
494 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
496 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
502 cv = sv_2cv(TOPs, &stash, &gv, 0);
504 ret = newSVpvn_flags(
505 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
515 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
517 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
519 PUSHs(MUTABLE_SV(cv));
533 if (GIMME != G_ARRAY) {
537 *MARK = &PL_sv_undef;
538 *MARK = refto(*MARK);
542 EXTEND_MORTAL(SP - MARK);
544 *MARK = refto(*MARK);
549 S_refto(pTHX_ SV *sv)
554 PERL_ARGS_ASSERT_REFTO;
556 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
559 if (!(sv = LvTARG(sv)))
562 SvREFCNT_inc_void_NN(sv);
564 else if (SvTYPE(sv) == SVt_PVAV) {
565 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
566 av_reify(MUTABLE_AV(sv));
568 SvREFCNT_inc_void_NN(sv);
570 else if (SvPADTMP(sv) && !IS_PADGV(sv))
574 SvREFCNT_inc_void_NN(sv);
577 sv_upgrade(rv, SVt_IV);
586 SV * const sv = POPs;
592 (void)sv_ref(TARG,SvRV(sv),TRUE);
605 stash = CopSTASH(PL_curcop);
606 if (SvTYPE(stash) != SVt_PVHV)
607 Perl_croak(aTHX_ "Attempt to bless into a freed package");
610 SV * const ssv = POPs;
614 if (!ssv) goto curstash;
615 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
616 Perl_croak(aTHX_ "Attempt to bless into a reference");
617 ptr = SvPV_const(ssv,len);
619 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
620 "Explicit blessing to '' (assuming package main)");
621 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
624 (void)sv_bless(TOPs, stash);
634 const char * const elem = SvPV_const(sv, len);
635 GV * const gv = MUTABLE_GV(POPs);
640 /* elem will always be NUL terminated. */
641 const char * const second_letter = elem + 1;
644 if (len == 5 && strEQ(second_letter, "RRAY"))
646 tmpRef = MUTABLE_SV(GvAV(gv));
647 if (tmpRef && !AvREAL((const AV *)tmpRef)
648 && AvREIFY((const AV *)tmpRef))
649 av_reify(MUTABLE_AV(tmpRef));
653 if (len == 4 && strEQ(second_letter, "ODE"))
654 tmpRef = MUTABLE_SV(GvCVu(gv));
657 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
658 /* finally deprecated in 5.8.0 */
659 deprecate("*glob{FILEHANDLE}");
660 tmpRef = MUTABLE_SV(GvIOp(gv));
663 if (len == 6 && strEQ(second_letter, "ORMAT"))
664 tmpRef = MUTABLE_SV(GvFORM(gv));
667 if (len == 4 && strEQ(second_letter, "LOB"))
668 tmpRef = MUTABLE_SV(gv);
671 if (len == 4 && strEQ(second_letter, "ASH"))
672 tmpRef = MUTABLE_SV(GvHV(gv));
675 if (*second_letter == 'O' && !elem[2] && len == 2)
676 tmpRef = MUTABLE_SV(GvIOp(gv));
679 if (len == 4 && strEQ(second_letter, "AME"))
680 sv = newSVhek(GvNAME_HEK(gv));
683 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
684 const HV * const stash = GvSTASH(gv);
685 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
686 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
690 if (len == 6 && strEQ(second_letter, "CALAR"))
705 /* Pattern matching */
713 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
714 /* Historically, study was skipped in these cases. */
718 /* Make study a no-op. It's no longer useful and its existence
719 complicates matters elsewhere. */
728 if (PL_op->op_flags & OPf_STACKED)
730 else if (PL_op->op_private & OPpTARGET_MY)
736 if(PL_op->op_type == OP_TRANSR) {
738 const char * const pv = SvPV(sv,len);
739 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
744 TARG = sv_newmortal();
750 /* Lvalue operators. */
753 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
759 PERL_ARGS_ASSERT_DO_CHOMP;
761 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
763 if (SvTYPE(sv) == SVt_PVAV) {
765 AV *const av = MUTABLE_AV(sv);
766 const I32 max = AvFILL(av);
768 for (i = 0; i <= max; i++) {
769 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
770 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
771 do_chomp(retval, sv, chomping);
775 else if (SvTYPE(sv) == SVt_PVHV) {
776 HV* const hv = MUTABLE_HV(sv);
778 (void)hv_iterinit(hv);
779 while ((entry = hv_iternext(hv)))
780 do_chomp(retval, hv_iterval(hv,entry), chomping);
783 else if (SvREADONLY(sv)) {
784 Perl_croak_no_modify();
786 else if (SvIsCOW(sv)) {
787 sv_force_normal_flags(sv, 0);
792 /* XXX, here sv is utf8-ized as a side-effect!
793 If encoding.pm is used properly, almost string-generating
794 operations, including literal strings, chr(), input data, etc.
795 should have been utf8-ized already, right?
797 sv_recode_to_utf8(sv, PL_encoding);
803 char *temp_buffer = NULL;
812 while (len && s[-1] == '\n') {
819 STRLEN rslen, rs_charlen;
820 const char *rsptr = SvPV_const(PL_rs, rslen);
822 rs_charlen = SvUTF8(PL_rs)
826 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
827 /* Assumption is that rs is shorter than the scalar. */
829 /* RS is utf8, scalar is 8 bit. */
831 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
834 /* Cannot downgrade, therefore cannot possibly match
836 assert (temp_buffer == rsptr);
842 else if (PL_encoding) {
843 /* RS is 8 bit, encoding.pm is used.
844 * Do not recode PL_rs as a side-effect. */
845 svrecode = newSVpvn(rsptr, rslen);
846 sv_recode_to_utf8(svrecode, PL_encoding);
847 rsptr = SvPV_const(svrecode, rslen);
848 rs_charlen = sv_len_utf8(svrecode);
851 /* RS is 8 bit, scalar is utf8. */
852 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
866 if (memNE(s, rsptr, rslen))
868 SvIVX(retval) += rs_charlen;
871 s = SvPV_force_nomg_nolen(sv);
879 SvREFCNT_dec(svrecode);
881 Safefree(temp_buffer);
883 if (len && !SvPOK(sv))
884 s = SvPV_force_nomg(sv, len);
887 char * const send = s + len;
888 char * const start = s;
890 while (s > start && UTF8_IS_CONTINUATION(*s))
892 if (is_utf8_string((U8*)s, send - s)) {
893 sv_setpvn(retval, s, send - s);
895 SvCUR_set(sv, s - start);
901 sv_setpvs(retval, "");
905 sv_setpvn(retval, s, 1);
912 sv_setpvs(retval, "");
920 const bool chomping = PL_op->op_type == OP_SCHOMP;
924 do_chomp(TARG, TOPs, chomping);
931 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
932 const bool chomping = PL_op->op_type == OP_CHOMP;
937 do_chomp(TARG, *++MARK, chomping);
948 if (!PL_op->op_private) {
957 SV_CHECK_THINKFIRST_COW_DROP(sv);
959 switch (SvTYPE(sv)) {
963 av_undef(MUTABLE_AV(sv));
966 hv_undef(MUTABLE_HV(sv));
969 if (cv_const_sv((const CV *)sv))
970 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
971 "Constant subroutine %"SVf" undefined",
972 SVfARG(CvANON((const CV *)sv)
973 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
974 : sv_2mortal(newSVhek(
976 ? CvNAME_HEK((CV *)sv)
977 : GvENAME_HEK(CvGV((const CV *)sv))
983 /* let user-undef'd sub keep its identity */
984 GV* const gv = CvGV((const CV *)sv);
985 HEK * const hek = CvNAME_HEK((CV *)sv);
986 if (hek) share_hek_hek(hek);
987 cv_undef(MUTABLE_CV(sv));
988 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
990 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
996 assert(isGV_with_GP(sv));
1002 /* undef *Pkg::meth_name ... */
1004 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1005 && HvENAME_get(stash);
1007 if((stash = GvHV((const GV *)sv))) {
1008 if(HvENAME_get(stash))
1009 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1013 gp_free(MUTABLE_GV(sv));
1015 GvGP_set(sv, gp_ref(gp));
1016 GvSV(sv) = newSV(0);
1017 GvLINE(sv) = CopLINE(PL_curcop);
1018 GvEGV(sv) = MUTABLE_GV(sv);
1022 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1024 /* undef *Foo::ISA */
1025 if( strEQ(GvNAME((const GV *)sv), "ISA")
1026 && (stash = GvSTASH((const GV *)sv))
1027 && (method_changed || HvENAME(stash)) )
1028 mro_isa_changed_in(stash);
1029 else if(method_changed)
1030 mro_method_changed_in(
1031 GvSTASH((const GV *)sv)
1037 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1053 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1054 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1055 Perl_croak_no_modify();
1057 TARG = sv_newmortal();
1058 sv_setsv(TARG, TOPs);
1059 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1060 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1062 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1063 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1067 else sv_dec_nomg(TOPs);
1069 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1070 if (inc && !SvOK(TARG))
1076 /* Ordinary operators. */
1080 dVAR; dSP; dATARGET; SV *svl, *svr;
1081 #ifdef PERL_PRESERVE_IVUV
1084 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1087 #ifdef PERL_PRESERVE_IVUV
1088 /* For integer to integer power, we do the calculation by hand wherever
1089 we're sure it is safe; otherwise we call pow() and try to convert to
1090 integer afterwards. */
1091 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1099 const IV iv = SvIVX(svr);
1103 goto float_it; /* Can't do negative powers this way. */
1107 baseuok = SvUOK(svl);
1109 baseuv = SvUVX(svl);
1111 const IV iv = SvIVX(svl);
1114 baseuok = TRUE; /* effectively it's a UV now */
1116 baseuv = -iv; /* abs, baseuok == false records sign */
1119 /* now we have integer ** positive integer. */
1122 /* foo & (foo - 1) is zero only for a power of 2. */
1123 if (!(baseuv & (baseuv - 1))) {
1124 /* We are raising power-of-2 to a positive integer.
1125 The logic here will work for any base (even non-integer
1126 bases) but it can be less accurate than
1127 pow (base,power) or exp (power * log (base)) when the
1128 intermediate values start to spill out of the mantissa.
1129 With powers of 2 we know this can't happen.
1130 And powers of 2 are the favourite thing for perl
1131 programmers to notice ** not doing what they mean. */
1133 NV base = baseuok ? baseuv : -(NV)baseuv;
1138 while (power >>= 1) {
1146 SvIV_please_nomg(svr);
1149 unsigned int highbit = 8 * sizeof(UV);
1150 unsigned int diff = 8 * sizeof(UV);
1151 while (diff >>= 1) {
1153 if (baseuv >> highbit) {
1157 /* we now have baseuv < 2 ** highbit */
1158 if (power * highbit <= 8 * sizeof(UV)) {
1159 /* result will definitely fit in UV, so use UV math
1160 on same algorithm as above */
1163 const bool odd_power = cBOOL(power & 1);
1167 while (power >>= 1) {
1174 if (baseuok || !odd_power)
1175 /* answer is positive */
1177 else if (result <= (UV)IV_MAX)
1178 /* answer negative, fits in IV */
1179 SETi( -(IV)result );
1180 else if (result == (UV)IV_MIN)
1181 /* 2's complement assumption: special case IV_MIN */
1184 /* answer negative, doesn't fit */
1185 SETn( -(NV)result );
1193 NV right = SvNV_nomg(svr);
1194 NV left = SvNV_nomg(svl);
1197 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1199 We are building perl with long double support and are on an AIX OS
1200 afflicted with a powl() function that wrongly returns NaNQ for any
1201 negative base. This was reported to IBM as PMR #23047-379 on
1202 03/06/2006. The problem exists in at least the following versions
1203 of AIX and the libm fileset, and no doubt others as well:
1205 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1206 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1207 AIX 5.2.0 bos.adt.libm 5.2.0.85
1209 So, until IBM fixes powl(), we provide the following workaround to
1210 handle the problem ourselves. Our logic is as follows: for
1211 negative bases (left), we use fmod(right, 2) to check if the
1212 exponent is an odd or even integer:
1214 - if odd, powl(left, right) == -powl(-left, right)
1215 - if even, powl(left, right) == powl(-left, right)
1217 If the exponent is not an integer, the result is rightly NaNQ, so
1218 we just return that (as NV_NAN).
1222 NV mod2 = Perl_fmod( right, 2.0 );
1223 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1224 SETn( -Perl_pow( -left, right) );
1225 } else if (mod2 == 0.0) { /* even integer */
1226 SETn( Perl_pow( -left, right) );
1227 } else { /* fractional power */
1231 SETn( Perl_pow( left, right) );
1234 SETn( Perl_pow( left, right) );
1235 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1237 #ifdef PERL_PRESERVE_IVUV
1239 SvIV_please_nomg(svr);
1247 dVAR; dSP; dATARGET; SV *svl, *svr;
1248 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1251 #ifdef PERL_PRESERVE_IVUV
1252 if (SvIV_please_nomg(svr)) {
1253 /* Unless the left argument is integer in range we are going to have to
1254 use NV maths. Hence only attempt to coerce the right argument if
1255 we know the left is integer. */
1256 /* Left operand is defined, so is it IV? */
1257 if (SvIV_please_nomg(svl)) {
1258 bool auvok = SvUOK(svl);
1259 bool buvok = SvUOK(svr);
1260 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1261 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1270 const IV aiv = SvIVX(svl);
1273 auvok = TRUE; /* effectively it's a UV now */
1275 alow = -aiv; /* abs, auvok == false records sign */
1281 const IV biv = SvIVX(svr);
1284 buvok = TRUE; /* effectively it's a UV now */
1286 blow = -biv; /* abs, buvok == false records sign */
1290 /* If this does sign extension on unsigned it's time for plan B */
1291 ahigh = alow >> (4 * sizeof (UV));
1293 bhigh = blow >> (4 * sizeof (UV));
1295 if (ahigh && bhigh) {
1297 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1298 which is overflow. Drop to NVs below. */
1299 } else if (!ahigh && !bhigh) {
1300 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1301 so the unsigned multiply cannot overflow. */
1302 const UV product = alow * blow;
1303 if (auvok == buvok) {
1304 /* -ve * -ve or +ve * +ve gives a +ve result. */
1308 } else if (product <= (UV)IV_MIN) {
1309 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1310 /* -ve result, which could overflow an IV */
1312 SETi( -(IV)product );
1314 } /* else drop to NVs below. */
1316 /* One operand is large, 1 small */
1319 /* swap the operands */
1321 bhigh = blow; /* bhigh now the temp var for the swap */
1325 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1326 multiplies can't overflow. shift can, add can, -ve can. */
1327 product_middle = ahigh * blow;
1328 if (!(product_middle & topmask)) {
1329 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1331 product_middle <<= (4 * sizeof (UV));
1332 product_low = alow * blow;
1334 /* as for pp_add, UV + something mustn't get smaller.
1335 IIRC ANSI mandates this wrapping *behaviour* for
1336 unsigned whatever the actual representation*/
1337 product_low += product_middle;
1338 if (product_low >= product_middle) {
1339 /* didn't overflow */
1340 if (auvok == buvok) {
1341 /* -ve * -ve or +ve * +ve gives a +ve result. */
1343 SETu( product_low );
1345 } else if (product_low <= (UV)IV_MIN) {
1346 /* 2s complement assumption again */
1347 /* -ve result, which could overflow an IV */
1349 SETi( -(IV)product_low );
1351 } /* else drop to NVs below. */
1353 } /* product_middle too large */
1354 } /* ahigh && bhigh */
1359 NV right = SvNV_nomg(svr);
1360 NV left = SvNV_nomg(svl);
1362 SETn( left * right );
1369 dVAR; dSP; dATARGET; SV *svl, *svr;
1370 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1373 /* Only try to do UV divide first
1374 if ((SLOPPYDIVIDE is true) or
1375 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1377 The assumption is that it is better to use floating point divide
1378 whenever possible, only doing integer divide first if we can't be sure.
1379 If NV_PRESERVES_UV is true then we know at compile time that no UV
1380 can be too large to preserve, so don't need to compile the code to
1381 test the size of UVs. */
1384 # define PERL_TRY_UV_DIVIDE
1385 /* ensure that 20./5. == 4. */
1387 # ifdef PERL_PRESERVE_IVUV
1388 # ifndef NV_PRESERVES_UV
1389 # define PERL_TRY_UV_DIVIDE
1394 #ifdef PERL_TRY_UV_DIVIDE
1395 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1396 bool left_non_neg = SvUOK(svl);
1397 bool right_non_neg = SvUOK(svr);
1401 if (right_non_neg) {
1405 const IV biv = SvIVX(svr);
1408 right_non_neg = TRUE; /* effectively it's a UV now */
1414 /* historically undef()/0 gives a "Use of uninitialized value"
1415 warning before dieing, hence this test goes here.
1416 If it were immediately before the second SvIV_please, then
1417 DIE() would be invoked before left was even inspected, so
1418 no inspection would give no warning. */
1420 DIE(aTHX_ "Illegal division by zero");
1426 const IV aiv = SvIVX(svl);
1429 left_non_neg = TRUE; /* effectively it's a UV now */
1438 /* For sloppy divide we always attempt integer division. */
1440 /* Otherwise we only attempt it if either or both operands
1441 would not be preserved by an NV. If both fit in NVs
1442 we fall through to the NV divide code below. However,
1443 as left >= right to ensure integer result here, we know that
1444 we can skip the test on the right operand - right big
1445 enough not to be preserved can't get here unless left is
1448 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1451 /* Integer division can't overflow, but it can be imprecise. */
1452 const UV result = left / right;
1453 if (result * right == left) {
1454 SP--; /* result is valid */
1455 if (left_non_neg == right_non_neg) {
1456 /* signs identical, result is positive. */
1460 /* 2s complement assumption */
1461 if (result <= (UV)IV_MIN)
1462 SETi( -(IV)result );
1464 /* It's exact but too negative for IV. */
1465 SETn( -(NV)result );
1468 } /* tried integer divide but it was not an integer result */
1469 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1470 } /* one operand wasn't SvIOK */
1471 #endif /* PERL_TRY_UV_DIVIDE */
1473 NV right = SvNV_nomg(svr);
1474 NV left = SvNV_nomg(svl);
1475 (void)POPs;(void)POPs;
1476 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1477 if (! Perl_isnan(right) && right == 0.0)
1481 DIE(aTHX_ "Illegal division by zero");
1482 PUSHn( left / right );
1489 dVAR; dSP; dATARGET;
1490 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1494 bool left_neg = FALSE;
1495 bool right_neg = FALSE;
1496 bool use_double = FALSE;
1497 bool dright_valid = FALSE;
1500 SV * const svr = TOPs;
1501 SV * const svl = TOPm1s;
1502 if (SvIV_please_nomg(svr)) {
1503 right_neg = !SvUOK(svr);
1507 const IV biv = SvIVX(svr);
1510 right_neg = FALSE; /* effectively it's a UV now */
1517 dright = SvNV_nomg(svr);
1518 right_neg = dright < 0;
1521 if (dright < UV_MAX_P1) {
1522 right = U_V(dright);
1523 dright_valid = TRUE; /* In case we need to use double below. */
1529 /* At this point use_double is only true if right is out of range for
1530 a UV. In range NV has been rounded down to nearest UV and
1531 use_double false. */
1532 if (!use_double && SvIV_please_nomg(svl)) {
1533 left_neg = !SvUOK(svl);
1537 const IV aiv = SvIVX(svl);
1540 left_neg = FALSE; /* effectively it's a UV now */
1547 dleft = SvNV_nomg(svl);
1548 left_neg = dleft < 0;
1552 /* This should be exactly the 5.6 behaviour - if left and right are
1553 both in range for UV then use U_V() rather than floor. */
1555 if (dleft < UV_MAX_P1) {
1556 /* right was in range, so is dleft, so use UVs not double.
1560 /* left is out of range for UV, right was in range, so promote
1561 right (back) to double. */
1563 /* The +0.5 is used in 5.6 even though it is not strictly
1564 consistent with the implicit +0 floor in the U_V()
1565 inside the #if 1. */
1566 dleft = Perl_floor(dleft + 0.5);
1569 dright = Perl_floor(dright + 0.5);
1580 DIE(aTHX_ "Illegal modulus zero");
1582 dans = Perl_fmod(dleft, dright);
1583 if ((left_neg != right_neg) && dans)
1584 dans = dright - dans;
1587 sv_setnv(TARG, dans);
1593 DIE(aTHX_ "Illegal modulus zero");
1596 if ((left_neg != right_neg) && ans)
1599 /* XXX may warn: unary minus operator applied to unsigned type */
1600 /* could change -foo to be (~foo)+1 instead */
1601 if (ans <= ~((UV)IV_MAX)+1)
1602 sv_setiv(TARG, ~ans+1);
1604 sv_setnv(TARG, -(NV)ans);
1607 sv_setuv(TARG, ans);
1616 dVAR; dSP; dATARGET;
1620 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1621 /* TODO: think of some way of doing list-repeat overloading ??? */
1626 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1632 const UV uv = SvUV_nomg(sv);
1634 count = IV_MAX; /* The best we can do? */
1638 const IV iv = SvIV_nomg(sv);
1645 else if (SvNOKp(sv)) {
1646 const NV nv = SvNV_nomg(sv);
1653 count = SvIV_nomg(sv);
1655 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1657 static const char* const oom_list_extend = "Out of memory during list extend";
1658 const I32 items = SP - MARK;
1659 const I32 max = items * count;
1660 const U8 mod = PL_op->op_flags & OPf_MOD;
1662 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1663 /* Did the max computation overflow? */
1664 if (items > 0 && max > 0 && (max < items || max < count))
1665 Perl_croak(aTHX_ "%s", oom_list_extend);
1670 /* This code was intended to fix 20010809.028:
1673 for (($x =~ /./g) x 2) {
1674 print chop; # "abcdabcd" expected as output.
1677 * but that change (#11635) broke this code:
1679 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1681 * I can't think of a better fix that doesn't introduce
1682 * an efficiency hit by copying the SVs. The stack isn't
1683 * refcounted, and mortalisation obviously doesn't
1684 * Do The Right Thing when the stack has more than
1685 * one pointer to the same mortal value.
1689 *SP = sv_2mortal(newSVsv(*SP));
1695 if (mod && SvPADTMP(*SP) && !IS_PADGV(*SP))
1696 *SP = sv_mortalcopy(*SP);
1703 repeatcpy((char*)(MARK + items), (char*)MARK,
1704 items * sizeof(const SV *), count - 1);
1707 else if (count <= 0)
1710 else { /* Note: mark already snarfed by pp_list */
1711 SV * const tmpstr = POPs;
1714 static const char* const oom_string_extend =
1715 "Out of memory during string extend";
1718 sv_setsv_nomg(TARG, tmpstr);
1719 SvPV_force_nomg(TARG, len);
1720 isutf = DO_UTF8(TARG);
1725 const STRLEN max = (UV)count * len;
1726 if (len > MEM_SIZE_MAX / count)
1727 Perl_croak(aTHX_ "%s", oom_string_extend);
1728 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1729 SvGROW(TARG, max + 1);
1730 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1731 SvCUR_set(TARG, SvCUR(TARG) * count);
1733 *SvEND(TARG) = '\0';
1736 (void)SvPOK_only_UTF8(TARG);
1738 (void)SvPOK_only(TARG);
1740 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1741 /* The parser saw this as a list repeat, and there
1742 are probably several items on the stack. But we're
1743 in scalar context, and there's no pp_list to save us
1744 now. So drop the rest of the items -- robin@kitsite.com
1756 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1757 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1760 useleft = USE_LEFT(svl);
1761 #ifdef PERL_PRESERVE_IVUV
1762 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1763 "bad things" happen if you rely on signed integers wrapping. */
1764 if (SvIV_please_nomg(svr)) {
1765 /* Unless the left argument is integer in range we are going to have to
1766 use NV maths. Hence only attempt to coerce the right argument if
1767 we know the left is integer. */
1774 a_valid = auvok = 1;
1775 /* left operand is undef, treat as zero. */
1777 /* Left operand is defined, so is it IV? */
1778 if (SvIV_please_nomg(svl)) {
1779 if ((auvok = SvUOK(svl)))
1782 const IV aiv = SvIVX(svl);
1785 auvok = 1; /* Now acting as a sign flag. */
1786 } else { /* 2s complement assumption for IV_MIN */
1794 bool result_good = 0;
1797 bool buvok = SvUOK(svr);
1802 const IV biv = SvIVX(svr);
1809 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1810 else "IV" now, independent of how it came in.
1811 if a, b represents positive, A, B negative, a maps to -A etc
1816 all UV maths. negate result if A negative.
1817 subtract if signs same, add if signs differ. */
1819 if (auvok ^ buvok) {
1828 /* Must get smaller */
1833 if (result <= buv) {
1834 /* result really should be -(auv-buv). as its negation
1835 of true value, need to swap our result flag */
1847 if (result <= (UV)IV_MIN)
1848 SETi( -(IV)result );
1850 /* result valid, but out of range for IV. */
1851 SETn( -(NV)result );
1855 } /* Overflow, drop through to NVs. */
1860 NV value = SvNV_nomg(svr);
1864 /* left operand is undef, treat as zero - value */
1868 SETn( SvNV_nomg(svl) - value );
1875 dVAR; dSP; dATARGET; SV *svl, *svr;
1876 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1880 const IV shift = SvIV_nomg(svr);
1881 if (PL_op->op_private & HINT_INTEGER) {
1882 const IV i = SvIV_nomg(svl);
1886 const UV u = SvUV_nomg(svl);
1895 dVAR; dSP; dATARGET; SV *svl, *svr;
1896 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1900 const IV shift = SvIV_nomg(svr);
1901 if (PL_op->op_private & HINT_INTEGER) {
1902 const IV i = SvIV_nomg(svl);
1906 const UV u = SvUV_nomg(svl);
1918 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1922 (SvIOK_notUV(left) && SvIOK_notUV(right))
1923 ? (SvIVX(left) < SvIVX(right))
1924 : (do_ncmp(left, right) == -1)
1934 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1938 (SvIOK_notUV(left) && SvIOK_notUV(right))
1939 ? (SvIVX(left) > SvIVX(right))
1940 : (do_ncmp(left, right) == 1)
1950 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1954 (SvIOK_notUV(left) && SvIOK_notUV(right))
1955 ? (SvIVX(left) <= SvIVX(right))
1956 : (do_ncmp(left, right) <= 0)
1966 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1970 (SvIOK_notUV(left) && SvIOK_notUV(right))
1971 ? (SvIVX(left) >= SvIVX(right))
1972 : ( (do_ncmp(left, right) & 2) == 0)
1982 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1986 (SvIOK_notUV(left) && SvIOK_notUV(right))
1987 ? (SvIVX(left) != SvIVX(right))
1988 : (do_ncmp(left, right) != 0)
1993 /* compare left and right SVs. Returns:
1997 * 2: left or right was a NaN
2000 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2004 PERL_ARGS_ASSERT_DO_NCMP;
2005 #ifdef PERL_PRESERVE_IVUV
2006 /* Fortunately it seems NaN isn't IOK */
2007 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2009 const IV leftiv = SvIVX(left);
2010 if (!SvUOK(right)) {
2011 /* ## IV <=> IV ## */
2012 const IV rightiv = SvIVX(right);
2013 return (leftiv > rightiv) - (leftiv < rightiv);
2015 /* ## IV <=> UV ## */
2017 /* As (b) is a UV, it's >=0, so it must be < */
2020 const UV rightuv = SvUVX(right);
2021 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2026 /* ## UV <=> UV ## */
2027 const UV leftuv = SvUVX(left);
2028 const UV rightuv = SvUVX(right);
2029 return (leftuv > rightuv) - (leftuv < rightuv);
2031 /* ## UV <=> IV ## */
2033 const IV rightiv = SvIVX(right);
2035 /* As (a) is a UV, it's >=0, so it cannot be < */
2038 const UV leftuv = SvUVX(left);
2039 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2042 assert(0); /* NOTREACHED */
2046 NV const rnv = SvNV_nomg(right);
2047 NV const lnv = SvNV_nomg(left);
2049 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2050 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2053 return (lnv > rnv) - (lnv < rnv);
2072 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2075 value = do_ncmp(left, right);
2090 int amg_type = sle_amg;
2094 switch (PL_op->op_type) {
2113 tryAMAGICbin_MG(amg_type, AMGf_set);
2116 const int cmp = (IN_LOCALE_RUNTIME
2117 ? sv_cmp_locale_flags(left, right, 0)
2118 : sv_cmp_flags(left, right, 0));
2119 SETs(boolSV(cmp * multiplier < rhs));
2127 tryAMAGICbin_MG(seq_amg, AMGf_set);
2130 SETs(boolSV(sv_eq_flags(left, right, 0)));
2138 tryAMAGICbin_MG(sne_amg, AMGf_set);
2141 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2149 tryAMAGICbin_MG(scmp_amg, 0);
2152 const int cmp = (IN_LOCALE_RUNTIME
2153 ? sv_cmp_locale_flags(left, right, 0)
2154 : sv_cmp_flags(left, right, 0));
2162 dVAR; dSP; dATARGET;
2163 tryAMAGICbin_MG(band_amg, AMGf_assign);
2166 if (SvNIOKp(left) || SvNIOKp(right)) {
2167 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2168 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2169 if (PL_op->op_private & HINT_INTEGER) {
2170 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2174 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2177 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2178 if (right_ro_nonnum) SvNIOK_off(right);
2181 do_vop(PL_op->op_type, TARG, left, right);
2190 dVAR; dSP; dATARGET;
2191 const int op_type = PL_op->op_type;
2193 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2196 if (SvNIOKp(left) || SvNIOKp(right)) {
2197 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2198 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2199 if (PL_op->op_private & HINT_INTEGER) {
2200 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2201 const IV r = SvIV_nomg(right);
2202 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2206 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2207 const UV r = SvUV_nomg(right);
2208 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2211 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2212 if (right_ro_nonnum) SvNIOK_off(right);
2215 do_vop(op_type, TARG, left, right);
2222 PERL_STATIC_INLINE bool
2223 S_negate_string(pTHX)
2228 SV * const sv = TOPs;
2229 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2231 s = SvPV_nomg_const(sv, len);
2232 if (isIDFIRST(*s)) {
2233 sv_setpvs(TARG, "-");
2236 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2237 sv_setsv_nomg(TARG, sv);
2238 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2248 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2249 if (S_negate_string(aTHX)) return NORMAL;
2251 SV * const sv = TOPs;
2254 /* It's publicly an integer */
2257 if (SvIVX(sv) == IV_MIN) {
2258 /* 2s complement assumption. */
2259 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2263 else if (SvUVX(sv) <= IV_MAX) {
2268 else if (SvIVX(sv) != IV_MIN) {
2272 #ifdef PERL_PRESERVE_IVUV
2279 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2280 SETn(-SvNV_nomg(sv));
2281 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2282 goto oops_its_an_int;
2284 SETn(-SvNV_nomg(sv));
2292 tryAMAGICun_MG(not_amg, AMGf_set);
2293 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2300 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2304 if (PL_op->op_private & HINT_INTEGER) {
2305 const IV i = ~SvIV_nomg(sv);
2309 const UV u = ~SvUV_nomg(sv);
2318 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2319 sv_setsv_nomg(TARG, sv);
2320 tmps = (U8*)SvPV_force_nomg(TARG, len);
2323 /* Calculate exact length, let's not estimate. */
2328 U8 * const send = tmps + len;
2329 U8 * const origtmps = tmps;
2330 const UV utf8flags = UTF8_ALLOW_ANYUV;
2332 while (tmps < send) {
2333 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2335 targlen += UNISKIP(~c);
2341 /* Now rewind strings and write them. */
2348 Newx(result, targlen + 1, U8);
2350 while (tmps < send) {
2351 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2353 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2356 sv_usepvn_flags(TARG, (char*)result, targlen,
2357 SV_HAS_TRAILING_NUL);
2364 Newx(result, nchar + 1, U8);
2366 while (tmps < send) {
2367 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2372 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2381 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2384 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2389 for ( ; anum > 0; anum--, tmps++)
2397 /* integer versions of some of the above */
2401 dVAR; dSP; dATARGET;
2402 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2405 SETi( left * right );
2413 dVAR; dSP; dATARGET;
2414 tryAMAGICbin_MG(div_amg, AMGf_assign);
2417 IV value = SvIV_nomg(right);
2419 DIE(aTHX_ "Illegal division by zero");
2420 num = SvIV_nomg(left);
2422 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2426 value = num / value;
2432 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2439 /* This is the vanilla old i_modulo. */
2440 dVAR; dSP; dATARGET;
2441 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2445 DIE(aTHX_ "Illegal modulus zero");
2446 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2450 SETi( left % right );
2455 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2460 /* This is the i_modulo with the workaround for the _moddi3 bug
2461 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2462 * See below for pp_i_modulo. */
2463 dVAR; dSP; dATARGET;
2464 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2468 DIE(aTHX_ "Illegal modulus zero");
2469 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2473 SETi( left % PERL_ABS(right) );
2480 dVAR; dSP; dATARGET;
2481 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2485 DIE(aTHX_ "Illegal modulus zero");
2486 /* The assumption is to use hereafter the old vanilla version... */
2488 PL_ppaddr[OP_I_MODULO] =
2490 /* .. but if we have glibc, we might have a buggy _moddi3
2491 * (at least glicb 2.2.5 is known to have this bug), in other
2492 * words our integer modulus with negative quad as the second
2493 * argument might be broken. Test for this and re-patch the
2494 * opcode dispatch table if that is the case, remembering to
2495 * also apply the workaround so that this first round works
2496 * right, too. See [perl #9402] for more information. */
2500 /* Cannot do this check with inlined IV constants since
2501 * that seems to work correctly even with the buggy glibc. */
2503 /* Yikes, we have the bug.
2504 * Patch in the workaround version. */
2506 PL_ppaddr[OP_I_MODULO] =
2507 &Perl_pp_i_modulo_1;
2508 /* Make certain we work right this time, too. */
2509 right = PERL_ABS(right);
2512 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2516 SETi( left % right );
2524 dVAR; dSP; dATARGET;
2525 tryAMAGICbin_MG(add_amg, AMGf_assign);
2527 dPOPTOPiirl_ul_nomg;
2528 SETi( left + right );
2535 dVAR; dSP; dATARGET;
2536 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2538 dPOPTOPiirl_ul_nomg;
2539 SETi( left - right );
2547 tryAMAGICbin_MG(lt_amg, AMGf_set);
2550 SETs(boolSV(left < right));
2558 tryAMAGICbin_MG(gt_amg, AMGf_set);
2561 SETs(boolSV(left > right));
2569 tryAMAGICbin_MG(le_amg, AMGf_set);
2572 SETs(boolSV(left <= right));
2580 tryAMAGICbin_MG(ge_amg, AMGf_set);
2583 SETs(boolSV(left >= right));
2591 tryAMAGICbin_MG(eq_amg, AMGf_set);
2594 SETs(boolSV(left == right));
2602 tryAMAGICbin_MG(ne_amg, AMGf_set);
2605 SETs(boolSV(left != right));
2613 tryAMAGICbin_MG(ncmp_amg, 0);
2620 else if (left < right)
2632 tryAMAGICun_MG(neg_amg, 0);
2633 if (S_negate_string(aTHX)) return NORMAL;
2635 SV * const sv = TOPs;
2636 IV const i = SvIV_nomg(sv);
2642 /* High falutin' math. */
2647 tryAMAGICbin_MG(atan2_amg, 0);
2650 SETn(Perl_atan2(left, right));
2658 int amg_type = sin_amg;
2659 const char *neg_report = NULL;
2660 NV (*func)(NV) = Perl_sin;
2661 const int op_type = PL_op->op_type;
2678 amg_type = sqrt_amg;
2680 neg_report = "sqrt";
2685 tryAMAGICun_MG(amg_type, 0);
2687 SV * const arg = POPs;
2688 const NV value = SvNV_nomg(arg);
2690 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2691 SET_NUMERIC_STANDARD();
2692 /* diag_listed_as: Can't take log of %g */
2693 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2696 XPUSHn(func(value));
2701 /* Support Configure command-line overrides for rand() functions.
2702 After 5.005, perhaps we should replace this by Configure support
2703 for drand48(), random(), or rand(). For 5.005, though, maintain
2704 compatibility by calling rand() but allow the user to override it.
2705 See INSTALL for details. --Andy Dougherty 15 July 1998
2707 /* Now it's after 5.005, and Configure supports drand48() and random(),
2708 in addition to rand(). So the overrides should not be needed any more.
2709 --Jarkko Hietaniemi 27 September 1998
2712 #ifndef HAS_DRAND48_PROTO
2713 extern double drand48 (void);
2719 if (!PL_srand_called) {
2720 (void)seedDrand01((Rand_seed_t)seed());
2721 PL_srand_called = TRUE;
2731 SV * const sv = POPs;
2737 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2745 sv_setnv_mg(TARG, value);
2756 if (MAXARG >= 1 && (TOPs || POPs)) {
2763 pv = SvPV(top, len);
2764 flags = grok_number(pv, len, &anum);
2766 if (!(flags & IS_NUMBER_IN_UV)) {
2767 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2768 "Integer overflow in srand");
2776 (void)seedDrand01((Rand_seed_t)anum);
2777 PL_srand_called = TRUE;
2781 /* Historically srand always returned true. We can avoid breaking
2783 sv_setpvs(TARG, "0 but true");
2792 tryAMAGICun_MG(int_amg, AMGf_numeric);
2794 SV * const sv = TOPs;
2795 const IV iv = SvIV_nomg(sv);
2796 /* XXX it's arguable that compiler casting to IV might be subtly
2797 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2798 else preferring IV has introduced a subtle behaviour change bug. OTOH
2799 relying on floating point to be accurate is a bug. */
2804 else if (SvIOK(sv)) {
2806 SETu(SvUV_nomg(sv));
2811 const NV value = SvNV_nomg(sv);
2813 if (value < (NV)UV_MAX + 0.5) {
2816 SETn(Perl_floor(value));
2820 if (value > (NV)IV_MIN - 0.5) {
2823 SETn(Perl_ceil(value));
2834 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2836 SV * const sv = TOPs;
2837 /* This will cache the NV value if string isn't actually integer */
2838 const IV iv = SvIV_nomg(sv);
2843 else if (SvIOK(sv)) {
2844 /* IVX is precise */
2846 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2854 /* 2s complement assumption. Also, not really needed as
2855 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2861 const NV value = SvNV_nomg(sv);
2875 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2879 SV* const sv = POPs;
2881 tmps = (SvPV_const(sv, len));
2883 /* If Unicode, try to downgrade
2884 * If not possible, croak. */
2885 SV* const tsv = sv_2mortal(newSVsv(sv));
2888 sv_utf8_downgrade(tsv, FALSE);
2889 tmps = SvPV_const(tsv, len);
2891 if (PL_op->op_type == OP_HEX)
2894 while (*tmps && len && isSPACE(*tmps))
2898 if (*tmps == 'x' || *tmps == 'X') {
2900 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2902 else if (*tmps == 'b' || *tmps == 'B')
2903 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2905 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2907 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2921 SV * const sv = TOPs;
2926 SETi(sv_len_utf8_nomg(sv));
2930 (void)SvPV_nomg_const(sv,len);
2934 if (!SvPADTMP(TARG)) {
2935 sv_setsv_nomg(TARG, &PL_sv_undef);
2943 /* Returns false if substring is completely outside original string.
2944 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2945 always be true for an explicit 0.
2948 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2949 bool pos1_is_uv, IV len_iv,
2950 bool len_is_uv, STRLEN *posp,
2956 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2958 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2959 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2962 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2965 if (len_iv || len_is_uv) {
2966 if (!len_is_uv && len_iv < 0) {
2967 pos2_iv = curlen + len_iv;
2969 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2972 } else { /* len_iv >= 0 */
2973 if (!pos1_is_uv && pos1_iv < 0) {
2974 pos2_iv = pos1_iv + len_iv;
2975 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2977 if ((UV)len_iv > curlen-(UV)pos1_iv)
2980 pos2_iv = pos1_iv+len_iv;
2990 if (!pos2_is_uv && pos2_iv < 0) {
2991 if (!pos1_is_uv && pos1_iv < 0)
2995 else if (!pos1_is_uv && pos1_iv < 0)
2998 if ((UV)pos2_iv < (UV)pos1_iv)
3000 if ((UV)pos2_iv > curlen)
3003 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3004 *posp = (STRLEN)( (UV)pos1_iv );
3005 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3022 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3023 const bool rvalue = (GIMME_V != G_VOID);
3026 const char *repl = NULL;
3028 int num_args = PL_op->op_private & 7;
3029 bool repl_need_utf8_upgrade = FALSE;
3033 if(!(repl_sv = POPs)) num_args--;
3035 if ((len_sv = POPs)) {
3036 len_iv = SvIV(len_sv);
3037 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3042 pos1_iv = SvIV(pos_sv);
3043 pos1_is_uv = SvIOK_UV(pos_sv);
3045 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3050 if (lvalue && !repl_sv) {
3052 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3053 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3055 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3057 pos1_is_uv || pos1_iv >= 0
3058 ? (STRLEN)(UV)pos1_iv
3059 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3061 len_is_uv || len_iv > 0
3062 ? (STRLEN)(UV)len_iv
3063 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3066 PUSHs(ret); /* avoid SvSETMAGIC here */
3070 repl = SvPV_const(repl_sv, repl_len);
3073 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3074 "Attempt to use reference as lvalue in substr"
3076 tmps = SvPV_force_nomg(sv, curlen);
3077 if (DO_UTF8(repl_sv) && repl_len) {
3079 sv_utf8_upgrade_nomg(sv);
3083 else if (DO_UTF8(sv))
3084 repl_need_utf8_upgrade = TRUE;
3086 else tmps = SvPV_const(sv, curlen);
3088 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3089 if (utf8_curlen == curlen)
3092 curlen = utf8_curlen;
3098 STRLEN pos, len, byte_len, byte_pos;
3100 if (!translate_substr_offsets(
3101 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3105 byte_pos = utf8_curlen
3106 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3111 SvTAINTED_off(TARG); /* decontaminate */
3112 SvUTF8_off(TARG); /* decontaminate */
3113 sv_setpvn(TARG, tmps, byte_len);
3114 #ifdef USE_LOCALE_COLLATE
3115 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3122 SV* repl_sv_copy = NULL;
3124 if (repl_need_utf8_upgrade) {
3125 repl_sv_copy = newSVsv(repl_sv);
3126 sv_utf8_upgrade(repl_sv_copy);
3127 repl = SvPV_const(repl_sv_copy, repl_len);
3131 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3132 SvREFCNT_dec(repl_sv_copy);
3144 Perl_croak(aTHX_ "substr outside of string");
3145 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3152 const IV size = POPi;
3153 const IV offset = POPi;
3154 SV * const src = POPs;
3155 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3158 if (lvalue) { /* it's an lvalue! */
3159 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3160 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3162 LvTARG(ret) = SvREFCNT_inc_simple(src);
3163 LvTARGOFF(ret) = offset;
3164 LvTARGLEN(ret) = size;
3168 SvTAINTED_off(TARG); /* decontaminate */
3172 sv_setuv(ret, do_vecget(src, offset, size));
3188 const char *little_p;
3191 const bool is_index = PL_op->op_type == OP_INDEX;
3192 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3198 big_p = SvPV_const(big, biglen);
3199 little_p = SvPV_const(little, llen);
3201 big_utf8 = DO_UTF8(big);
3202 little_utf8 = DO_UTF8(little);
3203 if (big_utf8 ^ little_utf8) {
3204 /* One needs to be upgraded. */
3205 if (little_utf8 && !PL_encoding) {
3206 /* Well, maybe instead we might be able to downgrade the small
3208 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3211 /* If the large string is ISO-8859-1, and it's not possible to
3212 convert the small string to ISO-8859-1, then there is no
3213 way that it could be found anywhere by index. */
3218 /* At this point, pv is a malloc()ed string. So donate it to temp
3219 to ensure it will get free()d */
3220 little = temp = newSV(0);
3221 sv_usepvn(temp, pv, llen);
3222 little_p = SvPVX(little);
3225 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3228 sv_recode_to_utf8(temp, PL_encoding);
3230 sv_utf8_upgrade(temp);
3235 big_p = SvPV_const(big, biglen);
3238 little_p = SvPV_const(little, llen);
3242 if (SvGAMAGIC(big)) {
3243 /* Life just becomes a lot easier if I use a temporary here.
3244 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3245 will trigger magic and overloading again, as will fbm_instr()
3247 big = newSVpvn_flags(big_p, biglen,
3248 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3251 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3252 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3253 warn on undef, and we've already triggered a warning with the
3254 SvPV_const some lines above. We can't remove that, as we need to
3255 call some SvPV to trigger overloading early and find out if the
3257 This is all getting to messy. The API isn't quite clean enough,
3258 because data access has side effects.
3260 little = newSVpvn_flags(little_p, llen,
3261 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3262 little_p = SvPVX(little);
3266 offset = is_index ? 0 : biglen;
3268 if (big_utf8 && offset > 0)
3269 sv_pos_u2b(big, &offset, 0);
3275 else if (offset > (I32)biglen)
3277 if (!(little_p = is_index
3278 ? fbm_instr((unsigned char*)big_p + offset,
3279 (unsigned char*)big_p + biglen, little, 0)
3280 : rninstr(big_p, big_p + offset,
3281 little_p, little_p + llen)))
3284 retval = little_p - big_p;
3285 if (retval > 0 && big_utf8)
3286 sv_pos_b2u(big, &retval);
3296 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3297 SvTAINTED_off(TARG);
3298 do_sprintf(TARG, SP-MARK, MARK+1);
3299 TAINT_IF(SvTAINTED(TARG));
3311 const U8 *s = (U8*)SvPV_const(argsv, len);
3313 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3314 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3315 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3319 XPUSHu(DO_UTF8(argsv) ?
3320 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3334 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3335 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3337 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3338 && SvNV_nomg(top) < 0.0))) {
3339 if (ckWARN(WARN_UTF8)) {
3340 if (SvGMAGICAL(top)) {
3341 SV *top2 = sv_newmortal();
3342 sv_setsv_nomg(top2, top);
3345 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3346 "Invalid negative number (%"SVf") in chr", top);
3348 value = UNICODE_REPLACEMENT;
3350 value = SvUV_nomg(top);
3353 SvUPGRADE(TARG,SVt_PV);
3355 if (value > 255 && !IN_BYTES) {
3356 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3357 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3358 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3360 (void)SvPOK_only(TARG);
3369 *tmps++ = (char)value;
3371 (void)SvPOK_only(TARG);
3373 if (PL_encoding && !IN_BYTES) {
3374 sv_recode_to_utf8(TARG, PL_encoding);
3376 if (SvCUR(TARG) == 0
3377 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3378 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3383 *tmps++ = (char)value;
3399 const char *tmps = SvPV_const(left, len);
3401 if (DO_UTF8(left)) {
3402 /* If Unicode, try to downgrade.
3403 * If not possible, croak.
3404 * Yes, we made this up. */
3405 SV* const tsv = sv_2mortal(newSVsv(left));
3408 sv_utf8_downgrade(tsv, FALSE);
3409 tmps = SvPV_const(tsv, len);
3411 # ifdef USE_ITHREADS
3413 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3414 /* This should be threadsafe because in ithreads there is only
3415 * one thread per interpreter. If this would not be true,
3416 * we would need a mutex to protect this malloc. */
3417 PL_reentrant_buffer->_crypt_struct_buffer =
3418 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3419 #if defined(__GLIBC__) || defined(__EMX__)
3420 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3421 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3422 /* work around glibc-2.2.5 bug */
3423 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3427 # endif /* HAS_CRYPT_R */
3428 # endif /* USE_ITHREADS */
3430 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3432 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3438 "The crypt() function is unimplemented due to excessive paranoia.");
3442 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3443 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3447 /* Actually is both lcfirst() and ucfirst(). Only the first character
3448 * changes. This means that possibly we can change in-place, ie., just
3449 * take the source and change that one character and store it back, but not
3450 * if read-only etc, or if the length changes */
3455 STRLEN slen; /* slen is the byte length of the whole SV. */
3458 bool inplace; /* ? Convert first char only, in-place */
3459 bool doing_utf8 = FALSE; /* ? using utf8 */
3460 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3461 const int op_type = PL_op->op_type;
3464 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3465 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3466 * stored as UTF-8 at s. */
3467 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3468 * lowercased) character stored in tmpbuf. May be either
3469 * UTF-8 or not, but in either case is the number of bytes */
3470 bool tainted = FALSE;
3474 s = (const U8*)SvPV_nomg_const(source, slen);
3476 if (ckWARN(WARN_UNINITIALIZED))
3477 report_uninit(source);
3482 /* We may be able to get away with changing only the first character, in
3483 * place, but not if read-only, etc. Later we may discover more reasons to
3484 * not convert in-place. */
3485 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3487 /* First calculate what the changed first character should be. This affects
3488 * whether we can just swap it out, leaving the rest of the string unchanged,
3489 * or even if have to convert the dest to UTF-8 when the source isn't */
3491 if (! slen) { /* If empty */
3492 need = 1; /* still need a trailing NUL */
3495 else if (DO_UTF8(source)) { /* Is the source utf8? */
3498 if (op_type == OP_UCFIRST) {
3499 _to_utf8_title_flags(s, tmpbuf, &tculen,
3500 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3503 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3504 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3507 /* we can't do in-place if the length changes. */
3508 if (ulen != tculen) inplace = FALSE;
3509 need = slen + 1 - ulen + tculen;
3511 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3512 * latin1 is treated as caseless. Note that a locale takes
3514 ulen = 1; /* Original character is 1 byte */
3515 tculen = 1; /* Most characters will require one byte, but this will
3516 * need to be overridden for the tricky ones */
3519 if (op_type == OP_LCFIRST) {
3521 /* lower case the first letter: no trickiness for any character */
3522 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3523 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3526 else if (IN_LOCALE_RUNTIME) {
3527 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3528 * have upper and title case different
3531 else if (! IN_UNI_8_BIT) {
3532 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3533 * on EBCDIC machines whatever the
3534 * native function does */
3536 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3537 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3539 assert(tculen == 2);
3541 /* If the result is an upper Latin1-range character, it can
3542 * still be represented in one byte, which is its ordinal */
3543 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3544 *tmpbuf = (U8) title_ord;
3548 /* Otherwise it became more than one ASCII character (in
3549 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3550 * beyond Latin1, so the number of bytes changed, so can't
3551 * replace just the first character in place. */
3554 /* If the result won't fit in a byte, the entire result
3555 * will have to be in UTF-8. Assume worst case sizing in
3556 * conversion. (all latin1 characters occupy at most two
3558 if (title_ord > 255) {
3560 convert_source_to_utf8 = TRUE;
3561 need = slen * 2 + 1;
3563 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3564 * (both) characters whose title case is above 255 is
3568 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3569 need = slen + 1 + 1;
3573 } /* End of use Unicode (Latin1) semantics */
3574 } /* End of changing the case of the first character */
3576 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3577 * generate the result */
3580 /* We can convert in place. This means we change just the first
3581 * character without disturbing the rest; no need to grow */
3583 s = d = (U8*)SvPV_force_nomg(source, slen);
3589 /* Here, we can't convert in place; we earlier calculated how much
3590 * space we will need, so grow to accommodate that */
3591 SvUPGRADE(dest, SVt_PV);
3592 d = (U8*)SvGROW(dest, need);
3593 (void)SvPOK_only(dest);
3600 if (! convert_source_to_utf8) {
3602 /* Here both source and dest are in UTF-8, but have to create
3603 * the entire output. We initialize the result to be the
3604 * title/lower cased first character, and then append the rest
3606 sv_setpvn(dest, (char*)tmpbuf, tculen);
3608 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3612 const U8 *const send = s + slen;
3614 /* Here the dest needs to be in UTF-8, but the source isn't,
3615 * except we earlier UTF-8'd the first character of the source
3616 * into tmpbuf. First put that into dest, and then append the
3617 * rest of the source, converting it to UTF-8 as we go. */
3619 /* Assert tculen is 2 here because the only two characters that
3620 * get to this part of the code have 2-byte UTF-8 equivalents */
3622 *d++ = *(tmpbuf + 1);
3623 s++; /* We have just processed the 1st char */
3625 for (; s < send; s++) {
3626 d = uvchr_to_utf8(d, *s);
3629 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3633 else { /* in-place UTF-8. Just overwrite the first character */
3634 Copy(tmpbuf, d, tculen, U8);
3635 SvCUR_set(dest, need - 1);
3643 else { /* Neither source nor dest are in or need to be UTF-8 */
3645 if (IN_LOCALE_RUNTIME) {
3649 if (inplace) { /* in-place, only need to change the 1st char */
3652 else { /* Not in-place */
3654 /* Copy the case-changed character(s) from tmpbuf */
3655 Copy(tmpbuf, d, tculen, U8);
3656 d += tculen - 1; /* Code below expects d to point to final
3657 * character stored */
3660 else { /* empty source */
3661 /* See bug #39028: Don't taint if empty */
3665 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3666 * the destination to retain that flag */
3670 if (!inplace) { /* Finish the rest of the string, unchanged */
3671 /* This will copy the trailing NUL */
3672 Copy(s + 1, d + 1, slen, U8);
3673 SvCUR_set(dest, need - 1);
3676 if (dest != source && SvTAINTED(source))
3682 /* There's so much setup/teardown code common between uc and lc, I wonder if
3683 it would be worth merging the two, and just having a switch outside each
3684 of the three tight loops. There is less and less commonality though */
3698 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3699 && SvTEMP(source) && !DO_UTF8(source)
3700 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3702 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3703 * make the loop tight, so we overwrite the source with the dest before
3704 * looking at it, and we need to look at the original source
3705 * afterwards. There would also need to be code added to handle
3706 * switching to not in-place in midstream if we run into characters
3707 * that change the length.
3710 s = d = (U8*)SvPV_force_nomg(source, len);
3717 /* The old implementation would copy source into TARG at this point.
3718 This had the side effect that if source was undef, TARG was now
3719 an undefined SV with PADTMP set, and they don't warn inside
3720 sv_2pv_flags(). However, we're now getting the PV direct from
3721 source, which doesn't have PADTMP set, so it would warn. Hence the
3725 s = (const U8*)SvPV_nomg_const(source, len);
3727 if (ckWARN(WARN_UNINITIALIZED))
3728 report_uninit(source);
3734 SvUPGRADE(dest, SVt_PV);
3735 d = (U8*)SvGROW(dest, min);
3736 (void)SvPOK_only(dest);
3741 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3742 to check DO_UTF8 again here. */
3744 if (DO_UTF8(source)) {
3745 const U8 *const send = s + len;
3746 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3747 bool tainted = FALSE;
3749 /* All occurrences of these are to be moved to follow any other marks.
3750 * This is context-dependent. We may not be passed enough context to
3751 * move the iota subscript beyond all of them, but we do the best we can
3752 * with what we're given. The result is always better than if we
3753 * hadn't done this. And, the problem would only arise if we are
3754 * passed a character without all its combining marks, which would be
3755 * the caller's mistake. The information this is based on comes from a
3756 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3757 * itself) and so can't be checked properly to see if it ever gets
3758 * revised. But the likelihood of it changing is remote */
3759 bool in_iota_subscript = FALSE;
3765 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3767 /* A non-mark. Time to output the iota subscript */
3768 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3769 d += capital_iota_len;
3770 in_iota_subscript = FALSE;
3773 /* Then handle the current character. Get the changed case value
3774 * and copy it to the output buffer */
3777 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3778 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3779 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3780 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3781 if (uv == GREEK_CAPITAL_LETTER_IOTA
3782 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3784 in_iota_subscript = TRUE;
3787 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3788 /* If the eventually required minimum size outgrows the
3789 * available space, we need to grow. */
3790 const UV o = d - (U8*)SvPVX_const(dest);
3792 /* If someone uppercases one million U+03B0s we SvGROW()
3793 * one million times. Or we could try guessing how much to
3794 * allocate without allocating too much. Such is life.
3795 * See corresponding comment in lc code for another option
3798 d = (U8*)SvPVX(dest) + o;
3800 Copy(tmpbuf, d, ulen, U8);
3805 if (in_iota_subscript) {
3806 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3807 d += capital_iota_len;
3812 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3818 else { /* Not UTF-8 */
3820 const U8 *const send = s + len;
3822 /* Use locale casing if in locale; regular style if not treating
3823 * latin1 as having case; otherwise the latin1 casing. Do the
3824 * whole thing in a tight loop, for speed, */
3825 if (IN_LOCALE_RUNTIME) {
3828 for (; s < send; d++, s++)
3829 *d = toUPPER_LC(*s);
3831 else if (! IN_UNI_8_BIT) {
3832 for (; s < send; d++, s++) {
3837 for (; s < send; d++, s++) {
3838 *d = toUPPER_LATIN1_MOD(*s);
3839 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3843 /* The mainstream case is the tight loop above. To avoid
3844 * extra tests in that, all three characters that require
3845 * special handling are mapped by the MOD to the one tested
3847 * Use the source to distinguish between the three cases */
3849 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3851 /* uc() of this requires 2 characters, but they are
3852 * ASCII. If not enough room, grow the string */
3853 if (SvLEN(dest) < ++min) {
3854 const UV o = d - (U8*)SvPVX_const(dest);
3856 d = (U8*)SvPVX(dest) + o;
3858 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3859 continue; /* Back to the tight loop; still in ASCII */
3862 /* The other two special handling characters have their
3863 * upper cases outside the latin1 range, hence need to be
3864 * in UTF-8, so the whole result needs to be in UTF-8. So,
3865 * here we are somewhere in the middle of processing a
3866 * non-UTF-8 string, and realize that we will have to convert
3867 * the whole thing to UTF-8. What to do? There are
3868 * several possibilities. The simplest to code is to
3869 * convert what we have so far, set a flag, and continue on
3870 * in the loop. The flag would be tested each time through
3871 * the loop, and if set, the next character would be
3872 * converted to UTF-8 and stored. But, I (khw) didn't want
3873 * to slow down the mainstream case at all for this fairly
3874 * rare case, so I didn't want to add a test that didn't
3875 * absolutely have to be there in the loop, besides the
3876 * possibility that it would get too complicated for
3877 * optimizers to deal with. Another possibility is to just
3878 * give up, convert the source to UTF-8, and restart the
3879 * function that way. Another possibility is to convert
3880 * both what has already been processed and what is yet to
3881 * come separately to UTF-8, then jump into the loop that
3882 * handles UTF-8. But the most efficient time-wise of the
3883 * ones I could think of is what follows, and turned out to
3884 * not require much extra code. */
3886 /* Convert what we have so far into UTF-8, telling the
3887 * function that we know it should be converted, and to
3888 * allow extra space for what we haven't processed yet.
3889 * Assume the worst case space requirements for converting
3890 * what we haven't processed so far: that it will require
3891 * two bytes for each remaining source character, plus the
3892 * NUL at the end. This may cause the string pointer to
3893 * move, so re-find it. */
3895 len = d - (U8*)SvPVX_const(dest);
3896 SvCUR_set(dest, len);
3897 len = sv_utf8_upgrade_flags_grow(dest,
3898 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3900 d = (U8*)SvPVX(dest) + len;
3902 /* Now process the remainder of the source, converting to
3903 * upper and UTF-8. If a resulting byte is invariant in
3904 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3905 * append it to the output. */
3906 for (; s < send; s++) {
3907 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3911 /* Here have processed the whole source; no need to continue
3912 * with the outer loop. Each character has been converted
3913 * to upper case and converted to UTF-8 */
3916 } /* End of processing all latin1-style chars */
3917 } /* End of processing all chars */
3918 } /* End of source is not empty */
3920 if (source != dest) {
3921 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3922 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3924 } /* End of isn't utf8 */
3925 if (dest != source && SvTAINTED(source))
3944 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3945 && SvTEMP(source) && !DO_UTF8(source)) {
3947 /* We can convert in place, as lowercasing anything in the latin1 range
3948 * (or else DO_UTF8 would have been on) doesn't lengthen it */
3950 s = d = (U8*)SvPV_force_nomg(source, len);
3957 /* The old implementation would copy source into TARG at this point.
3958 This had the side effect that if source was undef, TARG was now
3959 an undefined SV with PADTMP set, and they don't warn inside
3960 sv_2pv_flags(). However, we're now getting the PV direct from
3961 source, which doesn't have PADTMP set, so it would warn. Hence the
3965 s = (const U8*)SvPV_nomg_const(source, len);
3967 if (ckWARN(WARN_UNINITIALIZED))
3968 report_uninit(source);
3974 SvUPGRADE(dest, SVt_PV);
3975 d = (U8*)SvGROW(dest, min);
3976 (void)SvPOK_only(dest);
3981 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3982 to check DO_UTF8 again here. */
3984 if (DO_UTF8(source)) {
3985 const U8 *const send = s + len;
3986 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3987 bool tainted = FALSE;
3990 const STRLEN u = UTF8SKIP(s);
3993 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3994 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3996 /* Here is where we would do context-sensitive actions. See the
3997 * commit message for this comment for why there isn't any */
3999 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4001 /* If the eventually required minimum size outgrows the
4002 * available space, we need to grow. */
4003 const UV o = d - (U8*)SvPVX_const(dest);
4005 /* If someone lowercases one million U+0130s we SvGROW() one
4006 * million times. Or we could try guessing how much to
4007 * allocate without allocating too much. Such is life.
4008 * Another option would be to grow an extra byte or two more
4009 * each time we need to grow, which would cut down the million
4010 * to 500K, with little waste */
4012 d = (U8*)SvPVX(dest) + o;
4015 /* Copy the newly lowercased letter to the output buffer we're
4017 Copy(tmpbuf, d, ulen, U8);
4020 } /* End of looping through the source string */
4023 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4028 } else { /* Not utf8 */
4030 const U8 *const send = s + len;
4032 /* Use locale casing if in locale; regular style if not treating
4033 * latin1 as having case; otherwise the latin1 casing. Do the
4034 * whole thing in a tight loop, for speed, */
4035 if (IN_LOCALE_RUNTIME) {
4038 for (; s < send; d++, s++)
4039 *d = toLOWER_LC(*s);
4041 else if (! IN_UNI_8_BIT) {
4042 for (; s < send; d++, s++) {
4047 for (; s < send; d++, s++) {
4048 *d = toLOWER_LATIN1(*s);
4052 if (source != dest) {
4054 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4057 if (dest != source && SvTAINTED(source))
4066 SV * const sv = TOPs;
4068 const char *s = SvPV_const(sv,len);
4070 SvUTF8_off(TARG); /* decontaminate */
4073 SvUPGRADE(TARG, SVt_PV);
4074 SvGROW(TARG, (len * 2) + 1);
4078 STRLEN ulen = UTF8SKIP(s);
4079 bool to_quote = FALSE;
4081 if (UTF8_IS_INVARIANT(*s)) {
4082 if (_isQUOTEMETA(*s)) {
4086 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4088 /* In locale, we quote all non-ASCII Latin1 chars.
4089 * Otherwise use the quoting rules */
4090 if (IN_LOCALE_RUNTIME
4091 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
4096 else if (is_QUOTEMETA_high(s)) {
4111 else if (IN_UNI_8_BIT) {
4113 if (_isQUOTEMETA(*s))
4119 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4120 * including everything above ASCII */
4122 if (!isWORDCHAR_A(*s))
4128 SvCUR_set(TARG, d - SvPVX_const(TARG));
4129 (void)SvPOK_only_UTF8(TARG);
4132 sv_setpvn(TARG, s, len);
4149 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4150 const bool full_folding = TRUE;
4151 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4152 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4154 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4155 * You are welcome(?) -Hugmeir
4163 s = (const U8*)SvPV_nomg_const(source, len);
4165 if (ckWARN(WARN_UNINITIALIZED))
4166 report_uninit(source);
4173 SvUPGRADE(dest, SVt_PV);
4174 d = (U8*)SvGROW(dest, min);
4175 (void)SvPOK_only(dest);
4180 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4181 bool tainted = FALSE;
4183 const STRLEN u = UTF8SKIP(s);
4186 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4188 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4189 const UV o = d - (U8*)SvPVX_const(dest);
4191 d = (U8*)SvPVX(dest) + o;
4194 Copy(tmpbuf, d, ulen, U8);
4203 } /* Unflagged string */
4205 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4208 for (; s < send; d++, s++)
4211 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4212 for (; s < send; d++, s++)
4216 /* For ASCII and the Latin-1 range, there's only two troublesome
4217 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4218 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4219 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4220 * For the rest, the casefold is their lowercase. */
4221 for (; s < send; d++, s++) {
4222 if (*s == MICRO_SIGN) {
4223 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4224 * which is outside of the latin-1 range. There's a couple
4225 * of ways to deal with this -- khw discusses them in
4226 * pp_lc/uc, so go there :) What we do here is upgrade what
4227 * we had already casefolded, then enter an inner loop that
4228 * appends the rest of the characters as UTF-8. */
4229 len = d - (U8*)SvPVX_const(dest);
4230 SvCUR_set(dest, len);
4231 len = sv_utf8_upgrade_flags_grow(dest,
4232 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4233 /* The max expansion for latin1
4234 * chars is 1 byte becomes 2 */
4236 d = (U8*)SvPVX(dest) + len;
4238 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4241 for (; s < send; s++) {
4243 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4244 if UNI_IS_INVARIANT(fc) {
4246 && *s == LATIN_SMALL_LETTER_SHARP_S)
4255 Copy(tmpbuf, d, ulen, U8);
4261 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4262 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4263 * becomes "ss", which may require growing the SV. */
4264 if (SvLEN(dest) < ++min) {
4265 const UV o = d - (U8*)SvPVX_const(dest);
4267 d = (U8*)SvPVX(dest) + o;
4272 else { /* If it's not one of those two, the fold is their lower
4274 *d = toLOWER_LATIN1(*s);
4280 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4282 if (SvTAINTED(source))
4292 dVAR; dSP; dMARK; dORIGMARK;
4293 AV *const av = MUTABLE_AV(POPs);
4294 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4296 if (SvTYPE(av) == SVt_PVAV) {
4297 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4298 bool can_preserve = FALSE;
4304 can_preserve = SvCANEXISTDELETE(av);
4307 if (lval && localizing) {
4310 for (svp = MARK + 1; svp <= SP; svp++) {
4311 const I32 elem = SvIV(*svp);
4315 if (max > AvMAX(av))
4319 while (++MARK <= SP) {
4321 I32 elem = SvIV(*MARK);
4322 bool preeminent = TRUE;
4324 if (localizing && can_preserve) {
4325 /* If we can determine whether the element exist,
4326 * Try to preserve the existenceness of a tied array
4327 * element by using EXISTS and DELETE if possible.
4328 * Fallback to FETCH and STORE otherwise. */
4329 preeminent = av_exists(av, elem);
4332 svp = av_fetch(av, elem, lval);
4334 if (!svp || *svp == &PL_sv_undef)
4335 DIE(aTHX_ PL_no_aelem, elem);
4338 save_aelem(av, elem, svp);
4340 SAVEADELETE(av, elem);
4343 *MARK = svp ? *svp : &PL_sv_undef;
4346 if (GIMME != G_ARRAY) {
4348 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4354 /* Smart dereferencing for keys, values and each */
4366 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4371 "Type of argument to %s must be unblessed hashref or arrayref",
4372 PL_op_desc[PL_op->op_type] );
4375 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4377 "Can't modify %s in %s",
4378 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4381 /* Delegate to correct function for op type */
4383 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4384 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4387 return (SvTYPE(sv) == SVt_PVHV)
4388 ? Perl_pp_each(aTHX)
4389 : Perl_pp_aeach(aTHX);
4397 AV *array = MUTABLE_AV(POPs);
4398 const I32 gimme = GIMME_V;
4399 IV *iterp = Perl_av_iter_p(aTHX_ array);
4400 const IV current = (*iterp)++;
4402 if (current > av_len(array)) {
4404 if (gimme == G_SCALAR)
4412 if (gimme == G_ARRAY) {
4413 SV **const element = av_fetch(array, current, 0);
4414 PUSHs(element ? *element : &PL_sv_undef);
4423 AV *array = MUTABLE_AV(POPs);
4424 const I32 gimme = GIMME_V;
4426 *Perl_av_iter_p(aTHX_ array) = 0;
4428 if (gimme == G_SCALAR) {
4430 PUSHi(av_len(array) + 1);
4432 else if (gimme == G_ARRAY) {
4433 IV n = Perl_av_len(aTHX_ array);
4438 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4439 for (i = 0; i <= n; i++) {
4444 for (i = 0; i <= n; i++) {
4445 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4446 PUSHs(elem ? *elem : &PL_sv_undef);
4453 /* Associative arrays. */
4459 HV * hash = MUTABLE_HV(POPs);
4461 const I32 gimme = GIMME_V;
4464 /* might clobber stack_sp */
4465 entry = hv_iternext(hash);
4470 SV* const sv = hv_iterkeysv(entry);
4471 PUSHs(sv); /* won't clobber stack_sp */
4472 if (gimme == G_ARRAY) {
4475 /* might clobber stack_sp */
4476 val = hv_iterval(hash, entry);
4481 else if (gimme == G_SCALAR)
4488 S_do_delete_local(pTHX)
4492 const I32 gimme = GIMME_V;
4495 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4496 SV *unsliced_keysv = sliced ? NULL : POPs;
4497 SV * const osv = POPs;
4498 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4500 const bool tied = SvRMAGICAL(osv)
4501 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4502 const bool can_preserve = SvCANEXISTDELETE(osv);
4503 const U32 type = SvTYPE(osv);
4504 SV ** const end = sliced ? SP : &unsliced_keysv;
4506 if (type == SVt_PVHV) { /* hash element */
4507 HV * const hv = MUTABLE_HV(osv);
4508 while (++MARK <= end) {
4509 SV * const keysv = *MARK;
4511 bool preeminent = TRUE;
4513 preeminent = hv_exists_ent(hv, keysv, 0);
4515 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4522 sv = hv_delete_ent(hv, keysv, 0, 0);
4524 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4527 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4528 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4530 *MARK = sv_mortalcopy(sv);
4536 SAVEHDELETE(hv, keysv);
4537 *MARK = &PL_sv_undef;
4541 else if (type == SVt_PVAV) { /* array element */
4542 if (PL_op->op_flags & OPf_SPECIAL) {
4543 AV * const av = MUTABLE_AV(osv);
4544 while (++MARK <= end) {
4545 I32 idx = SvIV(*MARK);
4547 bool preeminent = TRUE;
4549 preeminent = av_exists(av, idx);
4551 SV **svp = av_fetch(av, idx, 1);
4558 sv = av_delete(av, idx, 0);
4560 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4563 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4565 *MARK = sv_mortalcopy(sv);
4571 SAVEADELETE(av, idx);
4572 *MARK = &PL_sv_undef;
4577 DIE(aTHX_ "panic: avhv_delete no longer supported");
4580 DIE(aTHX_ "Not a HASH reference");
4582 if (gimme == G_VOID)
4584 else if (gimme == G_SCALAR) {
4589 *++MARK = &PL_sv_undef;
4593 else if (gimme != G_VOID)
4594 PUSHs(unsliced_keysv);
4606 if (PL_op->op_private & OPpLVAL_INTRO)
4607 return do_delete_local();
4610 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4612 if (PL_op->op_private & OPpSLICE) {
4614 HV * const hv = MUTABLE_HV(POPs);
4615 const U32 hvtype = SvTYPE(hv);
4616 if (hvtype == SVt_PVHV) { /* hash element */
4617 while (++MARK <= SP) {
4618 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4619 *MARK = sv ? sv : &PL_sv_undef;
4622 else if (hvtype == SVt_PVAV) { /* array element */
4623 if (PL_op->op_flags & OPf_SPECIAL) {
4624 while (++MARK <= SP) {
4625 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4626 *MARK = sv ? sv : &PL_sv_undef;
4631 DIE(aTHX_ "Not a HASH reference");
4634 else if (gimme == G_SCALAR) {
4639 *++MARK = &PL_sv_undef;
4645 HV * const hv = MUTABLE_HV(POPs);
4647 if (SvTYPE(hv) == SVt_PVHV)
4648 sv = hv_delete_ent(hv, keysv, discard, 0);
4649 else if (SvTYPE(hv) == SVt_PVAV) {
4650 if (PL_op->op_flags & OPf_SPECIAL)
4651 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4653 DIE(aTHX_ "panic: avhv_delete no longer supported");
4656 DIE(aTHX_ "Not a HASH reference");
4672 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4674 SV * const sv = POPs;
4675 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4678 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4683 hv = MUTABLE_HV(POPs);
4684 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4685 if (hv_exists_ent(hv, tmpsv, 0))
4688 else if (SvTYPE(hv) == SVt_PVAV) {
4689 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4690 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4695 DIE(aTHX_ "Not a HASH reference");
4702 dVAR; dSP; dMARK; dORIGMARK;
4703 HV * const hv = MUTABLE_HV(POPs);
4704 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4705 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4706 bool can_preserve = FALSE;
4712 if (SvCANEXISTDELETE(hv))
4713 can_preserve = TRUE;
4716 while (++MARK <= SP) {
4717 SV * const keysv = *MARK;
4720 bool preeminent = TRUE;
4722 if (localizing && can_preserve) {
4723 /* If we can determine whether the element exist,
4724 * try to preserve the existenceness of a tied hash
4725 * element by using EXISTS and DELETE if possible.
4726 * Fallback to FETCH and STORE otherwise. */
4727 preeminent = hv_exists_ent(hv, keysv, 0);
4730 he = hv_fetch_ent(hv, keysv, lval, 0);
4731 svp = he ? &HeVAL(he) : NULL;
4734 if (!svp || !*svp || *svp == &PL_sv_undef) {
4735 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4738 if (HvNAME_get(hv) && isGV(*svp))
4739 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4740 else if (preeminent)
4741 save_helem_flags(hv, keysv, svp,
4742 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4744 SAVEHDELETE(hv, keysv);
4747 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4749 if (GIMME != G_ARRAY) {
4751 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4757 /* List operators. */
4762 if (GIMME != G_ARRAY) {
4764 *MARK = *SP; /* unwanted list, return last item */
4766 *MARK = &PL_sv_undef;
4776 SV ** const lastrelem = PL_stack_sp;
4777 SV ** const lastlelem = PL_stack_base + POPMARK;
4778 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4779 SV ** const firstrelem = lastlelem + 1;
4780 I32 is_something_there = FALSE;
4781 const U8 mod = PL_op->op_flags & OPf_MOD;
4783 const I32 max = lastrelem - lastlelem;
4786 if (GIMME != G_ARRAY) {
4787 I32 ix = SvIV(*lastlelem);
4790 if (ix < 0 || ix >= max)
4791 *firstlelem = &PL_sv_undef;
4793 *firstlelem = firstrelem[ix];
4799 SP = firstlelem - 1;
4803 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4804 I32 ix = SvIV(*lelem);
4807 if (ix < 0 || ix >= max)
4808 *lelem = &PL_sv_undef;
4810 is_something_there = TRUE;
4811 if (!(*lelem = firstrelem[ix]))
4812 *lelem = &PL_sv_undef;
4813 else if (mod && SvPADTMP(*lelem) && !IS_PADGV(*lelem))
4814 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
4817 if (is_something_there)
4820 SP = firstlelem - 1;
4827 const I32 items = SP - MARK;
4828 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4830 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4831 ? newRV_noinc(av) : av);
4837 dVAR; dSP; dMARK; dORIGMARK;
4838 HV* const hv = newHV();
4839 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
4840 ? newRV_noinc(MUTABLE_SV(hv))
4845 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4852 sv_setsv(val, *MARK);
4856 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4859 (void)hv_store_ent(hv,key,val,0);
4867 S_deref_plain_array(pTHX_ AV *ary)
4869 if (SvTYPE(ary) == SVt_PVAV) return ary;
4870 SvGETMAGIC((SV *)ary);
4871 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4872 Perl_die(aTHX_ "Not an ARRAY reference");
4873 else if (SvOBJECT(SvRV(ary)))
4874 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4875 return (AV *)SvRV(ary);
4878 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4879 # define DEREF_PLAIN_ARRAY(ary) \
4882 SvTYPE(aRrRay) == SVt_PVAV \
4884 : S_deref_plain_array(aTHX_ aRrRay); \
4887 # define DEREF_PLAIN_ARRAY(ary) \
4889 PL_Sv = (SV *)(ary), \
4890 SvTYPE(PL_Sv) == SVt_PVAV \
4892 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4898 dVAR; dSP; dMARK; dORIGMARK;
4899 int num_args = (SP - MARK);
4900 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4909 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4912 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
4913 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4920 offset = i = SvIV(*MARK);
4922 offset += AvFILLp(ary) + 1;
4924 DIE(aTHX_ PL_no_aelem, i);
4926 length = SvIVx(*MARK++);
4928 length += AvFILLp(ary) - offset + 1;
4934 length = AvMAX(ary) + 1; /* close enough to infinity */
4938 length = AvMAX(ary) + 1;
4940 if (offset > AvFILLp(ary) + 1) {
4942 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4943 offset = AvFILLp(ary) + 1;
4945 after = AvFILLp(ary) + 1 - (offset + length);
4946 if (after < 0) { /* not that much array */
4947 length += after; /* offset+length now in array */
4953 /* At this point, MARK .. SP-1 is our new LIST */
4956 diff = newlen - length;
4957 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4960 /* make new elements SVs now: avoid problems if they're from the array */
4961 for (dst = MARK, i = newlen; i; i--) {
4962 SV * const h = *dst;
4963 *dst++ = newSVsv(h);
4966 if (diff < 0) { /* shrinking the area */
4967 SV **tmparyval = NULL;
4969 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4970 Copy(MARK, tmparyval, newlen, SV*);
4973 MARK = ORIGMARK + 1;
4974 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4975 MEXTEND(MARK, length);
4976 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4978 EXTEND_MORTAL(length);
4979 for (i = length, dst = MARK; i; i--) {
4980 sv_2mortal(*dst); /* free them eventually */
4987 *MARK = AvARRAY(ary)[offset+length-1];
4990 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4991 SvREFCNT_dec(*dst++); /* free them now */
4994 AvFILLp(ary) += diff;
4996 /* pull up or down? */
4998 if (offset < after) { /* easier to pull up */
4999 if (offset) { /* esp. if nothing to pull */
5000 src = &AvARRAY(ary)[offset-1];
5001 dst = src - diff; /* diff is negative */
5002 for (i = offset; i > 0; i--) /* can't trust Copy */
5006 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5010 if (after) { /* anything to pull down? */
5011 src = AvARRAY(ary) + offset + length;
5012 dst = src + diff; /* diff is negative */
5013 Move(src, dst, after, SV*);
5015 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5016 /* avoid later double free */
5020 dst[--i] = &PL_sv_undef;
5023 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5024 Safefree(tmparyval);
5027 else { /* no, expanding (or same) */
5028 SV** tmparyval = NULL;
5030 Newx(tmparyval, length, SV*); /* so remember deletion */
5031 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5034 if (diff > 0) { /* expanding */
5035 /* push up or down? */
5036 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5040 Move(src, dst, offset, SV*);
5042 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5044 AvFILLp(ary) += diff;
5047 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5048 av_extend(ary, AvFILLp(ary) + diff);
5049 AvFILLp(ary) += diff;
5052 dst = AvARRAY(ary) + AvFILLp(ary);
5054 for (i = after; i; i--) {
5062 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5065 MARK = ORIGMARK + 1;
5066 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5068 Copy(tmparyval, MARK, length, SV*);
5070 EXTEND_MORTAL(length);
5071 for (i = length, dst = MARK; i; i--) {
5072 sv_2mortal(*dst); /* free them eventually */
5079 else if (length--) {
5080 *MARK = tmparyval[length];
5083 while (length-- > 0)
5084 SvREFCNT_dec(tmparyval[length]);
5088 *MARK = &PL_sv_undef;
5089 Safefree(tmparyval);
5093 mg_set(MUTABLE_SV(ary));
5101 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5102 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5103 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5106 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5109 ENTER_with_name("call_PUSH");
5110 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5111 LEAVE_with_name("call_PUSH");
5115 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5116 PL_delaymagic = DM_DELAY;
5117 for (++MARK; MARK <= SP; MARK++) {
5119 if (*MARK) SvGETMAGIC(*MARK);
5122 sv_setsv_nomg(sv, *MARK);
5123 av_store(ary, AvFILLp(ary)+1, sv);
5125 if (PL_delaymagic & DM_ARRAY_ISA)
5126 mg_set(MUTABLE_SV(ary));
5131 if (OP_GIMME(PL_op, 0) != G_VOID) {
5132 PUSHi( AvFILL(ary) + 1 );
5141 AV * const av = PL_op->op_flags & OPf_SPECIAL
5142 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5143 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5147 (void)sv_2mortal(sv);
5154 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5155 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5156 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5159 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5162 ENTER_with_name("call_UNSHIFT");
5163 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5164 LEAVE_with_name("call_UNSHIFT");
5169 av_unshift(ary, SP - MARK);
5171 SV * const sv = newSVsv(*++MARK);
5172 (void)av_store(ary, i++, sv);
5176 if (OP_GIMME(PL_op, 0) != G_VOID) {
5177 PUSHi( AvFILL(ary) + 1 );
5186 if (GIMME == G_ARRAY) {
5187 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5191 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5192 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5193 av = MUTABLE_AV((*SP));
5194 /* In-place reversing only happens in void context for the array
5195 * assignment. We don't need to push anything on the stack. */
5198 if (SvMAGICAL(av)) {
5200 SV *tmp = sv_newmortal();
5201 /* For SvCANEXISTDELETE */
5204 bool can_preserve = SvCANEXISTDELETE(av);
5206 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5210 if (!av_exists(av, i)) {
5211 if (av_exists(av, j)) {
5212 SV *sv = av_delete(av, j, 0);
5213 begin = *av_fetch(av, i, TRUE);
5214 sv_setsv_mg(begin, sv);
5218 else if (!av_exists(av, j)) {
5219 SV *sv = av_delete(av, i, 0);
5220 end = *av_fetch(av, j, TRUE);
5221 sv_setsv_mg(end, sv);
5226 begin = *av_fetch(av, i, TRUE);
5227 end = *av_fetch(av, j, TRUE);
5228 sv_setsv(tmp, begin);
5229 sv_setsv_mg(begin, end);
5230 sv_setsv_mg(end, tmp);
5234 SV **begin = AvARRAY(av);
5237 SV **end = begin + AvFILLp(av);
5239 while (begin < end) {
5240 SV * const tmp = *begin;
5251 SV * const tmp = *MARK;
5255 /* safe as long as stack cannot get extended in the above */
5266 SvUTF8_off(TARG); /* decontaminate */
5268 do_join(TARG, &PL_sv_no, MARK, SP);
5270 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5271 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5272 report_uninit(TARG);
5275 up = SvPV_force(TARG, len);
5277 if (DO_UTF8(TARG)) { /* first reverse each character */
5278 U8* s = (U8*)SvPVX(TARG);
5279 const U8* send = (U8*)(s + len);
5281 if (UTF8_IS_INVARIANT(*s)) {
5286 if (!utf8_to_uvchr_buf(s, send, 0))
5290 down = (char*)(s - 1);
5291 /* reverse this character */
5295 *down-- = (char)tmp;
5301 down = SvPVX(TARG) + len - 1;
5305 *down-- = (char)tmp;
5307 (void)SvPOK_only_UTF8(TARG);
5319 IV limit = POPi; /* note, negative is forever */
5320 SV * const sv = POPs;
5322 const char *s = SvPV_const(sv, len);
5323 const bool do_utf8 = DO_UTF8(sv);
5324 const char *strend = s + len;
5330 const STRLEN slen = do_utf8
5331 ? utf8_length((U8*)s, (U8*)strend)
5332 : (STRLEN)(strend - s);
5333 I32 maxiters = slen + 10;
5334 I32 trailing_empty = 0;
5336 const I32 origlimit = limit;
5339 const I32 gimme = GIMME_V;
5341 const I32 oldsave = PL_savestack_ix;
5342 U32 make_mortal = SVs_TEMP;
5347 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5352 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5355 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5356 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5359 if (pm->op_pmreplrootu.op_pmtargetoff) {
5360 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5363 if (pm->op_pmreplrootu.op_pmtargetgv) {
5364 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5375 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5377 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5384 for (i = AvFILLp(ary); i >= 0; i--)
5385 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5387 /* temporarily switch stacks */
5388 SAVESWITCHSTACK(PL_curstack, ary);
5392 base = SP - PL_stack_base;
5394 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5396 while (isSPACE_utf8(s))
5399 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5400 while (isSPACE_LC(*s))
5408 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5412 gimme_scalar = gimme == G_SCALAR && !ary;
5415 limit = maxiters + 2;
5416 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5419 /* this one uses 'm' and is a negative test */
5421 while (m < strend && ! isSPACE_utf8(m) ) {
5422 const int t = UTF8SKIP(m);
5423 /* isSPACE_utf8 returns FALSE for malform utf8 */
5430 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5432 while (m < strend && !isSPACE_LC(*m))
5435 while (m < strend && !isSPACE(*m))
5448 dstr = newSVpvn_flags(s, m-s,
5449 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5453 /* skip the whitespace found last */
5455 s = m + UTF8SKIP(m);
5459 /* this one uses 's' and is a positive test */
5461 while (s < strend && isSPACE_utf8(s) )
5464 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5466 while (s < strend && isSPACE_LC(*s))
5469 while (s < strend && isSPACE(*s))
5474 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5476 for (m = s; m < strend && *m != '\n'; m++)
5489 dstr = newSVpvn_flags(s, m-s,
5490 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5496 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5498 Pre-extend the stack, either the number of bytes or
5499 characters in the string or a limited amount, triggered by:
5501 my ($x, $y) = split //, $str;
5505 if (!gimme_scalar) {
5506 const U32 items = limit - 1;
5515 /* keep track of how many bytes we skip over */
5525 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5538 dstr = newSVpvn(s, 1);
5554 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5555 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5556 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5557 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5558 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5559 SV * const csv = CALLREG_INTUIT_STRING(rx);
5561 len = RX_MINLENRET(rx);
5562 if (len == 1 && !RX_UTF8(rx) && !tail) {
5563 const char c = *SvPV_nolen_const(csv);
5565 for (m = s; m < strend && *m != c; m++)
5576 dstr = newSVpvn_flags(s, m-s,
5577 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5580 /* The rx->minlen is in characters but we want to step
5581 * s ahead by bytes. */
5583 s = (char*)utf8_hop((U8*)m, len);
5585 s = m + len; /* Fake \n at the end */
5589 while (s < strend && --limit &&
5590 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5591 csv, multiline ? FBMrf_MULTILINE : 0)) )
5600 dstr = newSVpvn_flags(s, m-s,
5601 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5604 /* The rx->minlen is in characters but we want to step
5605 * s ahead by bytes. */
5607 s = (char*)utf8_hop((U8*)m, len);
5609 s = m + len; /* Fake \n at the end */
5614 maxiters += slen * RX_NPARENS(rx);
5615 while (s < strend && --limit)
5619 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5622 if (rex_return == 0)
5624 TAINT_IF(RX_MATCH_TAINTED(rx));
5625 /* we never pass the REXEC_COPY_STR flag, so it should
5626 * never get copied */
5627 assert(!RX_MATCH_COPIED(rx));
5628 m = RX_OFFS(rx)[0].start + orig;
5637 dstr = newSVpvn_flags(s, m-s,
5638 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5641 if (RX_NPARENS(rx)) {
5643 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5644 s = RX_OFFS(rx)[i].start + orig;
5645 m = RX_OFFS(rx)[i].end + orig;
5647 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5648 parens that didn't match -- they should be set to
5649 undef, not the empty string */
5657 if (m >= orig && s >= orig) {
5658 dstr = newSVpvn_flags(s, m-s,
5659 (do_utf8 ? SVf_UTF8 : 0)
5663 dstr = &PL_sv_undef; /* undef, not "" */
5669 s = RX_OFFS(rx)[0].end + orig;
5673 if (!gimme_scalar) {
5674 iters = (SP - PL_stack_base) - base;
5676 if (iters > maxiters)
5677 DIE(aTHX_ "Split loop");
5679 /* keep field after final delim? */
5680 if (s < strend || (iters && origlimit)) {
5681 if (!gimme_scalar) {
5682 const STRLEN l = strend - s;
5683 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5688 else if (!origlimit) {
5690 iters -= trailing_empty;
5692 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5693 if (TOPs && !make_mortal)
5695 *SP-- = &PL_sv_undef;
5702 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5706 if (SvSMAGICAL(ary)) {
5708 mg_set(MUTABLE_SV(ary));
5711 if (gimme == G_ARRAY) {
5713 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5720 ENTER_with_name("call_PUSH");
5721 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5722 LEAVE_with_name("call_PUSH");
5724 if (gimme == G_ARRAY) {
5726 /* EXTEND should not be needed - we just popped them */
5728 for (i=0; i < iters; i++) {
5729 SV **svp = av_fetch(ary, i, FALSE);
5730 PUSHs((svp) ? *svp : &PL_sv_undef);
5737 if (gimme == G_ARRAY)
5749 SV *const sv = PAD_SVl(PL_op->op_targ);
5751 if (SvPADSTALE(sv)) {
5754 RETURNOP(cLOGOP->op_other);
5756 RETURNOP(cLOGOP->op_next);
5766 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5767 || SvTYPE(retsv) == SVt_PVCV) {
5768 retsv = refto(retsv);
5775 PP(unimplemented_op)
5778 const Optype op_type = PL_op->op_type;
5779 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5780 with out of range op numbers - it only "special" cases op_custom.
5781 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5782 if we get here for a custom op then that means that the custom op didn't
5783 have an implementation. Given that OP_NAME() looks up the custom op
5784 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5785 registers &PL_unimplemented_op as the address of their custom op.
5786 NULL doesn't generate a useful error message. "custom" does. */
5787 const char *const name = op_type >= OP_max
5788 ? "[out of range]" : PL_op_name[PL_op->op_type];
5789 if(OP_IS_SOCKET(op_type))
5790 DIE(aTHX_ PL_no_sock_func, name);
5791 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5794 /* For sorting out arguments passed to a &CORE:: subroutine */
5798 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5799 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5800 AV * const at_ = GvAV(PL_defgv);
5801 SV **svp = at_ ? AvARRAY(at_) : NULL;
5802 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5803 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5804 bool seen_question = 0;
5805 const char *err = NULL;
5806 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5808 /* Count how many args there are first, to get some idea how far to
5809 extend the stack. */
5811 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5813 if (oa & OA_OPTIONAL) seen_question = 1;
5814 if (!seen_question) minargs++;
5818 if(numargs < minargs) err = "Not enough";
5819 else if(numargs > maxargs) err = "Too many";
5821 /* diag_listed_as: Too many arguments for %s */
5823 "%s arguments for %s", err,
5824 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5827 /* Reset the stack pointer. Without this, we end up returning our own
5828 arguments in list context, in addition to the values we are supposed
5829 to return. nextstate usually does this on sub entry, but we need
5830 to run the next op with the caller's hints, so we cannot have a
5832 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5834 if(!maxargs) RETURN;
5836 /* We do this here, rather than with a separate pushmark op, as it has
5837 to come in between two things this function does (stack reset and
5838 arg pushing). This seems the easiest way to do it. */
5841 (void)Perl_pp_pushmark(aTHX);
5844 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5845 PUTBACK; /* The code below can die in various places. */
5847 oa = PL_opargs[opnum] >> OASHIFT;
5848 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5853 if (!numargs && defgv && whicharg == minargs + 1) {
5854 PUSHs(find_rundefsv2(
5855 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5856 cxstack[cxstack_ix].blk_oldcop->cop_seq
5859 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5863 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5868 if (!svp || !*svp || !SvROK(*svp)
5869 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5871 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5872 "Type of arg %d to &CORE::%s must be hash reference",
5873 whicharg, OP_DESC(PL_op->op_next)
5878 if (!numargs) PUSHs(NULL);
5879 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5880 /* no magic here, as the prototype will have added an extra
5881 refgen and we just want what was there before that */
5884 const bool constr = PL_op->op_private & whicharg;
5886 svp && *svp ? *svp : &PL_sv_undef,
5887 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5893 if (!numargs) goto try_defsv;
5895 const bool wantscalar =
5896 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5897 if (!svp || !*svp || !SvROK(*svp)
5898 /* We have to permit globrefs even for the \$ proto, as
5899 *foo is indistinguishable from ${\*foo}, and the proto-
5900 type permits the latter. */
5901 || SvTYPE(SvRV(*svp)) > (
5902 wantscalar ? SVt_PVLV
5903 : opnum == OP_LOCK || opnum == OP_UNDEF
5909 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5910 "Type of arg %d to &CORE::%s must be %s",
5911 whicharg, PL_op_name[opnum],
5913 ? "scalar reference"
5914 : opnum == OP_LOCK || opnum == OP_UNDEF
5915 ? "reference to one of [$@%&*]"
5916 : "reference to one of [$@%*]"
5919 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5920 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5921 /* Undo @_ localisation, so that sub exit does not undo
5922 part of our undeffing. */
5923 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5925 cx->cx_type &= ~ CXp_HASARGS;
5926 assert(!AvREAL(cx->blk_sub.argarray));
5931 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5943 if (PL_op->op_private & OPpOFFBYONE) {
5944 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5946 else cv = find_runcv(NULL);
5947 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5954 * c-indentation-style: bsd
5956 * indent-tabs-mode: nil
5959 * ex: set ts=8 sts=4 sw=4 et: