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 (PL_op->op_private & OPpLVAL_INTRO)
72 if (!(PL_op->op_private & OPpPAD_STATE))
73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
75 if (PL_op->op_flags & OPf_REF) {
78 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 const I32 flags = is_lvalue_sub();
80 if (flags && !(flags & OPpENTERSUB_INARGS)) {
81 if (GIMME == G_SCALAR)
82 /* diag_listed_as: Can't return %s to lvalue scalar context */
83 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
89 if (gimme == G_ARRAY) {
90 /* XXX see also S_pushav in pp_hot.c */
91 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
93 if (SvMAGICAL(TARG)) {
95 for (i=0; i < (U32)maxarg; i++) {
96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
101 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
105 else if (gimme == G_SCALAR) {
106 SV* const sv = sv_newmortal();
107 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
108 sv_setiv(sv, maxarg);
119 assert(SvTYPE(TARG) == SVt_PVHV);
121 if (PL_op->op_private & OPpLVAL_INTRO)
122 if (!(PL_op->op_private & OPpPAD_STATE))
123 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
124 if (PL_op->op_flags & OPf_REF)
126 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
127 const I32 flags = is_lvalue_sub();
128 if (flags && !(flags & OPpENTERSUB_INARGS)) {
129 if (GIMME == G_SCALAR)
130 /* diag_listed_as: Can't return %s to lvalue scalar context */
131 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136 if (gimme == G_ARRAY) {
137 RETURNOP(Perl_do_kv(aTHX));
139 else if ((PL_op->op_private & OPpTRUEBOOL
140 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
141 && block_gimme() == G_VOID ))
142 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
143 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
144 else if (gimme == G_SCALAR) {
145 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
154 assert(SvTYPE(TARG) == SVt_PVCV);
162 SvPADSTALE_off(TARG);
170 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
172 assert(SvTYPE(TARG) == SVt_PVCV);
175 if (CvISXSUB(mg->mg_obj)) { /* constant */
176 /* XXX Should we clone it here? */
177 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
178 to introcv and remove the SvPADSTALE_off. */
179 SAVEPADSVANDMORTALIZE(ARGTARG);
180 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
183 if (CvROOT(mg->mg_obj)) {
184 assert(CvCLONE(mg->mg_obj));
185 assert(!CvCLONED(mg->mg_obj));
187 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
188 SAVECLEARSV(PAD_SVl(ARGTARG));
195 static const char S_no_symref_sv[] =
196 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
198 /* In some cases this function inspects PL_op. If this function is called
199 for new op types, more bool parameters may need to be added in place of
202 When noinit is true, the absence of a gv will cause a retval of undef.
203 This is unrelated to the cv-to-gv assignment case.
207 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
211 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
214 sv = amagic_deref_call(sv, to_gv_amg);
218 if (SvTYPE(sv) == SVt_PVIO) {
219 GV * const gv = MUTABLE_GV(sv_newmortal());
220 gv_init(gv, 0, "__ANONIO__", 10, 0);
221 GvIOp(gv) = MUTABLE_IO(sv);
222 SvREFCNT_inc_void_NN(sv);
225 else if (!isGV_with_GP(sv))
226 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
229 if (!isGV_with_GP(sv)) {
231 /* If this is a 'my' scalar and flag is set then vivify
234 if (vivify_sv && sv != &PL_sv_undef) {
237 Perl_croak_no_modify();
238 if (cUNOP->op_targ) {
239 SV * const namesv = PAD_SV(cUNOP->op_targ);
240 gv = MUTABLE_GV(newSV(0));
241 gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0);
244 const char * const name = CopSTASHPV(PL_curcop);
245 gv = newGVgen_flags(name,
246 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
248 prepare_SV_for_RV(sv);
249 SvRV_set(sv, MUTABLE_SV(gv));
254 if (PL_op->op_flags & OPf_REF || strict)
255 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
256 if (ckWARN(WARN_UNINITIALIZED))
262 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
263 sv, GV_ADDMG, SVt_PVGV
273 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
276 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
277 == OPpDONT_INIT_GV) {
278 /* We are the target of a coderef assignment. Return
279 the scalar unchanged, and let pp_sasssign deal with
283 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
285 /* FAKE globs in the symbol table cause weird bugs (#77810) */
289 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
290 SV *newsv = sv_newmortal();
291 sv_setsv_flags(newsv, sv, 0);
303 sv, PL_op->op_private & OPpDEREF,
304 PL_op->op_private & HINT_STRICT_REFS,
305 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
306 || PL_op->op_type == OP_READLINE
308 if (PL_op->op_private & OPpLVAL_INTRO)
309 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
314 /* Helper function for pp_rv2sv and pp_rv2av */
316 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
317 const svtype type, SV ***spp)
322 PERL_ARGS_ASSERT_SOFTREF2XV;
324 if (PL_op->op_private & HINT_STRICT_REFS) {
326 Perl_die(aTHX_ S_no_symref_sv, sv,
327 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
329 Perl_die(aTHX_ PL_no_usym, what);
333 PL_op->op_flags & OPf_REF
335 Perl_die(aTHX_ PL_no_usym, what);
336 if (ckWARN(WARN_UNINITIALIZED))
338 if (type != SVt_PV && GIMME_V == G_ARRAY) {
342 **spp = &PL_sv_undef;
345 if ((PL_op->op_flags & OPf_SPECIAL) &&
346 !(PL_op->op_flags & OPf_MOD))
348 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
350 **spp = &PL_sv_undef;
355 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
368 sv = amagic_deref_call(sv, to_sv_amg);
372 switch (SvTYPE(sv)) {
378 DIE(aTHX_ "Not a SCALAR reference");
385 if (!isGV_with_GP(gv)) {
386 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
392 if (PL_op->op_flags & OPf_MOD) {
393 if (PL_op->op_private & OPpLVAL_INTRO) {
394 if (cUNOP->op_first->op_type == OP_NULL)
395 sv = save_scalar(MUTABLE_GV(TOPs));
397 sv = save_scalar(gv);
399 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
401 else if (PL_op->op_private & OPpDEREF)
402 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
411 AV * const av = MUTABLE_AV(TOPs);
412 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
414 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
416 *sv = newSV_type(SVt_PVMG);
417 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
421 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
430 if (PL_op->op_flags & OPf_MOD || LVRET) {
431 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
432 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
434 LvTARG(ret) = SvREFCNT_inc_simple(sv);
435 PUSHs(ret); /* no SvSETMAGIC */
439 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
440 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
441 if (mg && mg->mg_len >= 0) {
459 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
461 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
462 == OPpMAY_RETURN_CONSTANT)
465 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
466 /* (But not in defined().) */
468 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
470 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
474 cv = MUTABLE_CV(&PL_sv_undef);
475 SETs(MUTABLE_SV(cv));
485 SV *ret = &PL_sv_undef;
487 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
488 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
489 const char * s = SvPVX_const(TOPs);
490 if (strnEQ(s, "CORE::", 6)) {
491 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
492 if (!code || code == -KEY_CORE)
493 DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
494 SVfARG(newSVpvn_flags(
496 (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP
499 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
505 cv = sv_2cv(TOPs, &stash, &gv, 0);
507 ret = newSVpvn_flags(
508 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
518 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
520 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
522 PUSHs(MUTABLE_SV(cv));
536 if (GIMME != G_ARRAY) {
540 *MARK = &PL_sv_undef;
541 *MARK = refto(*MARK);
545 EXTEND_MORTAL(SP - MARK);
547 *MARK = refto(*MARK);
552 S_refto(pTHX_ SV *sv)
557 PERL_ARGS_ASSERT_REFTO;
559 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
562 if (!(sv = LvTARG(sv)))
565 SvREFCNT_inc_void_NN(sv);
567 else if (SvTYPE(sv) == SVt_PVAV) {
568 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
569 av_reify(MUTABLE_AV(sv));
571 SvREFCNT_inc_void_NN(sv);
573 else if (SvPADTMP(sv) && !IS_PADGV(sv))
577 SvREFCNT_inc_void_NN(sv);
580 sv_upgrade(rv, SVt_IV);
589 SV * const sv = POPs;
594 if (!sv || !SvROK(sv))
597 (void)sv_ref(TARG,SvRV(sv),TRUE);
609 stash = CopSTASH(PL_curcop);
611 SV * const ssv = POPs;
615 if (!ssv) goto curstash;
616 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
617 Perl_croak(aTHX_ "Attempt to bless into a reference");
618 ptr = SvPV_const(ssv,len);
620 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
621 "Explicit blessing to '' (assuming package main)");
622 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
625 (void)sv_bless(TOPs, stash);
635 const char * const elem = SvPV_const(sv, len);
636 GV * const gv = MUTABLE_GV(POPs);
641 /* elem will always be NUL terminated. */
642 const char * const second_letter = elem + 1;
645 if (len == 5 && strEQ(second_letter, "RRAY"))
647 tmpRef = MUTABLE_SV(GvAV(gv));
648 if (tmpRef && !AvREAL((const AV *)tmpRef)
649 && AvREIFY((const AV *)tmpRef))
650 av_reify(MUTABLE_AV(tmpRef));
654 if (len == 4 && strEQ(second_letter, "ODE"))
655 tmpRef = MUTABLE_SV(GvCVu(gv));
658 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
659 /* finally deprecated in 5.8.0 */
660 deprecate("*glob{FILEHANDLE}");
661 tmpRef = MUTABLE_SV(GvIOp(gv));
664 if (len == 6 && strEQ(second_letter, "ORMAT"))
665 tmpRef = MUTABLE_SV(GvFORM(gv));
668 if (len == 4 && strEQ(second_letter, "LOB"))
669 tmpRef = MUTABLE_SV(gv);
672 if (len == 4 && strEQ(second_letter, "ASH"))
673 tmpRef = MUTABLE_SV(GvHV(gv));
676 if (*second_letter == 'O' && !elem[2] && len == 2)
677 tmpRef = MUTABLE_SV(GvIOp(gv));
680 if (len == 4 && strEQ(second_letter, "AME"))
681 sv = newSVhek(GvNAME_HEK(gv));
684 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
685 const HV * const stash = GvSTASH(gv);
686 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
687 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
691 if (len == 6 && strEQ(second_letter, "CALAR"))
706 /* Pattern matching */
714 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
715 /* Historically, study was skipped in these cases. */
719 /* Make study a no-op. It's no longer useful and its existence
720 complicates matters elsewhere. */
729 if (PL_op->op_flags & OPf_STACKED)
731 else if (PL_op->op_private & OPpTARGET_MY)
737 if(PL_op->op_type == OP_TRANSR) {
739 const char * const pv = SvPV(sv,len);
740 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
745 TARG = sv_newmortal();
751 /* Lvalue operators. */
754 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
760 PERL_ARGS_ASSERT_DO_CHOMP;
762 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
764 if (SvTYPE(sv) == SVt_PVAV) {
766 AV *const av = MUTABLE_AV(sv);
767 const I32 max = AvFILL(av);
769 for (i = 0; i <= max; i++) {
770 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
771 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
772 do_chomp(retval, sv, chomping);
776 else if (SvTYPE(sv) == SVt_PVHV) {
777 HV* const hv = MUTABLE_HV(sv);
779 (void)hv_iterinit(hv);
780 while ((entry = hv_iternext(hv)))
781 do_chomp(retval, hv_iterval(hv,entry), chomping);
784 else if (SvREADONLY(sv)) {
785 Perl_croak_no_modify();
787 else if (SvIsCOW(sv)) {
788 sv_force_normal_flags(sv, 0);
793 /* XXX, here sv is utf8-ized as a side-effect!
794 If encoding.pm is used properly, almost string-generating
795 operations, including literal strings, chr(), input data, etc.
796 should have been utf8-ized already, right?
798 sv_recode_to_utf8(sv, PL_encoding);
804 char *temp_buffer = NULL;
813 while (len && s[-1] == '\n') {
820 STRLEN rslen, rs_charlen;
821 const char *rsptr = SvPV_const(PL_rs, rslen);
823 rs_charlen = SvUTF8(PL_rs)
827 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
828 /* Assumption is that rs is shorter than the scalar. */
830 /* RS is utf8, scalar is 8 bit. */
832 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
835 /* Cannot downgrade, therefore cannot possibly match
837 assert (temp_buffer == rsptr);
843 else if (PL_encoding) {
844 /* RS is 8 bit, encoding.pm is used.
845 * Do not recode PL_rs as a side-effect. */
846 svrecode = newSVpvn(rsptr, rslen);
847 sv_recode_to_utf8(svrecode, PL_encoding);
848 rsptr = SvPV_const(svrecode, rslen);
849 rs_charlen = sv_len_utf8(svrecode);
852 /* RS is 8 bit, scalar is utf8. */
853 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
867 if (memNE(s, rsptr, rslen))
869 SvIVX(retval) += rs_charlen;
872 s = SvPV_force_nomg_nolen(sv);
880 SvREFCNT_dec(svrecode);
882 Safefree(temp_buffer);
884 if (len && !SvPOK(sv))
885 s = SvPV_force_nomg(sv, len);
888 char * const send = s + len;
889 char * const start = s;
891 while (s > start && UTF8_IS_CONTINUATION(*s))
893 if (is_utf8_string((U8*)s, send - s)) {
894 sv_setpvn(retval, s, send - s);
896 SvCUR_set(sv, s - start);
902 sv_setpvs(retval, "");
906 sv_setpvn(retval, s, 1);
913 sv_setpvs(retval, "");
921 const bool chomping = PL_op->op_type == OP_SCHOMP;
925 do_chomp(TARG, TOPs, chomping);
932 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
933 const bool chomping = PL_op->op_type == OP_CHOMP;
938 do_chomp(TARG, *++MARK, chomping);
949 if (!PL_op->op_private) {
958 SV_CHECK_THINKFIRST_COW_DROP(sv);
960 switch (SvTYPE(sv)) {
964 av_undef(MUTABLE_AV(sv));
967 hv_undef(MUTABLE_HV(sv));
970 if (cv_const_sv((const CV *)sv))
971 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
972 "Constant subroutine %"SVf" undefined",
973 SVfARG(CvANON((const CV *)sv)
974 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
975 : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
979 /* let user-undef'd sub keep its identity */
980 GV* const gv = CvGV((const CV *)sv);
981 HEK * const hek = CvNAME_HEK((CV *)sv);
982 if (hek) share_hek_hek(hek);
983 cv_undef(MUTABLE_CV(sv));
984 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
986 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
992 assert(isGV_with_GP(sv));
998 /* undef *Pkg::meth_name ... */
1000 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1001 && HvENAME_get(stash);
1003 if((stash = GvHV((const GV *)sv))) {
1004 if(HvENAME_get(stash))
1005 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1009 gp_free(MUTABLE_GV(sv));
1011 GvGP_set(sv, gp_ref(gp));
1012 GvSV(sv) = newSV(0);
1013 GvLINE(sv) = CopLINE(PL_curcop);
1014 GvEGV(sv) = MUTABLE_GV(sv);
1018 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1020 /* undef *Foo::ISA */
1021 if( strEQ(GvNAME((const GV *)sv), "ISA")
1022 && (stash = GvSTASH((const GV *)sv))
1023 && (method_changed || HvENAME(stash)) )
1024 mro_isa_changed_in(stash);
1025 else if(method_changed)
1026 mro_method_changed_in(
1027 GvSTASH((const GV *)sv)
1033 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1049 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1050 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1051 Perl_croak_no_modify();
1053 TARG = sv_newmortal();
1054 sv_setsv(TARG, TOPs);
1055 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1056 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1058 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1059 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1063 else sv_dec_nomg(TOPs);
1065 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1066 if (inc && !SvOK(TARG))
1072 /* Ordinary operators. */
1076 dVAR; dSP; dATARGET; SV *svl, *svr;
1077 #ifdef PERL_PRESERVE_IVUV
1080 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1083 #ifdef PERL_PRESERVE_IVUV
1084 /* For integer to integer power, we do the calculation by hand wherever
1085 we're sure it is safe; otherwise we call pow() and try to convert to
1086 integer afterwards. */
1087 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1095 const IV iv = SvIVX(svr);
1099 goto float_it; /* Can't do negative powers this way. */
1103 baseuok = SvUOK(svl);
1105 baseuv = SvUVX(svl);
1107 const IV iv = SvIVX(svl);
1110 baseuok = TRUE; /* effectively it's a UV now */
1112 baseuv = -iv; /* abs, baseuok == false records sign */
1115 /* now we have integer ** positive integer. */
1118 /* foo & (foo - 1) is zero only for a power of 2. */
1119 if (!(baseuv & (baseuv - 1))) {
1120 /* We are raising power-of-2 to a positive integer.
1121 The logic here will work for any base (even non-integer
1122 bases) but it can be less accurate than
1123 pow (base,power) or exp (power * log (base)) when the
1124 intermediate values start to spill out of the mantissa.
1125 With powers of 2 we know this can't happen.
1126 And powers of 2 are the favourite thing for perl
1127 programmers to notice ** not doing what they mean. */
1129 NV base = baseuok ? baseuv : -(NV)baseuv;
1134 while (power >>= 1) {
1142 SvIV_please_nomg(svr);
1145 unsigned int highbit = 8 * sizeof(UV);
1146 unsigned int diff = 8 * sizeof(UV);
1147 while (diff >>= 1) {
1149 if (baseuv >> highbit) {
1153 /* we now have baseuv < 2 ** highbit */
1154 if (power * highbit <= 8 * sizeof(UV)) {
1155 /* result will definitely fit in UV, so use UV math
1156 on same algorithm as above */
1159 const bool odd_power = cBOOL(power & 1);
1163 while (power >>= 1) {
1170 if (baseuok || !odd_power)
1171 /* answer is positive */
1173 else if (result <= (UV)IV_MAX)
1174 /* answer negative, fits in IV */
1175 SETi( -(IV)result );
1176 else if (result == (UV)IV_MIN)
1177 /* 2's complement assumption: special case IV_MIN */
1180 /* answer negative, doesn't fit */
1181 SETn( -(NV)result );
1189 NV right = SvNV_nomg(svr);
1190 NV left = SvNV_nomg(svl);
1193 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1195 We are building perl with long double support and are on an AIX OS
1196 afflicted with a powl() function that wrongly returns NaNQ for any
1197 negative base. This was reported to IBM as PMR #23047-379 on
1198 03/06/2006. The problem exists in at least the following versions
1199 of AIX and the libm fileset, and no doubt others as well:
1201 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1202 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1203 AIX 5.2.0 bos.adt.libm 5.2.0.85
1205 So, until IBM fixes powl(), we provide the following workaround to
1206 handle the problem ourselves. Our logic is as follows: for
1207 negative bases (left), we use fmod(right, 2) to check if the
1208 exponent is an odd or even integer:
1210 - if odd, powl(left, right) == -powl(-left, right)
1211 - if even, powl(left, right) == powl(-left, right)
1213 If the exponent is not an integer, the result is rightly NaNQ, so
1214 we just return that (as NV_NAN).
1218 NV mod2 = Perl_fmod( right, 2.0 );
1219 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1220 SETn( -Perl_pow( -left, right) );
1221 } else if (mod2 == 0.0) { /* even integer */
1222 SETn( Perl_pow( -left, right) );
1223 } else { /* fractional power */
1227 SETn( Perl_pow( left, right) );
1230 SETn( Perl_pow( left, right) );
1231 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1233 #ifdef PERL_PRESERVE_IVUV
1235 SvIV_please_nomg(svr);
1243 dVAR; dSP; dATARGET; SV *svl, *svr;
1244 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1247 #ifdef PERL_PRESERVE_IVUV
1248 if (SvIV_please_nomg(svr)) {
1249 /* Unless the left argument is integer in range we are going to have to
1250 use NV maths. Hence only attempt to coerce the right argument if
1251 we know the left is integer. */
1252 /* Left operand is defined, so is it IV? */
1253 if (SvIV_please_nomg(svl)) {
1254 bool auvok = SvUOK(svl);
1255 bool buvok = SvUOK(svr);
1256 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1257 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1266 const IV aiv = SvIVX(svl);
1269 auvok = TRUE; /* effectively it's a UV now */
1271 alow = -aiv; /* abs, auvok == false records sign */
1277 const IV biv = SvIVX(svr);
1280 buvok = TRUE; /* effectively it's a UV now */
1282 blow = -biv; /* abs, buvok == false records sign */
1286 /* If this does sign extension on unsigned it's time for plan B */
1287 ahigh = alow >> (4 * sizeof (UV));
1289 bhigh = blow >> (4 * sizeof (UV));
1291 if (ahigh && bhigh) {
1293 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1294 which is overflow. Drop to NVs below. */
1295 } else if (!ahigh && !bhigh) {
1296 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1297 so the unsigned multiply cannot overflow. */
1298 const UV product = alow * blow;
1299 if (auvok == buvok) {
1300 /* -ve * -ve or +ve * +ve gives a +ve result. */
1304 } else if (product <= (UV)IV_MIN) {
1305 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1306 /* -ve result, which could overflow an IV */
1308 SETi( -(IV)product );
1310 } /* else drop to NVs below. */
1312 /* One operand is large, 1 small */
1315 /* swap the operands */
1317 bhigh = blow; /* bhigh now the temp var for the swap */
1321 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1322 multiplies can't overflow. shift can, add can, -ve can. */
1323 product_middle = ahigh * blow;
1324 if (!(product_middle & topmask)) {
1325 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1327 product_middle <<= (4 * sizeof (UV));
1328 product_low = alow * blow;
1330 /* as for pp_add, UV + something mustn't get smaller.
1331 IIRC ANSI mandates this wrapping *behaviour* for
1332 unsigned whatever the actual representation*/
1333 product_low += product_middle;
1334 if (product_low >= product_middle) {
1335 /* didn't overflow */
1336 if (auvok == buvok) {
1337 /* -ve * -ve or +ve * +ve gives a +ve result. */
1339 SETu( product_low );
1341 } else if (product_low <= (UV)IV_MIN) {
1342 /* 2s complement assumption again */
1343 /* -ve result, which could overflow an IV */
1345 SETi( -(IV)product_low );
1347 } /* else drop to NVs below. */
1349 } /* product_middle too large */
1350 } /* ahigh && bhigh */
1355 NV right = SvNV_nomg(svr);
1356 NV left = SvNV_nomg(svl);
1358 SETn( left * right );
1365 dVAR; dSP; dATARGET; SV *svl, *svr;
1366 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1369 /* Only try to do UV divide first
1370 if ((SLOPPYDIVIDE is true) or
1371 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1373 The assumption is that it is better to use floating point divide
1374 whenever possible, only doing integer divide first if we can't be sure.
1375 If NV_PRESERVES_UV is true then we know at compile time that no UV
1376 can be too large to preserve, so don't need to compile the code to
1377 test the size of UVs. */
1380 # define PERL_TRY_UV_DIVIDE
1381 /* ensure that 20./5. == 4. */
1383 # ifdef PERL_PRESERVE_IVUV
1384 # ifndef NV_PRESERVES_UV
1385 # define PERL_TRY_UV_DIVIDE
1390 #ifdef PERL_TRY_UV_DIVIDE
1391 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1392 bool left_non_neg = SvUOK(svl);
1393 bool right_non_neg = SvUOK(svr);
1397 if (right_non_neg) {
1401 const IV biv = SvIVX(svr);
1404 right_non_neg = TRUE; /* effectively it's a UV now */
1410 /* historically undef()/0 gives a "Use of uninitialized value"
1411 warning before dieing, hence this test goes here.
1412 If it were immediately before the second SvIV_please, then
1413 DIE() would be invoked before left was even inspected, so
1414 no inspection would give no warning. */
1416 DIE(aTHX_ "Illegal division by zero");
1422 const IV aiv = SvIVX(svl);
1425 left_non_neg = TRUE; /* effectively it's a UV now */
1434 /* For sloppy divide we always attempt integer division. */
1436 /* Otherwise we only attempt it if either or both operands
1437 would not be preserved by an NV. If both fit in NVs
1438 we fall through to the NV divide code below. However,
1439 as left >= right to ensure integer result here, we know that
1440 we can skip the test on the right operand - right big
1441 enough not to be preserved can't get here unless left is
1444 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1447 /* Integer division can't overflow, but it can be imprecise. */
1448 const UV result = left / right;
1449 if (result * right == left) {
1450 SP--; /* result is valid */
1451 if (left_non_neg == right_non_neg) {
1452 /* signs identical, result is positive. */
1456 /* 2s complement assumption */
1457 if (result <= (UV)IV_MIN)
1458 SETi( -(IV)result );
1460 /* It's exact but too negative for IV. */
1461 SETn( -(NV)result );
1464 } /* tried integer divide but it was not an integer result */
1465 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1466 } /* one operand wasn't SvIOK */
1467 #endif /* PERL_TRY_UV_DIVIDE */
1469 NV right = SvNV_nomg(svr);
1470 NV left = SvNV_nomg(svl);
1471 (void)POPs;(void)POPs;
1472 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1473 if (! Perl_isnan(right) && right == 0.0)
1477 DIE(aTHX_ "Illegal division by zero");
1478 PUSHn( left / right );
1485 dVAR; dSP; dATARGET;
1486 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1490 bool left_neg = FALSE;
1491 bool right_neg = FALSE;
1492 bool use_double = FALSE;
1493 bool dright_valid = FALSE;
1496 SV * const svr = TOPs;
1497 SV * const svl = TOPm1s;
1498 if (SvIV_please_nomg(svr)) {
1499 right_neg = !SvUOK(svr);
1503 const IV biv = SvIVX(svr);
1506 right_neg = FALSE; /* effectively it's a UV now */
1513 dright = SvNV_nomg(svr);
1514 right_neg = dright < 0;
1517 if (dright < UV_MAX_P1) {
1518 right = U_V(dright);
1519 dright_valid = TRUE; /* In case we need to use double below. */
1525 /* At this point use_double is only true if right is out of range for
1526 a UV. In range NV has been rounded down to nearest UV and
1527 use_double false. */
1528 if (!use_double && SvIV_please_nomg(svl)) {
1529 left_neg = !SvUOK(svl);
1533 const IV aiv = SvIVX(svl);
1536 left_neg = FALSE; /* effectively it's a UV now */
1543 dleft = SvNV_nomg(svl);
1544 left_neg = dleft < 0;
1548 /* This should be exactly the 5.6 behaviour - if left and right are
1549 both in range for UV then use U_V() rather than floor. */
1551 if (dleft < UV_MAX_P1) {
1552 /* right was in range, so is dleft, so use UVs not double.
1556 /* left is out of range for UV, right was in range, so promote
1557 right (back) to double. */
1559 /* The +0.5 is used in 5.6 even though it is not strictly
1560 consistent with the implicit +0 floor in the U_V()
1561 inside the #if 1. */
1562 dleft = Perl_floor(dleft + 0.5);
1565 dright = Perl_floor(dright + 0.5);
1576 DIE(aTHX_ "Illegal modulus zero");
1578 dans = Perl_fmod(dleft, dright);
1579 if ((left_neg != right_neg) && dans)
1580 dans = dright - dans;
1583 sv_setnv(TARG, dans);
1589 DIE(aTHX_ "Illegal modulus zero");
1592 if ((left_neg != right_neg) && ans)
1595 /* XXX may warn: unary minus operator applied to unsigned type */
1596 /* could change -foo to be (~foo)+1 instead */
1597 if (ans <= ~((UV)IV_MAX)+1)
1598 sv_setiv(TARG, ~ans+1);
1600 sv_setnv(TARG, -(NV)ans);
1603 sv_setuv(TARG, ans);
1612 dVAR; dSP; dATARGET;
1616 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1617 /* TODO: think of some way of doing list-repeat overloading ??? */
1622 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1628 const UV uv = SvUV_nomg(sv);
1630 count = IV_MAX; /* The best we can do? */
1634 const IV iv = SvIV_nomg(sv);
1641 else if (SvNOKp(sv)) {
1642 const NV nv = SvNV_nomg(sv);
1649 count = SvIV_nomg(sv);
1651 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1653 static const char* const oom_list_extend = "Out of memory during list extend";
1654 const I32 items = SP - MARK;
1655 const I32 max = items * count;
1657 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1658 /* Did the max computation overflow? */
1659 if (items > 0 && max > 0 && (max < items || max < count))
1660 Perl_croak(aTHX_ "%s", oom_list_extend);
1665 /* This code was intended to fix 20010809.028:
1668 for (($x =~ /./g) x 2) {
1669 print chop; # "abcdabcd" expected as output.
1672 * but that change (#11635) broke this code:
1674 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1676 * I can't think of a better fix that doesn't introduce
1677 * an efficiency hit by copying the SVs. The stack isn't
1678 * refcounted, and mortalisation obviously doesn't
1679 * Do The Right Thing when the stack has more than
1680 * one pointer to the same mortal value.
1684 *SP = sv_2mortal(newSVsv(*SP));
1694 repeatcpy((char*)(MARK + items), (char*)MARK,
1695 items * sizeof(const SV *), count - 1);
1698 else if (count <= 0)
1701 else { /* Note: mark already snarfed by pp_list */
1702 SV * const tmpstr = POPs;
1705 static const char* const oom_string_extend =
1706 "Out of memory during string extend";
1709 sv_setsv_nomg(TARG, tmpstr);
1710 SvPV_force_nomg(TARG, len);
1711 isutf = DO_UTF8(TARG);
1716 const STRLEN max = (UV)count * len;
1717 if (len > MEM_SIZE_MAX / count)
1718 Perl_croak(aTHX_ "%s", oom_string_extend);
1719 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1720 SvGROW(TARG, max + 1);
1721 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1722 SvCUR_set(TARG, SvCUR(TARG) * count);
1724 *SvEND(TARG) = '\0';
1727 (void)SvPOK_only_UTF8(TARG);
1729 (void)SvPOK_only(TARG);
1731 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1732 /* The parser saw this as a list repeat, and there
1733 are probably several items on the stack. But we're
1734 in scalar context, and there's no pp_list to save us
1735 now. So drop the rest of the items -- robin@kitsite.com
1747 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1748 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1751 useleft = USE_LEFT(svl);
1752 #ifdef PERL_PRESERVE_IVUV
1753 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1754 "bad things" happen if you rely on signed integers wrapping. */
1755 if (SvIV_please_nomg(svr)) {
1756 /* Unless the left argument is integer in range we are going to have to
1757 use NV maths. Hence only attempt to coerce the right argument if
1758 we know the left is integer. */
1765 a_valid = auvok = 1;
1766 /* left operand is undef, treat as zero. */
1768 /* Left operand is defined, so is it IV? */
1769 if (SvIV_please_nomg(svl)) {
1770 if ((auvok = SvUOK(svl)))
1773 const IV aiv = SvIVX(svl);
1776 auvok = 1; /* Now acting as a sign flag. */
1777 } else { /* 2s complement assumption for IV_MIN */
1785 bool result_good = 0;
1788 bool buvok = SvUOK(svr);
1793 const IV biv = SvIVX(svr);
1800 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1801 else "IV" now, independent of how it came in.
1802 if a, b represents positive, A, B negative, a maps to -A etc
1807 all UV maths. negate result if A negative.
1808 subtract if signs same, add if signs differ. */
1810 if (auvok ^ buvok) {
1819 /* Must get smaller */
1824 if (result <= buv) {
1825 /* result really should be -(auv-buv). as its negation
1826 of true value, need to swap our result flag */
1838 if (result <= (UV)IV_MIN)
1839 SETi( -(IV)result );
1841 /* result valid, but out of range for IV. */
1842 SETn( -(NV)result );
1846 } /* Overflow, drop through to NVs. */
1851 NV value = SvNV_nomg(svr);
1855 /* left operand is undef, treat as zero - value */
1859 SETn( SvNV_nomg(svl) - value );
1866 dVAR; dSP; dATARGET; SV *svl, *svr;
1867 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1871 const IV shift = SvIV_nomg(svr);
1872 if (PL_op->op_private & HINT_INTEGER) {
1873 const IV i = SvIV_nomg(svl);
1877 const UV u = SvUV_nomg(svl);
1886 dVAR; dSP; dATARGET; SV *svl, *svr;
1887 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1891 const IV shift = SvIV_nomg(svr);
1892 if (PL_op->op_private & HINT_INTEGER) {
1893 const IV i = SvIV_nomg(svl);
1897 const UV u = SvUV_nomg(svl);
1909 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1913 (SvIOK_notUV(left) && SvIOK_notUV(right))
1914 ? (SvIVX(left) < SvIVX(right))
1915 : (do_ncmp(left, right) == -1)
1925 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1929 (SvIOK_notUV(left) && SvIOK_notUV(right))
1930 ? (SvIVX(left) > SvIVX(right))
1931 : (do_ncmp(left, right) == 1)
1941 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1945 (SvIOK_notUV(left) && SvIOK_notUV(right))
1946 ? (SvIVX(left) <= SvIVX(right))
1947 : (do_ncmp(left, right) <= 0)
1957 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1961 (SvIOK_notUV(left) && SvIOK_notUV(right))
1962 ? (SvIVX(left) >= SvIVX(right))
1963 : ( (do_ncmp(left, right) & 2) == 0)
1973 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1977 (SvIOK_notUV(left) && SvIOK_notUV(right))
1978 ? (SvIVX(left) != SvIVX(right))
1979 : (do_ncmp(left, right) != 0)
1984 /* compare left and right SVs. Returns:
1988 * 2: left or right was a NaN
1991 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1995 PERL_ARGS_ASSERT_DO_NCMP;
1996 #ifdef PERL_PRESERVE_IVUV
1997 /* Fortunately it seems NaN isn't IOK */
1998 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2000 const IV leftiv = SvIVX(left);
2001 if (!SvUOK(right)) {
2002 /* ## IV <=> IV ## */
2003 const IV rightiv = SvIVX(right);
2004 return (leftiv > rightiv) - (leftiv < rightiv);
2006 /* ## IV <=> UV ## */
2008 /* As (b) is a UV, it's >=0, so it must be < */
2011 const UV rightuv = SvUVX(right);
2012 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2017 /* ## UV <=> UV ## */
2018 const UV leftuv = SvUVX(left);
2019 const UV rightuv = SvUVX(right);
2020 return (leftuv > rightuv) - (leftuv < rightuv);
2022 /* ## UV <=> IV ## */
2024 const IV rightiv = SvIVX(right);
2026 /* As (a) is a UV, it's >=0, so it cannot be < */
2029 const UV leftuv = SvUVX(left);
2030 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2033 assert(0); /* NOTREACHED */
2037 NV const rnv = SvNV_nomg(right);
2038 NV const lnv = SvNV_nomg(left);
2040 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2041 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2044 return (lnv > rnv) - (lnv < rnv);
2063 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2066 value = do_ncmp(left, right);
2081 int amg_type = sle_amg;
2085 switch (PL_op->op_type) {
2104 tryAMAGICbin_MG(amg_type, AMGf_set);
2107 const int cmp = (IN_LOCALE_RUNTIME
2108 ? sv_cmp_locale_flags(left, right, 0)
2109 : sv_cmp_flags(left, right, 0));
2110 SETs(boolSV(cmp * multiplier < rhs));
2118 tryAMAGICbin_MG(seq_amg, AMGf_set);
2121 SETs(boolSV(sv_eq_flags(left, right, 0)));
2129 tryAMAGICbin_MG(sne_amg, AMGf_set);
2132 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2140 tryAMAGICbin_MG(scmp_amg, 0);
2143 const int cmp = (IN_LOCALE_RUNTIME
2144 ? sv_cmp_locale_flags(left, right, 0)
2145 : sv_cmp_flags(left, right, 0));
2153 dVAR; dSP; dATARGET;
2154 tryAMAGICbin_MG(band_amg, AMGf_assign);
2157 if (SvNIOKp(left) || SvNIOKp(right)) {
2158 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2159 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2160 if (PL_op->op_private & HINT_INTEGER) {
2161 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2165 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2168 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2169 if (right_ro_nonnum) SvNIOK_off(right);
2172 do_vop(PL_op->op_type, TARG, left, right);
2181 dVAR; dSP; dATARGET;
2182 const int op_type = PL_op->op_type;
2184 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2187 if (SvNIOKp(left) || SvNIOKp(right)) {
2188 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2189 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2190 if (PL_op->op_private & HINT_INTEGER) {
2191 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2192 const IV r = SvIV_nomg(right);
2193 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2197 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2198 const UV r = SvUV_nomg(right);
2199 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2202 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2203 if (right_ro_nonnum) SvNIOK_off(right);
2206 do_vop(op_type, TARG, left, right);
2213 PERL_STATIC_INLINE bool
2214 S_negate_string(pTHX)
2219 SV * const sv = TOPs;
2220 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2222 s = SvPV_nomg_const(sv, len);
2223 if (isIDFIRST(*s)) {
2224 sv_setpvs(TARG, "-");
2227 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2228 sv_setsv_nomg(TARG, sv);
2229 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2239 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2240 if (S_negate_string(aTHX)) return NORMAL;
2242 SV * const sv = TOPs;
2245 /* It's publicly an integer */
2248 if (SvIVX(sv) == IV_MIN) {
2249 /* 2s complement assumption. */
2250 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2254 else if (SvUVX(sv) <= IV_MAX) {
2259 else if (SvIVX(sv) != IV_MIN) {
2263 #ifdef PERL_PRESERVE_IVUV
2270 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2271 SETn(-SvNV_nomg(sv));
2272 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2273 goto oops_its_an_int;
2275 SETn(-SvNV_nomg(sv));
2283 tryAMAGICun_MG(not_amg, AMGf_set);
2284 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2291 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2295 if (PL_op->op_private & HINT_INTEGER) {
2296 const IV i = ~SvIV_nomg(sv);
2300 const UV u = ~SvUV_nomg(sv);
2309 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2310 sv_setsv_nomg(TARG, sv);
2311 tmps = (U8*)SvPV_force_nomg(TARG, len);
2314 /* Calculate exact length, let's not estimate. */
2319 U8 * const send = tmps + len;
2320 U8 * const origtmps = tmps;
2321 const UV utf8flags = UTF8_ALLOW_ANYUV;
2323 while (tmps < send) {
2324 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2326 targlen += UNISKIP(~c);
2332 /* Now rewind strings and write them. */
2339 Newx(result, targlen + 1, U8);
2341 while (tmps < send) {
2342 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2344 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2347 sv_usepvn_flags(TARG, (char*)result, targlen,
2348 SV_HAS_TRAILING_NUL);
2355 Newx(result, nchar + 1, U8);
2357 while (tmps < send) {
2358 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2363 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2372 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2375 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2380 for ( ; anum > 0; anum--, tmps++)
2388 /* integer versions of some of the above */
2392 dVAR; dSP; dATARGET;
2393 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2396 SETi( left * right );
2404 dVAR; dSP; dATARGET;
2405 tryAMAGICbin_MG(div_amg, AMGf_assign);
2408 IV value = SvIV_nomg(right);
2410 DIE(aTHX_ "Illegal division by zero");
2411 num = SvIV_nomg(left);
2413 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2417 value = num / value;
2423 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2430 /* This is the vanilla old i_modulo. */
2431 dVAR; dSP; dATARGET;
2432 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2436 DIE(aTHX_ "Illegal modulus zero");
2437 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2441 SETi( left % right );
2446 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2451 /* This is the i_modulo with the workaround for the _moddi3 bug
2452 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2453 * See below for pp_i_modulo. */
2454 dVAR; dSP; dATARGET;
2455 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2459 DIE(aTHX_ "Illegal modulus zero");
2460 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2464 SETi( left % PERL_ABS(right) );
2471 dVAR; dSP; dATARGET;
2472 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2476 DIE(aTHX_ "Illegal modulus zero");
2477 /* The assumption is to use hereafter the old vanilla version... */
2479 PL_ppaddr[OP_I_MODULO] =
2481 /* .. but if we have glibc, we might have a buggy _moddi3
2482 * (at least glicb 2.2.5 is known to have this bug), in other
2483 * words our integer modulus with negative quad as the second
2484 * argument might be broken. Test for this and re-patch the
2485 * opcode dispatch table if that is the case, remembering to
2486 * also apply the workaround so that this first round works
2487 * right, too. See [perl #9402] for more information. */
2491 /* Cannot do this check with inlined IV constants since
2492 * that seems to work correctly even with the buggy glibc. */
2494 /* Yikes, we have the bug.
2495 * Patch in the workaround version. */
2497 PL_ppaddr[OP_I_MODULO] =
2498 &Perl_pp_i_modulo_1;
2499 /* Make certain we work right this time, too. */
2500 right = PERL_ABS(right);
2503 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2507 SETi( left % right );
2515 dVAR; dSP; dATARGET;
2516 tryAMAGICbin_MG(add_amg, AMGf_assign);
2518 dPOPTOPiirl_ul_nomg;
2519 SETi( left + right );
2526 dVAR; dSP; dATARGET;
2527 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2529 dPOPTOPiirl_ul_nomg;
2530 SETi( left - right );
2538 tryAMAGICbin_MG(lt_amg, AMGf_set);
2541 SETs(boolSV(left < right));
2549 tryAMAGICbin_MG(gt_amg, AMGf_set);
2552 SETs(boolSV(left > right));
2560 tryAMAGICbin_MG(le_amg, AMGf_set);
2563 SETs(boolSV(left <= right));
2571 tryAMAGICbin_MG(ge_amg, AMGf_set);
2574 SETs(boolSV(left >= right));
2582 tryAMAGICbin_MG(eq_amg, AMGf_set);
2585 SETs(boolSV(left == right));
2593 tryAMAGICbin_MG(ne_amg, AMGf_set);
2596 SETs(boolSV(left != right));
2604 tryAMAGICbin_MG(ncmp_amg, 0);
2611 else if (left < right)
2623 tryAMAGICun_MG(neg_amg, 0);
2624 if (S_negate_string(aTHX)) return NORMAL;
2626 SV * const sv = TOPs;
2627 IV const i = SvIV_nomg(sv);
2633 /* High falutin' math. */
2638 tryAMAGICbin_MG(atan2_amg, 0);
2641 SETn(Perl_atan2(left, right));
2649 int amg_type = sin_amg;
2650 const char *neg_report = NULL;
2651 NV (*func)(NV) = Perl_sin;
2652 const int op_type = PL_op->op_type;
2669 amg_type = sqrt_amg;
2671 neg_report = "sqrt";
2676 tryAMAGICun_MG(amg_type, 0);
2678 SV * const arg = POPs;
2679 const NV value = SvNV_nomg(arg);
2681 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2682 SET_NUMERIC_STANDARD();
2683 /* diag_listed_as: Can't take log of %g */
2684 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2687 XPUSHn(func(value));
2692 /* Support Configure command-line overrides for rand() functions.
2693 After 5.005, perhaps we should replace this by Configure support
2694 for drand48(), random(), or rand(). For 5.005, though, maintain
2695 compatibility by calling rand() but allow the user to override it.
2696 See INSTALL for details. --Andy Dougherty 15 July 1998
2698 /* Now it's after 5.005, and Configure supports drand48() and random(),
2699 in addition to rand(). So the overrides should not be needed any more.
2700 --Jarkko Hietaniemi 27 September 1998
2703 #ifndef HAS_DRAND48_PROTO
2704 extern double drand48 (void);
2710 if (!PL_srand_called) {
2711 (void)seedDrand01((Rand_seed_t)seed());
2712 PL_srand_called = TRUE;
2722 SV * const sv = POPs;
2728 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2736 sv_setnv_mg(TARG, value);
2747 if (MAXARG >= 1 && (TOPs || POPs)) {
2754 pv = SvPV(top, len);
2755 flags = grok_number(pv, len, &anum);
2757 if (!(flags & IS_NUMBER_IN_UV)) {
2758 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2759 "Integer overflow in srand");
2767 (void)seedDrand01((Rand_seed_t)anum);
2768 PL_srand_called = TRUE;
2772 /* Historically srand always returned true. We can avoid breaking
2774 sv_setpvs(TARG, "0 but true");
2783 tryAMAGICun_MG(int_amg, AMGf_numeric);
2785 SV * const sv = TOPs;
2786 const IV iv = SvIV_nomg(sv);
2787 /* XXX it's arguable that compiler casting to IV might be subtly
2788 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2789 else preferring IV has introduced a subtle behaviour change bug. OTOH
2790 relying on floating point to be accurate is a bug. */
2795 else if (SvIOK(sv)) {
2797 SETu(SvUV_nomg(sv));
2802 const NV value = SvNV_nomg(sv);
2804 if (value < (NV)UV_MAX + 0.5) {
2807 SETn(Perl_floor(value));
2811 if (value > (NV)IV_MIN - 0.5) {
2814 SETn(Perl_ceil(value));
2825 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2827 SV * const sv = TOPs;
2828 /* This will cache the NV value if string isn't actually integer */
2829 const IV iv = SvIV_nomg(sv);
2834 else if (SvIOK(sv)) {
2835 /* IVX is precise */
2837 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2845 /* 2s complement assumption. Also, not really needed as
2846 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2852 const NV value = SvNV_nomg(sv);
2866 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2870 SV* const sv = POPs;
2872 tmps = (SvPV_const(sv, len));
2874 /* If Unicode, try to downgrade
2875 * If not possible, croak. */
2876 SV* const tsv = sv_2mortal(newSVsv(sv));
2879 sv_utf8_downgrade(tsv, FALSE);
2880 tmps = SvPV_const(tsv, len);
2882 if (PL_op->op_type == OP_HEX)
2885 while (*tmps && len && isSPACE(*tmps))
2889 if (*tmps == 'x' || *tmps == 'X') {
2891 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2893 else if (*tmps == 'b' || *tmps == 'B')
2894 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2896 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2898 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2912 SV * const sv = TOPs;
2917 SETi(sv_len_utf8_nomg(sv));
2921 (void)SvPV_nomg_const(sv,len);
2925 if (!SvPADTMP(TARG)) {
2926 sv_setsv_nomg(TARG, &PL_sv_undef);
2934 /* Returns false if substring is completely outside original string.
2935 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2936 always be true for an explicit 0.
2939 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2940 bool pos1_is_uv, IV len_iv,
2941 bool len_is_uv, STRLEN *posp,
2947 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2949 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2950 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2953 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2956 if (len_iv || len_is_uv) {
2957 if (!len_is_uv && len_iv < 0) {
2958 pos2_iv = curlen + len_iv;
2960 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2963 } else { /* len_iv >= 0 */
2964 if (!pos1_is_uv && pos1_iv < 0) {
2965 pos2_iv = pos1_iv + len_iv;
2966 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2968 if ((UV)len_iv > curlen-(UV)pos1_iv)
2971 pos2_iv = pos1_iv+len_iv;
2981 if (!pos2_is_uv && pos2_iv < 0) {
2982 if (!pos1_is_uv && pos1_iv < 0)
2986 else if (!pos1_is_uv && pos1_iv < 0)
2989 if ((UV)pos2_iv < (UV)pos1_iv)
2991 if ((UV)pos2_iv > curlen)
2994 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2995 *posp = (STRLEN)( (UV)pos1_iv );
2996 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3013 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3014 const bool rvalue = (GIMME_V != G_VOID);
3017 const char *repl = NULL;
3019 int num_args = PL_op->op_private & 7;
3020 bool repl_need_utf8_upgrade = FALSE;
3024 if(!(repl_sv = POPs)) num_args--;
3026 if ((len_sv = POPs)) {
3027 len_iv = SvIV(len_sv);
3028 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3033 pos1_iv = SvIV(pos_sv);
3034 pos1_is_uv = SvIOK_UV(pos_sv);
3036 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3041 if (lvalue && !repl_sv) {
3043 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3044 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3046 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3048 pos1_is_uv || pos1_iv >= 0
3049 ? (STRLEN)(UV)pos1_iv
3050 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3052 len_is_uv || len_iv > 0
3053 ? (STRLEN)(UV)len_iv
3054 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3057 PUSHs(ret); /* avoid SvSETMAGIC here */
3061 repl = SvPV_const(repl_sv, repl_len);
3064 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3065 "Attempt to use reference as lvalue in substr"
3067 tmps = SvPV_force_nomg(sv, curlen);
3068 if (DO_UTF8(repl_sv) && repl_len) {
3070 sv_utf8_upgrade_nomg(sv);
3074 else if (DO_UTF8(sv))
3075 repl_need_utf8_upgrade = TRUE;
3077 else tmps = SvPV_const(sv, curlen);
3079 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3080 if (utf8_curlen == curlen)
3083 curlen = utf8_curlen;
3089 STRLEN pos, len, byte_len, byte_pos;
3091 if (!translate_substr_offsets(
3092 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3096 byte_pos = utf8_curlen
3097 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3102 SvTAINTED_off(TARG); /* decontaminate */
3103 SvUTF8_off(TARG); /* decontaminate */
3104 sv_setpvn(TARG, tmps, byte_len);
3105 #ifdef USE_LOCALE_COLLATE
3106 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3113 SV* repl_sv_copy = NULL;
3115 if (repl_need_utf8_upgrade) {
3116 repl_sv_copy = newSVsv(repl_sv);
3117 sv_utf8_upgrade(repl_sv_copy);
3118 repl = SvPV_const(repl_sv_copy, repl_len);
3122 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3123 SvREFCNT_dec(repl_sv_copy);
3135 Perl_croak(aTHX_ "substr outside of string");
3136 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3143 const IV size = POPi;
3144 const IV offset = POPi;
3145 SV * const src = POPs;
3146 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3149 if (lvalue) { /* it's an lvalue! */
3150 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3151 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3153 LvTARG(ret) = SvREFCNT_inc_simple(src);
3154 LvTARGOFF(ret) = offset;
3155 LvTARGLEN(ret) = size;
3159 SvTAINTED_off(TARG); /* decontaminate */
3163 sv_setuv(ret, do_vecget(src, offset, size));
3179 const char *little_p;
3182 const bool is_index = PL_op->op_type == OP_INDEX;
3183 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3189 big_p = SvPV_const(big, biglen);
3190 little_p = SvPV_const(little, llen);
3192 big_utf8 = DO_UTF8(big);
3193 little_utf8 = DO_UTF8(little);
3194 if (big_utf8 ^ little_utf8) {
3195 /* One needs to be upgraded. */
3196 if (little_utf8 && !PL_encoding) {
3197 /* Well, maybe instead we might be able to downgrade the small
3199 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3202 /* If the large string is ISO-8859-1, and it's not possible to
3203 convert the small string to ISO-8859-1, then there is no
3204 way that it could be found anywhere by index. */
3209 /* At this point, pv is a malloc()ed string. So donate it to temp
3210 to ensure it will get free()d */
3211 little = temp = newSV(0);
3212 sv_usepvn(temp, pv, llen);
3213 little_p = SvPVX(little);
3216 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3219 sv_recode_to_utf8(temp, PL_encoding);
3221 sv_utf8_upgrade(temp);
3226 big_p = SvPV_const(big, biglen);
3229 little_p = SvPV_const(little, llen);
3233 if (SvGAMAGIC(big)) {
3234 /* Life just becomes a lot easier if I use a temporary here.
3235 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3236 will trigger magic and overloading again, as will fbm_instr()
3238 big = newSVpvn_flags(big_p, biglen,
3239 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3242 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3243 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3244 warn on undef, and we've already triggered a warning with the
3245 SvPV_const some lines above. We can't remove that, as we need to
3246 call some SvPV to trigger overloading early and find out if the
3248 This is all getting to messy. The API isn't quite clean enough,
3249 because data access has side effects.
3251 little = newSVpvn_flags(little_p, llen,
3252 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3253 little_p = SvPVX(little);
3257 offset = is_index ? 0 : biglen;
3259 if (big_utf8 && offset > 0)
3260 sv_pos_u2b(big, &offset, 0);
3266 else if (offset > (I32)biglen)
3268 if (!(little_p = is_index
3269 ? fbm_instr((unsigned char*)big_p + offset,
3270 (unsigned char*)big_p + biglen, little, 0)
3271 : rninstr(big_p, big_p + offset,
3272 little_p, little_p + llen)))
3275 retval = little_p - big_p;
3276 if (retval > 0 && big_utf8)
3277 sv_pos_b2u(big, &retval);
3287 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3288 SvTAINTED_off(TARG);
3289 do_sprintf(TARG, SP-MARK, MARK+1);
3290 TAINT_IF(SvTAINTED(TARG));
3302 const U8 *s = (U8*)SvPV_const(argsv, len);
3304 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3305 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3306 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3310 XPUSHu(DO_UTF8(argsv) ?
3311 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3325 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3326 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3328 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3329 && SvNV_nomg(top) < 0.0))) {
3330 if (ckWARN(WARN_UTF8)) {
3331 if (SvGMAGICAL(top)) {
3332 SV *top2 = sv_newmortal();
3333 sv_setsv_nomg(top2, top);
3336 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3337 "Invalid negative number (%"SVf") in chr", top);
3339 value = UNICODE_REPLACEMENT;
3341 value = SvUV_nomg(top);
3344 SvUPGRADE(TARG,SVt_PV);
3346 if (value > 255 && !IN_BYTES) {
3347 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3348 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3349 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3351 (void)SvPOK_only(TARG);
3360 *tmps++ = (char)value;
3362 (void)SvPOK_only(TARG);
3364 if (PL_encoding && !IN_BYTES) {
3365 sv_recode_to_utf8(TARG, PL_encoding);
3367 if (SvCUR(TARG) == 0
3368 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3369 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3374 *tmps++ = (char)value;
3390 const char *tmps = SvPV_const(left, len);
3392 if (DO_UTF8(left)) {
3393 /* If Unicode, try to downgrade.
3394 * If not possible, croak.
3395 * Yes, we made this up. */
3396 SV* const tsv = sv_2mortal(newSVsv(left));
3399 sv_utf8_downgrade(tsv, FALSE);
3400 tmps = SvPV_const(tsv, len);
3402 # ifdef USE_ITHREADS
3404 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3405 /* This should be threadsafe because in ithreads there is only
3406 * one thread per interpreter. If this would not be true,
3407 * we would need a mutex to protect this malloc. */
3408 PL_reentrant_buffer->_crypt_struct_buffer =
3409 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3410 #if defined(__GLIBC__) || defined(__EMX__)
3411 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3412 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3413 /* work around glibc-2.2.5 bug */
3414 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3418 # endif /* HAS_CRYPT_R */
3419 # endif /* USE_ITHREADS */
3421 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3423 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3429 "The crypt() function is unimplemented due to excessive paranoia.");
3433 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3434 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3438 /* Actually is both lcfirst() and ucfirst(). Only the first character
3439 * changes. This means that possibly we can change in-place, ie., just
3440 * take the source and change that one character and store it back, but not
3441 * if read-only etc, or if the length changes */
3446 STRLEN slen; /* slen is the byte length of the whole SV. */
3449 bool inplace; /* ? Convert first char only, in-place */
3450 bool doing_utf8 = FALSE; /* ? using utf8 */
3451 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3452 const int op_type = PL_op->op_type;
3455 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3456 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3457 * stored as UTF-8 at s. */
3458 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3459 * lowercased) character stored in tmpbuf. May be either
3460 * UTF-8 or not, but in either case is the number of bytes */
3461 bool tainted = FALSE;
3465 s = (const U8*)SvPV_nomg_const(source, slen);
3467 if (ckWARN(WARN_UNINITIALIZED))
3468 report_uninit(source);
3473 /* We may be able to get away with changing only the first character, in
3474 * place, but not if read-only, etc. Later we may discover more reasons to
3475 * not convert in-place. */
3476 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3478 /* First calculate what the changed first character should be. This affects
3479 * whether we can just swap it out, leaving the rest of the string unchanged,
3480 * or even if have to convert the dest to UTF-8 when the source isn't */
3482 if (! slen) { /* If empty */
3483 need = 1; /* still need a trailing NUL */
3486 else if (DO_UTF8(source)) { /* Is the source utf8? */
3489 if (op_type == OP_UCFIRST) {
3490 _to_utf8_title_flags(s, tmpbuf, &tculen,
3491 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3494 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3495 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3498 /* we can't do in-place if the length changes. */
3499 if (ulen != tculen) inplace = FALSE;
3500 need = slen + 1 - ulen + tculen;
3502 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3503 * latin1 is treated as caseless. Note that a locale takes
3505 ulen = 1; /* Original character is 1 byte */
3506 tculen = 1; /* Most characters will require one byte, but this will
3507 * need to be overridden for the tricky ones */
3510 if (op_type == OP_LCFIRST) {
3512 /* lower case the first letter: no trickiness for any character */
3513 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3514 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3517 else if (IN_LOCALE_RUNTIME) {
3518 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3519 * have upper and title case different
3522 else if (! IN_UNI_8_BIT) {
3523 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3524 * on EBCDIC machines whatever the
3525 * native function does */
3527 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3528 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3530 assert(tculen == 2);
3532 /* If the result is an upper Latin1-range character, it can
3533 * still be represented in one byte, which is its ordinal */
3534 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3535 *tmpbuf = (U8) title_ord;
3539 /* Otherwise it became more than one ASCII character (in
3540 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3541 * beyond Latin1, so the number of bytes changed, so can't
3542 * replace just the first character in place. */
3545 /* If the result won't fit in a byte, the entire result
3546 * will have to be in UTF-8. Assume worst case sizing in
3547 * conversion. (all latin1 characters occupy at most two
3549 if (title_ord > 255) {
3551 convert_source_to_utf8 = TRUE;
3552 need = slen * 2 + 1;
3554 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3555 * (both) characters whose title case is above 255 is
3559 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3560 need = slen + 1 + 1;
3564 } /* End of use Unicode (Latin1) semantics */
3565 } /* End of changing the case of the first character */
3567 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3568 * generate the result */
3571 /* We can convert in place. This means we change just the first
3572 * character without disturbing the rest; no need to grow */
3574 s = d = (U8*)SvPV_force_nomg(source, slen);
3580 /* Here, we can't convert in place; we earlier calculated how much
3581 * space we will need, so grow to accommodate that */
3582 SvUPGRADE(dest, SVt_PV);
3583 d = (U8*)SvGROW(dest, need);
3584 (void)SvPOK_only(dest);
3591 if (! convert_source_to_utf8) {
3593 /* Here both source and dest are in UTF-8, but have to create
3594 * the entire output. We initialize the result to be the
3595 * title/lower cased first character, and then append the rest
3597 sv_setpvn(dest, (char*)tmpbuf, tculen);
3599 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3603 const U8 *const send = s + slen;
3605 /* Here the dest needs to be in UTF-8, but the source isn't,
3606 * except we earlier UTF-8'd the first character of the source
3607 * into tmpbuf. First put that into dest, and then append the
3608 * rest of the source, converting it to UTF-8 as we go. */
3610 /* Assert tculen is 2 here because the only two characters that
3611 * get to this part of the code have 2-byte UTF-8 equivalents */
3613 *d++ = *(tmpbuf + 1);
3614 s++; /* We have just processed the 1st char */
3616 for (; s < send; s++) {
3617 d = uvchr_to_utf8(d, *s);
3620 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3624 else { /* in-place UTF-8. Just overwrite the first character */
3625 Copy(tmpbuf, d, tculen, U8);
3626 SvCUR_set(dest, need - 1);
3634 else { /* Neither source nor dest are in or need to be UTF-8 */
3636 if (IN_LOCALE_RUNTIME) {
3640 if (inplace) { /* in-place, only need to change the 1st char */
3643 else { /* Not in-place */
3645 /* Copy the case-changed character(s) from tmpbuf */
3646 Copy(tmpbuf, d, tculen, U8);
3647 d += tculen - 1; /* Code below expects d to point to final
3648 * character stored */
3651 else { /* empty source */
3652 /* See bug #39028: Don't taint if empty */
3656 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3657 * the destination to retain that flag */
3661 if (!inplace) { /* Finish the rest of the string, unchanged */
3662 /* This will copy the trailing NUL */
3663 Copy(s + 1, d + 1, slen, U8);
3664 SvCUR_set(dest, need - 1);
3667 if (dest != source && SvTAINTED(source))
3673 /* There's so much setup/teardown code common between uc and lc, I wonder if
3674 it would be worth merging the two, and just having a switch outside each
3675 of the three tight loops. There is less and less commonality though */
3689 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3690 && SvTEMP(source) && !DO_UTF8(source)
3691 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3693 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3694 * make the loop tight, so we overwrite the source with the dest before
3695 * looking at it, and we need to look at the original source
3696 * afterwards. There would also need to be code added to handle
3697 * switching to not in-place in midstream if we run into characters
3698 * that change the length.
3701 s = d = (U8*)SvPV_force_nomg(source, len);
3708 /* The old implementation would copy source into TARG at this point.
3709 This had the side effect that if source was undef, TARG was now
3710 an undefined SV with PADTMP set, and they don't warn inside
3711 sv_2pv_flags(). However, we're now getting the PV direct from
3712 source, which doesn't have PADTMP set, so it would warn. Hence the
3716 s = (const U8*)SvPV_nomg_const(source, len);
3718 if (ckWARN(WARN_UNINITIALIZED))
3719 report_uninit(source);
3725 SvUPGRADE(dest, SVt_PV);
3726 d = (U8*)SvGROW(dest, min);
3727 (void)SvPOK_only(dest);
3732 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3733 to check DO_UTF8 again here. */
3735 if (DO_UTF8(source)) {
3736 const U8 *const send = s + len;
3737 U8 tmpbuf[UTF8_MAXBYTES+1];
3738 bool tainted = FALSE;
3740 /* All occurrences of these are to be moved to follow any other marks.
3741 * This is context-dependent. We may not be passed enough context to
3742 * move the iota subscript beyond all of them, but we do the best we can
3743 * with what we're given. The result is always better than if we
3744 * hadn't done this. And, the problem would only arise if we are
3745 * passed a character without all its combining marks, which would be
3746 * the caller's mistake. The information this is based on comes from a
3747 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3748 * itself) and so can't be checked properly to see if it ever gets
3749 * revised. But the likelihood of it changing is remote */
3750 bool in_iota_subscript = FALSE;
3756 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3758 /* A non-mark. Time to output the iota subscript */
3759 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3760 d += capital_iota_len;
3761 in_iota_subscript = FALSE;
3764 /* Then handle the current character. Get the changed case value
3765 * and copy it to the output buffer */
3768 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3769 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3770 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3771 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3772 if (uv == GREEK_CAPITAL_LETTER_IOTA
3773 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3775 in_iota_subscript = TRUE;
3778 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3779 /* If the eventually required minimum size outgrows the
3780 * available space, we need to grow. */
3781 const UV o = d - (U8*)SvPVX_const(dest);
3783 /* If someone uppercases one million U+03B0s we SvGROW()
3784 * one million times. Or we could try guessing how much to
3785 * allocate without allocating too much. Such is life.
3786 * See corresponding comment in lc code for another option
3789 d = (U8*)SvPVX(dest) + o;
3791 Copy(tmpbuf, d, ulen, U8);
3796 if (in_iota_subscript) {
3797 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3798 d += capital_iota_len;
3803 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3809 else { /* Not UTF-8 */
3811 const U8 *const send = s + len;
3813 /* Use locale casing if in locale; regular style if not treating
3814 * latin1 as having case; otherwise the latin1 casing. Do the
3815 * whole thing in a tight loop, for speed, */
3816 if (IN_LOCALE_RUNTIME) {
3819 for (; s < send; d++, s++)
3820 *d = toUPPER_LC(*s);
3822 else if (! IN_UNI_8_BIT) {
3823 for (; s < send; d++, s++) {
3828 for (; s < send; d++, s++) {
3829 *d = toUPPER_LATIN1_MOD(*s);
3830 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3834 /* The mainstream case is the tight loop above. To avoid
3835 * extra tests in that, all three characters that require
3836 * special handling are mapped by the MOD to the one tested
3838 * Use the source to distinguish between the three cases */
3840 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3842 /* uc() of this requires 2 characters, but they are
3843 * ASCII. If not enough room, grow the string */
3844 if (SvLEN(dest) < ++min) {
3845 const UV o = d - (U8*)SvPVX_const(dest);
3847 d = (U8*)SvPVX(dest) + o;
3849 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3850 continue; /* Back to the tight loop; still in ASCII */
3853 /* The other two special handling characters have their
3854 * upper cases outside the latin1 range, hence need to be
3855 * in UTF-8, so the whole result needs to be in UTF-8. So,
3856 * here we are somewhere in the middle of processing a
3857 * non-UTF-8 string, and realize that we will have to convert
3858 * the whole thing to UTF-8. What to do? There are
3859 * several possibilities. The simplest to code is to
3860 * convert what we have so far, set a flag, and continue on
3861 * in the loop. The flag would be tested each time through
3862 * the loop, and if set, the next character would be
3863 * converted to UTF-8 and stored. But, I (khw) didn't want
3864 * to slow down the mainstream case at all for this fairly
3865 * rare case, so I didn't want to add a test that didn't
3866 * absolutely have to be there in the loop, besides the
3867 * possibility that it would get too complicated for
3868 * optimizers to deal with. Another possibility is to just
3869 * give up, convert the source to UTF-8, and restart the
3870 * function that way. Another possibility is to convert
3871 * both what has already been processed and what is yet to
3872 * come separately to UTF-8, then jump into the loop that
3873 * handles UTF-8. But the most efficient time-wise of the
3874 * ones I could think of is what follows, and turned out to
3875 * not require much extra code. */
3877 /* Convert what we have so far into UTF-8, telling the
3878 * function that we know it should be converted, and to
3879 * allow extra space for what we haven't processed yet.
3880 * Assume the worst case space requirements for converting
3881 * what we haven't processed so far: that it will require
3882 * two bytes for each remaining source character, plus the
3883 * NUL at the end. This may cause the string pointer to
3884 * move, so re-find it. */
3886 len = d - (U8*)SvPVX_const(dest);
3887 SvCUR_set(dest, len);
3888 len = sv_utf8_upgrade_flags_grow(dest,
3889 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3891 d = (U8*)SvPVX(dest) + len;
3893 /* Now process the remainder of the source, converting to
3894 * upper and UTF-8. If a resulting byte is invariant in
3895 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3896 * append it to the output. */
3897 for (; s < send; s++) {
3898 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3902 /* Here have processed the whole source; no need to continue
3903 * with the outer loop. Each character has been converted
3904 * to upper case and converted to UTF-8 */
3907 } /* End of processing all latin1-style chars */
3908 } /* End of processing all chars */
3909 } /* End of source is not empty */
3911 if (source != dest) {
3912 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3913 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3915 } /* End of isn't utf8 */
3916 if (dest != source && SvTAINTED(source))
3935 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3936 && SvTEMP(source) && !DO_UTF8(source)) {
3938 /* We can convert in place, as lowercasing anything in the latin1 range
3939 * (or else DO_UTF8 would have been on) doesn't lengthen it */
3941 s = d = (U8*)SvPV_force_nomg(source, len);
3948 /* The old implementation would copy source into TARG at this point.
3949 This had the side effect that if source was undef, TARG was now
3950 an undefined SV with PADTMP set, and they don't warn inside
3951 sv_2pv_flags(). However, we're now getting the PV direct from
3952 source, which doesn't have PADTMP set, so it would warn. Hence the
3956 s = (const U8*)SvPV_nomg_const(source, len);
3958 if (ckWARN(WARN_UNINITIALIZED))
3959 report_uninit(source);
3965 SvUPGRADE(dest, SVt_PV);
3966 d = (U8*)SvGROW(dest, min);
3967 (void)SvPOK_only(dest);
3972 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3973 to check DO_UTF8 again here. */
3975 if (DO_UTF8(source)) {
3976 const U8 *const send = s + len;
3977 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3978 bool tainted = FALSE;
3981 const STRLEN u = UTF8SKIP(s);
3984 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3985 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3987 /* Here is where we would do context-sensitive actions. See the
3988 * commit message for this comment for why there isn't any */
3990 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3992 /* If the eventually required minimum size outgrows the
3993 * available space, we need to grow. */
3994 const UV o = d - (U8*)SvPVX_const(dest);
3996 /* If someone lowercases one million U+0130s we SvGROW() one
3997 * million times. Or we could try guessing how much to
3998 * allocate without allocating too much. Such is life.
3999 * Another option would be to grow an extra byte or two more
4000 * each time we need to grow, which would cut down the million
4001 * to 500K, with little waste */
4003 d = (U8*)SvPVX(dest) + o;
4006 /* Copy the newly lowercased letter to the output buffer we're
4008 Copy(tmpbuf, d, ulen, U8);
4011 } /* End of looping through the source string */
4014 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4019 } else { /* Not utf8 */
4021 const U8 *const send = s + len;
4023 /* Use locale casing if in locale; regular style if not treating
4024 * latin1 as having case; otherwise the latin1 casing. Do the
4025 * whole thing in a tight loop, for speed, */
4026 if (IN_LOCALE_RUNTIME) {
4029 for (; s < send; d++, s++)
4030 *d = toLOWER_LC(*s);
4032 else if (! IN_UNI_8_BIT) {
4033 for (; s < send; d++, s++) {
4038 for (; s < send; d++, s++) {
4039 *d = toLOWER_LATIN1(*s);
4043 if (source != dest) {
4045 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4048 if (dest != source && SvTAINTED(source))
4057 SV * const sv = TOPs;
4059 const char *s = SvPV_const(sv,len);
4061 SvUTF8_off(TARG); /* decontaminate */
4064 SvUPGRADE(TARG, SVt_PV);
4065 SvGROW(TARG, (len * 2) + 1);
4069 STRLEN ulen = UTF8SKIP(s);
4070 bool to_quote = FALSE;
4072 if (UTF8_IS_INVARIANT(*s)) {
4073 if (_isQUOTEMETA(*s)) {
4077 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4079 /* In locale, we quote all non-ASCII Latin1 chars.
4080 * Otherwise use the quoting rules */
4081 if (IN_LOCALE_RUNTIME
4082 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
4087 else if (is_QUOTEMETA_high(s)) {
4102 else if (IN_UNI_8_BIT) {
4104 if (_isQUOTEMETA(*s))
4110 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4111 * including everything above ASCII */
4113 if (!isWORDCHAR_A(*s))
4119 SvCUR_set(TARG, d - SvPVX_const(TARG));
4120 (void)SvPOK_only_UTF8(TARG);
4123 sv_setpvn(TARG, s, len);
4140 U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
4141 const bool full_folding = TRUE;
4142 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4143 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4145 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4146 * You are welcome(?) -Hugmeir
4154 s = (const U8*)SvPV_nomg_const(source, len);
4156 if (ckWARN(WARN_UNINITIALIZED))
4157 report_uninit(source);
4164 SvUPGRADE(dest, SVt_PV);
4165 d = (U8*)SvGROW(dest, min);
4166 (void)SvPOK_only(dest);
4171 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4172 bool tainted = FALSE;
4174 const STRLEN u = UTF8SKIP(s);
4177 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4179 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4180 const UV o = d - (U8*)SvPVX_const(dest);
4182 d = (U8*)SvPVX(dest) + o;
4185 Copy(tmpbuf, d, ulen, U8);
4194 } /* Unflagged string */
4196 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4199 for (; s < send; d++, s++)
4202 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4203 for (; s < send; d++, s++)
4207 /* For ASCII and the Latin-1 range, there's only two troublesome
4208 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4209 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4210 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4211 * For the rest, the casefold is their lowercase. */
4212 for (; s < send; d++, s++) {
4213 if (*s == MICRO_SIGN) {
4214 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4215 * which is outside of the latin-1 range. There's a couple
4216 * of ways to deal with this -- khw discusses them in
4217 * pp_lc/uc, so go there :) What we do here is upgrade what
4218 * we had already casefolded, then enter an inner loop that
4219 * appends the rest of the characters as UTF-8. */
4220 len = d - (U8*)SvPVX_const(dest);
4221 SvCUR_set(dest, len);
4222 len = sv_utf8_upgrade_flags_grow(dest,
4223 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4224 /* The max expansion for latin1
4225 * chars is 1 byte becomes 2 */
4227 d = (U8*)SvPVX(dest) + len;
4229 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4232 for (; s < send; s++) {
4234 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4235 if UNI_IS_INVARIANT(fc) {
4237 && *s == LATIN_SMALL_LETTER_SHARP_S)
4246 Copy(tmpbuf, d, ulen, U8);
4252 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4253 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4254 * becomes "ss", which may require growing the SV. */
4255 if (SvLEN(dest) < ++min) {
4256 const UV o = d - (U8*)SvPVX_const(dest);
4258 d = (U8*)SvPVX(dest) + o;
4263 else { /* If it's not one of those two, the fold is their lower
4265 *d = toLOWER_LATIN1(*s);
4271 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4273 if (SvTAINTED(source))
4283 dVAR; dSP; dMARK; dORIGMARK;
4284 AV *const av = MUTABLE_AV(POPs);
4285 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4287 if (SvTYPE(av) == SVt_PVAV) {
4288 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4289 bool can_preserve = FALSE;
4295 can_preserve = SvCANEXISTDELETE(av);
4298 if (lval && localizing) {
4301 for (svp = MARK + 1; svp <= SP; svp++) {
4302 const I32 elem = SvIV(*svp);
4306 if (max > AvMAX(av))
4310 while (++MARK <= SP) {
4312 I32 elem = SvIV(*MARK);
4313 bool preeminent = TRUE;
4315 if (localizing && can_preserve) {
4316 /* If we can determine whether the element exist,
4317 * Try to preserve the existenceness of a tied array
4318 * element by using EXISTS and DELETE if possible.
4319 * Fallback to FETCH and STORE otherwise. */
4320 preeminent = av_exists(av, elem);
4323 svp = av_fetch(av, elem, lval);
4325 if (!svp || *svp == &PL_sv_undef)
4326 DIE(aTHX_ PL_no_aelem, elem);
4329 save_aelem(av, elem, svp);
4331 SAVEADELETE(av, elem);
4334 *MARK = svp ? *svp : &PL_sv_undef;
4337 if (GIMME != G_ARRAY) {
4339 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4345 /* Smart dereferencing for keys, values and each */
4357 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4362 "Type of argument to %s must be unblessed hashref or arrayref",
4363 PL_op_desc[PL_op->op_type] );
4366 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4368 "Can't modify %s in %s",
4369 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4372 /* Delegate to correct function for op type */
4374 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4375 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4378 return (SvTYPE(sv) == SVt_PVHV)
4379 ? Perl_pp_each(aTHX)
4380 : Perl_pp_aeach(aTHX);
4388 AV *array = MUTABLE_AV(POPs);
4389 const I32 gimme = GIMME_V;
4390 IV *iterp = Perl_av_iter_p(aTHX_ array);
4391 const IV current = (*iterp)++;
4393 if (current > av_len(array)) {
4395 if (gimme == G_SCALAR)
4403 if (gimme == G_ARRAY) {
4404 SV **const element = av_fetch(array, current, 0);
4405 PUSHs(element ? *element : &PL_sv_undef);
4414 AV *array = MUTABLE_AV(POPs);
4415 const I32 gimme = GIMME_V;
4417 *Perl_av_iter_p(aTHX_ array) = 0;
4419 if (gimme == G_SCALAR) {
4421 PUSHi(av_len(array) + 1);
4423 else if (gimme == G_ARRAY) {
4424 IV n = Perl_av_len(aTHX_ array);
4429 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4430 for (i = 0; i <= n; i++) {
4435 for (i = 0; i <= n; i++) {
4436 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4437 PUSHs(elem ? *elem : &PL_sv_undef);
4444 /* Associative arrays. */
4450 HV * hash = MUTABLE_HV(POPs);
4452 const I32 gimme = GIMME_V;
4455 /* might clobber stack_sp */
4456 entry = hv_iternext(hash);
4461 SV* const sv = hv_iterkeysv(entry);
4462 PUSHs(sv); /* won't clobber stack_sp */
4463 if (gimme == G_ARRAY) {
4466 /* might clobber stack_sp */
4467 val = hv_iterval(hash, entry);
4472 else if (gimme == G_SCALAR)
4479 S_do_delete_local(pTHX)
4483 const I32 gimme = GIMME_V;
4486 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4487 SV *unsliced_keysv = sliced ? NULL : POPs;
4488 SV * const osv = POPs;
4489 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4491 const bool tied = SvRMAGICAL(osv)
4492 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4493 const bool can_preserve = SvCANEXISTDELETE(osv);
4494 const U32 type = SvTYPE(osv);
4495 SV ** const end = sliced ? SP : &unsliced_keysv;
4497 if (type == SVt_PVHV) { /* hash element */
4498 HV * const hv = MUTABLE_HV(osv);
4499 while (++MARK <= end) {
4500 SV * const keysv = *MARK;
4502 bool preeminent = TRUE;
4504 preeminent = hv_exists_ent(hv, keysv, 0);
4506 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4513 sv = hv_delete_ent(hv, keysv, 0, 0);
4514 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4517 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4518 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4520 *MARK = sv_mortalcopy(sv);
4526 SAVEHDELETE(hv, keysv);
4527 *MARK = &PL_sv_undef;
4531 else if (type == SVt_PVAV) { /* array element */
4532 if (PL_op->op_flags & OPf_SPECIAL) {
4533 AV * const av = MUTABLE_AV(osv);
4534 while (++MARK <= end) {
4535 I32 idx = SvIV(*MARK);
4537 bool preeminent = TRUE;
4539 preeminent = av_exists(av, idx);
4541 SV **svp = av_fetch(av, idx, 1);
4548 sv = av_delete(av, idx, 0);
4549 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4552 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4554 *MARK = sv_mortalcopy(sv);
4560 SAVEADELETE(av, idx);
4561 *MARK = &PL_sv_undef;
4566 DIE(aTHX_ "panic: avhv_delete no longer supported");
4569 DIE(aTHX_ "Not a HASH reference");
4571 if (gimme == G_VOID)
4573 else if (gimme == G_SCALAR) {
4578 *++MARK = &PL_sv_undef;
4582 else if (gimme != G_VOID)
4583 PUSHs(unsliced_keysv);
4595 if (PL_op->op_private & OPpLVAL_INTRO)
4596 return do_delete_local();
4599 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4601 if (PL_op->op_private & OPpSLICE) {
4603 HV * const hv = MUTABLE_HV(POPs);
4604 const U32 hvtype = SvTYPE(hv);
4605 if (hvtype == SVt_PVHV) { /* hash element */
4606 while (++MARK <= SP) {
4607 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4608 *MARK = sv ? sv : &PL_sv_undef;
4611 else if (hvtype == SVt_PVAV) { /* array element */
4612 if (PL_op->op_flags & OPf_SPECIAL) {
4613 while (++MARK <= SP) {
4614 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4615 *MARK = sv ? sv : &PL_sv_undef;
4620 DIE(aTHX_ "Not a HASH reference");
4623 else if (gimme == G_SCALAR) {
4628 *++MARK = &PL_sv_undef;
4634 HV * const hv = MUTABLE_HV(POPs);
4636 if (SvTYPE(hv) == SVt_PVHV)
4637 sv = hv_delete_ent(hv, keysv, discard, 0);
4638 else if (SvTYPE(hv) == SVt_PVAV) {
4639 if (PL_op->op_flags & OPf_SPECIAL)
4640 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4642 DIE(aTHX_ "panic: avhv_delete no longer supported");
4645 DIE(aTHX_ "Not a HASH reference");
4661 if (PL_op->op_private & OPpEXISTS_SUB) {
4663 SV * const sv = POPs;
4664 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4667 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4672 hv = MUTABLE_HV(POPs);
4673 if (SvTYPE(hv) == SVt_PVHV) {
4674 if (hv_exists_ent(hv, tmpsv, 0))
4677 else if (SvTYPE(hv) == SVt_PVAV) {
4678 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4679 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4684 DIE(aTHX_ "Not a HASH reference");
4691 dVAR; dSP; dMARK; dORIGMARK;
4692 HV * const hv = MUTABLE_HV(POPs);
4693 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4694 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4695 bool can_preserve = FALSE;
4701 if (SvCANEXISTDELETE(hv))
4702 can_preserve = TRUE;
4705 while (++MARK <= SP) {
4706 SV * const keysv = *MARK;
4709 bool preeminent = TRUE;
4711 if (localizing && can_preserve) {
4712 /* If we can determine whether the element exist,
4713 * try to preserve the existenceness of a tied hash
4714 * element by using EXISTS and DELETE if possible.
4715 * Fallback to FETCH and STORE otherwise. */
4716 preeminent = hv_exists_ent(hv, keysv, 0);
4719 he = hv_fetch_ent(hv, keysv, lval, 0);
4720 svp = he ? &HeVAL(he) : NULL;
4723 if (!svp || !*svp || *svp == &PL_sv_undef) {
4724 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4727 if (HvNAME_get(hv) && isGV(*svp))
4728 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4729 else if (preeminent)
4730 save_helem_flags(hv, keysv, svp,
4731 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4733 SAVEHDELETE(hv, keysv);
4736 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4738 if (GIMME != G_ARRAY) {
4740 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4746 /* List operators. */
4751 if (GIMME != G_ARRAY) {
4753 *MARK = *SP; /* unwanted list, return last item */
4755 *MARK = &PL_sv_undef;
4765 SV ** const lastrelem = PL_stack_sp;
4766 SV ** const lastlelem = PL_stack_base + POPMARK;
4767 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4768 SV ** const firstrelem = lastlelem + 1;
4769 I32 is_something_there = FALSE;
4771 const I32 max = lastrelem - lastlelem;
4774 if (GIMME != G_ARRAY) {
4775 I32 ix = SvIV(*lastlelem);
4778 if (ix < 0 || ix >= max)
4779 *firstlelem = &PL_sv_undef;
4781 *firstlelem = firstrelem[ix];
4787 SP = firstlelem - 1;
4791 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4792 I32 ix = SvIV(*lelem);
4795 if (ix < 0 || ix >= max)
4796 *lelem = &PL_sv_undef;
4798 is_something_there = TRUE;
4799 if (!(*lelem = firstrelem[ix]))
4800 *lelem = &PL_sv_undef;
4803 if (is_something_there)
4806 SP = firstlelem - 1;
4812 dVAR; dSP; dMARK; dORIGMARK;
4813 const I32 items = SP - MARK;
4814 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4815 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4816 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4817 ? newRV_noinc(av) : av);
4823 dVAR; dSP; dMARK; dORIGMARK;
4824 HV* const hv = (HV *)sv_2mortal((SV *)newHV());
4828 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4835 sv_setsv(val, *MARK);
4839 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4842 (void)hv_store_ent(hv,key,val,0);
4845 if (PL_op->op_flags & OPf_SPECIAL)
4846 mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
4847 else XPUSHs(MUTABLE_SV(hv));
4852 S_deref_plain_array(pTHX_ AV *ary)
4854 if (SvTYPE(ary) == SVt_PVAV) return ary;
4855 SvGETMAGIC((SV *)ary);
4856 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4857 Perl_die(aTHX_ "Not an ARRAY reference");
4858 else if (SvOBJECT(SvRV(ary)))
4859 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4860 return (AV *)SvRV(ary);
4863 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4864 # define DEREF_PLAIN_ARRAY(ary) \
4867 SvTYPE(aRrRay) == SVt_PVAV \
4869 : S_deref_plain_array(aTHX_ aRrRay); \
4872 # define DEREF_PLAIN_ARRAY(ary) \
4874 PL_Sv = (SV *)(ary), \
4875 SvTYPE(PL_Sv) == SVt_PVAV \
4877 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4883 dVAR; dSP; dMARK; dORIGMARK;
4884 int num_args = (SP - MARK);
4885 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4894 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4897 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4898 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4905 offset = i = SvIV(*MARK);
4907 offset += AvFILLp(ary) + 1;
4909 DIE(aTHX_ PL_no_aelem, i);
4911 length = SvIVx(*MARK++);
4913 length += AvFILLp(ary) - offset + 1;
4919 length = AvMAX(ary) + 1; /* close enough to infinity */
4923 length = AvMAX(ary) + 1;
4925 if (offset > AvFILLp(ary) + 1) {
4927 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4928 offset = AvFILLp(ary) + 1;
4930 after = AvFILLp(ary) + 1 - (offset + length);
4931 if (after < 0) { /* not that much array */
4932 length += after; /* offset+length now in array */
4938 /* At this point, MARK .. SP-1 is our new LIST */
4941 diff = newlen - length;
4942 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4945 /* make new elements SVs now: avoid problems if they're from the array */
4946 for (dst = MARK, i = newlen; i; i--) {
4947 SV * const h = *dst;
4948 *dst++ = newSVsv(h);
4951 if (diff < 0) { /* shrinking the area */
4952 SV **tmparyval = NULL;
4954 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4955 Copy(MARK, tmparyval, newlen, SV*);
4958 MARK = ORIGMARK + 1;
4959 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4960 MEXTEND(MARK, length);
4961 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4963 EXTEND_MORTAL(length);
4964 for (i = length, dst = MARK; i; i--) {
4965 sv_2mortal(*dst); /* free them eventually */
4972 *MARK = AvARRAY(ary)[offset+length-1];
4975 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4976 SvREFCNT_dec(*dst++); /* free them now */
4979 AvFILLp(ary) += diff;
4981 /* pull up or down? */
4983 if (offset < after) { /* easier to pull up */
4984 if (offset) { /* esp. if nothing to pull */
4985 src = &AvARRAY(ary)[offset-1];
4986 dst = src - diff; /* diff is negative */
4987 for (i = offset; i > 0; i--) /* can't trust Copy */
4991 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4995 if (after) { /* anything to pull down? */
4996 src = AvARRAY(ary) + offset + length;
4997 dst = src + diff; /* diff is negative */
4998 Move(src, dst, after, SV*);
5000 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5001 /* avoid later double free */
5005 dst[--i] = &PL_sv_undef;
5008 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5009 Safefree(tmparyval);
5012 else { /* no, expanding (or same) */
5013 SV** tmparyval = NULL;
5015 Newx(tmparyval, length, SV*); /* so remember deletion */
5016 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5019 if (diff > 0) { /* expanding */
5020 /* push up or down? */
5021 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5025 Move(src, dst, offset, SV*);
5027 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5029 AvFILLp(ary) += diff;
5032 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5033 av_extend(ary, AvFILLp(ary) + diff);
5034 AvFILLp(ary) += diff;
5037 dst = AvARRAY(ary) + AvFILLp(ary);
5039 for (i = after; i; i--) {
5047 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5050 MARK = ORIGMARK + 1;
5051 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5053 Copy(tmparyval, MARK, length, SV*);
5055 EXTEND_MORTAL(length);
5056 for (i = length, dst = MARK; i; i--) {
5057 sv_2mortal(*dst); /* free them eventually */
5064 else if (length--) {
5065 *MARK = tmparyval[length];
5068 while (length-- > 0)
5069 SvREFCNT_dec(tmparyval[length]);
5073 *MARK = &PL_sv_undef;
5074 Safefree(tmparyval);
5078 mg_set(MUTABLE_SV(ary));
5086 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5087 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5088 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5091 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5094 ENTER_with_name("call_PUSH");
5095 call_method("PUSH",G_SCALAR|G_DISCARD);
5096 LEAVE_with_name("call_PUSH");
5100 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5101 PL_delaymagic = DM_DELAY;
5102 for (++MARK; MARK <= SP; MARK++) {
5104 if (*MARK) SvGETMAGIC(*MARK);
5107 sv_setsv_nomg(sv, *MARK);
5108 av_store(ary, AvFILLp(ary)+1, sv);
5110 if (PL_delaymagic & DM_ARRAY_ISA)
5111 mg_set(MUTABLE_SV(ary));
5116 if (OP_GIMME(PL_op, 0) != G_VOID) {
5117 PUSHi( AvFILL(ary) + 1 );
5126 AV * const av = PL_op->op_flags & OPf_SPECIAL
5127 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5128 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5132 (void)sv_2mortal(sv);
5139 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5140 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5141 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5144 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5147 ENTER_with_name("call_UNSHIFT");
5148 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5149 LEAVE_with_name("call_UNSHIFT");
5154 av_unshift(ary, SP - MARK);
5156 SV * const sv = newSVsv(*++MARK);
5157 (void)av_store(ary, i++, sv);
5161 if (OP_GIMME(PL_op, 0) != G_VOID) {
5162 PUSHi( AvFILL(ary) + 1 );
5171 if (GIMME == G_ARRAY) {
5172 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5176 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5177 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5178 av = MUTABLE_AV((*SP));
5179 /* In-place reversing only happens in void context for the array
5180 * assignment. We don't need to push anything on the stack. */
5183 if (SvMAGICAL(av)) {
5185 SV *tmp = sv_newmortal();
5186 /* For SvCANEXISTDELETE */
5189 bool can_preserve = SvCANEXISTDELETE(av);
5191 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5195 if (!av_exists(av, i)) {
5196 if (av_exists(av, j)) {
5197 SV *sv = av_delete(av, j, 0);
5198 begin = *av_fetch(av, i, TRUE);
5199 sv_setsv_mg(begin, sv);
5203 else if (!av_exists(av, j)) {
5204 SV *sv = av_delete(av, i, 0);
5205 end = *av_fetch(av, j, TRUE);
5206 sv_setsv_mg(end, sv);
5211 begin = *av_fetch(av, i, TRUE);
5212 end = *av_fetch(av, j, TRUE);
5213 sv_setsv(tmp, begin);
5214 sv_setsv_mg(begin, end);
5215 sv_setsv_mg(end, tmp);
5219 SV **begin = AvARRAY(av);
5222 SV **end = begin + AvFILLp(av);
5224 while (begin < end) {
5225 SV * const tmp = *begin;
5236 SV * const tmp = *MARK;
5240 /* safe as long as stack cannot get extended in the above */
5251 SvUTF8_off(TARG); /* decontaminate */
5253 do_join(TARG, &PL_sv_no, MARK, SP);
5255 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5256 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5257 report_uninit(TARG);
5260 up = SvPV_force(TARG, len);
5262 if (DO_UTF8(TARG)) { /* first reverse each character */
5263 U8* s = (U8*)SvPVX(TARG);
5264 const U8* send = (U8*)(s + len);
5266 if (UTF8_IS_INVARIANT(*s)) {
5271 if (!utf8_to_uvchr_buf(s, send, 0))
5275 down = (char*)(s - 1);
5276 /* reverse this character */
5280 *down-- = (char)tmp;
5286 down = SvPVX(TARG) + len - 1;
5290 *down-- = (char)tmp;
5292 (void)SvPOK_only_UTF8(TARG);
5304 IV limit = POPi; /* note, negative is forever */
5305 SV * const sv = POPs;
5307 const char *s = SvPV_const(sv, len);
5308 const bool do_utf8 = DO_UTF8(sv);
5309 const char *strend = s + len;
5315 const STRLEN slen = do_utf8
5316 ? utf8_length((U8*)s, (U8*)strend)
5317 : (STRLEN)(strend - s);
5318 I32 maxiters = slen + 10;
5319 I32 trailing_empty = 0;
5321 const I32 origlimit = limit;
5324 const I32 gimme = GIMME_V;
5326 const I32 oldsave = PL_savestack_ix;
5327 U32 make_mortal = SVs_TEMP;
5332 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5337 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5340 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5341 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5343 RX_MATCH_UTF8_set(rx, do_utf8);
5346 if (pm->op_pmreplrootu.op_pmtargetoff) {
5347 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5350 if (pm->op_pmreplrootu.op_pmtargetgv) {
5351 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5362 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5364 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5371 for (i = AvFILLp(ary); i >= 0; i--)
5372 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5374 /* temporarily switch stacks */
5375 SAVESWITCHSTACK(PL_curstack, ary);
5379 base = SP - PL_stack_base;
5381 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5383 while (isSPACE_utf8(s))
5386 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5387 while (isSPACE_LC(*s))
5395 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5399 gimme_scalar = gimme == G_SCALAR && !ary;
5402 limit = maxiters + 2;
5403 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5406 /* this one uses 'm' and is a negative test */
5408 while (m < strend && ! isSPACE_utf8(m) ) {
5409 const int t = UTF8SKIP(m);
5410 /* isSPACE_utf8 returns FALSE for malform utf8 */
5417 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5419 while (m < strend && !isSPACE_LC(*m))
5422 while (m < strend && !isSPACE(*m))
5435 dstr = newSVpvn_flags(s, m-s,
5436 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5440 /* skip the whitespace found last */
5442 s = m + UTF8SKIP(m);
5446 /* this one uses 's' and is a positive test */
5448 while (s < strend && isSPACE_utf8(s) )
5451 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5453 while (s < strend && isSPACE_LC(*s))
5456 while (s < strend && isSPACE(*s))
5461 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5463 for (m = s; m < strend && *m != '\n'; m++)
5476 dstr = newSVpvn_flags(s, m-s,
5477 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5483 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5485 Pre-extend the stack, either the number of bytes or
5486 characters in the string or a limited amount, triggered by:
5488 my ($x, $y) = split //, $str;
5492 if (!gimme_scalar) {
5493 const U32 items = limit - 1;
5502 /* keep track of how many bytes we skip over */
5512 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5525 dstr = newSVpvn(s, 1);
5541 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5542 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5543 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5544 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5545 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5546 SV * const csv = CALLREG_INTUIT_STRING(rx);
5548 len = RX_MINLENRET(rx);
5549 if (len == 1 && !RX_UTF8(rx) && !tail) {
5550 const char c = *SvPV_nolen_const(csv);
5552 for (m = s; m < strend && *m != c; m++)
5563 dstr = newSVpvn_flags(s, m-s,
5564 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5567 /* The rx->minlen is in characters but we want to step
5568 * s ahead by bytes. */
5570 s = (char*)utf8_hop((U8*)m, len);
5572 s = m + len; /* Fake \n at the end */
5576 while (s < strend && --limit &&
5577 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5578 csv, multiline ? FBMrf_MULTILINE : 0)) )
5587 dstr = newSVpvn_flags(s, m-s,
5588 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5591 /* The rx->minlen is in characters but we want to step
5592 * s ahead by bytes. */
5594 s = (char*)utf8_hop((U8*)m, len);
5596 s = m + len; /* Fake \n at the end */
5601 maxiters += slen * RX_NPARENS(rx);
5602 while (s < strend && --limit)
5606 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5609 if (rex_return == 0)
5611 TAINT_IF(RX_MATCH_TAINTED(rx));
5612 /* we never pass the REXEC_COPY_STR flag, so it should
5613 * never get copied */
5614 assert(!RX_MATCH_COPIED(rx));
5615 m = RX_OFFS(rx)[0].start + orig;
5624 dstr = newSVpvn_flags(s, m-s,
5625 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5628 if (RX_NPARENS(rx)) {
5630 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5631 s = RX_OFFS(rx)[i].start + orig;
5632 m = RX_OFFS(rx)[i].end + orig;
5634 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5635 parens that didn't match -- they should be set to
5636 undef, not the empty string */
5644 if (m >= orig && s >= orig) {
5645 dstr = newSVpvn_flags(s, m-s,
5646 (do_utf8 ? SVf_UTF8 : 0)
5650 dstr = &PL_sv_undef; /* undef, not "" */
5656 s = RX_OFFS(rx)[0].end + orig;
5660 if (!gimme_scalar) {
5661 iters = (SP - PL_stack_base) - base;
5663 if (iters > maxiters)
5664 DIE(aTHX_ "Split loop");
5666 /* keep field after final delim? */
5667 if (s < strend || (iters && origlimit)) {
5668 if (!gimme_scalar) {
5669 const STRLEN l = strend - s;
5670 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5675 else if (!origlimit) {
5677 iters -= trailing_empty;
5679 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5680 if (TOPs && !make_mortal)
5682 *SP-- = &PL_sv_undef;
5689 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5693 if (SvSMAGICAL(ary)) {
5695 mg_set(MUTABLE_SV(ary));
5698 if (gimme == G_ARRAY) {
5700 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5707 ENTER_with_name("call_PUSH");
5708 call_method("PUSH",G_SCALAR|G_DISCARD);
5709 LEAVE_with_name("call_PUSH");
5711 if (gimme == G_ARRAY) {
5713 /* EXTEND should not be needed - we just popped them */
5715 for (i=0; i < iters; i++) {
5716 SV **svp = av_fetch(ary, i, FALSE);
5717 PUSHs((svp) ? *svp : &PL_sv_undef);
5724 if (gimme == G_ARRAY)
5736 SV *const sv = PAD_SVl(PL_op->op_targ);
5738 if (SvPADSTALE(sv)) {
5741 RETURNOP(cLOGOP->op_other);
5743 RETURNOP(cLOGOP->op_next);
5753 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5754 || SvTYPE(retsv) == SVt_PVCV) {
5755 retsv = refto(retsv);
5762 PP(unimplemented_op)
5765 const Optype op_type = PL_op->op_type;
5766 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5767 with out of range op numbers - it only "special" cases op_custom.
5768 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5769 if we get here for a custom op then that means that the custom op didn't
5770 have an implementation. Given that OP_NAME() looks up the custom op
5771 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5772 registers &PL_unimplemented_op as the address of their custom op.
5773 NULL doesn't generate a useful error message. "custom" does. */
5774 const char *const name = op_type >= OP_max
5775 ? "[out of range]" : PL_op_name[PL_op->op_type];
5776 if(OP_IS_SOCKET(op_type))
5777 DIE(aTHX_ PL_no_sock_func, name);
5778 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5781 /* For sorting out arguments passed to a &CORE:: subroutine */
5785 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5786 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5787 AV * const at_ = GvAV(PL_defgv);
5788 SV **svp = at_ ? AvARRAY(at_) : NULL;
5789 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5790 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5791 bool seen_question = 0;
5792 const char *err = NULL;
5793 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5795 /* Count how many args there are first, to get some idea how far to
5796 extend the stack. */
5798 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5800 if (oa & OA_OPTIONAL) seen_question = 1;
5801 if (!seen_question) minargs++;
5805 if(numargs < minargs) err = "Not enough";
5806 else if(numargs > maxargs) err = "Too many";
5808 /* diag_listed_as: Too many arguments for %s */
5810 "%s arguments for %s", err,
5811 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5814 /* Reset the stack pointer. Without this, we end up returning our own
5815 arguments in list context, in addition to the values we are supposed
5816 to return. nextstate usually does this on sub entry, but we need
5817 to run the next op with the caller's hints, so we cannot have a
5819 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5821 if(!maxargs) RETURN;
5823 /* We do this here, rather than with a separate pushmark op, as it has
5824 to come in between two things this function does (stack reset and
5825 arg pushing). This seems the easiest way to do it. */
5828 (void)Perl_pp_pushmark(aTHX);
5831 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5832 PUTBACK; /* The code below can die in various places. */
5834 oa = PL_opargs[opnum] >> OASHIFT;
5835 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5840 if (!numargs && defgv && whicharg == minargs + 1) {
5841 PUSHs(find_rundefsv2(
5842 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5843 cxstack[cxstack_ix].blk_oldcop->cop_seq
5846 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5850 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5855 if (!svp || !*svp || !SvROK(*svp)
5856 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5858 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5859 "Type of arg %d to &CORE::%s must be hash reference",
5860 whicharg, OP_DESC(PL_op->op_next)
5865 if (!numargs) PUSHs(NULL);
5866 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5867 /* no magic here, as the prototype will have added an extra
5868 refgen and we just want what was there before that */
5871 const bool constr = PL_op->op_private & whicharg;
5873 svp && *svp ? *svp : &PL_sv_undef,
5874 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5880 if (!numargs) goto try_defsv;
5882 const bool wantscalar =
5883 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5884 if (!svp || !*svp || !SvROK(*svp)
5885 /* We have to permit globrefs even for the \$ proto, as
5886 *foo is indistinguishable from ${\*foo}, and the proto-
5887 type permits the latter. */
5888 || SvTYPE(SvRV(*svp)) > (
5889 wantscalar ? SVt_PVLV
5890 : opnum == OP_LOCK || opnum == OP_UNDEF
5896 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5897 "Type of arg %d to &CORE::%s must be %s",
5898 whicharg, PL_op_name[opnum],
5900 ? "scalar reference"
5901 : opnum == OP_LOCK || opnum == OP_UNDEF
5902 ? "reference to one of [$@%&*]"
5903 : "reference to one of [$@%*]"
5906 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5907 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5908 /* Undo @_ localisation, so that sub exit does not undo
5909 part of our undeffing. */
5910 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5912 cx->cx_type &= ~ CXp_HASARGS;
5913 assert(!AvREAL(cx->blk_sub.argarray));
5918 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5930 if (PL_op->op_private & OPpOFFBYONE) {
5931 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5933 else cv = find_runcv(NULL);
5934 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5941 * c-indentation-style: bsd
5943 * indent-tabs-mode: nil
5946 * ex: set ts=8 sts=4 sw=4 et: