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 Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
93 if (SvMAGICAL(TARG)) {
95 for (i=0; i < maxarg; i++) {
96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
102 for (i=0; i < (PADOFFSET)maxarg; i++) {
103 SV * const sv = AvARRAY((const AV *)TARG)[i];
104 SP[i+1] = sv ? sv : &PL_sv_undef;
109 else if (gimme == G_SCALAR) {
110 SV* const sv = sv_newmortal();
111 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
112 sv_setiv(sv, maxarg);
123 assert(SvTYPE(TARG) == SVt_PVHV);
125 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
127 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
128 if (PL_op->op_flags & OPf_REF)
130 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131 const I32 flags = is_lvalue_sub();
132 if (flags && !(flags & OPpENTERSUB_INARGS)) {
133 if (GIMME == G_SCALAR)
134 /* diag_listed_as: Can't return %s to lvalue scalar context */
135 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
140 if (gimme == G_ARRAY) {
141 RETURNOP(Perl_do_kv(aTHX));
143 else if ((PL_op->op_private & OPpTRUEBOOL
144 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
145 && block_gimme() == G_VOID ))
146 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
148 else if (gimme == G_SCALAR) {
149 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
158 assert(SvTYPE(TARG) == SVt_PVCV);
166 SvPADSTALE_off(TARG);
174 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
176 assert(SvTYPE(TARG) == SVt_PVCV);
179 if (CvISXSUB(mg->mg_obj)) { /* constant */
180 /* XXX Should we clone it here? */
181 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
182 to introcv and remove the SvPADSTALE_off. */
183 SAVEPADSVANDMORTALIZE(ARGTARG);
184 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
187 if (CvROOT(mg->mg_obj)) {
188 assert(CvCLONE(mg->mg_obj));
189 assert(!CvCLONED(mg->mg_obj));
191 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
192 SAVECLEARSV(PAD_SVl(ARGTARG));
199 static const char S_no_symref_sv[] =
200 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
202 /* In some cases this function inspects PL_op. If this function is called
203 for new op types, more bool parameters may need to be added in place of
206 When noinit is true, the absence of a gv will cause a retval of undef.
207 This is unrelated to the cv-to-gv assignment case.
211 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
215 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
218 sv = amagic_deref_call(sv, to_gv_amg);
222 if (SvTYPE(sv) == SVt_PVIO) {
223 GV * const gv = MUTABLE_GV(sv_newmortal());
224 gv_init(gv, 0, "__ANONIO__", 10, 0);
225 GvIOp(gv) = MUTABLE_IO(sv);
226 SvREFCNT_inc_void_NN(sv);
229 else if (!isGV_with_GP(sv))
230 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
233 if (!isGV_with_GP(sv)) {
235 /* If this is a 'my' scalar and flag is set then vivify
238 if (vivify_sv && sv != &PL_sv_undef) {
241 Perl_croak_no_modify();
242 if (cUNOP->op_targ) {
243 SV * const namesv = PAD_SV(cUNOP->op_targ);
244 HV *stash = CopSTASH(PL_curcop);
245 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
246 gv = MUTABLE_GV(newSV(0));
247 gv_init_sv(gv, stash, namesv, 0);
250 const char * const name = CopSTASHPV(PL_curcop);
251 gv = newGVgen_flags(name,
252 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
254 prepare_SV_for_RV(sv);
255 SvRV_set(sv, MUTABLE_SV(gv));
260 if (PL_op->op_flags & OPf_REF || strict)
261 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
262 if (ckWARN(WARN_UNINITIALIZED))
268 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
269 sv, GV_ADDMG, SVt_PVGV
279 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
282 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
283 == OPpDONT_INIT_GV) {
284 /* We are the target of a coderef assignment. Return
285 the scalar unchanged, and let pp_sasssign deal with
289 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
291 /* FAKE globs in the symbol table cause weird bugs (#77810) */
295 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
296 SV *newsv = sv_newmortal();
297 sv_setsv_flags(newsv, sv, 0);
309 sv, PL_op->op_private & OPpDEREF,
310 PL_op->op_private & HINT_STRICT_REFS,
311 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
312 || PL_op->op_type == OP_READLINE
314 if (PL_op->op_private & OPpLVAL_INTRO)
315 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
320 /* Helper function for pp_rv2sv and pp_rv2av */
322 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
323 const svtype type, SV ***spp)
328 PERL_ARGS_ASSERT_SOFTREF2XV;
330 if (PL_op->op_private & HINT_STRICT_REFS) {
332 Perl_die(aTHX_ S_no_symref_sv, sv,
333 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
335 Perl_die(aTHX_ PL_no_usym, what);
339 PL_op->op_flags & OPf_REF
341 Perl_die(aTHX_ PL_no_usym, what);
342 if (ckWARN(WARN_UNINITIALIZED))
344 if (type != SVt_PV && GIMME_V == G_ARRAY) {
348 **spp = &PL_sv_undef;
351 if ((PL_op->op_flags & OPf_SPECIAL) &&
352 !(PL_op->op_flags & OPf_MOD))
354 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
356 **spp = &PL_sv_undef;
361 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
374 sv = amagic_deref_call(sv, to_sv_amg);
378 switch (SvTYPE(sv)) {
384 DIE(aTHX_ "Not a SCALAR reference");
391 if (!isGV_with_GP(gv)) {
392 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
398 if (PL_op->op_flags & OPf_MOD) {
399 if (PL_op->op_private & OPpLVAL_INTRO) {
400 if (cUNOP->op_first->op_type == OP_NULL)
401 sv = save_scalar(MUTABLE_GV(TOPs));
403 sv = save_scalar(gv);
405 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
407 else if (PL_op->op_private & OPpDEREF)
408 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
417 AV * const av = MUTABLE_AV(TOPs);
418 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
420 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
422 *sv = newSV_type(SVt_PVMG);
423 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
427 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
436 if (PL_op->op_flags & OPf_MOD || LVRET) {
437 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
438 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
440 LvTARG(ret) = SvREFCNT_inc_simple(sv);
441 PUSHs(ret); /* no SvSETMAGIC */
445 const MAGIC * const mg = mg_find_mglob(sv);
446 if (mg && mg->mg_len != -1) {
448 STRLEN i = mg->mg_len;
449 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
450 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
463 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
465 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
466 == OPpMAY_RETURN_CONSTANT)
469 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
470 /* (But not in defined().) */
472 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
474 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
478 cv = MUTABLE_CV(&PL_sv_undef);
479 SETs(MUTABLE_SV(cv));
489 SV *ret = &PL_sv_undef;
491 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
492 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
493 const char * s = SvPVX_const(TOPs);
494 if (strnEQ(s, "CORE::", 6)) {
495 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
496 if (!code || code == -KEY_CORE)
497 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
498 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
500 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
506 cv = sv_2cv(TOPs, &stash, &gv, 0);
508 ret = newSVpvn_flags(
509 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
519 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
521 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
523 PUSHs(MUTABLE_SV(cv));
537 if (GIMME != G_ARRAY) {
541 *MARK = &PL_sv_undef;
542 *MARK = refto(*MARK);
546 EXTEND_MORTAL(SP - MARK);
548 *MARK = refto(*MARK);
553 S_refto(pTHX_ SV *sv)
558 PERL_ARGS_ASSERT_REFTO;
560 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
563 if (!(sv = LvTARG(sv)))
566 SvREFCNT_inc_void_NN(sv);
568 else if (SvTYPE(sv) == SVt_PVAV) {
569 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
570 av_reify(MUTABLE_AV(sv));
572 SvREFCNT_inc_void_NN(sv);
574 else if (SvPADTMP(sv) && !IS_PADGV(sv))
578 SvREFCNT_inc_void_NN(sv);
581 sv_upgrade(rv, SVt_IV);
590 SV * const sv = POPs;
596 (void)sv_ref(TARG,SvRV(sv),TRUE);
609 stash = CopSTASH(PL_curcop);
610 if (SvTYPE(stash) != SVt_PVHV)
611 Perl_croak(aTHX_ "Attempt to bless into a freed package");
614 SV * const ssv = POPs;
618 if (!ssv) goto curstash;
619 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
620 Perl_croak(aTHX_ "Attempt to bless into a reference");
621 ptr = SvPV_const(ssv,len);
623 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
624 "Explicit blessing to '' (assuming package main)");
625 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
628 (void)sv_bless(TOPs, stash);
638 const char * const elem = SvPV_const(sv, len);
639 GV * const gv = MUTABLE_GV(POPs);
644 /* elem will always be NUL terminated. */
645 const char * const second_letter = elem + 1;
648 if (len == 5 && strEQ(second_letter, "RRAY"))
650 tmpRef = MUTABLE_SV(GvAV(gv));
651 if (tmpRef && !AvREAL((const AV *)tmpRef)
652 && AvREIFY((const AV *)tmpRef))
653 av_reify(MUTABLE_AV(tmpRef));
657 if (len == 4 && strEQ(second_letter, "ODE"))
658 tmpRef = MUTABLE_SV(GvCVu(gv));
661 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
662 /* finally deprecated in 5.8.0 */
663 deprecate("*glob{FILEHANDLE}");
664 tmpRef = MUTABLE_SV(GvIOp(gv));
667 if (len == 6 && strEQ(second_letter, "ORMAT"))
668 tmpRef = MUTABLE_SV(GvFORM(gv));
671 if (len == 4 && strEQ(second_letter, "LOB"))
672 tmpRef = MUTABLE_SV(gv);
675 if (len == 4 && strEQ(second_letter, "ASH"))
676 tmpRef = MUTABLE_SV(GvHV(gv));
679 if (*second_letter == 'O' && !elem[2] && len == 2)
680 tmpRef = MUTABLE_SV(GvIOp(gv));
683 if (len == 4 && strEQ(second_letter, "AME"))
684 sv = newSVhek(GvNAME_HEK(gv));
687 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
688 const HV * const stash = GvSTASH(gv);
689 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
690 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
694 if (len == 6 && strEQ(second_letter, "CALAR"))
709 /* Pattern matching */
717 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
718 /* Historically, study was skipped in these cases. */
722 /* Make study a no-op. It's no longer useful and its existence
723 complicates matters elsewhere. */
732 if (PL_op->op_flags & OPf_STACKED)
734 else if (PL_op->op_private & OPpTARGET_MY)
740 if(PL_op->op_type == OP_TRANSR) {
742 const char * const pv = SvPV(sv,len);
743 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
748 TARG = sv_newmortal();
754 /* Lvalue operators. */
757 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
763 PERL_ARGS_ASSERT_DO_CHOMP;
765 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
767 if (SvTYPE(sv) == SVt_PVAV) {
769 AV *const av = MUTABLE_AV(sv);
770 const I32 max = AvFILL(av);
772 for (i = 0; i <= max; i++) {
773 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
774 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
775 do_chomp(retval, sv, chomping);
779 else if (SvTYPE(sv) == SVt_PVHV) {
780 HV* const hv = MUTABLE_HV(sv);
782 (void)hv_iterinit(hv);
783 while ((entry = hv_iternext(hv)))
784 do_chomp(retval, hv_iterval(hv,entry), chomping);
787 else if (SvREADONLY(sv)) {
788 Perl_croak_no_modify();
790 else if (SvIsCOW(sv)) {
791 sv_force_normal_flags(sv, 0);
796 /* XXX, here sv is utf8-ized as a side-effect!
797 If encoding.pm is used properly, almost string-generating
798 operations, including literal strings, chr(), input data, etc.
799 should have been utf8-ized already, right?
801 sv_recode_to_utf8(sv, PL_encoding);
807 char *temp_buffer = NULL;
816 while (len && s[-1] == '\n') {
823 STRLEN rslen, rs_charlen;
824 const char *rsptr = SvPV_const(PL_rs, rslen);
826 rs_charlen = SvUTF8(PL_rs)
830 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
831 /* Assumption is that rs is shorter than the scalar. */
833 /* RS is utf8, scalar is 8 bit. */
835 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
838 /* Cannot downgrade, therefore cannot possibly match
840 assert (temp_buffer == rsptr);
846 else if (PL_encoding) {
847 /* RS is 8 bit, encoding.pm is used.
848 * Do not recode PL_rs as a side-effect. */
849 svrecode = newSVpvn(rsptr, rslen);
850 sv_recode_to_utf8(svrecode, PL_encoding);
851 rsptr = SvPV_const(svrecode, rslen);
852 rs_charlen = sv_len_utf8(svrecode);
855 /* RS is 8 bit, scalar is utf8. */
856 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
870 if (memNE(s, rsptr, rslen))
872 SvIVX(retval) += rs_charlen;
875 s = SvPV_force_nomg_nolen(sv);
883 SvREFCNT_dec(svrecode);
885 Safefree(temp_buffer);
887 if (len && !SvPOK(sv))
888 s = SvPV_force_nomg(sv, len);
891 char * const send = s + len;
892 char * const start = s;
894 while (s > start && UTF8_IS_CONTINUATION(*s))
896 if (is_utf8_string((U8*)s, send - s)) {
897 sv_setpvn(retval, s, send - s);
899 SvCUR_set(sv, s - start);
905 sv_setpvs(retval, "");
909 sv_setpvn(retval, s, 1);
916 sv_setpvs(retval, "");
924 const bool chomping = PL_op->op_type == OP_SCHOMP;
928 do_chomp(TARG, TOPs, chomping);
935 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
936 const bool chomping = PL_op->op_type == OP_CHOMP;
941 do_chomp(TARG, *++MARK, chomping);
952 if (!PL_op->op_private) {
961 SV_CHECK_THINKFIRST_COW_DROP(sv);
963 switch (SvTYPE(sv)) {
967 av_undef(MUTABLE_AV(sv));
970 hv_undef(MUTABLE_HV(sv));
973 if (cv_const_sv((const CV *)sv))
974 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
975 "Constant subroutine %"SVf" undefined",
976 SVfARG(CvANON((const CV *)sv)
977 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
978 : sv_2mortal(newSVhek(
980 ? CvNAME_HEK((CV *)sv)
981 : GvENAME_HEK(CvGV((const CV *)sv))
987 /* let user-undef'd sub keep its identity */
988 GV* const gv = CvGV((const CV *)sv);
989 HEK * const hek = CvNAME_HEK((CV *)sv);
990 if (hek) share_hek_hek(hek);
991 cv_undef(MUTABLE_CV(sv));
992 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
994 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
1000 assert(isGV_with_GP(sv));
1001 assert(!SvFAKE(sv));
1006 /* undef *Pkg::meth_name ... */
1008 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1009 && HvENAME_get(stash);
1011 if((stash = GvHV((const GV *)sv))) {
1012 if(HvENAME_get(stash))
1013 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1017 gp_free(MUTABLE_GV(sv));
1019 GvGP_set(sv, gp_ref(gp));
1020 GvSV(sv) = newSV(0);
1021 GvLINE(sv) = CopLINE(PL_curcop);
1022 GvEGV(sv) = MUTABLE_GV(sv);
1026 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1028 /* undef *Foo::ISA */
1029 if( strEQ(GvNAME((const GV *)sv), "ISA")
1030 && (stash = GvSTASH((const GV *)sv))
1031 && (method_changed || HvENAME(stash)) )
1032 mro_isa_changed_in(stash);
1033 else if(method_changed)
1034 mro_method_changed_in(
1035 GvSTASH((const GV *)sv)
1041 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1057 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1058 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1059 Perl_croak_no_modify();
1061 TARG = sv_newmortal();
1062 sv_setsv(TARG, TOPs);
1063 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1064 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1066 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1067 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1071 else sv_dec_nomg(TOPs);
1073 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1074 if (inc && !SvOK(TARG))
1080 /* Ordinary operators. */
1084 dVAR; dSP; dATARGET; SV *svl, *svr;
1085 #ifdef PERL_PRESERVE_IVUV
1088 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1091 #ifdef PERL_PRESERVE_IVUV
1092 /* For integer to integer power, we do the calculation by hand wherever
1093 we're sure it is safe; otherwise we call pow() and try to convert to
1094 integer afterwards. */
1095 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1103 const IV iv = SvIVX(svr);
1107 goto float_it; /* Can't do negative powers this way. */
1111 baseuok = SvUOK(svl);
1113 baseuv = SvUVX(svl);
1115 const IV iv = SvIVX(svl);
1118 baseuok = TRUE; /* effectively it's a UV now */
1120 baseuv = -iv; /* abs, baseuok == false records sign */
1123 /* now we have integer ** positive integer. */
1126 /* foo & (foo - 1) is zero only for a power of 2. */
1127 if (!(baseuv & (baseuv - 1))) {
1128 /* We are raising power-of-2 to a positive integer.
1129 The logic here will work for any base (even non-integer
1130 bases) but it can be less accurate than
1131 pow (base,power) or exp (power * log (base)) when the
1132 intermediate values start to spill out of the mantissa.
1133 With powers of 2 we know this can't happen.
1134 And powers of 2 are the favourite thing for perl
1135 programmers to notice ** not doing what they mean. */
1137 NV base = baseuok ? baseuv : -(NV)baseuv;
1142 while (power >>= 1) {
1150 SvIV_please_nomg(svr);
1153 unsigned int highbit = 8 * sizeof(UV);
1154 unsigned int diff = 8 * sizeof(UV);
1155 while (diff >>= 1) {
1157 if (baseuv >> highbit) {
1161 /* we now have baseuv < 2 ** highbit */
1162 if (power * highbit <= 8 * sizeof(UV)) {
1163 /* result will definitely fit in UV, so use UV math
1164 on same algorithm as above */
1167 const bool odd_power = cBOOL(power & 1);
1171 while (power >>= 1) {
1178 if (baseuok || !odd_power)
1179 /* answer is positive */
1181 else if (result <= (UV)IV_MAX)
1182 /* answer negative, fits in IV */
1183 SETi( -(IV)result );
1184 else if (result == (UV)IV_MIN)
1185 /* 2's complement assumption: special case IV_MIN */
1188 /* answer negative, doesn't fit */
1189 SETn( -(NV)result );
1197 NV right = SvNV_nomg(svr);
1198 NV left = SvNV_nomg(svl);
1201 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1203 We are building perl with long double support and are on an AIX OS
1204 afflicted with a powl() function that wrongly returns NaNQ for any
1205 negative base. This was reported to IBM as PMR #23047-379 on
1206 03/06/2006. The problem exists in at least the following versions
1207 of AIX and the libm fileset, and no doubt others as well:
1209 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1210 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1211 AIX 5.2.0 bos.adt.libm 5.2.0.85
1213 So, until IBM fixes powl(), we provide the following workaround to
1214 handle the problem ourselves. Our logic is as follows: for
1215 negative bases (left), we use fmod(right, 2) to check if the
1216 exponent is an odd or even integer:
1218 - if odd, powl(left, right) == -powl(-left, right)
1219 - if even, powl(left, right) == powl(-left, right)
1221 If the exponent is not an integer, the result is rightly NaNQ, so
1222 we just return that (as NV_NAN).
1226 NV mod2 = Perl_fmod( right, 2.0 );
1227 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1228 SETn( -Perl_pow( -left, right) );
1229 } else if (mod2 == 0.0) { /* even integer */
1230 SETn( Perl_pow( -left, right) );
1231 } else { /* fractional power */
1235 SETn( Perl_pow( left, right) );
1238 SETn( Perl_pow( left, right) );
1239 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1241 #ifdef PERL_PRESERVE_IVUV
1243 SvIV_please_nomg(svr);
1251 dVAR; dSP; dATARGET; SV *svl, *svr;
1252 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1255 #ifdef PERL_PRESERVE_IVUV
1256 if (SvIV_please_nomg(svr)) {
1257 /* Unless the left argument is integer in range we are going to have to
1258 use NV maths. Hence only attempt to coerce the right argument if
1259 we know the left is integer. */
1260 /* Left operand is defined, so is it IV? */
1261 if (SvIV_please_nomg(svl)) {
1262 bool auvok = SvUOK(svl);
1263 bool buvok = SvUOK(svr);
1264 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1265 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1274 const IV aiv = SvIVX(svl);
1277 auvok = TRUE; /* effectively it's a UV now */
1279 alow = -aiv; /* abs, auvok == false records sign */
1285 const IV biv = SvIVX(svr);
1288 buvok = TRUE; /* effectively it's a UV now */
1290 blow = -biv; /* abs, buvok == false records sign */
1294 /* If this does sign extension on unsigned it's time for plan B */
1295 ahigh = alow >> (4 * sizeof (UV));
1297 bhigh = blow >> (4 * sizeof (UV));
1299 if (ahigh && bhigh) {
1301 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1302 which is overflow. Drop to NVs below. */
1303 } else if (!ahigh && !bhigh) {
1304 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1305 so the unsigned multiply cannot overflow. */
1306 const UV product = alow * blow;
1307 if (auvok == buvok) {
1308 /* -ve * -ve or +ve * +ve gives a +ve result. */
1312 } else if (product <= (UV)IV_MIN) {
1313 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1314 /* -ve result, which could overflow an IV */
1316 SETi( -(IV)product );
1318 } /* else drop to NVs below. */
1320 /* One operand is large, 1 small */
1323 /* swap the operands */
1325 bhigh = blow; /* bhigh now the temp var for the swap */
1329 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1330 multiplies can't overflow. shift can, add can, -ve can. */
1331 product_middle = ahigh * blow;
1332 if (!(product_middle & topmask)) {
1333 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1335 product_middle <<= (4 * sizeof (UV));
1336 product_low = alow * blow;
1338 /* as for pp_add, UV + something mustn't get smaller.
1339 IIRC ANSI mandates this wrapping *behaviour* for
1340 unsigned whatever the actual representation*/
1341 product_low += product_middle;
1342 if (product_low >= product_middle) {
1343 /* didn't overflow */
1344 if (auvok == buvok) {
1345 /* -ve * -ve or +ve * +ve gives a +ve result. */
1347 SETu( product_low );
1349 } else if (product_low <= (UV)IV_MIN) {
1350 /* 2s complement assumption again */
1351 /* -ve result, which could overflow an IV */
1353 SETi( -(IV)product_low );
1355 } /* else drop to NVs below. */
1357 } /* product_middle too large */
1358 } /* ahigh && bhigh */
1363 NV right = SvNV_nomg(svr);
1364 NV left = SvNV_nomg(svl);
1366 SETn( left * right );
1373 dVAR; dSP; dATARGET; SV *svl, *svr;
1374 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1377 /* Only try to do UV divide first
1378 if ((SLOPPYDIVIDE is true) or
1379 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1381 The assumption is that it is better to use floating point divide
1382 whenever possible, only doing integer divide first if we can't be sure.
1383 If NV_PRESERVES_UV is true then we know at compile time that no UV
1384 can be too large to preserve, so don't need to compile the code to
1385 test the size of UVs. */
1388 # define PERL_TRY_UV_DIVIDE
1389 /* ensure that 20./5. == 4. */
1391 # ifdef PERL_PRESERVE_IVUV
1392 # ifndef NV_PRESERVES_UV
1393 # define PERL_TRY_UV_DIVIDE
1398 #ifdef PERL_TRY_UV_DIVIDE
1399 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1400 bool left_non_neg = SvUOK(svl);
1401 bool right_non_neg = SvUOK(svr);
1405 if (right_non_neg) {
1409 const IV biv = SvIVX(svr);
1412 right_non_neg = TRUE; /* effectively it's a UV now */
1418 /* historically undef()/0 gives a "Use of uninitialized value"
1419 warning before dieing, hence this test goes here.
1420 If it were immediately before the second SvIV_please, then
1421 DIE() would be invoked before left was even inspected, so
1422 no inspection would give no warning. */
1424 DIE(aTHX_ "Illegal division by zero");
1430 const IV aiv = SvIVX(svl);
1433 left_non_neg = TRUE; /* effectively it's a UV now */
1442 /* For sloppy divide we always attempt integer division. */
1444 /* Otherwise we only attempt it if either or both operands
1445 would not be preserved by an NV. If both fit in NVs
1446 we fall through to the NV divide code below. However,
1447 as left >= right to ensure integer result here, we know that
1448 we can skip the test on the right operand - right big
1449 enough not to be preserved can't get here unless left is
1452 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1455 /* Integer division can't overflow, but it can be imprecise. */
1456 const UV result = left / right;
1457 if (result * right == left) {
1458 SP--; /* result is valid */
1459 if (left_non_neg == right_non_neg) {
1460 /* signs identical, result is positive. */
1464 /* 2s complement assumption */
1465 if (result <= (UV)IV_MIN)
1466 SETi( -(IV)result );
1468 /* It's exact but too negative for IV. */
1469 SETn( -(NV)result );
1472 } /* tried integer divide but it was not an integer result */
1473 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1474 } /* one operand wasn't SvIOK */
1475 #endif /* PERL_TRY_UV_DIVIDE */
1477 NV right = SvNV_nomg(svr);
1478 NV left = SvNV_nomg(svl);
1479 (void)POPs;(void)POPs;
1480 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1481 if (! Perl_isnan(right) && right == 0.0)
1485 DIE(aTHX_ "Illegal division by zero");
1486 PUSHn( left / right );
1493 dVAR; dSP; dATARGET;
1494 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1498 bool left_neg = FALSE;
1499 bool right_neg = FALSE;
1500 bool use_double = FALSE;
1501 bool dright_valid = FALSE;
1504 SV * const svr = TOPs;
1505 SV * const svl = TOPm1s;
1506 if (SvIV_please_nomg(svr)) {
1507 right_neg = !SvUOK(svr);
1511 const IV biv = SvIVX(svr);
1514 right_neg = FALSE; /* effectively it's a UV now */
1521 dright = SvNV_nomg(svr);
1522 right_neg = dright < 0;
1525 if (dright < UV_MAX_P1) {
1526 right = U_V(dright);
1527 dright_valid = TRUE; /* In case we need to use double below. */
1533 /* At this point use_double is only true if right is out of range for
1534 a UV. In range NV has been rounded down to nearest UV and
1535 use_double false. */
1536 if (!use_double && SvIV_please_nomg(svl)) {
1537 left_neg = !SvUOK(svl);
1541 const IV aiv = SvIVX(svl);
1544 left_neg = FALSE; /* effectively it's a UV now */
1551 dleft = SvNV_nomg(svl);
1552 left_neg = dleft < 0;
1556 /* This should be exactly the 5.6 behaviour - if left and right are
1557 both in range for UV then use U_V() rather than floor. */
1559 if (dleft < UV_MAX_P1) {
1560 /* right was in range, so is dleft, so use UVs not double.
1564 /* left is out of range for UV, right was in range, so promote
1565 right (back) to double. */
1567 /* The +0.5 is used in 5.6 even though it is not strictly
1568 consistent with the implicit +0 floor in the U_V()
1569 inside the #if 1. */
1570 dleft = Perl_floor(dleft + 0.5);
1573 dright = Perl_floor(dright + 0.5);
1584 DIE(aTHX_ "Illegal modulus zero");
1586 dans = Perl_fmod(dleft, dright);
1587 if ((left_neg != right_neg) && dans)
1588 dans = dright - dans;
1591 sv_setnv(TARG, dans);
1597 DIE(aTHX_ "Illegal modulus zero");
1600 if ((left_neg != right_neg) && ans)
1603 /* XXX may warn: unary minus operator applied to unsigned type */
1604 /* could change -foo to be (~foo)+1 instead */
1605 if (ans <= ~((UV)IV_MAX)+1)
1606 sv_setiv(TARG, ~ans+1);
1608 sv_setnv(TARG, -(NV)ans);
1611 sv_setuv(TARG, ans);
1620 dVAR; dSP; dATARGET;
1624 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1625 /* TODO: think of some way of doing list-repeat overloading ??? */
1630 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1636 const UV uv = SvUV_nomg(sv);
1638 count = IV_MAX; /* The best we can do? */
1642 const IV iv = SvIV_nomg(sv);
1649 else if (SvNOKp(sv)) {
1650 const NV nv = SvNV_nomg(sv);
1657 count = SvIV_nomg(sv);
1659 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1661 static const char* const oom_list_extend = "Out of memory during list extend";
1662 const I32 items = SP - MARK;
1663 const I32 max = items * count;
1664 const U8 mod = PL_op->op_flags & OPf_MOD;
1666 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1667 /* Did the max computation overflow? */
1668 if (items > 0 && max > 0 && (max < items || max < count))
1669 Perl_croak(aTHX_ "%s", oom_list_extend);
1674 /* This code was intended to fix 20010809.028:
1677 for (($x =~ /./g) x 2) {
1678 print chop; # "abcdabcd" expected as output.
1681 * but that change (#11635) broke this code:
1683 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1685 * I can't think of a better fix that doesn't introduce
1686 * an efficiency hit by copying the SVs. The stack isn't
1687 * refcounted, and mortalisation obviously doesn't
1688 * Do The Right Thing when the stack has more than
1689 * one pointer to the same mortal value.
1693 *SP = sv_2mortal(newSVsv(*SP));
1699 if (mod && SvPADTMP(*SP) && !IS_PADGV(*SP))
1700 *SP = sv_mortalcopy(*SP);
1707 repeatcpy((char*)(MARK + items), (char*)MARK,
1708 items * sizeof(const SV *), count - 1);
1711 else if (count <= 0)
1714 else { /* Note: mark already snarfed by pp_list */
1715 SV * const tmpstr = POPs;
1718 static const char* const oom_string_extend =
1719 "Out of memory during string extend";
1722 sv_setsv_nomg(TARG, tmpstr);
1723 SvPV_force_nomg(TARG, len);
1724 isutf = DO_UTF8(TARG);
1729 const STRLEN max = (UV)count * len;
1730 if (len > MEM_SIZE_MAX / count)
1731 Perl_croak(aTHX_ "%s", oom_string_extend);
1732 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1733 SvGROW(TARG, max + 1);
1734 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1735 SvCUR_set(TARG, SvCUR(TARG) * count);
1737 *SvEND(TARG) = '\0';
1740 (void)SvPOK_only_UTF8(TARG);
1742 (void)SvPOK_only(TARG);
1744 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1745 /* The parser saw this as a list repeat, and there
1746 are probably several items on the stack. But we're
1747 in scalar context, and there's no pp_list to save us
1748 now. So drop the rest of the items -- robin@kitsite.com
1760 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1761 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1764 useleft = USE_LEFT(svl);
1765 #ifdef PERL_PRESERVE_IVUV
1766 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1767 "bad things" happen if you rely on signed integers wrapping. */
1768 if (SvIV_please_nomg(svr)) {
1769 /* Unless the left argument is integer in range we are going to have to
1770 use NV maths. Hence only attempt to coerce the right argument if
1771 we know the left is integer. */
1778 a_valid = auvok = 1;
1779 /* left operand is undef, treat as zero. */
1781 /* Left operand is defined, so is it IV? */
1782 if (SvIV_please_nomg(svl)) {
1783 if ((auvok = SvUOK(svl)))
1786 const IV aiv = SvIVX(svl);
1789 auvok = 1; /* Now acting as a sign flag. */
1790 } else { /* 2s complement assumption for IV_MIN */
1798 bool result_good = 0;
1801 bool buvok = SvUOK(svr);
1806 const IV biv = SvIVX(svr);
1813 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1814 else "IV" now, independent of how it came in.
1815 if a, b represents positive, A, B negative, a maps to -A etc
1820 all UV maths. negate result if A negative.
1821 subtract if signs same, add if signs differ. */
1823 if (auvok ^ buvok) {
1832 /* Must get smaller */
1837 if (result <= buv) {
1838 /* result really should be -(auv-buv). as its negation
1839 of true value, need to swap our result flag */
1851 if (result <= (UV)IV_MIN)
1852 SETi( -(IV)result );
1854 /* result valid, but out of range for IV. */
1855 SETn( -(NV)result );
1859 } /* Overflow, drop through to NVs. */
1864 NV value = SvNV_nomg(svr);
1868 /* left operand is undef, treat as zero - value */
1872 SETn( SvNV_nomg(svl) - value );
1879 dVAR; dSP; dATARGET; SV *svl, *svr;
1880 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1884 const IV shift = SvIV_nomg(svr);
1885 if (PL_op->op_private & HINT_INTEGER) {
1886 const IV i = SvIV_nomg(svl);
1890 const UV u = SvUV_nomg(svl);
1899 dVAR; dSP; dATARGET; SV *svl, *svr;
1900 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1904 const IV shift = SvIV_nomg(svr);
1905 if (PL_op->op_private & HINT_INTEGER) {
1906 const IV i = SvIV_nomg(svl);
1910 const UV u = SvUV_nomg(svl);
1922 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1926 (SvIOK_notUV(left) && SvIOK_notUV(right))
1927 ? (SvIVX(left) < SvIVX(right))
1928 : (do_ncmp(left, right) == -1)
1938 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1942 (SvIOK_notUV(left) && SvIOK_notUV(right))
1943 ? (SvIVX(left) > SvIVX(right))
1944 : (do_ncmp(left, right) == 1)
1954 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1958 (SvIOK_notUV(left) && SvIOK_notUV(right))
1959 ? (SvIVX(left) <= SvIVX(right))
1960 : (do_ncmp(left, right) <= 0)
1970 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1974 (SvIOK_notUV(left) && SvIOK_notUV(right))
1975 ? (SvIVX(left) >= SvIVX(right))
1976 : ( (do_ncmp(left, right) & 2) == 0)
1986 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1990 (SvIOK_notUV(left) && SvIOK_notUV(right))
1991 ? (SvIVX(left) != SvIVX(right))
1992 : (do_ncmp(left, right) != 0)
1997 /* compare left and right SVs. Returns:
2001 * 2: left or right was a NaN
2004 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2008 PERL_ARGS_ASSERT_DO_NCMP;
2009 #ifdef PERL_PRESERVE_IVUV
2010 /* Fortunately it seems NaN isn't IOK */
2011 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2013 const IV leftiv = SvIVX(left);
2014 if (!SvUOK(right)) {
2015 /* ## IV <=> IV ## */
2016 const IV rightiv = SvIVX(right);
2017 return (leftiv > rightiv) - (leftiv < rightiv);
2019 /* ## IV <=> UV ## */
2021 /* As (b) is a UV, it's >=0, so it must be < */
2024 const UV rightuv = SvUVX(right);
2025 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2030 /* ## UV <=> UV ## */
2031 const UV leftuv = SvUVX(left);
2032 const UV rightuv = SvUVX(right);
2033 return (leftuv > rightuv) - (leftuv < rightuv);
2035 /* ## UV <=> IV ## */
2037 const IV rightiv = SvIVX(right);
2039 /* As (a) is a UV, it's >=0, so it cannot be < */
2042 const UV leftuv = SvUVX(left);
2043 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2046 assert(0); /* NOTREACHED */
2050 NV const rnv = SvNV_nomg(right);
2051 NV const lnv = SvNV_nomg(left);
2053 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2054 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2057 return (lnv > rnv) - (lnv < rnv);
2076 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2079 value = do_ncmp(left, right);
2094 int amg_type = sle_amg;
2098 switch (PL_op->op_type) {
2117 tryAMAGICbin_MG(amg_type, AMGf_set);
2120 const int cmp = (IN_LOCALE_RUNTIME
2121 ? sv_cmp_locale_flags(left, right, 0)
2122 : sv_cmp_flags(left, right, 0));
2123 SETs(boolSV(cmp * multiplier < rhs));
2131 tryAMAGICbin_MG(seq_amg, AMGf_set);
2134 SETs(boolSV(sv_eq_flags(left, right, 0)));
2142 tryAMAGICbin_MG(sne_amg, AMGf_set);
2145 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2153 tryAMAGICbin_MG(scmp_amg, 0);
2156 const int cmp = (IN_LOCALE_RUNTIME
2157 ? sv_cmp_locale_flags(left, right, 0)
2158 : sv_cmp_flags(left, right, 0));
2166 dVAR; dSP; dATARGET;
2167 tryAMAGICbin_MG(band_amg, AMGf_assign);
2170 if (SvNIOKp(left) || SvNIOKp(right)) {
2171 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2172 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2173 if (PL_op->op_private & HINT_INTEGER) {
2174 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2178 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2181 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2182 if (right_ro_nonnum) SvNIOK_off(right);
2185 do_vop(PL_op->op_type, TARG, left, right);
2194 dVAR; dSP; dATARGET;
2195 const int op_type = PL_op->op_type;
2197 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2200 if (SvNIOKp(left) || SvNIOKp(right)) {
2201 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2202 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2203 if (PL_op->op_private & HINT_INTEGER) {
2204 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2205 const IV r = SvIV_nomg(right);
2206 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2210 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2211 const UV r = SvUV_nomg(right);
2212 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2215 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2216 if (right_ro_nonnum) SvNIOK_off(right);
2219 do_vop(op_type, TARG, left, right);
2226 PERL_STATIC_INLINE bool
2227 S_negate_string(pTHX)
2232 SV * const sv = TOPs;
2233 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2235 s = SvPV_nomg_const(sv, len);
2236 if (isIDFIRST(*s)) {
2237 sv_setpvs(TARG, "-");
2240 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2241 sv_setsv_nomg(TARG, sv);
2242 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2252 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2253 if (S_negate_string(aTHX)) return NORMAL;
2255 SV * const sv = TOPs;
2258 /* It's publicly an integer */
2261 if (SvIVX(sv) == IV_MIN) {
2262 /* 2s complement assumption. */
2263 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2267 else if (SvUVX(sv) <= IV_MAX) {
2272 else if (SvIVX(sv) != IV_MIN) {
2276 #ifdef PERL_PRESERVE_IVUV
2283 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2284 SETn(-SvNV_nomg(sv));
2285 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2286 goto oops_its_an_int;
2288 SETn(-SvNV_nomg(sv));
2296 tryAMAGICun_MG(not_amg, AMGf_set);
2297 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2304 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2308 if (PL_op->op_private & HINT_INTEGER) {
2309 const IV i = ~SvIV_nomg(sv);
2313 const UV u = ~SvUV_nomg(sv);
2322 sv_copypv_nomg(TARG, sv);
2323 tmps = (U8*)SvPV_nomg(TARG, len);
2326 /* Calculate exact length, let's not estimate. */
2331 U8 * const send = tmps + len;
2332 U8 * const origtmps = tmps;
2333 const UV utf8flags = UTF8_ALLOW_ANYUV;
2335 while (tmps < send) {
2336 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2338 targlen += UNISKIP(~c);
2344 /* Now rewind strings and write them. */
2351 Newx(result, targlen + 1, U8);
2353 while (tmps < send) {
2354 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2356 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2359 sv_usepvn_flags(TARG, (char*)result, targlen,
2360 SV_HAS_TRAILING_NUL);
2367 Newx(result, nchar + 1, U8);
2369 while (tmps < send) {
2370 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2375 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2384 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2387 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2392 for ( ; anum > 0; anum--, tmps++)
2400 /* integer versions of some of the above */
2404 dVAR; dSP; dATARGET;
2405 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2408 SETi( left * right );
2416 dVAR; dSP; dATARGET;
2417 tryAMAGICbin_MG(div_amg, AMGf_assign);
2420 IV value = SvIV_nomg(right);
2422 DIE(aTHX_ "Illegal division by zero");
2423 num = SvIV_nomg(left);
2425 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2429 value = num / value;
2435 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2442 /* This is the vanilla old i_modulo. */
2443 dVAR; dSP; dATARGET;
2444 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2448 DIE(aTHX_ "Illegal modulus zero");
2449 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2453 SETi( left % right );
2458 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2463 /* This is the i_modulo with the workaround for the _moddi3 bug
2464 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2465 * See below for pp_i_modulo. */
2466 dVAR; dSP; dATARGET;
2467 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2471 DIE(aTHX_ "Illegal modulus zero");
2472 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2476 SETi( left % PERL_ABS(right) );
2483 dVAR; dSP; dATARGET;
2484 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2488 DIE(aTHX_ "Illegal modulus zero");
2489 /* The assumption is to use hereafter the old vanilla version... */
2491 PL_ppaddr[OP_I_MODULO] =
2493 /* .. but if we have glibc, we might have a buggy _moddi3
2494 * (at least glicb 2.2.5 is known to have this bug), in other
2495 * words our integer modulus with negative quad as the second
2496 * argument might be broken. Test for this and re-patch the
2497 * opcode dispatch table if that is the case, remembering to
2498 * also apply the workaround so that this first round works
2499 * right, too. See [perl #9402] for more information. */
2503 /* Cannot do this check with inlined IV constants since
2504 * that seems to work correctly even with the buggy glibc. */
2506 /* Yikes, we have the bug.
2507 * Patch in the workaround version. */
2509 PL_ppaddr[OP_I_MODULO] =
2510 &Perl_pp_i_modulo_1;
2511 /* Make certain we work right this time, too. */
2512 right = PERL_ABS(right);
2515 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2519 SETi( left % right );
2527 dVAR; dSP; dATARGET;
2528 tryAMAGICbin_MG(add_amg, AMGf_assign);
2530 dPOPTOPiirl_ul_nomg;
2531 SETi( left + right );
2538 dVAR; dSP; dATARGET;
2539 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2541 dPOPTOPiirl_ul_nomg;
2542 SETi( left - right );
2550 tryAMAGICbin_MG(lt_amg, AMGf_set);
2553 SETs(boolSV(left < right));
2561 tryAMAGICbin_MG(gt_amg, AMGf_set);
2564 SETs(boolSV(left > right));
2572 tryAMAGICbin_MG(le_amg, AMGf_set);
2575 SETs(boolSV(left <= right));
2583 tryAMAGICbin_MG(ge_amg, AMGf_set);
2586 SETs(boolSV(left >= right));
2594 tryAMAGICbin_MG(eq_amg, AMGf_set);
2597 SETs(boolSV(left == right));
2605 tryAMAGICbin_MG(ne_amg, AMGf_set);
2608 SETs(boolSV(left != right));
2616 tryAMAGICbin_MG(ncmp_amg, 0);
2623 else if (left < right)
2635 tryAMAGICun_MG(neg_amg, 0);
2636 if (S_negate_string(aTHX)) return NORMAL;
2638 SV * const sv = TOPs;
2639 IV const i = SvIV_nomg(sv);
2645 /* High falutin' math. */
2650 tryAMAGICbin_MG(atan2_amg, 0);
2653 SETn(Perl_atan2(left, right));
2661 int amg_type = sin_amg;
2662 const char *neg_report = NULL;
2663 NV (*func)(NV) = Perl_sin;
2664 const int op_type = PL_op->op_type;
2681 amg_type = sqrt_amg;
2683 neg_report = "sqrt";
2688 tryAMAGICun_MG(amg_type, 0);
2690 SV * const arg = POPs;
2691 const NV value = SvNV_nomg(arg);
2693 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2694 SET_NUMERIC_STANDARD();
2695 /* diag_listed_as: Can't take log of %g */
2696 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2699 XPUSHn(func(value));
2704 /* Support Configure command-line overrides for rand() functions.
2705 After 5.005, perhaps we should replace this by Configure support
2706 for drand48(), random(), or rand(). For 5.005, though, maintain
2707 compatibility by calling rand() but allow the user to override it.
2708 See INSTALL for details. --Andy Dougherty 15 July 1998
2710 /* Now it's after 5.005, and Configure supports drand48() and random(),
2711 in addition to rand(). So the overrides should not be needed any more.
2712 --Jarkko Hietaniemi 27 September 1998
2718 if (!PL_srand_called) {
2719 (void)seedDrand01((Rand_seed_t)seed());
2720 PL_srand_called = TRUE;
2730 SV * const sv = POPs;
2736 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2744 sv_setnv_mg(TARG, value);
2755 if (MAXARG >= 1 && (TOPs || POPs)) {
2762 pv = SvPV(top, len);
2763 flags = grok_number(pv, len, &anum);
2765 if (!(flags & IS_NUMBER_IN_UV)) {
2766 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2767 "Integer overflow in srand");
2775 (void)seedDrand01((Rand_seed_t)anum);
2776 PL_srand_called = TRUE;
2780 /* Historically srand always returned true. We can avoid breaking
2782 sv_setpvs(TARG, "0 but true");
2791 tryAMAGICun_MG(int_amg, AMGf_numeric);
2793 SV * const sv = TOPs;
2794 const IV iv = SvIV_nomg(sv);
2795 /* XXX it's arguable that compiler casting to IV might be subtly
2796 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2797 else preferring IV has introduced a subtle behaviour change bug. OTOH
2798 relying on floating point to be accurate is a bug. */
2803 else if (SvIOK(sv)) {
2805 SETu(SvUV_nomg(sv));
2810 const NV value = SvNV_nomg(sv);
2812 if (value < (NV)UV_MAX + 0.5) {
2815 SETn(Perl_floor(value));
2819 if (value > (NV)IV_MIN - 0.5) {
2822 SETn(Perl_ceil(value));
2833 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2835 SV * const sv = TOPs;
2836 /* This will cache the NV value if string isn't actually integer */
2837 const IV iv = SvIV_nomg(sv);
2842 else if (SvIOK(sv)) {
2843 /* IVX is precise */
2845 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2853 /* 2s complement assumption. Also, not really needed as
2854 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2860 const NV value = SvNV_nomg(sv);
2874 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2878 SV* const sv = POPs;
2880 tmps = (SvPV_const(sv, len));
2882 /* If Unicode, try to downgrade
2883 * If not possible, croak. */
2884 SV* const tsv = sv_2mortal(newSVsv(sv));
2887 sv_utf8_downgrade(tsv, FALSE);
2888 tmps = SvPV_const(tsv, len);
2890 if (PL_op->op_type == OP_HEX)
2893 while (*tmps && len && isSPACE(*tmps))
2897 if (*tmps == 'x' || *tmps == 'X') {
2899 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2901 else if (*tmps == 'b' || *tmps == 'B')
2902 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2904 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2906 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2920 SV * const sv = TOPs;
2925 SETi(sv_len_utf8_nomg(sv));
2929 (void)SvPV_nomg_const(sv,len);
2933 if (!SvPADTMP(TARG)) {
2934 sv_setsv_nomg(TARG, &PL_sv_undef);
2942 /* Returns false if substring is completely outside original string.
2943 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2944 always be true for an explicit 0.
2947 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2948 bool pos1_is_uv, IV len_iv,
2949 bool len_is_uv, STRLEN *posp,
2955 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2957 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2958 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2961 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2964 if (len_iv || len_is_uv) {
2965 if (!len_is_uv && len_iv < 0) {
2966 pos2_iv = curlen + len_iv;
2968 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2971 } else { /* len_iv >= 0 */
2972 if (!pos1_is_uv && pos1_iv < 0) {
2973 pos2_iv = pos1_iv + len_iv;
2974 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2976 if ((UV)len_iv > curlen-(UV)pos1_iv)
2979 pos2_iv = pos1_iv+len_iv;
2989 if (!pos2_is_uv && pos2_iv < 0) {
2990 if (!pos1_is_uv && pos1_iv < 0)
2994 else if (!pos1_is_uv && pos1_iv < 0)
2997 if ((UV)pos2_iv < (UV)pos1_iv)
2999 if ((UV)pos2_iv > curlen)
3002 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3003 *posp = (STRLEN)( (UV)pos1_iv );
3004 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3021 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3022 const bool rvalue = (GIMME_V != G_VOID);
3025 const char *repl = NULL;
3027 int num_args = PL_op->op_private & 7;
3028 bool repl_need_utf8_upgrade = FALSE;
3032 if(!(repl_sv = POPs)) num_args--;
3034 if ((len_sv = POPs)) {
3035 len_iv = SvIV(len_sv);
3036 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3041 pos1_iv = SvIV(pos_sv);
3042 pos1_is_uv = SvIOK_UV(pos_sv);
3044 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3049 if (lvalue && !repl_sv) {
3051 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3052 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3054 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3056 pos1_is_uv || pos1_iv >= 0
3057 ? (STRLEN)(UV)pos1_iv
3058 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3060 len_is_uv || len_iv > 0
3061 ? (STRLEN)(UV)len_iv
3062 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3065 PUSHs(ret); /* avoid SvSETMAGIC here */
3069 repl = SvPV_const(repl_sv, repl_len);
3072 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3073 "Attempt to use reference as lvalue in substr"
3075 tmps = SvPV_force_nomg(sv, curlen);
3076 if (DO_UTF8(repl_sv) && repl_len) {
3078 sv_utf8_upgrade_nomg(sv);
3082 else if (DO_UTF8(sv))
3083 repl_need_utf8_upgrade = TRUE;
3085 else tmps = SvPV_const(sv, curlen);
3087 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3088 if (utf8_curlen == curlen)
3091 curlen = utf8_curlen;
3097 STRLEN pos, len, byte_len, byte_pos;
3099 if (!translate_substr_offsets(
3100 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3104 byte_pos = utf8_curlen
3105 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3110 SvTAINTED_off(TARG); /* decontaminate */
3111 SvUTF8_off(TARG); /* decontaminate */
3112 sv_setpvn(TARG, tmps, byte_len);
3113 #ifdef USE_LOCALE_COLLATE
3114 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3121 SV* repl_sv_copy = NULL;
3123 if (repl_need_utf8_upgrade) {
3124 repl_sv_copy = newSVsv(repl_sv);
3125 sv_utf8_upgrade(repl_sv_copy);
3126 repl = SvPV_const(repl_sv_copy, repl_len);
3130 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3131 SvREFCNT_dec(repl_sv_copy);
3143 Perl_croak(aTHX_ "substr outside of string");
3144 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3151 const IV size = POPi;
3152 const IV offset = POPi;
3153 SV * const src = POPs;
3154 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3157 if (lvalue) { /* it's an lvalue! */
3158 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3159 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3161 LvTARG(ret) = SvREFCNT_inc_simple(src);
3162 LvTARGOFF(ret) = offset;
3163 LvTARGLEN(ret) = size;
3167 SvTAINTED_off(TARG); /* decontaminate */
3171 sv_setuv(ret, do_vecget(src, offset, size));
3187 const char *little_p;
3190 const bool is_index = PL_op->op_type == OP_INDEX;
3191 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3197 big_p = SvPV_const(big, biglen);
3198 little_p = SvPV_const(little, llen);
3200 big_utf8 = DO_UTF8(big);
3201 little_utf8 = DO_UTF8(little);
3202 if (big_utf8 ^ little_utf8) {
3203 /* One needs to be upgraded. */
3204 if (little_utf8 && !PL_encoding) {
3205 /* Well, maybe instead we might be able to downgrade the small
3207 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3210 /* If the large string is ISO-8859-1, and it's not possible to
3211 convert the small string to ISO-8859-1, then there is no
3212 way that it could be found anywhere by index. */
3217 /* At this point, pv is a malloc()ed string. So donate it to temp
3218 to ensure it will get free()d */
3219 little = temp = newSV(0);
3220 sv_usepvn(temp, pv, llen);
3221 little_p = SvPVX(little);
3224 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3227 sv_recode_to_utf8(temp, PL_encoding);
3229 sv_utf8_upgrade(temp);
3234 big_p = SvPV_const(big, biglen);
3237 little_p = SvPV_const(little, llen);
3241 if (SvGAMAGIC(big)) {
3242 /* Life just becomes a lot easier if I use a temporary here.
3243 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3244 will trigger magic and overloading again, as will fbm_instr()
3246 big = newSVpvn_flags(big_p, biglen,
3247 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3250 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3251 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3252 warn on undef, and we've already triggered a warning with the
3253 SvPV_const some lines above. We can't remove that, as we need to
3254 call some SvPV to trigger overloading early and find out if the
3256 This is all getting to messy. The API isn't quite clean enough,
3257 because data access has side effects.
3259 little = newSVpvn_flags(little_p, llen,
3260 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3261 little_p = SvPVX(little);
3265 offset = is_index ? 0 : biglen;
3267 if (big_utf8 && offset > 0)
3268 sv_pos_u2b(big, &offset, 0);
3274 else if (offset > (I32)biglen)
3276 if (!(little_p = is_index
3277 ? fbm_instr((unsigned char*)big_p + offset,
3278 (unsigned char*)big_p + biglen, little, 0)
3279 : rninstr(big_p, big_p + offset,
3280 little_p, little_p + llen)))
3283 retval = little_p - big_p;
3284 if (retval > 0 && big_utf8)
3285 sv_pos_b2u(big, &retval);
3295 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3296 SvTAINTED_off(TARG);
3297 do_sprintf(TARG, SP-MARK, MARK+1);
3298 TAINT_IF(SvTAINTED(TARG));
3310 const U8 *s = (U8*)SvPV_const(argsv, len);
3312 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3313 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3314 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3318 XPUSHu(DO_UTF8(argsv)
3319 ? utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV)
3333 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3334 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3336 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3337 && SvNV_nomg(top) < 0.0))) {
3338 if (ckWARN(WARN_UTF8)) {
3339 if (SvGMAGICAL(top)) {
3340 SV *top2 = sv_newmortal();
3341 sv_setsv_nomg(top2, top);
3344 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3345 "Invalid negative number (%"SVf") in chr", top);
3347 value = UNICODE_REPLACEMENT;
3349 value = SvUV_nomg(top);
3352 SvUPGRADE(TARG,SVt_PV);
3354 if (value > 255 && !IN_BYTES) {
3355 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3356 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3357 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3359 (void)SvPOK_only(TARG);
3368 *tmps++ = (char)value;
3370 (void)SvPOK_only(TARG);
3372 if (PL_encoding && !IN_BYTES) {
3373 sv_recode_to_utf8(TARG, PL_encoding);
3375 if (SvCUR(TARG) == 0
3376 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3377 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3382 *tmps++ = (char)value;
3398 const char *tmps = SvPV_const(left, len);
3400 if (DO_UTF8(left)) {
3401 /* If Unicode, try to downgrade.
3402 * If not possible, croak.
3403 * Yes, we made this up. */
3404 SV* const tsv = sv_2mortal(newSVsv(left));
3407 sv_utf8_downgrade(tsv, FALSE);
3408 tmps = SvPV_const(tsv, len);
3410 # ifdef USE_ITHREADS
3412 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3413 /* This should be threadsafe because in ithreads there is only
3414 * one thread per interpreter. If this would not be true,
3415 * we would need a mutex to protect this malloc. */
3416 PL_reentrant_buffer->_crypt_struct_buffer =
3417 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3418 #if defined(__GLIBC__) || defined(__EMX__)
3419 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3420 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3421 /* work around glibc-2.2.5 bug */
3422 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3426 # endif /* HAS_CRYPT_R */
3427 # endif /* USE_ITHREADS */
3429 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3431 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3437 "The crypt() function is unimplemented due to excessive paranoia.");
3441 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3442 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3446 /* Actually is both lcfirst() and ucfirst(). Only the first character
3447 * changes. This means that possibly we can change in-place, ie., just
3448 * take the source and change that one character and store it back, but not
3449 * if read-only etc, or if the length changes */
3454 STRLEN slen; /* slen is the byte length of the whole SV. */
3457 bool inplace; /* ? Convert first char only, in-place */
3458 bool doing_utf8 = FALSE; /* ? using utf8 */
3459 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3460 const int op_type = PL_op->op_type;
3463 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3464 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3465 * stored as UTF-8 at s. */
3466 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3467 * lowercased) character stored in tmpbuf. May be either
3468 * UTF-8 or not, but in either case is the number of bytes */
3469 bool tainted = FALSE;
3473 s = (const U8*)SvPV_nomg_const(source, slen);
3475 if (ckWARN(WARN_UNINITIALIZED))
3476 report_uninit(source);
3481 /* We may be able to get away with changing only the first character, in
3482 * place, but not if read-only, etc. Later we may discover more reasons to
3483 * not convert in-place. */
3484 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3486 /* First calculate what the changed first character should be. This affects
3487 * whether we can just swap it out, leaving the rest of the string unchanged,
3488 * or even if have to convert the dest to UTF-8 when the source isn't */
3490 if (! slen) { /* If empty */
3491 need = 1; /* still need a trailing NUL */
3494 else if (DO_UTF8(source)) { /* Is the source utf8? */
3497 if (op_type == OP_UCFIRST) {
3498 _to_utf8_title_flags(s, tmpbuf, &tculen,
3499 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3502 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3503 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3506 /* we can't do in-place if the length changes. */
3507 if (ulen != tculen) inplace = FALSE;
3508 need = slen + 1 - ulen + tculen;
3510 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3511 * latin1 is treated as caseless. Note that a locale takes
3513 ulen = 1; /* Original character is 1 byte */
3514 tculen = 1; /* Most characters will require one byte, but this will
3515 * need to be overridden for the tricky ones */
3518 if (op_type == OP_LCFIRST) {
3520 /* lower case the first letter: no trickiness for any character */
3521 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3522 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3525 else if (IN_LOCALE_RUNTIME) {
3526 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3527 * have upper and title case different
3530 else if (! IN_UNI_8_BIT) {
3531 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3532 * on EBCDIC machines whatever the
3533 * native function does */
3535 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3536 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3538 assert(tculen == 2);
3540 /* If the result is an upper Latin1-range character, it can
3541 * still be represented in one byte, which is its ordinal */
3542 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3543 *tmpbuf = (U8) title_ord;
3547 /* Otherwise it became more than one ASCII character (in
3548 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3549 * beyond Latin1, so the number of bytes changed, so can't
3550 * replace just the first character in place. */
3553 /* If the result won't fit in a byte, the entire result
3554 * will have to be in UTF-8. Assume worst case sizing in
3555 * conversion. (all latin1 characters occupy at most two
3557 if (title_ord > 255) {
3559 convert_source_to_utf8 = TRUE;
3560 need = slen * 2 + 1;
3562 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3563 * (both) characters whose title case is above 255 is
3567 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3568 need = slen + 1 + 1;
3572 } /* End of use Unicode (Latin1) semantics */
3573 } /* End of changing the case of the first character */
3575 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3576 * generate the result */
3579 /* We can convert in place. This means we change just the first
3580 * character without disturbing the rest; no need to grow */
3582 s = d = (U8*)SvPV_force_nomg(source, slen);
3588 /* Here, we can't convert in place; we earlier calculated how much
3589 * space we will need, so grow to accommodate that */
3590 SvUPGRADE(dest, SVt_PV);
3591 d = (U8*)SvGROW(dest, need);
3592 (void)SvPOK_only(dest);
3599 if (! convert_source_to_utf8) {
3601 /* Here both source and dest are in UTF-8, but have to create
3602 * the entire output. We initialize the result to be the
3603 * title/lower cased first character, and then append the rest
3605 sv_setpvn(dest, (char*)tmpbuf, tculen);
3607 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3611 const U8 *const send = s + slen;
3613 /* Here the dest needs to be in UTF-8, but the source isn't,
3614 * except we earlier UTF-8'd the first character of the source
3615 * into tmpbuf. First put that into dest, and then append the
3616 * rest of the source, converting it to UTF-8 as we go. */
3618 /* Assert tculen is 2 here because the only two characters that
3619 * get to this part of the code have 2-byte UTF-8 equivalents */
3621 *d++ = *(tmpbuf + 1);
3622 s++; /* We have just processed the 1st char */
3624 for (; s < send; s++) {
3625 d = uvchr_to_utf8(d, *s);
3628 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3632 else { /* in-place UTF-8. Just overwrite the first character */
3633 Copy(tmpbuf, d, tculen, U8);
3634 SvCUR_set(dest, need - 1);
3642 else { /* Neither source nor dest are in or need to be UTF-8 */
3644 if (IN_LOCALE_RUNTIME) {
3648 if (inplace) { /* in-place, only need to change the 1st char */
3651 else { /* Not in-place */
3653 /* Copy the case-changed character(s) from tmpbuf */
3654 Copy(tmpbuf, d, tculen, U8);
3655 d += tculen - 1; /* Code below expects d to point to final
3656 * character stored */
3659 else { /* empty source */
3660 /* See bug #39028: Don't taint if empty */
3664 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3665 * the destination to retain that flag */
3666 if (SvUTF8(source) && ! IN_BYTES)
3669 if (!inplace) { /* Finish the rest of the string, unchanged */
3670 /* This will copy the trailing NUL */
3671 Copy(s + 1, d + 1, slen, U8);
3672 SvCUR_set(dest, need - 1);
3675 if (dest != source && SvTAINTED(source))
3681 /* There's so much setup/teardown code common between uc and lc, I wonder if
3682 it would be worth merging the two, and just having a switch outside each
3683 of the three tight loops. There is less and less commonality though */
3697 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3698 && SvTEMP(source) && !DO_UTF8(source)
3699 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3701 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3702 * make the loop tight, so we overwrite the source with the dest before
3703 * looking at it, and we need to look at the original source
3704 * afterwards. There would also need to be code added to handle
3705 * switching to not in-place in midstream if we run into characters
3706 * that change the length.
3709 s = d = (U8*)SvPV_force_nomg(source, len);
3716 /* The old implementation would copy source into TARG at this point.
3717 This had the side effect that if source was undef, TARG was now
3718 an undefined SV with PADTMP set, and they don't warn inside
3719 sv_2pv_flags(). However, we're now getting the PV direct from
3720 source, which doesn't have PADTMP set, so it would warn. Hence the
3724 s = (const U8*)SvPV_nomg_const(source, len);
3726 if (ckWARN(WARN_UNINITIALIZED))
3727 report_uninit(source);
3733 SvUPGRADE(dest, SVt_PV);
3734 d = (U8*)SvGROW(dest, min);
3735 (void)SvPOK_only(dest);
3740 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3741 to check DO_UTF8 again here. */
3743 if (DO_UTF8(source)) {
3744 const U8 *const send = s + len;
3745 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3746 bool tainted = FALSE;
3748 /* All occurrences of these are to be moved to follow any other marks.
3749 * This is context-dependent. We may not be passed enough context to
3750 * move the iota subscript beyond all of them, but we do the best we can
3751 * with what we're given. The result is always better than if we
3752 * hadn't done this. And, the problem would only arise if we are
3753 * passed a character without all its combining marks, which would be
3754 * the caller's mistake. The information this is based on comes from a
3755 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3756 * itself) and so can't be checked properly to see if it ever gets
3757 * revised. But the likelihood of it changing is remote */
3758 bool in_iota_subscript = FALSE;
3764 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3766 /* A non-mark. Time to output the iota subscript */
3767 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3768 d += capital_iota_len;
3769 in_iota_subscript = FALSE;
3772 /* Then handle the current character. Get the changed case value
3773 * and copy it to the output buffer */
3776 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3777 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3778 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3779 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3780 if (uv == GREEK_CAPITAL_LETTER_IOTA
3781 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3783 in_iota_subscript = TRUE;
3786 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3787 /* If the eventually required minimum size outgrows the
3788 * available space, we need to grow. */
3789 const UV o = d - (U8*)SvPVX_const(dest);
3791 /* If someone uppercases one million U+03B0s we SvGROW()
3792 * one million times. Or we could try guessing how much to
3793 * allocate without allocating too much. Such is life.
3794 * See corresponding comment in lc code for another option
3797 d = (U8*)SvPVX(dest) + o;
3799 Copy(tmpbuf, d, ulen, U8);
3804 if (in_iota_subscript) {
3805 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3806 d += capital_iota_len;
3811 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3817 else { /* Not UTF-8 */
3819 const U8 *const send = s + len;
3821 /* Use locale casing if in locale; regular style if not treating
3822 * latin1 as having case; otherwise the latin1 casing. Do the
3823 * whole thing in a tight loop, for speed, */
3824 if (IN_LOCALE_RUNTIME) {
3827 for (; s < send; d++, s++)
3828 *d = toUPPER_LC(*s);
3830 else if (! IN_UNI_8_BIT) {
3831 for (; s < send; d++, s++) {
3836 for (; s < send; d++, s++) {
3837 *d = toUPPER_LATIN1_MOD(*s);
3838 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3842 /* The mainstream case is the tight loop above. To avoid
3843 * extra tests in that, all three characters that require
3844 * special handling are mapped by the MOD to the one tested
3846 * Use the source to distinguish between the three cases */
3848 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3850 /* uc() of this requires 2 characters, but they are
3851 * ASCII. If not enough room, grow the string */
3852 if (SvLEN(dest) < ++min) {
3853 const UV o = d - (U8*)SvPVX_const(dest);
3855 d = (U8*)SvPVX(dest) + o;
3857 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3858 continue; /* Back to the tight loop; still in ASCII */
3861 /* The other two special handling characters have their
3862 * upper cases outside the latin1 range, hence need to be
3863 * in UTF-8, so the whole result needs to be in UTF-8. So,
3864 * here we are somewhere in the middle of processing a
3865 * non-UTF-8 string, and realize that we will have to convert
3866 * the whole thing to UTF-8. What to do? There are
3867 * several possibilities. The simplest to code is to
3868 * convert what we have so far, set a flag, and continue on
3869 * in the loop. The flag would be tested each time through
3870 * the loop, and if set, the next character would be
3871 * converted to UTF-8 and stored. But, I (khw) didn't want
3872 * to slow down the mainstream case at all for this fairly
3873 * rare case, so I didn't want to add a test that didn't
3874 * absolutely have to be there in the loop, besides the
3875 * possibility that it would get too complicated for
3876 * optimizers to deal with. Another possibility is to just
3877 * give up, convert the source to UTF-8, and restart the
3878 * function that way. Another possibility is to convert
3879 * both what has already been processed and what is yet to
3880 * come separately to UTF-8, then jump into the loop that
3881 * handles UTF-8. But the most efficient time-wise of the
3882 * ones I could think of is what follows, and turned out to
3883 * not require much extra code. */
3885 /* Convert what we have so far into UTF-8, telling the
3886 * function that we know it should be converted, and to
3887 * allow extra space for what we haven't processed yet.
3888 * Assume the worst case space requirements for converting
3889 * what we haven't processed so far: that it will require
3890 * two bytes for each remaining source character, plus the
3891 * NUL at the end. This may cause the string pointer to
3892 * move, so re-find it. */
3894 len = d - (U8*)SvPVX_const(dest);
3895 SvCUR_set(dest, len);
3896 len = sv_utf8_upgrade_flags_grow(dest,
3897 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3899 d = (U8*)SvPVX(dest) + len;
3901 /* Now process the remainder of the source, converting to
3902 * upper and UTF-8. If a resulting byte is invariant in
3903 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3904 * append it to the output. */
3905 for (; s < send; s++) {
3906 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3910 /* Here have processed the whole source; no need to continue
3911 * with the outer loop. Each character has been converted
3912 * to upper case and converted to UTF-8 */
3915 } /* End of processing all latin1-style chars */
3916 } /* End of processing all chars */
3917 } /* End of source is not empty */
3919 if (source != dest) {
3920 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3921 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3923 } /* End of isn't utf8 */
3924 if (dest != source && SvTAINTED(source))
3943 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3944 && SvTEMP(source) && !DO_UTF8(source)) {
3946 /* We can convert in place, as lowercasing anything in the latin1 range
3947 * (or else DO_UTF8 would have been on) doesn't lengthen it */
3949 s = d = (U8*)SvPV_force_nomg(source, len);
3956 /* The old implementation would copy source into TARG at this point.
3957 This had the side effect that if source was undef, TARG was now
3958 an undefined SV with PADTMP set, and they don't warn inside
3959 sv_2pv_flags(). However, we're now getting the PV direct from
3960 source, which doesn't have PADTMP set, so it would warn. Hence the
3964 s = (const U8*)SvPV_nomg_const(source, len);
3966 if (ckWARN(WARN_UNINITIALIZED))
3967 report_uninit(source);
3973 SvUPGRADE(dest, SVt_PV);
3974 d = (U8*)SvGROW(dest, min);
3975 (void)SvPOK_only(dest);
3980 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3981 to check DO_UTF8 again here. */
3983 if (DO_UTF8(source)) {
3984 const U8 *const send = s + len;
3985 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3986 bool tainted = FALSE;
3989 const STRLEN u = UTF8SKIP(s);
3992 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3993 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3995 /* Here is where we would do context-sensitive actions. See the
3996 * commit message for this comment for why there isn't any */
3998 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4000 /* If the eventually required minimum size outgrows the
4001 * available space, we need to grow. */
4002 const UV o = d - (U8*)SvPVX_const(dest);
4004 /* If someone lowercases one million U+0130s we SvGROW() one
4005 * million times. Or we could try guessing how much to
4006 * allocate without allocating too much. Such is life.
4007 * Another option would be to grow an extra byte or two more
4008 * each time we need to grow, which would cut down the million
4009 * to 500K, with little waste */
4011 d = (U8*)SvPVX(dest) + o;
4014 /* Copy the newly lowercased letter to the output buffer we're
4016 Copy(tmpbuf, d, ulen, U8);
4019 } /* End of looping through the source string */
4022 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4027 } else { /* Not utf8 */
4029 const U8 *const send = s + len;
4031 /* Use locale casing if in locale; regular style if not treating
4032 * latin1 as having case; otherwise the latin1 casing. Do the
4033 * whole thing in a tight loop, for speed, */
4034 if (IN_LOCALE_RUNTIME) {
4037 for (; s < send; d++, s++)
4038 *d = toLOWER_LC(*s);
4040 else if (! IN_UNI_8_BIT) {
4041 for (; s < send; d++, s++) {
4046 for (; s < send; d++, s++) {
4047 *d = toLOWER_LATIN1(*s);
4051 if (source != dest) {
4053 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4056 if (dest != source && SvTAINTED(source))
4065 SV * const sv = TOPs;
4067 const char *s = SvPV_const(sv,len);
4069 SvUTF8_off(TARG); /* decontaminate */
4072 SvUPGRADE(TARG, SVt_PV);
4073 SvGROW(TARG, (len * 2) + 1);
4077 STRLEN ulen = UTF8SKIP(s);
4078 bool to_quote = FALSE;
4080 if (UTF8_IS_INVARIANT(*s)) {
4081 if (_isQUOTEMETA(*s)) {
4085 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4087 /* In locale, we quote all non-ASCII Latin1 chars.
4088 * Otherwise use the quoting rules */
4089 if (IN_LOCALE_RUNTIME
4090 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4095 else if (is_QUOTEMETA_high(s)) {
4110 else if (IN_UNI_8_BIT) {
4112 if (_isQUOTEMETA(*s))
4118 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4119 * including everything above ASCII */
4121 if (!isWORDCHAR_A(*s))
4127 SvCUR_set(TARG, d - SvPVX_const(TARG));
4128 (void)SvPOK_only_UTF8(TARG);
4131 sv_setpvn(TARG, s, len);
4148 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4149 const bool full_folding = TRUE;
4150 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4151 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4153 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4154 * You are welcome(?) -Hugmeir
4162 s = (const U8*)SvPV_nomg_const(source, len);
4164 if (ckWARN(WARN_UNINITIALIZED))
4165 report_uninit(source);
4172 SvUPGRADE(dest, SVt_PV);
4173 d = (U8*)SvGROW(dest, min);
4174 (void)SvPOK_only(dest);
4179 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4180 bool tainted = FALSE;
4182 const STRLEN u = UTF8SKIP(s);
4185 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4187 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4188 const UV o = d - (U8*)SvPVX_const(dest);
4190 d = (U8*)SvPVX(dest) + o;
4193 Copy(tmpbuf, d, ulen, U8);
4202 } /* Unflagged string */
4204 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4207 for (; s < send; d++, s++)
4210 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4211 for (; s < send; d++, s++)
4215 /* For ASCII and the Latin-1 range, there's only two troublesome
4216 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4217 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4218 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4219 * For the rest, the casefold is their lowercase. */
4220 for (; s < send; d++, s++) {
4221 if (*s == MICRO_SIGN) {
4222 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4223 * which is outside of the latin-1 range. There's a couple
4224 * of ways to deal with this -- khw discusses them in
4225 * pp_lc/uc, so go there :) What we do here is upgrade what
4226 * we had already casefolded, then enter an inner loop that
4227 * appends the rest of the characters as UTF-8. */
4228 len = d - (U8*)SvPVX_const(dest);
4229 SvCUR_set(dest, len);
4230 len = sv_utf8_upgrade_flags_grow(dest,
4231 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4232 /* The max expansion for latin1
4233 * chars is 1 byte becomes 2 */
4235 d = (U8*)SvPVX(dest) + len;
4237 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4240 for (; s < send; s++) {
4242 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4243 if UVCHR_IS_INVARIANT(fc) {
4245 && *s == LATIN_SMALL_LETTER_SHARP_S)
4254 Copy(tmpbuf, d, ulen, U8);
4260 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4261 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4262 * becomes "ss", which may require growing the SV. */
4263 if (SvLEN(dest) < ++min) {
4264 const UV o = d - (U8*)SvPVX_const(dest);
4266 d = (U8*)SvPVX(dest) + o;
4271 else { /* If it's not one of those two, the fold is their lower
4273 *d = toLOWER_LATIN1(*s);
4279 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4281 if (SvTAINTED(source))
4291 dVAR; dSP; dMARK; dORIGMARK;
4292 AV *const av = MUTABLE_AV(POPs);
4293 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4295 if (SvTYPE(av) == SVt_PVAV) {
4296 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4297 bool can_preserve = FALSE;
4303 can_preserve = SvCANEXISTDELETE(av);
4306 if (lval && localizing) {
4309 for (svp = MARK + 1; svp <= SP; svp++) {
4310 const SSize_t elem = SvIV(*svp);
4314 if (max > AvMAX(av))
4318 while (++MARK <= SP) {
4320 SSize_t elem = SvIV(*MARK);
4321 bool preeminent = TRUE;
4323 if (localizing && can_preserve) {
4324 /* If we can determine whether the element exist,
4325 * Try to preserve the existenceness of a tied array
4326 * element by using EXISTS and DELETE if possible.
4327 * Fallback to FETCH and STORE otherwise. */
4328 preeminent = av_exists(av, elem);
4331 svp = av_fetch(av, elem, lval);
4334 DIE(aTHX_ PL_no_aelem, elem);
4337 save_aelem(av, elem, svp);
4339 SAVEADELETE(av, elem);
4342 *MARK = svp ? *svp : &PL_sv_undef;
4345 if (GIMME != G_ARRAY) {
4347 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4356 AV *const av = MUTABLE_AV(POPs);
4357 I32 lval = (PL_op->op_flags & OPf_MOD);
4358 I32 items = SP - MARK;
4360 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4361 const I32 flags = is_lvalue_sub();
4363 if (!(flags & OPpENTERSUB_INARGS))
4364 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4371 *(MARK+items*2-1) = *(MARK+items);
4377 while (++MARK <= SP) {
4380 svp = av_fetch(av, SvIV(*MARK), lval);
4382 if (!svp || !*svp || *svp == &PL_sv_undef) {
4383 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4385 *MARK = sv_mortalcopy(*MARK);
4387 *++MARK = svp ? *svp : &PL_sv_undef;
4389 if (GIMME != G_ARRAY) {
4390 MARK = SP - items*2;
4391 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4397 /* Smart dereferencing for keys, values and each */
4409 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4414 "Type of argument to %s must be unblessed hashref or arrayref",
4415 PL_op_desc[PL_op->op_type] );
4418 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4420 "Can't modify %s in %s",
4421 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4424 /* Delegate to correct function for op type */
4426 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4427 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4430 return (SvTYPE(sv) == SVt_PVHV)
4431 ? Perl_pp_each(aTHX)
4432 : Perl_pp_aeach(aTHX);
4440 AV *array = MUTABLE_AV(POPs);
4441 const I32 gimme = GIMME_V;
4442 IV *iterp = Perl_av_iter_p(aTHX_ array);
4443 const IV current = (*iterp)++;
4445 if (current > av_len(array)) {
4447 if (gimme == G_SCALAR)
4455 if (gimme == G_ARRAY) {
4456 SV **const element = av_fetch(array, current, 0);
4457 PUSHs(element ? *element : &PL_sv_undef);
4466 AV *array = MUTABLE_AV(POPs);
4467 const I32 gimme = GIMME_V;
4469 *Perl_av_iter_p(aTHX_ array) = 0;
4471 if (gimme == G_SCALAR) {
4473 PUSHi(av_len(array) + 1);
4475 else if (gimme == G_ARRAY) {
4476 IV n = Perl_av_len(aTHX_ array);
4481 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4482 for (i = 0; i <= n; i++) {
4487 for (i = 0; i <= n; i++) {
4488 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4489 PUSHs(elem ? *elem : &PL_sv_undef);
4496 /* Associative arrays. */
4502 HV * hash = MUTABLE_HV(POPs);
4504 const I32 gimme = GIMME_V;
4507 /* might clobber stack_sp */
4508 entry = hv_iternext(hash);
4513 SV* const sv = hv_iterkeysv(entry);
4514 PUSHs(sv); /* won't clobber stack_sp */
4515 if (gimme == G_ARRAY) {
4518 /* might clobber stack_sp */
4519 val = hv_iterval(hash, entry);
4524 else if (gimme == G_SCALAR)
4531 S_do_delete_local(pTHX)
4535 const I32 gimme = GIMME_V;
4538 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4539 SV *unsliced_keysv = sliced ? NULL : POPs;
4540 SV * const osv = POPs;
4541 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4543 const bool tied = SvRMAGICAL(osv)
4544 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4545 const bool can_preserve = SvCANEXISTDELETE(osv);
4546 const U32 type = SvTYPE(osv);
4547 SV ** const end = sliced ? SP : &unsliced_keysv;
4549 if (type == SVt_PVHV) { /* hash element */
4550 HV * const hv = MUTABLE_HV(osv);
4551 while (++MARK <= end) {
4552 SV * const keysv = *MARK;
4554 bool preeminent = TRUE;
4556 preeminent = hv_exists_ent(hv, keysv, 0);
4558 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4565 sv = hv_delete_ent(hv, keysv, 0, 0);
4567 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4570 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4571 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4573 *MARK = sv_mortalcopy(sv);
4579 SAVEHDELETE(hv, keysv);
4580 *MARK = &PL_sv_undef;
4584 else if (type == SVt_PVAV) { /* array element */
4585 if (PL_op->op_flags & OPf_SPECIAL) {
4586 AV * const av = MUTABLE_AV(osv);
4587 while (++MARK <= end) {
4588 SSize_t idx = SvIV(*MARK);
4590 bool preeminent = TRUE;
4592 preeminent = av_exists(av, idx);
4594 SV **svp = av_fetch(av, idx, 1);
4601 sv = av_delete(av, idx, 0);
4603 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4606 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4608 *MARK = sv_mortalcopy(sv);
4614 SAVEADELETE(av, idx);
4615 *MARK = &PL_sv_undef;
4620 DIE(aTHX_ "panic: avhv_delete no longer supported");
4623 DIE(aTHX_ "Not a HASH reference");
4625 if (gimme == G_VOID)
4627 else if (gimme == G_SCALAR) {
4632 *++MARK = &PL_sv_undef;
4636 else if (gimme != G_VOID)
4637 PUSHs(unsliced_keysv);
4649 if (PL_op->op_private & OPpLVAL_INTRO)
4650 return do_delete_local();
4653 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4655 if (PL_op->op_private & OPpSLICE) {
4657 HV * const hv = MUTABLE_HV(POPs);
4658 const U32 hvtype = SvTYPE(hv);
4659 if (hvtype == SVt_PVHV) { /* hash element */
4660 while (++MARK <= SP) {
4661 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4662 *MARK = sv ? sv : &PL_sv_undef;
4665 else if (hvtype == SVt_PVAV) { /* array element */
4666 if (PL_op->op_flags & OPf_SPECIAL) {
4667 while (++MARK <= SP) {
4668 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4669 *MARK = sv ? sv : &PL_sv_undef;
4674 DIE(aTHX_ "Not a HASH reference");
4677 else if (gimme == G_SCALAR) {
4682 *++MARK = &PL_sv_undef;
4688 HV * const hv = MUTABLE_HV(POPs);
4690 if (SvTYPE(hv) == SVt_PVHV)
4691 sv = hv_delete_ent(hv, keysv, discard, 0);
4692 else if (SvTYPE(hv) == SVt_PVAV) {
4693 if (PL_op->op_flags & OPf_SPECIAL)
4694 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4696 DIE(aTHX_ "panic: avhv_delete no longer supported");
4699 DIE(aTHX_ "Not a HASH reference");
4715 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4717 SV * const sv = POPs;
4718 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4721 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4726 hv = MUTABLE_HV(POPs);
4727 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4728 if (hv_exists_ent(hv, tmpsv, 0))
4731 else if (SvTYPE(hv) == SVt_PVAV) {
4732 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4733 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4738 DIE(aTHX_ "Not a HASH reference");
4745 dVAR; dSP; dMARK; dORIGMARK;
4746 HV * const hv = MUTABLE_HV(POPs);
4747 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4748 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4749 bool can_preserve = FALSE;
4755 if (SvCANEXISTDELETE(hv))
4756 can_preserve = TRUE;
4759 while (++MARK <= SP) {
4760 SV * const keysv = *MARK;
4763 bool preeminent = TRUE;
4765 if (localizing && can_preserve) {
4766 /* If we can determine whether the element exist,
4767 * try to preserve the existenceness of a tied hash
4768 * element by using EXISTS and DELETE if possible.
4769 * Fallback to FETCH and STORE otherwise. */
4770 preeminent = hv_exists_ent(hv, keysv, 0);
4773 he = hv_fetch_ent(hv, keysv, lval, 0);
4774 svp = he ? &HeVAL(he) : NULL;
4777 if (!svp || !*svp || *svp == &PL_sv_undef) {
4778 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4781 if (HvNAME_get(hv) && isGV(*svp))
4782 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4783 else if (preeminent)
4784 save_helem_flags(hv, keysv, svp,
4785 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4787 SAVEHDELETE(hv, keysv);
4790 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4792 if (GIMME != G_ARRAY) {
4794 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4802 dVAR; dSP; dMARK; dORIGMARK;
4803 HV * const hv = MUTABLE_HV(POPs);
4804 I32 lval = (PL_op->op_flags & OPf_MOD);
4805 I32 items = SP - MARK;
4807 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4808 const I32 flags = is_lvalue_sub();
4810 if (!(flags & OPpENTERSUB_INARGS))
4811 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4818 *(MARK+items*2-1) = *(MARK+items);
4824 while (++MARK <= SP) {
4825 SV * const keysv = *MARK;
4829 he = hv_fetch_ent(hv, keysv, lval, 0);
4830 svp = he ? &HeVAL(he) : NULL;
4833 if (!svp || !*svp || *svp == &PL_sv_undef) {
4834 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4836 *MARK = sv_mortalcopy(*MARK);
4838 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4840 if (GIMME != G_ARRAY) {
4841 MARK = SP - items*2;
4842 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4848 /* List operators. */
4853 if (GIMME != G_ARRAY) {
4855 *MARK = *SP; /* unwanted list, return last item */
4857 *MARK = &PL_sv_undef;
4867 SV ** const lastrelem = PL_stack_sp;
4868 SV ** const lastlelem = PL_stack_base + POPMARK;
4869 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4870 SV ** const firstrelem = lastlelem + 1;
4871 I32 is_something_there = FALSE;
4872 const U8 mod = PL_op->op_flags & OPf_MOD;
4874 const I32 max = lastrelem - lastlelem;
4877 if (GIMME != G_ARRAY) {
4878 I32 ix = SvIV(*lastlelem);
4881 if (ix < 0 || ix >= max)
4882 *firstlelem = &PL_sv_undef;
4884 *firstlelem = firstrelem[ix];
4890 SP = firstlelem - 1;
4894 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4895 I32 ix = SvIV(*lelem);
4898 if (ix < 0 || ix >= max)
4899 *lelem = &PL_sv_undef;
4901 is_something_there = TRUE;
4902 if (!(*lelem = firstrelem[ix]))
4903 *lelem = &PL_sv_undef;
4904 else if (mod && SvPADTMP(*lelem) && !IS_PADGV(*lelem))
4905 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
4908 if (is_something_there)
4911 SP = firstlelem - 1;
4918 const I32 items = SP - MARK;
4919 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4921 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4922 ? newRV_noinc(av) : av);
4928 dVAR; dSP; dMARK; dORIGMARK;
4929 HV* const hv = newHV();
4930 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
4931 ? newRV_noinc(MUTABLE_SV(hv))
4936 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4943 sv_setsv(val, *MARK);
4947 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4950 (void)hv_store_ent(hv,key,val,0);
4958 S_deref_plain_array(pTHX_ AV *ary)
4960 if (SvTYPE(ary) == SVt_PVAV) return ary;
4961 SvGETMAGIC((SV *)ary);
4962 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4963 Perl_die(aTHX_ "Not an ARRAY reference");
4964 else if (SvOBJECT(SvRV(ary)))
4965 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4966 return (AV *)SvRV(ary);
4969 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4970 # define DEREF_PLAIN_ARRAY(ary) \
4973 SvTYPE(aRrRay) == SVt_PVAV \
4975 : S_deref_plain_array(aTHX_ aRrRay); \
4978 # define DEREF_PLAIN_ARRAY(ary) \
4980 PL_Sv = (SV *)(ary), \
4981 SvTYPE(PL_Sv) == SVt_PVAV \
4983 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4989 dVAR; dSP; dMARK; dORIGMARK;
4990 int num_args = (SP - MARK);
4991 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5000 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5003 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5004 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5011 offset = i = SvIV(*MARK);
5013 offset += AvFILLp(ary) + 1;
5015 DIE(aTHX_ PL_no_aelem, i);
5017 length = SvIVx(*MARK++);
5019 length += AvFILLp(ary) - offset + 1;
5025 length = AvMAX(ary) + 1; /* close enough to infinity */
5029 length = AvMAX(ary) + 1;
5031 if (offset > AvFILLp(ary) + 1) {
5033 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5034 offset = AvFILLp(ary) + 1;
5036 after = AvFILLp(ary) + 1 - (offset + length);
5037 if (after < 0) { /* not that much array */
5038 length += after; /* offset+length now in array */
5044 /* At this point, MARK .. SP-1 is our new LIST */
5047 diff = newlen - length;
5048 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5051 /* make new elements SVs now: avoid problems if they're from the array */
5052 for (dst = MARK, i = newlen; i; i--) {
5053 SV * const h = *dst;
5054 *dst++ = newSVsv(h);
5057 if (diff < 0) { /* shrinking the area */
5058 SV **tmparyval = NULL;
5060 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5061 Copy(MARK, tmparyval, newlen, SV*);
5064 MARK = ORIGMARK + 1;
5065 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5066 const bool real = cBOOL(AvREAL(ary));
5067 MEXTEND(MARK, length);
5069 EXTEND_MORTAL(length);
5070 for (i = 0, dst = MARK; i < length; i++) {
5071 if ((*dst = AvARRAY(ary)[i+offset])) {
5073 sv_2mortal(*dst); /* free them eventually */
5076 *dst = &PL_sv_undef;
5082 *MARK = AvARRAY(ary)[offset+length-1];
5085 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5086 SvREFCNT_dec(*dst++); /* free them now */
5089 AvFILLp(ary) += diff;
5091 /* pull up or down? */
5093 if (offset < after) { /* easier to pull up */
5094 if (offset) { /* esp. if nothing to pull */
5095 src = &AvARRAY(ary)[offset-1];
5096 dst = src - diff; /* diff is negative */
5097 for (i = offset; i > 0; i--) /* can't trust Copy */
5101 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5105 if (after) { /* anything to pull down? */
5106 src = AvARRAY(ary) + offset + length;
5107 dst = src + diff; /* diff is negative */
5108 Move(src, dst, after, SV*);
5110 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5111 /* avoid later double free */
5118 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5119 Safefree(tmparyval);
5122 else { /* no, expanding (or same) */
5123 SV** tmparyval = NULL;
5125 Newx(tmparyval, length, SV*); /* so remember deletion */
5126 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5129 if (diff > 0) { /* expanding */
5130 /* push up or down? */
5131 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5135 Move(src, dst, offset, SV*);
5137 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5139 AvFILLp(ary) += diff;
5142 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5143 av_extend(ary, AvFILLp(ary) + diff);
5144 AvFILLp(ary) += diff;
5147 dst = AvARRAY(ary) + AvFILLp(ary);
5149 for (i = after; i; i--) {
5157 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5160 MARK = ORIGMARK + 1;
5161 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5163 const bool real = cBOOL(AvREAL(ary));
5165 EXTEND_MORTAL(length);
5166 for (i = 0, dst = MARK; i < length; i++) {
5167 if ((*dst = tmparyval[i])) {
5169 sv_2mortal(*dst); /* free them eventually */
5171 else *dst = &PL_sv_undef;
5177 else if (length--) {
5178 *MARK = tmparyval[length];
5181 while (length-- > 0)
5182 SvREFCNT_dec(tmparyval[length]);
5186 *MARK = &PL_sv_undef;
5187 Safefree(tmparyval);
5191 mg_set(MUTABLE_SV(ary));
5199 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5200 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5201 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5204 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5207 ENTER_with_name("call_PUSH");
5208 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5209 LEAVE_with_name("call_PUSH");
5213 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5214 PL_delaymagic = DM_DELAY;
5215 for (++MARK; MARK <= SP; MARK++) {
5217 if (*MARK) SvGETMAGIC(*MARK);
5220 sv_setsv_nomg(sv, *MARK);
5221 av_store(ary, AvFILLp(ary)+1, sv);
5223 if (PL_delaymagic & DM_ARRAY_ISA)
5224 mg_set(MUTABLE_SV(ary));
5229 if (OP_GIMME(PL_op, 0) != G_VOID) {
5230 PUSHi( AvFILL(ary) + 1 );
5239 AV * const av = PL_op->op_flags & OPf_SPECIAL
5240 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5241 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5245 (void)sv_2mortal(sv);
5252 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5253 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5254 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5257 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5260 ENTER_with_name("call_UNSHIFT");
5261 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5262 LEAVE_with_name("call_UNSHIFT");
5267 av_unshift(ary, SP - MARK);
5269 SV * const sv = newSVsv(*++MARK);
5270 (void)av_store(ary, i++, sv);
5274 if (OP_GIMME(PL_op, 0) != G_VOID) {
5275 PUSHi( AvFILL(ary) + 1 );
5284 if (GIMME == G_ARRAY) {
5285 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5289 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5290 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5291 av = MUTABLE_AV((*SP));
5292 /* In-place reversing only happens in void context for the array
5293 * assignment. We don't need to push anything on the stack. */
5296 if (SvMAGICAL(av)) {
5298 SV *tmp = sv_newmortal();
5299 /* For SvCANEXISTDELETE */
5302 bool can_preserve = SvCANEXISTDELETE(av);
5304 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5308 if (!av_exists(av, i)) {
5309 if (av_exists(av, j)) {
5310 SV *sv = av_delete(av, j, 0);
5311 begin = *av_fetch(av, i, TRUE);
5312 sv_setsv_mg(begin, sv);
5316 else if (!av_exists(av, j)) {
5317 SV *sv = av_delete(av, i, 0);
5318 end = *av_fetch(av, j, TRUE);
5319 sv_setsv_mg(end, sv);
5324 begin = *av_fetch(av, i, TRUE);
5325 end = *av_fetch(av, j, TRUE);
5326 sv_setsv(tmp, begin);
5327 sv_setsv_mg(begin, end);
5328 sv_setsv_mg(end, tmp);
5332 SV **begin = AvARRAY(av);
5335 SV **end = begin + AvFILLp(av);
5337 while (begin < end) {
5338 SV * const tmp = *begin;
5349 SV * const tmp = *MARK;
5353 /* safe as long as stack cannot get extended in the above */
5364 SvUTF8_off(TARG); /* decontaminate */
5366 do_join(TARG, &PL_sv_no, MARK, SP);
5368 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5371 up = SvPV_force(TARG, len);
5373 if (DO_UTF8(TARG)) { /* first reverse each character */
5374 U8* s = (U8*)SvPVX(TARG);
5375 const U8* send = (U8*)(s + len);
5377 if (UTF8_IS_INVARIANT(*s)) {
5382 if (!utf8_to_uvchr_buf(s, send, 0))
5386 down = (char*)(s - 1);
5387 /* reverse this character */
5391 *down-- = (char)tmp;
5397 down = SvPVX(TARG) + len - 1;
5401 *down-- = (char)tmp;
5403 (void)SvPOK_only_UTF8(TARG);
5415 IV limit = POPi; /* note, negative is forever */
5416 SV * const sv = POPs;
5418 const char *s = SvPV_const(sv, len);
5419 const bool do_utf8 = DO_UTF8(sv);
5420 const char *strend = s + len;
5426 const STRLEN slen = do_utf8
5427 ? utf8_length((U8*)s, (U8*)strend)
5428 : (STRLEN)(strend - s);
5429 SSize_t maxiters = slen + 10;
5430 I32 trailing_empty = 0;
5432 const I32 origlimit = limit;
5435 const I32 gimme = GIMME_V;
5437 const I32 oldsave = PL_savestack_ix;
5438 U32 make_mortal = SVs_TEMP;
5443 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5448 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5451 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5452 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5455 if (pm->op_pmreplrootu.op_pmtargetoff) {
5456 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5459 if (pm->op_pmreplrootu.op_pmtargetgv) {
5460 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5471 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5473 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5480 for (i = AvFILLp(ary); i >= 0; i--)
5481 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5483 /* temporarily switch stacks */
5484 SAVESWITCHSTACK(PL_curstack, ary);
5488 base = SP - PL_stack_base;
5490 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5492 while (isSPACE_utf8(s))
5495 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5496 while (isSPACE_LC(*s))
5504 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5508 gimme_scalar = gimme == G_SCALAR && !ary;
5511 limit = maxiters + 2;
5512 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5515 /* this one uses 'm' and is a negative test */
5517 while (m < strend && ! isSPACE_utf8(m) ) {
5518 const int t = UTF8SKIP(m);
5519 /* isSPACE_utf8 returns FALSE for malform utf8 */
5526 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5528 while (m < strend && !isSPACE_LC(*m))
5531 while (m < strend && !isSPACE(*m))
5544 dstr = newSVpvn_flags(s, m-s,
5545 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5549 /* skip the whitespace found last */
5551 s = m + UTF8SKIP(m);
5555 /* this one uses 's' and is a positive test */
5557 while (s < strend && isSPACE_utf8(s) )
5560 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5562 while (s < strend && isSPACE_LC(*s))
5565 while (s < strend && isSPACE(*s))
5570 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5572 for (m = s; m < strend && *m != '\n'; m++)
5585 dstr = newSVpvn_flags(s, m-s,
5586 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5592 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5594 Pre-extend the stack, either the number of bytes or
5595 characters in the string or a limited amount, triggered by:
5597 my ($x, $y) = split //, $str;
5601 if (!gimme_scalar) {
5602 const U32 items = limit - 1;
5611 /* keep track of how many bytes we skip over */
5621 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5634 dstr = newSVpvn(s, 1);
5650 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5651 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5652 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5653 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5654 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5655 SV * const csv = CALLREG_INTUIT_STRING(rx);
5657 len = RX_MINLENRET(rx);
5658 if (len == 1 && !RX_UTF8(rx) && !tail) {
5659 const char c = *SvPV_nolen_const(csv);
5661 for (m = s; m < strend && *m != c; m++)
5672 dstr = newSVpvn_flags(s, m-s,
5673 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5676 /* The rx->minlen is in characters but we want to step
5677 * s ahead by bytes. */
5679 s = (char*)utf8_hop((U8*)m, len);
5681 s = m + len; /* Fake \n at the end */
5685 while (s < strend && --limit &&
5686 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5687 csv, multiline ? FBMrf_MULTILINE : 0)) )
5696 dstr = newSVpvn_flags(s, m-s,
5697 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5700 /* The rx->minlen is in characters but we want to step
5701 * s ahead by bytes. */
5703 s = (char*)utf8_hop((U8*)m, len);
5705 s = m + len; /* Fake \n at the end */
5710 maxiters += slen * RX_NPARENS(rx);
5711 while (s < strend && --limit)
5715 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5718 if (rex_return == 0)
5720 TAINT_IF(RX_MATCH_TAINTED(rx));
5721 /* we never pass the REXEC_COPY_STR flag, so it should
5722 * never get copied */
5723 assert(!RX_MATCH_COPIED(rx));
5724 m = RX_OFFS(rx)[0].start + orig;
5733 dstr = newSVpvn_flags(s, m-s,
5734 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5737 if (RX_NPARENS(rx)) {
5739 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5740 s = RX_OFFS(rx)[i].start + orig;
5741 m = RX_OFFS(rx)[i].end + orig;
5743 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5744 parens that didn't match -- they should be set to
5745 undef, not the empty string */
5753 if (m >= orig && s >= orig) {
5754 dstr = newSVpvn_flags(s, m-s,
5755 (do_utf8 ? SVf_UTF8 : 0)
5759 dstr = &PL_sv_undef; /* undef, not "" */
5765 s = RX_OFFS(rx)[0].end + orig;
5769 if (!gimme_scalar) {
5770 iters = (SP - PL_stack_base) - base;
5772 if (iters > maxiters)
5773 DIE(aTHX_ "Split loop");
5775 /* keep field after final delim? */
5776 if (s < strend || (iters && origlimit)) {
5777 if (!gimme_scalar) {
5778 const STRLEN l = strend - s;
5779 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5784 else if (!origlimit) {
5786 iters -= trailing_empty;
5788 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5789 if (TOPs && !make_mortal)
5791 *SP-- = &PL_sv_undef;
5798 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5802 if (SvSMAGICAL(ary)) {
5804 mg_set(MUTABLE_SV(ary));
5807 if (gimme == G_ARRAY) {
5809 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5816 ENTER_with_name("call_PUSH");
5817 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5818 LEAVE_with_name("call_PUSH");
5820 if (gimme == G_ARRAY) {
5822 /* EXTEND should not be needed - we just popped them */
5824 for (i=0; i < iters; i++) {
5825 SV **svp = av_fetch(ary, i, FALSE);
5826 PUSHs((svp) ? *svp : &PL_sv_undef);
5833 if (gimme == G_ARRAY)
5845 SV *const sv = PAD_SVl(PL_op->op_targ);
5847 if (SvPADSTALE(sv)) {
5850 RETURNOP(cLOGOP->op_other);
5852 RETURNOP(cLOGOP->op_next);
5862 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5863 || SvTYPE(retsv) == SVt_PVCV) {
5864 retsv = refto(retsv);
5871 PP(unimplemented_op)
5874 const Optype op_type = PL_op->op_type;
5875 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5876 with out of range op numbers - it only "special" cases op_custom.
5877 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5878 if we get here for a custom op then that means that the custom op didn't
5879 have an implementation. Given that OP_NAME() looks up the custom op
5880 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5881 registers &PL_unimplemented_op as the address of their custom op.
5882 NULL doesn't generate a useful error message. "custom" does. */
5883 const char *const name = op_type >= OP_max
5884 ? "[out of range]" : PL_op_name[PL_op->op_type];
5885 if(OP_IS_SOCKET(op_type))
5886 DIE(aTHX_ PL_no_sock_func, name);
5887 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5890 /* For sorting out arguments passed to a &CORE:: subroutine */
5894 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5895 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5896 AV * const at_ = GvAV(PL_defgv);
5897 SV **svp = at_ ? AvARRAY(at_) : NULL;
5898 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5899 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5900 bool seen_question = 0;
5901 const char *err = NULL;
5902 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5904 /* Count how many args there are first, to get some idea how far to
5905 extend the stack. */
5907 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5909 if (oa & OA_OPTIONAL) seen_question = 1;
5910 if (!seen_question) minargs++;
5914 if(numargs < minargs) err = "Not enough";
5915 else if(numargs > maxargs) err = "Too many";
5917 /* diag_listed_as: Too many arguments for %s */
5919 "%s arguments for %s", err,
5920 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5923 /* Reset the stack pointer. Without this, we end up returning our own
5924 arguments in list context, in addition to the values we are supposed
5925 to return. nextstate usually does this on sub entry, but we need
5926 to run the next op with the caller's hints, so we cannot have a
5928 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5930 if(!maxargs) RETURN;
5932 /* We do this here, rather than with a separate pushmark op, as it has
5933 to come in between two things this function does (stack reset and
5934 arg pushing). This seems the easiest way to do it. */
5937 (void)Perl_pp_pushmark(aTHX);
5940 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5941 PUTBACK; /* The code below can die in various places. */
5943 oa = PL_opargs[opnum] >> OASHIFT;
5944 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5949 if (!numargs && defgv && whicharg == minargs + 1) {
5950 PUSHs(find_rundefsv2(
5951 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5952 cxstack[cxstack_ix].blk_oldcop->cop_seq
5955 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5959 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5964 if (!svp || !*svp || !SvROK(*svp)
5965 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5967 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5968 "Type of arg %d to &CORE::%s must be hash reference",
5969 whicharg, OP_DESC(PL_op->op_next)
5974 if (!numargs) PUSHs(NULL);
5975 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5976 /* no magic here, as the prototype will have added an extra
5977 refgen and we just want what was there before that */
5980 const bool constr = PL_op->op_private & whicharg;
5982 svp && *svp ? *svp : &PL_sv_undef,
5983 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5989 if (!numargs) goto try_defsv;
5991 const bool wantscalar =
5992 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5993 if (!svp || !*svp || !SvROK(*svp)
5994 /* We have to permit globrefs even for the \$ proto, as
5995 *foo is indistinguishable from ${\*foo}, and the proto-
5996 type permits the latter. */
5997 || SvTYPE(SvRV(*svp)) > (
5998 wantscalar ? SVt_PVLV
5999 : opnum == OP_LOCK || opnum == OP_UNDEF
6005 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6006 "Type of arg %d to &CORE::%s must be %s",
6007 whicharg, PL_op_name[opnum],
6009 ? "scalar reference"
6010 : opnum == OP_LOCK || opnum == OP_UNDEF
6011 ? "reference to one of [$@%&*]"
6012 : "reference to one of [$@%*]"
6015 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6016 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6017 /* Undo @_ localisation, so that sub exit does not undo
6018 part of our undeffing. */
6019 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6021 cx->cx_type &= ~ CXp_HASARGS;
6022 assert(!AvREAL(cx->blk_sub.argarray));
6027 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6039 if (PL_op->op_private & OPpOFFBYONE) {
6040 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6042 else cv = find_runcv(NULL);
6043 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6050 * c-indentation-style: bsd
6052 * indent-tabs-mode: nil
6055 * ex: set ts=8 sts=4 sw=4 et: