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 HV *stash = CopSTASH(PL_curcop);
241 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
242 gv = MUTABLE_GV(newSV(0));
243 gv_init_sv(gv, stash, namesv, 0);
246 const char * const name = CopSTASHPV(PL_curcop);
247 gv = newGVgen_flags(name,
248 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
250 prepare_SV_for_RV(sv);
251 SvRV_set(sv, MUTABLE_SV(gv));
256 if (PL_op->op_flags & OPf_REF || strict)
257 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
258 if (ckWARN(WARN_UNINITIALIZED))
264 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
265 sv, GV_ADDMG, SVt_PVGV
275 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
278 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
279 == OPpDONT_INIT_GV) {
280 /* We are the target of a coderef assignment. Return
281 the scalar unchanged, and let pp_sasssign deal with
285 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
287 /* FAKE globs in the symbol table cause weird bugs (#77810) */
291 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
292 SV *newsv = sv_newmortal();
293 sv_setsv_flags(newsv, sv, 0);
305 sv, PL_op->op_private & OPpDEREF,
306 PL_op->op_private & HINT_STRICT_REFS,
307 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
308 || PL_op->op_type == OP_READLINE
310 if (PL_op->op_private & OPpLVAL_INTRO)
311 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
316 /* Helper function for pp_rv2sv and pp_rv2av */
318 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
319 const svtype type, SV ***spp)
324 PERL_ARGS_ASSERT_SOFTREF2XV;
326 if (PL_op->op_private & HINT_STRICT_REFS) {
328 Perl_die(aTHX_ S_no_symref_sv, sv,
329 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
331 Perl_die(aTHX_ PL_no_usym, what);
335 PL_op->op_flags & OPf_REF
337 Perl_die(aTHX_ PL_no_usym, what);
338 if (ckWARN(WARN_UNINITIALIZED))
340 if (type != SVt_PV && GIMME_V == G_ARRAY) {
344 **spp = &PL_sv_undef;
347 if ((PL_op->op_flags & OPf_SPECIAL) &&
348 !(PL_op->op_flags & OPf_MOD))
350 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
352 **spp = &PL_sv_undef;
357 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
370 sv = amagic_deref_call(sv, to_sv_amg);
374 switch (SvTYPE(sv)) {
380 DIE(aTHX_ "Not a SCALAR reference");
387 if (!isGV_with_GP(gv)) {
388 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
394 if (PL_op->op_flags & OPf_MOD) {
395 if (PL_op->op_private & OPpLVAL_INTRO) {
396 if (cUNOP->op_first->op_type == OP_NULL)
397 sv = save_scalar(MUTABLE_GV(TOPs));
399 sv = save_scalar(gv);
401 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
403 else if (PL_op->op_private & OPpDEREF)
404 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
413 AV * const av = MUTABLE_AV(TOPs);
414 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
416 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
418 *sv = newSV_type(SVt_PVMG);
419 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
423 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
432 if (PL_op->op_flags & OPf_MOD || LVRET) {
433 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
434 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
436 LvTARG(ret) = SvREFCNT_inc_simple(sv);
437 PUSHs(ret); /* no SvSETMAGIC */
441 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
442 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
443 if (mg && mg->mg_len >= 0) {
461 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
463 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
464 == OPpMAY_RETURN_CONSTANT)
467 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
468 /* (But not in defined().) */
470 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
472 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
476 cv = MUTABLE_CV(&PL_sv_undef);
477 SETs(MUTABLE_SV(cv));
487 SV *ret = &PL_sv_undef;
489 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
490 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
491 const char * s = SvPVX_const(TOPs);
492 if (strnEQ(s, "CORE::", 6)) {
493 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
494 if (!code || code == -KEY_CORE)
495 DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
496 SVfARG(newSVpvn_flags(
498 (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP
501 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
507 cv = sv_2cv(TOPs, &stash, &gv, 0);
509 ret = newSVpvn_flags(
510 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
520 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
522 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
524 PUSHs(MUTABLE_SV(cv));
538 if (GIMME != G_ARRAY) {
542 *MARK = &PL_sv_undef;
543 *MARK = refto(*MARK);
547 EXTEND_MORTAL(SP - MARK);
549 *MARK = refto(*MARK);
554 S_refto(pTHX_ SV *sv)
559 PERL_ARGS_ASSERT_REFTO;
561 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
564 if (!(sv = LvTARG(sv)))
567 SvREFCNT_inc_void_NN(sv);
569 else if (SvTYPE(sv) == SVt_PVAV) {
570 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
571 av_reify(MUTABLE_AV(sv));
573 SvREFCNT_inc_void_NN(sv);
575 else if (SvPADTMP(sv) && !IS_PADGV(sv))
579 SvREFCNT_inc_void_NN(sv);
582 sv_upgrade(rv, SVt_IV);
591 SV * const sv = POPs;
597 (void)sv_ref(TARG,SvRV(sv),TRUE);
610 stash = CopSTASH(PL_curcop);
611 if (SvTYPE(stash) != SVt_PVHV)
612 Perl_croak(aTHX_ "Attempt to bless into a freed package");
615 SV * const ssv = POPs;
619 if (!ssv) goto curstash;
620 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
621 Perl_croak(aTHX_ "Attempt to bless into a reference");
622 ptr = SvPV_const(ssv,len);
624 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
625 "Explicit blessing to '' (assuming package main)");
626 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
629 (void)sv_bless(TOPs, stash);
639 const char * const elem = SvPV_const(sv, len);
640 GV * const gv = MUTABLE_GV(POPs);
645 /* elem will always be NUL terminated. */
646 const char * const second_letter = elem + 1;
649 if (len == 5 && strEQ(second_letter, "RRAY"))
651 tmpRef = MUTABLE_SV(GvAV(gv));
652 if (tmpRef && !AvREAL((const AV *)tmpRef)
653 && AvREIFY((const AV *)tmpRef))
654 av_reify(MUTABLE_AV(tmpRef));
658 if (len == 4 && strEQ(second_letter, "ODE"))
659 tmpRef = MUTABLE_SV(GvCVu(gv));
662 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
663 /* finally deprecated in 5.8.0 */
664 deprecate("*glob{FILEHANDLE}");
665 tmpRef = MUTABLE_SV(GvIOp(gv));
668 if (len == 6 && strEQ(second_letter, "ORMAT"))
669 tmpRef = MUTABLE_SV(GvFORM(gv));
672 if (len == 4 && strEQ(second_letter, "LOB"))
673 tmpRef = MUTABLE_SV(gv);
676 if (len == 4 && strEQ(second_letter, "ASH"))
677 tmpRef = MUTABLE_SV(GvHV(gv));
680 if (*second_letter == 'O' && !elem[2] && len == 2)
681 tmpRef = MUTABLE_SV(GvIOp(gv));
684 if (len == 4 && strEQ(second_letter, "AME"))
685 sv = newSVhek(GvNAME_HEK(gv));
688 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
689 const HV * const stash = GvSTASH(gv);
690 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
691 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
695 if (len == 6 && strEQ(second_letter, "CALAR"))
710 /* Pattern matching */
718 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
719 /* Historically, study was skipped in these cases. */
723 /* Make study a no-op. It's no longer useful and its existence
724 complicates matters elsewhere. */
733 if (PL_op->op_flags & OPf_STACKED)
735 else if (PL_op->op_private & OPpTARGET_MY)
741 if(PL_op->op_type == OP_TRANSR) {
743 const char * const pv = SvPV(sv,len);
744 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
749 TARG = sv_newmortal();
755 /* Lvalue operators. */
758 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
764 PERL_ARGS_ASSERT_DO_CHOMP;
766 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
768 if (SvTYPE(sv) == SVt_PVAV) {
770 AV *const av = MUTABLE_AV(sv);
771 const I32 max = AvFILL(av);
773 for (i = 0; i <= max; i++) {
774 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
775 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
776 do_chomp(retval, sv, chomping);
780 else if (SvTYPE(sv) == SVt_PVHV) {
781 HV* const hv = MUTABLE_HV(sv);
783 (void)hv_iterinit(hv);
784 while ((entry = hv_iternext(hv)))
785 do_chomp(retval, hv_iterval(hv,entry), chomping);
788 else if (SvREADONLY(sv)) {
789 Perl_croak_no_modify();
791 else if (SvIsCOW(sv)) {
792 sv_force_normal_flags(sv, 0);
797 /* XXX, here sv is utf8-ized as a side-effect!
798 If encoding.pm is used properly, almost string-generating
799 operations, including literal strings, chr(), input data, etc.
800 should have been utf8-ized already, right?
802 sv_recode_to_utf8(sv, PL_encoding);
808 char *temp_buffer = NULL;
817 while (len && s[-1] == '\n') {
824 STRLEN rslen, rs_charlen;
825 const char *rsptr = SvPV_const(PL_rs, rslen);
827 rs_charlen = SvUTF8(PL_rs)
831 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
832 /* Assumption is that rs is shorter than the scalar. */
834 /* RS is utf8, scalar is 8 bit. */
836 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
839 /* Cannot downgrade, therefore cannot possibly match
841 assert (temp_buffer == rsptr);
847 else if (PL_encoding) {
848 /* RS is 8 bit, encoding.pm is used.
849 * Do not recode PL_rs as a side-effect. */
850 svrecode = newSVpvn(rsptr, rslen);
851 sv_recode_to_utf8(svrecode, PL_encoding);
852 rsptr = SvPV_const(svrecode, rslen);
853 rs_charlen = sv_len_utf8(svrecode);
856 /* RS is 8 bit, scalar is utf8. */
857 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
871 if (memNE(s, rsptr, rslen))
873 SvIVX(retval) += rs_charlen;
876 s = SvPV_force_nomg_nolen(sv);
884 SvREFCNT_dec(svrecode);
886 Safefree(temp_buffer);
888 if (len && !SvPOK(sv))
889 s = SvPV_force_nomg(sv, len);
892 char * const send = s + len;
893 char * const start = s;
895 while (s > start && UTF8_IS_CONTINUATION(*s))
897 if (is_utf8_string((U8*)s, send - s)) {
898 sv_setpvn(retval, s, send - s);
900 SvCUR_set(sv, s - start);
906 sv_setpvs(retval, "");
910 sv_setpvn(retval, s, 1);
917 sv_setpvs(retval, "");
925 const bool chomping = PL_op->op_type == OP_SCHOMP;
929 do_chomp(TARG, TOPs, chomping);
936 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
937 const bool chomping = PL_op->op_type == OP_CHOMP;
942 do_chomp(TARG, *++MARK, chomping);
953 if (!PL_op->op_private) {
962 SV_CHECK_THINKFIRST_COW_DROP(sv);
964 switch (SvTYPE(sv)) {
968 av_undef(MUTABLE_AV(sv));
971 hv_undef(MUTABLE_HV(sv));
974 if (cv_const_sv((const CV *)sv))
975 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
976 "Constant subroutine %"SVf" undefined",
977 SVfARG(CvANON((const CV *)sv)
978 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
979 : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
983 /* let user-undef'd sub keep its identity */
984 GV* const gv = CvGV((const CV *)sv);
985 HEK * const hek = CvNAME_HEK((CV *)sv);
986 if (hek) share_hek_hek(hek);
987 cv_undef(MUTABLE_CV(sv));
988 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
990 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
996 assert(isGV_with_GP(sv));
1002 /* undef *Pkg::meth_name ... */
1004 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1005 && HvENAME_get(stash);
1007 if((stash = GvHV((const GV *)sv))) {
1008 if(HvENAME_get(stash))
1009 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1013 gp_free(MUTABLE_GV(sv));
1015 GvGP_set(sv, gp_ref(gp));
1016 GvSV(sv) = newSV(0);
1017 GvLINE(sv) = CopLINE(PL_curcop);
1018 GvEGV(sv) = MUTABLE_GV(sv);
1022 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1024 /* undef *Foo::ISA */
1025 if( strEQ(GvNAME((const GV *)sv), "ISA")
1026 && (stash = GvSTASH((const GV *)sv))
1027 && (method_changed || HvENAME(stash)) )
1028 mro_isa_changed_in(stash);
1029 else if(method_changed)
1030 mro_method_changed_in(
1031 GvSTASH((const GV *)sv)
1037 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1053 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1054 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1055 Perl_croak_no_modify();
1057 TARG = sv_newmortal();
1058 sv_setsv(TARG, TOPs);
1059 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1060 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1062 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1063 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1067 else sv_dec_nomg(TOPs);
1069 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1070 if (inc && !SvOK(TARG))
1076 /* Ordinary operators. */
1080 dVAR; dSP; dATARGET; SV *svl, *svr;
1081 #ifdef PERL_PRESERVE_IVUV
1084 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1087 #ifdef PERL_PRESERVE_IVUV
1088 /* For integer to integer power, we do the calculation by hand wherever
1089 we're sure it is safe; otherwise we call pow() and try to convert to
1090 integer afterwards. */
1091 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1099 const IV iv = SvIVX(svr);
1103 goto float_it; /* Can't do negative powers this way. */
1107 baseuok = SvUOK(svl);
1109 baseuv = SvUVX(svl);
1111 const IV iv = SvIVX(svl);
1114 baseuok = TRUE; /* effectively it's a UV now */
1116 baseuv = -iv; /* abs, baseuok == false records sign */
1119 /* now we have integer ** positive integer. */
1122 /* foo & (foo - 1) is zero only for a power of 2. */
1123 if (!(baseuv & (baseuv - 1))) {
1124 /* We are raising power-of-2 to a positive integer.
1125 The logic here will work for any base (even non-integer
1126 bases) but it can be less accurate than
1127 pow (base,power) or exp (power * log (base)) when the
1128 intermediate values start to spill out of the mantissa.
1129 With powers of 2 we know this can't happen.
1130 And powers of 2 are the favourite thing for perl
1131 programmers to notice ** not doing what they mean. */
1133 NV base = baseuok ? baseuv : -(NV)baseuv;
1138 while (power >>= 1) {
1146 SvIV_please_nomg(svr);
1149 unsigned int highbit = 8 * sizeof(UV);
1150 unsigned int diff = 8 * sizeof(UV);
1151 while (diff >>= 1) {
1153 if (baseuv >> highbit) {
1157 /* we now have baseuv < 2 ** highbit */
1158 if (power * highbit <= 8 * sizeof(UV)) {
1159 /* result will definitely fit in UV, so use UV math
1160 on same algorithm as above */
1163 const bool odd_power = cBOOL(power & 1);
1167 while (power >>= 1) {
1174 if (baseuok || !odd_power)
1175 /* answer is positive */
1177 else if (result <= (UV)IV_MAX)
1178 /* answer negative, fits in IV */
1179 SETi( -(IV)result );
1180 else if (result == (UV)IV_MIN)
1181 /* 2's complement assumption: special case IV_MIN */
1184 /* answer negative, doesn't fit */
1185 SETn( -(NV)result );
1193 NV right = SvNV_nomg(svr);
1194 NV left = SvNV_nomg(svl);
1197 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1199 We are building perl with long double support and are on an AIX OS
1200 afflicted with a powl() function that wrongly returns NaNQ for any
1201 negative base. This was reported to IBM as PMR #23047-379 on
1202 03/06/2006. The problem exists in at least the following versions
1203 of AIX and the libm fileset, and no doubt others as well:
1205 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1206 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1207 AIX 5.2.0 bos.adt.libm 5.2.0.85
1209 So, until IBM fixes powl(), we provide the following workaround to
1210 handle the problem ourselves. Our logic is as follows: for
1211 negative bases (left), we use fmod(right, 2) to check if the
1212 exponent is an odd or even integer:
1214 - if odd, powl(left, right) == -powl(-left, right)
1215 - if even, powl(left, right) == powl(-left, right)
1217 If the exponent is not an integer, the result is rightly NaNQ, so
1218 we just return that (as NV_NAN).
1222 NV mod2 = Perl_fmod( right, 2.0 );
1223 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1224 SETn( -Perl_pow( -left, right) );
1225 } else if (mod2 == 0.0) { /* even integer */
1226 SETn( Perl_pow( -left, right) );
1227 } else { /* fractional power */
1231 SETn( Perl_pow( left, right) );
1234 SETn( Perl_pow( left, right) );
1235 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1237 #ifdef PERL_PRESERVE_IVUV
1239 SvIV_please_nomg(svr);
1247 dVAR; dSP; dATARGET; SV *svl, *svr;
1248 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1251 #ifdef PERL_PRESERVE_IVUV
1252 if (SvIV_please_nomg(svr)) {
1253 /* Unless the left argument is integer in range we are going to have to
1254 use NV maths. Hence only attempt to coerce the right argument if
1255 we know the left is integer. */
1256 /* Left operand is defined, so is it IV? */
1257 if (SvIV_please_nomg(svl)) {
1258 bool auvok = SvUOK(svl);
1259 bool buvok = SvUOK(svr);
1260 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1261 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1270 const IV aiv = SvIVX(svl);
1273 auvok = TRUE; /* effectively it's a UV now */
1275 alow = -aiv; /* abs, auvok == false records sign */
1281 const IV biv = SvIVX(svr);
1284 buvok = TRUE; /* effectively it's a UV now */
1286 blow = -biv; /* abs, buvok == false records sign */
1290 /* If this does sign extension on unsigned it's time for plan B */
1291 ahigh = alow >> (4 * sizeof (UV));
1293 bhigh = blow >> (4 * sizeof (UV));
1295 if (ahigh && bhigh) {
1297 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1298 which is overflow. Drop to NVs below. */
1299 } else if (!ahigh && !bhigh) {
1300 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1301 so the unsigned multiply cannot overflow. */
1302 const UV product = alow * blow;
1303 if (auvok == buvok) {
1304 /* -ve * -ve or +ve * +ve gives a +ve result. */
1308 } else if (product <= (UV)IV_MIN) {
1309 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1310 /* -ve result, which could overflow an IV */
1312 SETi( -(IV)product );
1314 } /* else drop to NVs below. */
1316 /* One operand is large, 1 small */
1319 /* swap the operands */
1321 bhigh = blow; /* bhigh now the temp var for the swap */
1325 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1326 multiplies can't overflow. shift can, add can, -ve can. */
1327 product_middle = ahigh * blow;
1328 if (!(product_middle & topmask)) {
1329 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1331 product_middle <<= (4 * sizeof (UV));
1332 product_low = alow * blow;
1334 /* as for pp_add, UV + something mustn't get smaller.
1335 IIRC ANSI mandates this wrapping *behaviour* for
1336 unsigned whatever the actual representation*/
1337 product_low += product_middle;
1338 if (product_low >= product_middle) {
1339 /* didn't overflow */
1340 if (auvok == buvok) {
1341 /* -ve * -ve or +ve * +ve gives a +ve result. */
1343 SETu( product_low );
1345 } else if (product_low <= (UV)IV_MIN) {
1346 /* 2s complement assumption again */
1347 /* -ve result, which could overflow an IV */
1349 SETi( -(IV)product_low );
1351 } /* else drop to NVs below. */
1353 } /* product_middle too large */
1354 } /* ahigh && bhigh */
1359 NV right = SvNV_nomg(svr);
1360 NV left = SvNV_nomg(svl);
1362 SETn( left * right );
1369 dVAR; dSP; dATARGET; SV *svl, *svr;
1370 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1373 /* Only try to do UV divide first
1374 if ((SLOPPYDIVIDE is true) or
1375 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1377 The assumption is that it is better to use floating point divide
1378 whenever possible, only doing integer divide first if we can't be sure.
1379 If NV_PRESERVES_UV is true then we know at compile time that no UV
1380 can be too large to preserve, so don't need to compile the code to
1381 test the size of UVs. */
1384 # define PERL_TRY_UV_DIVIDE
1385 /* ensure that 20./5. == 4. */
1387 # ifdef PERL_PRESERVE_IVUV
1388 # ifndef NV_PRESERVES_UV
1389 # define PERL_TRY_UV_DIVIDE
1394 #ifdef PERL_TRY_UV_DIVIDE
1395 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1396 bool left_non_neg = SvUOK(svl);
1397 bool right_non_neg = SvUOK(svr);
1401 if (right_non_neg) {
1405 const IV biv = SvIVX(svr);
1408 right_non_neg = TRUE; /* effectively it's a UV now */
1414 /* historically undef()/0 gives a "Use of uninitialized value"
1415 warning before dieing, hence this test goes here.
1416 If it were immediately before the second SvIV_please, then
1417 DIE() would be invoked before left was even inspected, so
1418 no inspection would give no warning. */
1420 DIE(aTHX_ "Illegal division by zero");
1426 const IV aiv = SvIVX(svl);
1429 left_non_neg = TRUE; /* effectively it's a UV now */
1438 /* For sloppy divide we always attempt integer division. */
1440 /* Otherwise we only attempt it if either or both operands
1441 would not be preserved by an NV. If both fit in NVs
1442 we fall through to the NV divide code below. However,
1443 as left >= right to ensure integer result here, we know that
1444 we can skip the test on the right operand - right big
1445 enough not to be preserved can't get here unless left is
1448 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1451 /* Integer division can't overflow, but it can be imprecise. */
1452 const UV result = left / right;
1453 if (result * right == left) {
1454 SP--; /* result is valid */
1455 if (left_non_neg == right_non_neg) {
1456 /* signs identical, result is positive. */
1460 /* 2s complement assumption */
1461 if (result <= (UV)IV_MIN)
1462 SETi( -(IV)result );
1464 /* It's exact but too negative for IV. */
1465 SETn( -(NV)result );
1468 } /* tried integer divide but it was not an integer result */
1469 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1470 } /* one operand wasn't SvIOK */
1471 #endif /* PERL_TRY_UV_DIVIDE */
1473 NV right = SvNV_nomg(svr);
1474 NV left = SvNV_nomg(svl);
1475 (void)POPs;(void)POPs;
1476 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1477 if (! Perl_isnan(right) && right == 0.0)
1481 DIE(aTHX_ "Illegal division by zero");
1482 PUSHn( left / right );
1489 dVAR; dSP; dATARGET;
1490 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1494 bool left_neg = FALSE;
1495 bool right_neg = FALSE;
1496 bool use_double = FALSE;
1497 bool dright_valid = FALSE;
1500 SV * const svr = TOPs;
1501 SV * const svl = TOPm1s;
1502 if (SvIV_please_nomg(svr)) {
1503 right_neg = !SvUOK(svr);
1507 const IV biv = SvIVX(svr);
1510 right_neg = FALSE; /* effectively it's a UV now */
1517 dright = SvNV_nomg(svr);
1518 right_neg = dright < 0;
1521 if (dright < UV_MAX_P1) {
1522 right = U_V(dright);
1523 dright_valid = TRUE; /* In case we need to use double below. */
1529 /* At this point use_double is only true if right is out of range for
1530 a UV. In range NV has been rounded down to nearest UV and
1531 use_double false. */
1532 if (!use_double && SvIV_please_nomg(svl)) {
1533 left_neg = !SvUOK(svl);
1537 const IV aiv = SvIVX(svl);
1540 left_neg = FALSE; /* effectively it's a UV now */
1547 dleft = SvNV_nomg(svl);
1548 left_neg = dleft < 0;
1552 /* This should be exactly the 5.6 behaviour - if left and right are
1553 both in range for UV then use U_V() rather than floor. */
1555 if (dleft < UV_MAX_P1) {
1556 /* right was in range, so is dleft, so use UVs not double.
1560 /* left is out of range for UV, right was in range, so promote
1561 right (back) to double. */
1563 /* The +0.5 is used in 5.6 even though it is not strictly
1564 consistent with the implicit +0 floor in the U_V()
1565 inside the #if 1. */
1566 dleft = Perl_floor(dleft + 0.5);
1569 dright = Perl_floor(dright + 0.5);
1580 DIE(aTHX_ "Illegal modulus zero");
1582 dans = Perl_fmod(dleft, dright);
1583 if ((left_neg != right_neg) && dans)
1584 dans = dright - dans;
1587 sv_setnv(TARG, dans);
1593 DIE(aTHX_ "Illegal modulus zero");
1596 if ((left_neg != right_neg) && ans)
1599 /* XXX may warn: unary minus operator applied to unsigned type */
1600 /* could change -foo to be (~foo)+1 instead */
1601 if (ans <= ~((UV)IV_MAX)+1)
1602 sv_setiv(TARG, ~ans+1);
1604 sv_setnv(TARG, -(NV)ans);
1607 sv_setuv(TARG, ans);
1616 dVAR; dSP; dATARGET;
1620 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1621 /* TODO: think of some way of doing list-repeat overloading ??? */
1626 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1632 const UV uv = SvUV_nomg(sv);
1634 count = IV_MAX; /* The best we can do? */
1638 const IV iv = SvIV_nomg(sv);
1645 else if (SvNOKp(sv)) {
1646 const NV nv = SvNV_nomg(sv);
1653 count = SvIV_nomg(sv);
1655 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1657 static const char* const oom_list_extend = "Out of memory during list extend";
1658 const I32 items = SP - MARK;
1659 const I32 max = items * count;
1661 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1662 /* Did the max computation overflow? */
1663 if (items > 0 && max > 0 && (max < items || max < count))
1664 Perl_croak(aTHX_ "%s", oom_list_extend);
1669 /* This code was intended to fix 20010809.028:
1672 for (($x =~ /./g) x 2) {
1673 print chop; # "abcdabcd" expected as output.
1676 * but that change (#11635) broke this code:
1678 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1680 * I can't think of a better fix that doesn't introduce
1681 * an efficiency hit by copying the SVs. The stack isn't
1682 * refcounted, and mortalisation obviously doesn't
1683 * Do The Right Thing when the stack has more than
1684 * one pointer to the same mortal value.
1688 *SP = sv_2mortal(newSVsv(*SP));
1698 repeatcpy((char*)(MARK + items), (char*)MARK,
1699 items * sizeof(const SV *), count - 1);
1702 else if (count <= 0)
1705 else { /* Note: mark already snarfed by pp_list */
1706 SV * const tmpstr = POPs;
1709 static const char* const oom_string_extend =
1710 "Out of memory during string extend";
1713 sv_setsv_nomg(TARG, tmpstr);
1714 SvPV_force_nomg(TARG, len);
1715 isutf = DO_UTF8(TARG);
1720 const STRLEN max = (UV)count * len;
1721 if (len > MEM_SIZE_MAX / count)
1722 Perl_croak(aTHX_ "%s", oom_string_extend);
1723 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1724 SvGROW(TARG, max + 1);
1725 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1726 SvCUR_set(TARG, SvCUR(TARG) * count);
1728 *SvEND(TARG) = '\0';
1731 (void)SvPOK_only_UTF8(TARG);
1733 (void)SvPOK_only(TARG);
1735 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1736 /* The parser saw this as a list repeat, and there
1737 are probably several items on the stack. But we're
1738 in scalar context, and there's no pp_list to save us
1739 now. So drop the rest of the items -- robin@kitsite.com
1751 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1752 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1755 useleft = USE_LEFT(svl);
1756 #ifdef PERL_PRESERVE_IVUV
1757 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1758 "bad things" happen if you rely on signed integers wrapping. */
1759 if (SvIV_please_nomg(svr)) {
1760 /* Unless the left argument is integer in range we are going to have to
1761 use NV maths. Hence only attempt to coerce the right argument if
1762 we know the left is integer. */
1769 a_valid = auvok = 1;
1770 /* left operand is undef, treat as zero. */
1772 /* Left operand is defined, so is it IV? */
1773 if (SvIV_please_nomg(svl)) {
1774 if ((auvok = SvUOK(svl)))
1777 const IV aiv = SvIVX(svl);
1780 auvok = 1; /* Now acting as a sign flag. */
1781 } else { /* 2s complement assumption for IV_MIN */
1789 bool result_good = 0;
1792 bool buvok = SvUOK(svr);
1797 const IV biv = SvIVX(svr);
1804 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1805 else "IV" now, independent of how it came in.
1806 if a, b represents positive, A, B negative, a maps to -A etc
1811 all UV maths. negate result if A negative.
1812 subtract if signs same, add if signs differ. */
1814 if (auvok ^ buvok) {
1823 /* Must get smaller */
1828 if (result <= buv) {
1829 /* result really should be -(auv-buv). as its negation
1830 of true value, need to swap our result flag */
1842 if (result <= (UV)IV_MIN)
1843 SETi( -(IV)result );
1845 /* result valid, but out of range for IV. */
1846 SETn( -(NV)result );
1850 } /* Overflow, drop through to NVs. */
1855 NV value = SvNV_nomg(svr);
1859 /* left operand is undef, treat as zero - value */
1863 SETn( SvNV_nomg(svl) - value );
1870 dVAR; dSP; dATARGET; SV *svl, *svr;
1871 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1875 const IV shift = SvIV_nomg(svr);
1876 if (PL_op->op_private & HINT_INTEGER) {
1877 const IV i = SvIV_nomg(svl);
1881 const UV u = SvUV_nomg(svl);
1890 dVAR; dSP; dATARGET; SV *svl, *svr;
1891 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1895 const IV shift = SvIV_nomg(svr);
1896 if (PL_op->op_private & HINT_INTEGER) {
1897 const IV i = SvIV_nomg(svl);
1901 const UV u = SvUV_nomg(svl);
1913 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1917 (SvIOK_notUV(left) && SvIOK_notUV(right))
1918 ? (SvIVX(left) < SvIVX(right))
1919 : (do_ncmp(left, right) == -1)
1929 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1933 (SvIOK_notUV(left) && SvIOK_notUV(right))
1934 ? (SvIVX(left) > SvIVX(right))
1935 : (do_ncmp(left, right) == 1)
1945 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1949 (SvIOK_notUV(left) && SvIOK_notUV(right))
1950 ? (SvIVX(left) <= SvIVX(right))
1951 : (do_ncmp(left, right) <= 0)
1961 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1965 (SvIOK_notUV(left) && SvIOK_notUV(right))
1966 ? (SvIVX(left) >= SvIVX(right))
1967 : ( (do_ncmp(left, right) & 2) == 0)
1977 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1981 (SvIOK_notUV(left) && SvIOK_notUV(right))
1982 ? (SvIVX(left) != SvIVX(right))
1983 : (do_ncmp(left, right) != 0)
1988 /* compare left and right SVs. Returns:
1992 * 2: left or right was a NaN
1995 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1999 PERL_ARGS_ASSERT_DO_NCMP;
2000 #ifdef PERL_PRESERVE_IVUV
2001 /* Fortunately it seems NaN isn't IOK */
2002 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2004 const IV leftiv = SvIVX(left);
2005 if (!SvUOK(right)) {
2006 /* ## IV <=> IV ## */
2007 const IV rightiv = SvIVX(right);
2008 return (leftiv > rightiv) - (leftiv < rightiv);
2010 /* ## IV <=> UV ## */
2012 /* As (b) is a UV, it's >=0, so it must be < */
2015 const UV rightuv = SvUVX(right);
2016 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2021 /* ## UV <=> UV ## */
2022 const UV leftuv = SvUVX(left);
2023 const UV rightuv = SvUVX(right);
2024 return (leftuv > rightuv) - (leftuv < rightuv);
2026 /* ## UV <=> IV ## */
2028 const IV rightiv = SvIVX(right);
2030 /* As (a) is a UV, it's >=0, so it cannot be < */
2033 const UV leftuv = SvUVX(left);
2034 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2037 assert(0); /* NOTREACHED */
2041 NV const rnv = SvNV_nomg(right);
2042 NV const lnv = SvNV_nomg(left);
2044 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2045 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2048 return (lnv > rnv) - (lnv < rnv);
2067 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2070 value = do_ncmp(left, right);
2085 int amg_type = sle_amg;
2089 switch (PL_op->op_type) {
2108 tryAMAGICbin_MG(amg_type, AMGf_set);
2111 const int cmp = (IN_LOCALE_RUNTIME
2112 ? sv_cmp_locale_flags(left, right, 0)
2113 : sv_cmp_flags(left, right, 0));
2114 SETs(boolSV(cmp * multiplier < rhs));
2122 tryAMAGICbin_MG(seq_amg, AMGf_set);
2125 SETs(boolSV(sv_eq_flags(left, right, 0)));
2133 tryAMAGICbin_MG(sne_amg, AMGf_set);
2136 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2144 tryAMAGICbin_MG(scmp_amg, 0);
2147 const int cmp = (IN_LOCALE_RUNTIME
2148 ? sv_cmp_locale_flags(left, right, 0)
2149 : sv_cmp_flags(left, right, 0));
2157 dVAR; dSP; dATARGET;
2158 tryAMAGICbin_MG(band_amg, AMGf_assign);
2161 if (SvNIOKp(left) || SvNIOKp(right)) {
2162 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2163 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2164 if (PL_op->op_private & HINT_INTEGER) {
2165 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2169 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2172 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2173 if (right_ro_nonnum) SvNIOK_off(right);
2176 do_vop(PL_op->op_type, TARG, left, right);
2185 dVAR; dSP; dATARGET;
2186 const int op_type = PL_op->op_type;
2188 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2191 if (SvNIOKp(left) || SvNIOKp(right)) {
2192 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2193 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2194 if (PL_op->op_private & HINT_INTEGER) {
2195 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2196 const IV r = SvIV_nomg(right);
2197 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2201 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2202 const UV r = SvUV_nomg(right);
2203 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2206 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2207 if (right_ro_nonnum) SvNIOK_off(right);
2210 do_vop(op_type, TARG, left, right);
2217 PERL_STATIC_INLINE bool
2218 S_negate_string(pTHX)
2223 SV * const sv = TOPs;
2224 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2226 s = SvPV_nomg_const(sv, len);
2227 if (isIDFIRST(*s)) {
2228 sv_setpvs(TARG, "-");
2231 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2232 sv_setsv_nomg(TARG, sv);
2233 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2243 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2244 if (S_negate_string(aTHX)) return NORMAL;
2246 SV * const sv = TOPs;
2249 /* It's publicly an integer */
2252 if (SvIVX(sv) == IV_MIN) {
2253 /* 2s complement assumption. */
2254 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2258 else if (SvUVX(sv) <= IV_MAX) {
2263 else if (SvIVX(sv) != IV_MIN) {
2267 #ifdef PERL_PRESERVE_IVUV
2274 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2275 SETn(-SvNV_nomg(sv));
2276 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2277 goto oops_its_an_int;
2279 SETn(-SvNV_nomg(sv));
2287 tryAMAGICun_MG(not_amg, AMGf_set);
2288 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2295 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2299 if (PL_op->op_private & HINT_INTEGER) {
2300 const IV i = ~SvIV_nomg(sv);
2304 const UV u = ~SvUV_nomg(sv);
2313 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2314 sv_setsv_nomg(TARG, sv);
2315 tmps = (U8*)SvPV_force_nomg(TARG, len);
2318 /* Calculate exact length, let's not estimate. */
2323 U8 * const send = tmps + len;
2324 U8 * const origtmps = tmps;
2325 const UV utf8flags = UTF8_ALLOW_ANYUV;
2327 while (tmps < send) {
2328 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2330 targlen += UNISKIP(~c);
2336 /* Now rewind strings and write them. */
2343 Newx(result, targlen + 1, U8);
2345 while (tmps < send) {
2346 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2348 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2351 sv_usepvn_flags(TARG, (char*)result, targlen,
2352 SV_HAS_TRAILING_NUL);
2359 Newx(result, nchar + 1, U8);
2361 while (tmps < send) {
2362 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2367 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2376 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2379 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2384 for ( ; anum > 0; anum--, tmps++)
2392 /* integer versions of some of the above */
2396 dVAR; dSP; dATARGET;
2397 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2400 SETi( left * right );
2408 dVAR; dSP; dATARGET;
2409 tryAMAGICbin_MG(div_amg, AMGf_assign);
2412 IV value = SvIV_nomg(right);
2414 DIE(aTHX_ "Illegal division by zero");
2415 num = SvIV_nomg(left);
2417 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2421 value = num / value;
2427 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2434 /* This is the vanilla old i_modulo. */
2435 dVAR; dSP; dATARGET;
2436 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2440 DIE(aTHX_ "Illegal modulus zero");
2441 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2445 SETi( left % right );
2450 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2455 /* This is the i_modulo with the workaround for the _moddi3 bug
2456 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2457 * See below for pp_i_modulo. */
2458 dVAR; dSP; dATARGET;
2459 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2463 DIE(aTHX_ "Illegal modulus zero");
2464 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2468 SETi( left % PERL_ABS(right) );
2475 dVAR; dSP; dATARGET;
2476 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2480 DIE(aTHX_ "Illegal modulus zero");
2481 /* The assumption is to use hereafter the old vanilla version... */
2483 PL_ppaddr[OP_I_MODULO] =
2485 /* .. but if we have glibc, we might have a buggy _moddi3
2486 * (at least glicb 2.2.5 is known to have this bug), in other
2487 * words our integer modulus with negative quad as the second
2488 * argument might be broken. Test for this and re-patch the
2489 * opcode dispatch table if that is the case, remembering to
2490 * also apply the workaround so that this first round works
2491 * right, too. See [perl #9402] for more information. */
2495 /* Cannot do this check with inlined IV constants since
2496 * that seems to work correctly even with the buggy glibc. */
2498 /* Yikes, we have the bug.
2499 * Patch in the workaround version. */
2501 PL_ppaddr[OP_I_MODULO] =
2502 &Perl_pp_i_modulo_1;
2503 /* Make certain we work right this time, too. */
2504 right = PERL_ABS(right);
2507 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2511 SETi( left % right );
2519 dVAR; dSP; dATARGET;
2520 tryAMAGICbin_MG(add_amg, AMGf_assign);
2522 dPOPTOPiirl_ul_nomg;
2523 SETi( left + right );
2530 dVAR; dSP; dATARGET;
2531 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2533 dPOPTOPiirl_ul_nomg;
2534 SETi( left - right );
2542 tryAMAGICbin_MG(lt_amg, AMGf_set);
2545 SETs(boolSV(left < right));
2553 tryAMAGICbin_MG(gt_amg, AMGf_set);
2556 SETs(boolSV(left > right));
2564 tryAMAGICbin_MG(le_amg, AMGf_set);
2567 SETs(boolSV(left <= right));
2575 tryAMAGICbin_MG(ge_amg, AMGf_set);
2578 SETs(boolSV(left >= right));
2586 tryAMAGICbin_MG(eq_amg, AMGf_set);
2589 SETs(boolSV(left == right));
2597 tryAMAGICbin_MG(ne_amg, AMGf_set);
2600 SETs(boolSV(left != right));
2608 tryAMAGICbin_MG(ncmp_amg, 0);
2615 else if (left < right)
2627 tryAMAGICun_MG(neg_amg, 0);
2628 if (S_negate_string(aTHX)) return NORMAL;
2630 SV * const sv = TOPs;
2631 IV const i = SvIV_nomg(sv);
2637 /* High falutin' math. */
2642 tryAMAGICbin_MG(atan2_amg, 0);
2645 SETn(Perl_atan2(left, right));
2653 int amg_type = sin_amg;
2654 const char *neg_report = NULL;
2655 NV (*func)(NV) = Perl_sin;
2656 const int op_type = PL_op->op_type;
2673 amg_type = sqrt_amg;
2675 neg_report = "sqrt";
2680 tryAMAGICun_MG(amg_type, 0);
2682 SV * const arg = POPs;
2683 const NV value = SvNV_nomg(arg);
2685 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2686 SET_NUMERIC_STANDARD();
2687 /* diag_listed_as: Can't take log of %g */
2688 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2691 XPUSHn(func(value));
2696 /* Support Configure command-line overrides for rand() functions.
2697 After 5.005, perhaps we should replace this by Configure support
2698 for drand48(), random(), or rand(). For 5.005, though, maintain
2699 compatibility by calling rand() but allow the user to override it.
2700 See INSTALL for details. --Andy Dougherty 15 July 1998
2702 /* Now it's after 5.005, and Configure supports drand48() and random(),
2703 in addition to rand(). So the overrides should not be needed any more.
2704 --Jarkko Hietaniemi 27 September 1998
2707 #ifndef HAS_DRAND48_PROTO
2708 extern double drand48 (void);
2714 if (!PL_srand_called) {
2715 (void)seedDrand01((Rand_seed_t)seed());
2716 PL_srand_called = TRUE;
2726 SV * const sv = POPs;
2732 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2740 sv_setnv_mg(TARG, value);
2751 if (MAXARG >= 1 && (TOPs || POPs)) {
2758 pv = SvPV(top, len);
2759 flags = grok_number(pv, len, &anum);
2761 if (!(flags & IS_NUMBER_IN_UV)) {
2762 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2763 "Integer overflow in srand");
2771 (void)seedDrand01((Rand_seed_t)anum);
2772 PL_srand_called = TRUE;
2776 /* Historically srand always returned true. We can avoid breaking
2778 sv_setpvs(TARG, "0 but true");
2787 tryAMAGICun_MG(int_amg, AMGf_numeric);
2789 SV * const sv = TOPs;
2790 const IV iv = SvIV_nomg(sv);
2791 /* XXX it's arguable that compiler casting to IV might be subtly
2792 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2793 else preferring IV has introduced a subtle behaviour change bug. OTOH
2794 relying on floating point to be accurate is a bug. */
2799 else if (SvIOK(sv)) {
2801 SETu(SvUV_nomg(sv));
2806 const NV value = SvNV_nomg(sv);
2808 if (value < (NV)UV_MAX + 0.5) {
2811 SETn(Perl_floor(value));
2815 if (value > (NV)IV_MIN - 0.5) {
2818 SETn(Perl_ceil(value));
2829 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2831 SV * const sv = TOPs;
2832 /* This will cache the NV value if string isn't actually integer */
2833 const IV iv = SvIV_nomg(sv);
2838 else if (SvIOK(sv)) {
2839 /* IVX is precise */
2841 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2849 /* 2s complement assumption. Also, not really needed as
2850 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2856 const NV value = SvNV_nomg(sv);
2870 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2874 SV* const sv = POPs;
2876 tmps = (SvPV_const(sv, len));
2878 /* If Unicode, try to downgrade
2879 * If not possible, croak. */
2880 SV* const tsv = sv_2mortal(newSVsv(sv));
2883 sv_utf8_downgrade(tsv, FALSE);
2884 tmps = SvPV_const(tsv, len);
2886 if (PL_op->op_type == OP_HEX)
2889 while (*tmps && len && isSPACE(*tmps))
2893 if (*tmps == 'x' || *tmps == 'X') {
2895 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2897 else if (*tmps == 'b' || *tmps == 'B')
2898 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2900 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2902 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2916 SV * const sv = TOPs;
2921 SETi(sv_len_utf8_nomg(sv));
2925 (void)SvPV_nomg_const(sv,len);
2929 if (!SvPADTMP(TARG)) {
2930 sv_setsv_nomg(TARG, &PL_sv_undef);
2938 /* Returns false if substring is completely outside original string.
2939 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2940 always be true for an explicit 0.
2943 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2944 bool pos1_is_uv, IV len_iv,
2945 bool len_is_uv, STRLEN *posp,
2951 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2953 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2954 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2957 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2960 if (len_iv || len_is_uv) {
2961 if (!len_is_uv && len_iv < 0) {
2962 pos2_iv = curlen + len_iv;
2964 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2967 } else { /* len_iv >= 0 */
2968 if (!pos1_is_uv && pos1_iv < 0) {
2969 pos2_iv = pos1_iv + len_iv;
2970 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2972 if ((UV)len_iv > curlen-(UV)pos1_iv)
2975 pos2_iv = pos1_iv+len_iv;
2985 if (!pos2_is_uv && pos2_iv < 0) {
2986 if (!pos1_is_uv && pos1_iv < 0)
2990 else if (!pos1_is_uv && pos1_iv < 0)
2993 if ((UV)pos2_iv < (UV)pos1_iv)
2995 if ((UV)pos2_iv > curlen)
2998 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2999 *posp = (STRLEN)( (UV)pos1_iv );
3000 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3017 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3018 const bool rvalue = (GIMME_V != G_VOID);
3021 const char *repl = NULL;
3023 int num_args = PL_op->op_private & 7;
3024 bool repl_need_utf8_upgrade = FALSE;
3028 if(!(repl_sv = POPs)) num_args--;
3030 if ((len_sv = POPs)) {
3031 len_iv = SvIV(len_sv);
3032 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3037 pos1_iv = SvIV(pos_sv);
3038 pos1_is_uv = SvIOK_UV(pos_sv);
3040 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3045 if (lvalue && !repl_sv) {
3047 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3048 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3050 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3052 pos1_is_uv || pos1_iv >= 0
3053 ? (STRLEN)(UV)pos1_iv
3054 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3056 len_is_uv || len_iv > 0
3057 ? (STRLEN)(UV)len_iv
3058 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3061 PUSHs(ret); /* avoid SvSETMAGIC here */
3065 repl = SvPV_const(repl_sv, repl_len);
3068 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3069 "Attempt to use reference as lvalue in substr"
3071 tmps = SvPV_force_nomg(sv, curlen);
3072 if (DO_UTF8(repl_sv) && repl_len) {
3074 sv_utf8_upgrade_nomg(sv);
3078 else if (DO_UTF8(sv))
3079 repl_need_utf8_upgrade = TRUE;
3081 else tmps = SvPV_const(sv, curlen);
3083 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3084 if (utf8_curlen == curlen)
3087 curlen = utf8_curlen;
3093 STRLEN pos, len, byte_len, byte_pos;
3095 if (!translate_substr_offsets(
3096 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3100 byte_pos = utf8_curlen
3101 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3106 SvTAINTED_off(TARG); /* decontaminate */
3107 SvUTF8_off(TARG); /* decontaminate */
3108 sv_setpvn(TARG, tmps, byte_len);
3109 #ifdef USE_LOCALE_COLLATE
3110 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3117 SV* repl_sv_copy = NULL;
3119 if (repl_need_utf8_upgrade) {
3120 repl_sv_copy = newSVsv(repl_sv);
3121 sv_utf8_upgrade(repl_sv_copy);
3122 repl = SvPV_const(repl_sv_copy, repl_len);
3126 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3127 SvREFCNT_dec(repl_sv_copy);
3139 Perl_croak(aTHX_ "substr outside of string");
3140 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3147 const IV size = POPi;
3148 const IV offset = POPi;
3149 SV * const src = POPs;
3150 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3153 if (lvalue) { /* it's an lvalue! */
3154 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3155 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3157 LvTARG(ret) = SvREFCNT_inc_simple(src);
3158 LvTARGOFF(ret) = offset;
3159 LvTARGLEN(ret) = size;
3163 SvTAINTED_off(TARG); /* decontaminate */
3167 sv_setuv(ret, do_vecget(src, offset, size));
3183 const char *little_p;
3186 const bool is_index = PL_op->op_type == OP_INDEX;
3187 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3193 big_p = SvPV_const(big, biglen);
3194 little_p = SvPV_const(little, llen);
3196 big_utf8 = DO_UTF8(big);
3197 little_utf8 = DO_UTF8(little);
3198 if (big_utf8 ^ little_utf8) {
3199 /* One needs to be upgraded. */
3200 if (little_utf8 && !PL_encoding) {
3201 /* Well, maybe instead we might be able to downgrade the small
3203 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3206 /* If the large string is ISO-8859-1, and it's not possible to
3207 convert the small string to ISO-8859-1, then there is no
3208 way that it could be found anywhere by index. */
3213 /* At this point, pv is a malloc()ed string. So donate it to temp
3214 to ensure it will get free()d */
3215 little = temp = newSV(0);
3216 sv_usepvn(temp, pv, llen);
3217 little_p = SvPVX(little);
3220 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3223 sv_recode_to_utf8(temp, PL_encoding);
3225 sv_utf8_upgrade(temp);
3230 big_p = SvPV_const(big, biglen);
3233 little_p = SvPV_const(little, llen);
3237 if (SvGAMAGIC(big)) {
3238 /* Life just becomes a lot easier if I use a temporary here.
3239 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3240 will trigger magic and overloading again, as will fbm_instr()
3242 big = newSVpvn_flags(big_p, biglen,
3243 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3246 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3247 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3248 warn on undef, and we've already triggered a warning with the
3249 SvPV_const some lines above. We can't remove that, as we need to
3250 call some SvPV to trigger overloading early and find out if the
3252 This is all getting to messy. The API isn't quite clean enough,
3253 because data access has side effects.
3255 little = newSVpvn_flags(little_p, llen,
3256 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3257 little_p = SvPVX(little);
3261 offset = is_index ? 0 : biglen;
3263 if (big_utf8 && offset > 0)
3264 sv_pos_u2b(big, &offset, 0);
3270 else if (offset > (I32)biglen)
3272 if (!(little_p = is_index
3273 ? fbm_instr((unsigned char*)big_p + offset,
3274 (unsigned char*)big_p + biglen, little, 0)
3275 : rninstr(big_p, big_p + offset,
3276 little_p, little_p + llen)))
3279 retval = little_p - big_p;
3280 if (retval > 0 && big_utf8)
3281 sv_pos_b2u(big, &retval);
3291 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3292 SvTAINTED_off(TARG);
3293 do_sprintf(TARG, SP-MARK, MARK+1);
3294 TAINT_IF(SvTAINTED(TARG));
3306 const U8 *s = (U8*)SvPV_const(argsv, len);
3308 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3309 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3310 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3314 XPUSHu(DO_UTF8(argsv) ?
3315 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3329 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3330 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3332 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3333 && SvNV_nomg(top) < 0.0))) {
3334 if (ckWARN(WARN_UTF8)) {
3335 if (SvGMAGICAL(top)) {
3336 SV *top2 = sv_newmortal();
3337 sv_setsv_nomg(top2, top);
3340 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3341 "Invalid negative number (%"SVf") in chr", top);
3343 value = UNICODE_REPLACEMENT;
3345 value = SvUV_nomg(top);
3348 SvUPGRADE(TARG,SVt_PV);
3350 if (value > 255 && !IN_BYTES) {
3351 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3352 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3353 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3355 (void)SvPOK_only(TARG);
3364 *tmps++ = (char)value;
3366 (void)SvPOK_only(TARG);
3368 if (PL_encoding && !IN_BYTES) {
3369 sv_recode_to_utf8(TARG, PL_encoding);
3371 if (SvCUR(TARG) == 0
3372 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3373 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3378 *tmps++ = (char)value;
3394 const char *tmps = SvPV_const(left, len);
3396 if (DO_UTF8(left)) {
3397 /* If Unicode, try to downgrade.
3398 * If not possible, croak.
3399 * Yes, we made this up. */
3400 SV* const tsv = sv_2mortal(newSVsv(left));
3403 sv_utf8_downgrade(tsv, FALSE);
3404 tmps = SvPV_const(tsv, len);
3406 # ifdef USE_ITHREADS
3408 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3409 /* This should be threadsafe because in ithreads there is only
3410 * one thread per interpreter. If this would not be true,
3411 * we would need a mutex to protect this malloc. */
3412 PL_reentrant_buffer->_crypt_struct_buffer =
3413 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3414 #if defined(__GLIBC__) || defined(__EMX__)
3415 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3416 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3417 /* work around glibc-2.2.5 bug */
3418 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3422 # endif /* HAS_CRYPT_R */
3423 # endif /* USE_ITHREADS */
3425 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3427 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3433 "The crypt() function is unimplemented due to excessive paranoia.");
3437 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3438 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3442 /* Actually is both lcfirst() and ucfirst(). Only the first character
3443 * changes. This means that possibly we can change in-place, ie., just
3444 * take the source and change that one character and store it back, but not
3445 * if read-only etc, or if the length changes */
3450 STRLEN slen; /* slen is the byte length of the whole SV. */
3453 bool inplace; /* ? Convert first char only, in-place */
3454 bool doing_utf8 = FALSE; /* ? using utf8 */
3455 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3456 const int op_type = PL_op->op_type;
3459 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3460 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3461 * stored as UTF-8 at s. */
3462 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3463 * lowercased) character stored in tmpbuf. May be either
3464 * UTF-8 or not, but in either case is the number of bytes */
3465 bool tainted = FALSE;
3469 s = (const U8*)SvPV_nomg_const(source, slen);
3471 if (ckWARN(WARN_UNINITIALIZED))
3472 report_uninit(source);
3477 /* We may be able to get away with changing only the first character, in
3478 * place, but not if read-only, etc. Later we may discover more reasons to
3479 * not convert in-place. */
3480 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3482 /* First calculate what the changed first character should be. This affects
3483 * whether we can just swap it out, leaving the rest of the string unchanged,
3484 * or even if have to convert the dest to UTF-8 when the source isn't */
3486 if (! slen) { /* If empty */
3487 need = 1; /* still need a trailing NUL */
3490 else if (DO_UTF8(source)) { /* Is the source utf8? */
3493 if (op_type == OP_UCFIRST) {
3494 _to_utf8_title_flags(s, tmpbuf, &tculen,
3495 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3498 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3499 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3502 /* we can't do in-place if the length changes. */
3503 if (ulen != tculen) inplace = FALSE;
3504 need = slen + 1 - ulen + tculen;
3506 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3507 * latin1 is treated as caseless. Note that a locale takes
3509 ulen = 1; /* Original character is 1 byte */
3510 tculen = 1; /* Most characters will require one byte, but this will
3511 * need to be overridden for the tricky ones */
3514 if (op_type == OP_LCFIRST) {
3516 /* lower case the first letter: no trickiness for any character */
3517 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3518 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3521 else if (IN_LOCALE_RUNTIME) {
3522 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3523 * have upper and title case different
3526 else if (! IN_UNI_8_BIT) {
3527 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3528 * on EBCDIC machines whatever the
3529 * native function does */
3531 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3532 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3534 assert(tculen == 2);
3536 /* If the result is an upper Latin1-range character, it can
3537 * still be represented in one byte, which is its ordinal */
3538 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3539 *tmpbuf = (U8) title_ord;
3543 /* Otherwise it became more than one ASCII character (in
3544 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3545 * beyond Latin1, so the number of bytes changed, so can't
3546 * replace just the first character in place. */
3549 /* If the result won't fit in a byte, the entire result
3550 * will have to be in UTF-8. Assume worst case sizing in
3551 * conversion. (all latin1 characters occupy at most two
3553 if (title_ord > 255) {
3555 convert_source_to_utf8 = TRUE;
3556 need = slen * 2 + 1;
3558 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3559 * (both) characters whose title case is above 255 is
3563 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3564 need = slen + 1 + 1;
3568 } /* End of use Unicode (Latin1) semantics */
3569 } /* End of changing the case of the first character */
3571 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3572 * generate the result */
3575 /* We can convert in place. This means we change just the first
3576 * character without disturbing the rest; no need to grow */
3578 s = d = (U8*)SvPV_force_nomg(source, slen);
3584 /* Here, we can't convert in place; we earlier calculated how much
3585 * space we will need, so grow to accommodate that */
3586 SvUPGRADE(dest, SVt_PV);
3587 d = (U8*)SvGROW(dest, need);
3588 (void)SvPOK_only(dest);
3595 if (! convert_source_to_utf8) {
3597 /* Here both source and dest are in UTF-8, but have to create
3598 * the entire output. We initialize the result to be the
3599 * title/lower cased first character, and then append the rest
3601 sv_setpvn(dest, (char*)tmpbuf, tculen);
3603 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3607 const U8 *const send = s + slen;
3609 /* Here the dest needs to be in UTF-8, but the source isn't,
3610 * except we earlier UTF-8'd the first character of the source
3611 * into tmpbuf. First put that into dest, and then append the
3612 * rest of the source, converting it to UTF-8 as we go. */
3614 /* Assert tculen is 2 here because the only two characters that
3615 * get to this part of the code have 2-byte UTF-8 equivalents */
3617 *d++ = *(tmpbuf + 1);
3618 s++; /* We have just processed the 1st char */
3620 for (; s < send; s++) {
3621 d = uvchr_to_utf8(d, *s);
3624 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3628 else { /* in-place UTF-8. Just overwrite the first character */
3629 Copy(tmpbuf, d, tculen, U8);
3630 SvCUR_set(dest, need - 1);
3638 else { /* Neither source nor dest are in or need to be UTF-8 */
3640 if (IN_LOCALE_RUNTIME) {
3644 if (inplace) { /* in-place, only need to change the 1st char */
3647 else { /* Not in-place */
3649 /* Copy the case-changed character(s) from tmpbuf */
3650 Copy(tmpbuf, d, tculen, U8);
3651 d += tculen - 1; /* Code below expects d to point to final
3652 * character stored */
3655 else { /* empty source */
3656 /* See bug #39028: Don't taint if empty */
3660 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3661 * the destination to retain that flag */
3665 if (!inplace) { /* Finish the rest of the string, unchanged */
3666 /* This will copy the trailing NUL */
3667 Copy(s + 1, d + 1, slen, U8);
3668 SvCUR_set(dest, need - 1);
3671 if (dest != source && SvTAINTED(source))
3677 /* There's so much setup/teardown code common between uc and lc, I wonder if
3678 it would be worth merging the two, and just having a switch outside each
3679 of the three tight loops. There is less and less commonality though */
3693 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3694 && SvTEMP(source) && !DO_UTF8(source)
3695 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3697 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3698 * make the loop tight, so we overwrite the source with the dest before
3699 * looking at it, and we need to look at the original source
3700 * afterwards. There would also need to be code added to handle
3701 * switching to not in-place in midstream if we run into characters
3702 * that change the length.
3705 s = d = (U8*)SvPV_force_nomg(source, len);
3712 /* The old implementation would copy source into TARG at this point.
3713 This had the side effect that if source was undef, TARG was now
3714 an undefined SV with PADTMP set, and they don't warn inside
3715 sv_2pv_flags(). However, we're now getting the PV direct from
3716 source, which doesn't have PADTMP set, so it would warn. Hence the
3720 s = (const U8*)SvPV_nomg_const(source, len);
3722 if (ckWARN(WARN_UNINITIALIZED))
3723 report_uninit(source);
3729 SvUPGRADE(dest, SVt_PV);
3730 d = (U8*)SvGROW(dest, min);
3731 (void)SvPOK_only(dest);
3736 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3737 to check DO_UTF8 again here. */
3739 if (DO_UTF8(source)) {
3740 const U8 *const send = s + len;
3741 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3742 bool tainted = FALSE;
3744 /* All occurrences of these are to be moved to follow any other marks.
3745 * This is context-dependent. We may not be passed enough context to
3746 * move the iota subscript beyond all of them, but we do the best we can
3747 * with what we're given. The result is always better than if we
3748 * hadn't done this. And, the problem would only arise if we are
3749 * passed a character without all its combining marks, which would be
3750 * the caller's mistake. The information this is based on comes from a
3751 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3752 * itself) and so can't be checked properly to see if it ever gets
3753 * revised. But the likelihood of it changing is remote */
3754 bool in_iota_subscript = FALSE;
3760 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3762 /* A non-mark. Time to output the iota subscript */
3763 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3764 d += capital_iota_len;
3765 in_iota_subscript = FALSE;
3768 /* Then handle the current character. Get the changed case value
3769 * and copy it to the output buffer */
3772 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3773 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3774 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3775 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3776 if (uv == GREEK_CAPITAL_LETTER_IOTA
3777 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3779 in_iota_subscript = TRUE;
3782 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3783 /* If the eventually required minimum size outgrows the
3784 * available space, we need to grow. */
3785 const UV o = d - (U8*)SvPVX_const(dest);
3787 /* If someone uppercases one million U+03B0s we SvGROW()
3788 * one million times. Or we could try guessing how much to
3789 * allocate without allocating too much. Such is life.
3790 * See corresponding comment in lc code for another option
3793 d = (U8*)SvPVX(dest) + o;
3795 Copy(tmpbuf, d, ulen, U8);
3800 if (in_iota_subscript) {
3801 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3802 d += capital_iota_len;
3807 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3813 else { /* Not UTF-8 */
3815 const U8 *const send = s + len;
3817 /* Use locale casing if in locale; regular style if not treating
3818 * latin1 as having case; otherwise the latin1 casing. Do the
3819 * whole thing in a tight loop, for speed, */
3820 if (IN_LOCALE_RUNTIME) {
3823 for (; s < send; d++, s++)
3824 *d = toUPPER_LC(*s);
3826 else if (! IN_UNI_8_BIT) {
3827 for (; s < send; d++, s++) {
3832 for (; s < send; d++, s++) {
3833 *d = toUPPER_LATIN1_MOD(*s);
3834 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3838 /* The mainstream case is the tight loop above. To avoid
3839 * extra tests in that, all three characters that require
3840 * special handling are mapped by the MOD to the one tested
3842 * Use the source to distinguish between the three cases */
3844 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3846 /* uc() of this requires 2 characters, but they are
3847 * ASCII. If not enough room, grow the string */
3848 if (SvLEN(dest) < ++min) {
3849 const UV o = d - (U8*)SvPVX_const(dest);
3851 d = (U8*)SvPVX(dest) + o;
3853 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3854 continue; /* Back to the tight loop; still in ASCII */
3857 /* The other two special handling characters have their
3858 * upper cases outside the latin1 range, hence need to be
3859 * in UTF-8, so the whole result needs to be in UTF-8. So,
3860 * here we are somewhere in the middle of processing a
3861 * non-UTF-8 string, and realize that we will have to convert
3862 * the whole thing to UTF-8. What to do? There are
3863 * several possibilities. The simplest to code is to
3864 * convert what we have so far, set a flag, and continue on
3865 * in the loop. The flag would be tested each time through
3866 * the loop, and if set, the next character would be
3867 * converted to UTF-8 and stored. But, I (khw) didn't want
3868 * to slow down the mainstream case at all for this fairly
3869 * rare case, so I didn't want to add a test that didn't
3870 * absolutely have to be there in the loop, besides the
3871 * possibility that it would get too complicated for
3872 * optimizers to deal with. Another possibility is to just
3873 * give up, convert the source to UTF-8, and restart the
3874 * function that way. Another possibility is to convert
3875 * both what has already been processed and what is yet to
3876 * come separately to UTF-8, then jump into the loop that
3877 * handles UTF-8. But the most efficient time-wise of the
3878 * ones I could think of is what follows, and turned out to
3879 * not require much extra code. */
3881 /* Convert what we have so far into UTF-8, telling the
3882 * function that we know it should be converted, and to
3883 * allow extra space for what we haven't processed yet.
3884 * Assume the worst case space requirements for converting
3885 * what we haven't processed so far: that it will require
3886 * two bytes for each remaining source character, plus the
3887 * NUL at the end. This may cause the string pointer to
3888 * move, so re-find it. */
3890 len = d - (U8*)SvPVX_const(dest);
3891 SvCUR_set(dest, len);
3892 len = sv_utf8_upgrade_flags_grow(dest,
3893 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3895 d = (U8*)SvPVX(dest) + len;
3897 /* Now process the remainder of the source, converting to
3898 * upper and UTF-8. If a resulting byte is invariant in
3899 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3900 * append it to the output. */
3901 for (; s < send; s++) {
3902 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3906 /* Here have processed the whole source; no need to continue
3907 * with the outer loop. Each character has been converted
3908 * to upper case and converted to UTF-8 */
3911 } /* End of processing all latin1-style chars */
3912 } /* End of processing all chars */
3913 } /* End of source is not empty */
3915 if (source != dest) {
3916 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3917 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3919 } /* End of isn't utf8 */
3920 if (dest != source && SvTAINTED(source))
3939 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3940 && SvTEMP(source) && !DO_UTF8(source)) {
3942 /* We can convert in place, as lowercasing anything in the latin1 range
3943 * (or else DO_UTF8 would have been on) doesn't lengthen it */
3945 s = d = (U8*)SvPV_force_nomg(source, len);
3952 /* The old implementation would copy source into TARG at this point.
3953 This had the side effect that if source was undef, TARG was now
3954 an undefined SV with PADTMP set, and they don't warn inside
3955 sv_2pv_flags(). However, we're now getting the PV direct from
3956 source, which doesn't have PADTMP set, so it would warn. Hence the
3960 s = (const U8*)SvPV_nomg_const(source, len);
3962 if (ckWARN(WARN_UNINITIALIZED))
3963 report_uninit(source);
3969 SvUPGRADE(dest, SVt_PV);
3970 d = (U8*)SvGROW(dest, min);
3971 (void)SvPOK_only(dest);
3976 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3977 to check DO_UTF8 again here. */
3979 if (DO_UTF8(source)) {
3980 const U8 *const send = s + len;
3981 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3982 bool tainted = FALSE;
3985 const STRLEN u = UTF8SKIP(s);
3988 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3989 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3991 /* Here is where we would do context-sensitive actions. See the
3992 * commit message for this comment for why there isn't any */
3994 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3996 /* If the eventually required minimum size outgrows the
3997 * available space, we need to grow. */
3998 const UV o = d - (U8*)SvPVX_const(dest);
4000 /* If someone lowercases one million U+0130s we SvGROW() one
4001 * million times. Or we could try guessing how much to
4002 * allocate without allocating too much. Such is life.
4003 * Another option would be to grow an extra byte or two more
4004 * each time we need to grow, which would cut down the million
4005 * to 500K, with little waste */
4007 d = (U8*)SvPVX(dest) + o;
4010 /* Copy the newly lowercased letter to the output buffer we're
4012 Copy(tmpbuf, d, ulen, U8);
4015 } /* End of looping through the source string */
4018 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4023 } else { /* Not utf8 */
4025 const U8 *const send = s + len;
4027 /* Use locale casing if in locale; regular style if not treating
4028 * latin1 as having case; otherwise the latin1 casing. Do the
4029 * whole thing in a tight loop, for speed, */
4030 if (IN_LOCALE_RUNTIME) {
4033 for (; s < send; d++, s++)
4034 *d = toLOWER_LC(*s);
4036 else if (! IN_UNI_8_BIT) {
4037 for (; s < send; d++, s++) {
4042 for (; s < send; d++, s++) {
4043 *d = toLOWER_LATIN1(*s);
4047 if (source != dest) {
4049 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4052 if (dest != source && SvTAINTED(source))
4061 SV * const sv = TOPs;
4063 const char *s = SvPV_const(sv,len);
4065 SvUTF8_off(TARG); /* decontaminate */
4068 SvUPGRADE(TARG, SVt_PV);
4069 SvGROW(TARG, (len * 2) + 1);
4073 STRLEN ulen = UTF8SKIP(s);
4074 bool to_quote = FALSE;
4076 if (UTF8_IS_INVARIANT(*s)) {
4077 if (_isQUOTEMETA(*s)) {
4081 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4083 /* In locale, we quote all non-ASCII Latin1 chars.
4084 * Otherwise use the quoting rules */
4085 if (IN_LOCALE_RUNTIME
4086 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
4091 else if (is_QUOTEMETA_high(s)) {
4106 else if (IN_UNI_8_BIT) {
4108 if (_isQUOTEMETA(*s))
4114 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4115 * including everything above ASCII */
4117 if (!isWORDCHAR_A(*s))
4123 SvCUR_set(TARG, d - SvPVX_const(TARG));
4124 (void)SvPOK_only_UTF8(TARG);
4127 sv_setpvn(TARG, s, len);
4144 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4145 const bool full_folding = TRUE;
4146 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4147 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4149 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4150 * You are welcome(?) -Hugmeir
4158 s = (const U8*)SvPV_nomg_const(source, len);
4160 if (ckWARN(WARN_UNINITIALIZED))
4161 report_uninit(source);
4168 SvUPGRADE(dest, SVt_PV);
4169 d = (U8*)SvGROW(dest, min);
4170 (void)SvPOK_only(dest);
4175 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4176 bool tainted = FALSE;
4178 const STRLEN u = UTF8SKIP(s);
4181 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4183 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4184 const UV o = d - (U8*)SvPVX_const(dest);
4186 d = (U8*)SvPVX(dest) + o;
4189 Copy(tmpbuf, d, ulen, U8);
4198 } /* Unflagged string */
4200 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4203 for (; s < send; d++, s++)
4206 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4207 for (; s < send; d++, s++)
4211 /* For ASCII and the Latin-1 range, there's only two troublesome
4212 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4213 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4214 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4215 * For the rest, the casefold is their lowercase. */
4216 for (; s < send; d++, s++) {
4217 if (*s == MICRO_SIGN) {
4218 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4219 * which is outside of the latin-1 range. There's a couple
4220 * of ways to deal with this -- khw discusses them in
4221 * pp_lc/uc, so go there :) What we do here is upgrade what
4222 * we had already casefolded, then enter an inner loop that
4223 * appends the rest of the characters as UTF-8. */
4224 len = d - (U8*)SvPVX_const(dest);
4225 SvCUR_set(dest, len);
4226 len = sv_utf8_upgrade_flags_grow(dest,
4227 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4228 /* The max expansion for latin1
4229 * chars is 1 byte becomes 2 */
4231 d = (U8*)SvPVX(dest) + len;
4233 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4236 for (; s < send; s++) {
4238 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4239 if UNI_IS_INVARIANT(fc) {
4241 && *s == LATIN_SMALL_LETTER_SHARP_S)
4250 Copy(tmpbuf, d, ulen, U8);
4256 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4257 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4258 * becomes "ss", which may require growing the SV. */
4259 if (SvLEN(dest) < ++min) {
4260 const UV o = d - (U8*)SvPVX_const(dest);
4262 d = (U8*)SvPVX(dest) + o;
4267 else { /* If it's not one of those two, the fold is their lower
4269 *d = toLOWER_LATIN1(*s);
4275 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4277 if (SvTAINTED(source))
4287 dVAR; dSP; dMARK; dORIGMARK;
4288 AV *const av = MUTABLE_AV(POPs);
4289 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4291 if (SvTYPE(av) == SVt_PVAV) {
4292 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4293 bool can_preserve = FALSE;
4299 can_preserve = SvCANEXISTDELETE(av);
4302 if (lval && localizing) {
4305 for (svp = MARK + 1; svp <= SP; svp++) {
4306 const I32 elem = SvIV(*svp);
4310 if (max > AvMAX(av))
4314 while (++MARK <= SP) {
4316 I32 elem = SvIV(*MARK);
4317 bool preeminent = TRUE;
4319 if (localizing && can_preserve) {
4320 /* If we can determine whether the element exist,
4321 * Try to preserve the existenceness of a tied array
4322 * element by using EXISTS and DELETE if possible.
4323 * Fallback to FETCH and STORE otherwise. */
4324 preeminent = av_exists(av, elem);
4327 svp = av_fetch(av, elem, lval);
4329 if (!svp || *svp == &PL_sv_undef)
4330 DIE(aTHX_ PL_no_aelem, elem);
4333 save_aelem(av, elem, svp);
4335 SAVEADELETE(av, elem);
4338 *MARK = svp ? *svp : &PL_sv_undef;
4341 if (GIMME != G_ARRAY) {
4343 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4349 /* Smart dereferencing for keys, values and each */
4361 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4366 "Type of argument to %s must be unblessed hashref or arrayref",
4367 PL_op_desc[PL_op->op_type] );
4370 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4372 "Can't modify %s in %s",
4373 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4376 /* Delegate to correct function for op type */
4378 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4379 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4382 return (SvTYPE(sv) == SVt_PVHV)
4383 ? Perl_pp_each(aTHX)
4384 : Perl_pp_aeach(aTHX);
4392 AV *array = MUTABLE_AV(POPs);
4393 const I32 gimme = GIMME_V;
4394 IV *iterp = Perl_av_iter_p(aTHX_ array);
4395 const IV current = (*iterp)++;
4397 if (current > av_len(array)) {
4399 if (gimme == G_SCALAR)
4407 if (gimme == G_ARRAY) {
4408 SV **const element = av_fetch(array, current, 0);
4409 PUSHs(element ? *element : &PL_sv_undef);
4418 AV *array = MUTABLE_AV(POPs);
4419 const I32 gimme = GIMME_V;
4421 *Perl_av_iter_p(aTHX_ array) = 0;
4423 if (gimme == G_SCALAR) {
4425 PUSHi(av_len(array) + 1);
4427 else if (gimme == G_ARRAY) {
4428 IV n = Perl_av_len(aTHX_ array);
4433 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4434 for (i = 0; i <= n; i++) {
4439 for (i = 0; i <= n; i++) {
4440 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4441 PUSHs(elem ? *elem : &PL_sv_undef);
4448 /* Associative arrays. */
4454 HV * hash = MUTABLE_HV(POPs);
4456 const I32 gimme = GIMME_V;
4459 /* might clobber stack_sp */
4460 entry = hv_iternext(hash);
4465 SV* const sv = hv_iterkeysv(entry);
4466 PUSHs(sv); /* won't clobber stack_sp */
4467 if (gimme == G_ARRAY) {
4470 /* might clobber stack_sp */
4471 val = hv_iterval(hash, entry);
4476 else if (gimme == G_SCALAR)
4483 S_do_delete_local(pTHX)
4487 const I32 gimme = GIMME_V;
4490 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4491 SV *unsliced_keysv = sliced ? NULL : POPs;
4492 SV * const osv = POPs;
4493 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4495 const bool tied = SvRMAGICAL(osv)
4496 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4497 const bool can_preserve = SvCANEXISTDELETE(osv);
4498 const U32 type = SvTYPE(osv);
4499 SV ** const end = sliced ? SP : &unsliced_keysv;
4501 if (type == SVt_PVHV) { /* hash element */
4502 HV * const hv = MUTABLE_HV(osv);
4503 while (++MARK <= end) {
4504 SV * const keysv = *MARK;
4506 bool preeminent = TRUE;
4508 preeminent = hv_exists_ent(hv, keysv, 0);
4510 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4517 sv = hv_delete_ent(hv, keysv, 0, 0);
4519 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4522 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4523 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4525 *MARK = sv_mortalcopy(sv);
4531 SAVEHDELETE(hv, keysv);
4532 *MARK = &PL_sv_undef;
4536 else if (type == SVt_PVAV) { /* array element */
4537 if (PL_op->op_flags & OPf_SPECIAL) {
4538 AV * const av = MUTABLE_AV(osv);
4539 while (++MARK <= end) {
4540 I32 idx = SvIV(*MARK);
4542 bool preeminent = TRUE;
4544 preeminent = av_exists(av, idx);
4546 SV **svp = av_fetch(av, idx, 1);
4553 sv = av_delete(av, idx, 0);
4555 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4558 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4560 *MARK = sv_mortalcopy(sv);
4566 SAVEADELETE(av, idx);
4567 *MARK = &PL_sv_undef;
4572 DIE(aTHX_ "panic: avhv_delete no longer supported");
4575 DIE(aTHX_ "Not a HASH reference");
4577 if (gimme == G_VOID)
4579 else if (gimme == G_SCALAR) {
4584 *++MARK = &PL_sv_undef;
4588 else if (gimme != G_VOID)
4589 PUSHs(unsliced_keysv);
4601 if (PL_op->op_private & OPpLVAL_INTRO)
4602 return do_delete_local();
4605 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4607 if (PL_op->op_private & OPpSLICE) {
4609 HV * const hv = MUTABLE_HV(POPs);
4610 const U32 hvtype = SvTYPE(hv);
4611 if (hvtype == SVt_PVHV) { /* hash element */
4612 while (++MARK <= SP) {
4613 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4614 *MARK = sv ? sv : &PL_sv_undef;
4617 else if (hvtype == SVt_PVAV) { /* array element */
4618 if (PL_op->op_flags & OPf_SPECIAL) {
4619 while (++MARK <= SP) {
4620 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4621 *MARK = sv ? sv : &PL_sv_undef;
4626 DIE(aTHX_ "Not a HASH reference");
4629 else if (gimme == G_SCALAR) {
4634 *++MARK = &PL_sv_undef;
4640 HV * const hv = MUTABLE_HV(POPs);
4642 if (SvTYPE(hv) == SVt_PVHV)
4643 sv = hv_delete_ent(hv, keysv, discard, 0);
4644 else if (SvTYPE(hv) == SVt_PVAV) {
4645 if (PL_op->op_flags & OPf_SPECIAL)
4646 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4648 DIE(aTHX_ "panic: avhv_delete no longer supported");
4651 DIE(aTHX_ "Not a HASH reference");
4667 if (PL_op->op_private & OPpEXISTS_SUB) {
4669 SV * const sv = POPs;
4670 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4673 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4678 hv = MUTABLE_HV(POPs);
4679 if (SvTYPE(hv) == SVt_PVHV) {
4680 if (hv_exists_ent(hv, tmpsv, 0))
4683 else if (SvTYPE(hv) == SVt_PVAV) {
4684 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4685 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4690 DIE(aTHX_ "Not a HASH reference");
4697 dVAR; dSP; dMARK; dORIGMARK;
4698 HV * const hv = MUTABLE_HV(POPs);
4699 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4700 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4701 bool can_preserve = FALSE;
4707 if (SvCANEXISTDELETE(hv))
4708 can_preserve = TRUE;
4711 while (++MARK <= SP) {
4712 SV * const keysv = *MARK;
4715 bool preeminent = TRUE;
4717 if (localizing && can_preserve) {
4718 /* If we can determine whether the element exist,
4719 * try to preserve the existenceness of a tied hash
4720 * element by using EXISTS and DELETE if possible.
4721 * Fallback to FETCH and STORE otherwise. */
4722 preeminent = hv_exists_ent(hv, keysv, 0);
4725 he = hv_fetch_ent(hv, keysv, lval, 0);
4726 svp = he ? &HeVAL(he) : NULL;
4729 if (!svp || !*svp || *svp == &PL_sv_undef) {
4730 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4733 if (HvNAME_get(hv) && isGV(*svp))
4734 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4735 else if (preeminent)
4736 save_helem_flags(hv, keysv, svp,
4737 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4739 SAVEHDELETE(hv, keysv);
4742 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4744 if (GIMME != G_ARRAY) {
4746 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4752 /* List operators. */
4757 if (GIMME != G_ARRAY) {
4759 *MARK = *SP; /* unwanted list, return last item */
4761 *MARK = &PL_sv_undef;
4771 SV ** const lastrelem = PL_stack_sp;
4772 SV ** const lastlelem = PL_stack_base + POPMARK;
4773 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4774 SV ** const firstrelem = lastlelem + 1;
4775 I32 is_something_there = FALSE;
4777 const I32 max = lastrelem - lastlelem;
4780 if (GIMME != G_ARRAY) {
4781 I32 ix = SvIV(*lastlelem);
4784 if (ix < 0 || ix >= max)
4785 *firstlelem = &PL_sv_undef;
4787 *firstlelem = firstrelem[ix];
4793 SP = firstlelem - 1;
4797 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4798 I32 ix = SvIV(*lelem);
4801 if (ix < 0 || ix >= max)
4802 *lelem = &PL_sv_undef;
4804 is_something_there = TRUE;
4805 if (!(*lelem = firstrelem[ix]))
4806 *lelem = &PL_sv_undef;
4809 if (is_something_there)
4812 SP = firstlelem - 1;
4819 const I32 items = SP - MARK;
4820 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4822 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4823 ? newRV_noinc(av) : av);
4829 dVAR; dSP; dMARK; dORIGMARK;
4830 HV* const hv = (HV *)sv_2mortal((SV *)newHV());
4834 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4841 sv_setsv(val, *MARK);
4845 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4848 (void)hv_store_ent(hv,key,val,0);
4851 if (PL_op->op_flags & OPf_SPECIAL)
4852 mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
4853 else XPUSHs(MUTABLE_SV(hv));
4858 S_deref_plain_array(pTHX_ AV *ary)
4860 if (SvTYPE(ary) == SVt_PVAV) return ary;
4861 SvGETMAGIC((SV *)ary);
4862 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4863 Perl_die(aTHX_ "Not an ARRAY reference");
4864 else if (SvOBJECT(SvRV(ary)))
4865 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4866 return (AV *)SvRV(ary);
4869 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4870 # define DEREF_PLAIN_ARRAY(ary) \
4873 SvTYPE(aRrRay) == SVt_PVAV \
4875 : S_deref_plain_array(aTHX_ aRrRay); \
4878 # define DEREF_PLAIN_ARRAY(ary) \
4880 PL_Sv = (SV *)(ary), \
4881 SvTYPE(PL_Sv) == SVt_PVAV \
4883 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4889 dVAR; dSP; dMARK; dORIGMARK;
4890 int num_args = (SP - MARK);
4891 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4900 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4903 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4904 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4911 offset = i = SvIV(*MARK);
4913 offset += AvFILLp(ary) + 1;
4915 DIE(aTHX_ PL_no_aelem, i);
4917 length = SvIVx(*MARK++);
4919 length += AvFILLp(ary) - offset + 1;
4925 length = AvMAX(ary) + 1; /* close enough to infinity */
4929 length = AvMAX(ary) + 1;
4931 if (offset > AvFILLp(ary) + 1) {
4933 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4934 offset = AvFILLp(ary) + 1;
4936 after = AvFILLp(ary) + 1 - (offset + length);
4937 if (after < 0) { /* not that much array */
4938 length += after; /* offset+length now in array */
4944 /* At this point, MARK .. SP-1 is our new LIST */
4947 diff = newlen - length;
4948 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4951 /* make new elements SVs now: avoid problems if they're from the array */
4952 for (dst = MARK, i = newlen; i; i--) {
4953 SV * const h = *dst;
4954 *dst++ = newSVsv(h);
4957 if (diff < 0) { /* shrinking the area */
4958 SV **tmparyval = NULL;
4960 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4961 Copy(MARK, tmparyval, newlen, SV*);
4964 MARK = ORIGMARK + 1;
4965 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4966 MEXTEND(MARK, length);
4967 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4969 EXTEND_MORTAL(length);
4970 for (i = length, dst = MARK; i; i--) {
4971 sv_2mortal(*dst); /* free them eventually */
4978 *MARK = AvARRAY(ary)[offset+length-1];
4981 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4982 SvREFCNT_dec(*dst++); /* free them now */
4985 AvFILLp(ary) += diff;
4987 /* pull up or down? */
4989 if (offset < after) { /* easier to pull up */
4990 if (offset) { /* esp. if nothing to pull */
4991 src = &AvARRAY(ary)[offset-1];
4992 dst = src - diff; /* diff is negative */
4993 for (i = offset; i > 0; i--) /* can't trust Copy */
4997 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5001 if (after) { /* anything to pull down? */
5002 src = AvARRAY(ary) + offset + length;
5003 dst = src + diff; /* diff is negative */
5004 Move(src, dst, after, SV*);
5006 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5007 /* avoid later double free */
5011 dst[--i] = &PL_sv_undef;
5014 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5015 Safefree(tmparyval);
5018 else { /* no, expanding (or same) */
5019 SV** tmparyval = NULL;
5021 Newx(tmparyval, length, SV*); /* so remember deletion */
5022 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5025 if (diff > 0) { /* expanding */
5026 /* push up or down? */
5027 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5031 Move(src, dst, offset, SV*);
5033 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5035 AvFILLp(ary) += diff;
5038 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5039 av_extend(ary, AvFILLp(ary) + diff);
5040 AvFILLp(ary) += diff;
5043 dst = AvARRAY(ary) + AvFILLp(ary);
5045 for (i = after; i; i--) {
5053 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5056 MARK = ORIGMARK + 1;
5057 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5059 Copy(tmparyval, MARK, length, SV*);
5061 EXTEND_MORTAL(length);
5062 for (i = length, dst = MARK; i; i--) {
5063 sv_2mortal(*dst); /* free them eventually */
5070 else if (length--) {
5071 *MARK = tmparyval[length];
5074 while (length-- > 0)
5075 SvREFCNT_dec(tmparyval[length]);
5079 *MARK = &PL_sv_undef;
5080 Safefree(tmparyval);
5084 mg_set(MUTABLE_SV(ary));
5092 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5093 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5094 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5097 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5100 ENTER_with_name("call_PUSH");
5101 call_method("PUSH",G_SCALAR|G_DISCARD);
5102 LEAVE_with_name("call_PUSH");
5106 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5107 PL_delaymagic = DM_DELAY;
5108 for (++MARK; MARK <= SP; MARK++) {
5110 if (*MARK) SvGETMAGIC(*MARK);
5113 sv_setsv_nomg(sv, *MARK);
5114 av_store(ary, AvFILLp(ary)+1, sv);
5116 if (PL_delaymagic & DM_ARRAY_ISA)
5117 mg_set(MUTABLE_SV(ary));
5122 if (OP_GIMME(PL_op, 0) != G_VOID) {
5123 PUSHi( AvFILL(ary) + 1 );
5132 AV * const av = PL_op->op_flags & OPf_SPECIAL
5133 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5134 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5138 (void)sv_2mortal(sv);
5145 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5146 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5147 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5150 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5153 ENTER_with_name("call_UNSHIFT");
5154 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5155 LEAVE_with_name("call_UNSHIFT");
5160 av_unshift(ary, SP - MARK);
5162 SV * const sv = newSVsv(*++MARK);
5163 (void)av_store(ary, i++, sv);
5167 if (OP_GIMME(PL_op, 0) != G_VOID) {
5168 PUSHi( AvFILL(ary) + 1 );
5177 if (GIMME == G_ARRAY) {
5178 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5182 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5183 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5184 av = MUTABLE_AV((*SP));
5185 /* In-place reversing only happens in void context for the array
5186 * assignment. We don't need to push anything on the stack. */
5189 if (SvMAGICAL(av)) {
5191 SV *tmp = sv_newmortal();
5192 /* For SvCANEXISTDELETE */
5195 bool can_preserve = SvCANEXISTDELETE(av);
5197 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5201 if (!av_exists(av, i)) {
5202 if (av_exists(av, j)) {
5203 SV *sv = av_delete(av, j, 0);
5204 begin = *av_fetch(av, i, TRUE);
5205 sv_setsv_mg(begin, sv);
5209 else if (!av_exists(av, j)) {
5210 SV *sv = av_delete(av, i, 0);
5211 end = *av_fetch(av, j, TRUE);
5212 sv_setsv_mg(end, sv);
5217 begin = *av_fetch(av, i, TRUE);
5218 end = *av_fetch(av, j, TRUE);
5219 sv_setsv(tmp, begin);
5220 sv_setsv_mg(begin, end);
5221 sv_setsv_mg(end, tmp);
5225 SV **begin = AvARRAY(av);
5228 SV **end = begin + AvFILLp(av);
5230 while (begin < end) {
5231 SV * const tmp = *begin;
5242 SV * const tmp = *MARK;
5246 /* safe as long as stack cannot get extended in the above */
5257 SvUTF8_off(TARG); /* decontaminate */
5259 do_join(TARG, &PL_sv_no, MARK, SP);
5261 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5262 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5263 report_uninit(TARG);
5266 up = SvPV_force(TARG, len);
5268 if (DO_UTF8(TARG)) { /* first reverse each character */
5269 U8* s = (U8*)SvPVX(TARG);
5270 const U8* send = (U8*)(s + len);
5272 if (UTF8_IS_INVARIANT(*s)) {
5277 if (!utf8_to_uvchr_buf(s, send, 0))
5281 down = (char*)(s - 1);
5282 /* reverse this character */
5286 *down-- = (char)tmp;
5292 down = SvPVX(TARG) + len - 1;
5296 *down-- = (char)tmp;
5298 (void)SvPOK_only_UTF8(TARG);
5310 IV limit = POPi; /* note, negative is forever */
5311 SV * const sv = POPs;
5313 const char *s = SvPV_const(sv, len);
5314 const bool do_utf8 = DO_UTF8(sv);
5315 const char *strend = s + len;
5321 const STRLEN slen = do_utf8
5322 ? utf8_length((U8*)s, (U8*)strend)
5323 : (STRLEN)(strend - s);
5324 I32 maxiters = slen + 10;
5325 I32 trailing_empty = 0;
5327 const I32 origlimit = limit;
5330 const I32 gimme = GIMME_V;
5332 const I32 oldsave = PL_savestack_ix;
5333 U32 make_mortal = SVs_TEMP;
5338 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5343 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5346 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5347 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5350 if (pm->op_pmreplrootu.op_pmtargetoff) {
5351 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5354 if (pm->op_pmreplrootu.op_pmtargetgv) {
5355 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5366 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5368 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5375 for (i = AvFILLp(ary); i >= 0; i--)
5376 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5378 /* temporarily switch stacks */
5379 SAVESWITCHSTACK(PL_curstack, ary);
5383 base = SP - PL_stack_base;
5385 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5387 while (isSPACE_utf8(s))
5390 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5391 while (isSPACE_LC(*s))
5399 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5403 gimme_scalar = gimme == G_SCALAR && !ary;
5406 limit = maxiters + 2;
5407 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5410 /* this one uses 'm' and is a negative test */
5412 while (m < strend && ! isSPACE_utf8(m) ) {
5413 const int t = UTF8SKIP(m);
5414 /* isSPACE_utf8 returns FALSE for malform utf8 */
5421 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5423 while (m < strend && !isSPACE_LC(*m))
5426 while (m < strend && !isSPACE(*m))
5439 dstr = newSVpvn_flags(s, m-s,
5440 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5444 /* skip the whitespace found last */
5446 s = m + UTF8SKIP(m);
5450 /* this one uses 's' and is a positive test */
5452 while (s < strend && isSPACE_utf8(s) )
5455 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5457 while (s < strend && isSPACE_LC(*s))
5460 while (s < strend && isSPACE(*s))
5465 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5467 for (m = s; m < strend && *m != '\n'; m++)
5480 dstr = newSVpvn_flags(s, m-s,
5481 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5487 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5489 Pre-extend the stack, either the number of bytes or
5490 characters in the string or a limited amount, triggered by:
5492 my ($x, $y) = split //, $str;
5496 if (!gimme_scalar) {
5497 const U32 items = limit - 1;
5506 /* keep track of how many bytes we skip over */
5516 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5529 dstr = newSVpvn(s, 1);
5545 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5546 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5547 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5548 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5549 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5550 SV * const csv = CALLREG_INTUIT_STRING(rx);
5552 len = RX_MINLENRET(rx);
5553 if (len == 1 && !RX_UTF8(rx) && !tail) {
5554 const char c = *SvPV_nolen_const(csv);
5556 for (m = s; m < strend && *m != c; m++)
5567 dstr = newSVpvn_flags(s, m-s,
5568 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5571 /* The rx->minlen is in characters but we want to step
5572 * s ahead by bytes. */
5574 s = (char*)utf8_hop((U8*)m, len);
5576 s = m + len; /* Fake \n at the end */
5580 while (s < strend && --limit &&
5581 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5582 csv, multiline ? FBMrf_MULTILINE : 0)) )
5591 dstr = newSVpvn_flags(s, m-s,
5592 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5595 /* The rx->minlen is in characters but we want to step
5596 * s ahead by bytes. */
5598 s = (char*)utf8_hop((U8*)m, len);
5600 s = m + len; /* Fake \n at the end */
5605 maxiters += slen * RX_NPARENS(rx);
5606 while (s < strend && --limit)
5610 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5613 if (rex_return == 0)
5615 TAINT_IF(RX_MATCH_TAINTED(rx));
5616 /* we never pass the REXEC_COPY_STR flag, so it should
5617 * never get copied */
5618 assert(!RX_MATCH_COPIED(rx));
5619 m = RX_OFFS(rx)[0].start + orig;
5628 dstr = newSVpvn_flags(s, m-s,
5629 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5632 if (RX_NPARENS(rx)) {
5634 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5635 s = RX_OFFS(rx)[i].start + orig;
5636 m = RX_OFFS(rx)[i].end + orig;
5638 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5639 parens that didn't match -- they should be set to
5640 undef, not the empty string */
5648 if (m >= orig && s >= orig) {
5649 dstr = newSVpvn_flags(s, m-s,
5650 (do_utf8 ? SVf_UTF8 : 0)
5654 dstr = &PL_sv_undef; /* undef, not "" */
5660 s = RX_OFFS(rx)[0].end + orig;
5664 if (!gimme_scalar) {
5665 iters = (SP - PL_stack_base) - base;
5667 if (iters > maxiters)
5668 DIE(aTHX_ "Split loop");
5670 /* keep field after final delim? */
5671 if (s < strend || (iters && origlimit)) {
5672 if (!gimme_scalar) {
5673 const STRLEN l = strend - s;
5674 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5679 else if (!origlimit) {
5681 iters -= trailing_empty;
5683 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5684 if (TOPs && !make_mortal)
5686 *SP-- = &PL_sv_undef;
5693 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5697 if (SvSMAGICAL(ary)) {
5699 mg_set(MUTABLE_SV(ary));
5702 if (gimme == G_ARRAY) {
5704 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5711 ENTER_with_name("call_PUSH");
5712 call_method("PUSH",G_SCALAR|G_DISCARD);
5713 LEAVE_with_name("call_PUSH");
5715 if (gimme == G_ARRAY) {
5717 /* EXTEND should not be needed - we just popped them */
5719 for (i=0; i < iters; i++) {
5720 SV **svp = av_fetch(ary, i, FALSE);
5721 PUSHs((svp) ? *svp : &PL_sv_undef);
5728 if (gimme == G_ARRAY)
5740 SV *const sv = PAD_SVl(PL_op->op_targ);
5742 if (SvPADSTALE(sv)) {
5745 RETURNOP(cLOGOP->op_other);
5747 RETURNOP(cLOGOP->op_next);
5757 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5758 || SvTYPE(retsv) == SVt_PVCV) {
5759 retsv = refto(retsv);
5766 PP(unimplemented_op)
5769 const Optype op_type = PL_op->op_type;
5770 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5771 with out of range op numbers - it only "special" cases op_custom.
5772 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5773 if we get here for a custom op then that means that the custom op didn't
5774 have an implementation. Given that OP_NAME() looks up the custom op
5775 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5776 registers &PL_unimplemented_op as the address of their custom op.
5777 NULL doesn't generate a useful error message. "custom" does. */
5778 const char *const name = op_type >= OP_max
5779 ? "[out of range]" : PL_op_name[PL_op->op_type];
5780 if(OP_IS_SOCKET(op_type))
5781 DIE(aTHX_ PL_no_sock_func, name);
5782 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5785 /* For sorting out arguments passed to a &CORE:: subroutine */
5789 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5790 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5791 AV * const at_ = GvAV(PL_defgv);
5792 SV **svp = at_ ? AvARRAY(at_) : NULL;
5793 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5794 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5795 bool seen_question = 0;
5796 const char *err = NULL;
5797 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5799 /* Count how many args there are first, to get some idea how far to
5800 extend the stack. */
5802 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5804 if (oa & OA_OPTIONAL) seen_question = 1;
5805 if (!seen_question) minargs++;
5809 if(numargs < minargs) err = "Not enough";
5810 else if(numargs > maxargs) err = "Too many";
5812 /* diag_listed_as: Too many arguments for %s */
5814 "%s arguments for %s", err,
5815 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5818 /* Reset the stack pointer. Without this, we end up returning our own
5819 arguments in list context, in addition to the values we are supposed
5820 to return. nextstate usually does this on sub entry, but we need
5821 to run the next op with the caller's hints, so we cannot have a
5823 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5825 if(!maxargs) RETURN;
5827 /* We do this here, rather than with a separate pushmark op, as it has
5828 to come in between two things this function does (stack reset and
5829 arg pushing). This seems the easiest way to do it. */
5832 (void)Perl_pp_pushmark(aTHX);
5835 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5836 PUTBACK; /* The code below can die in various places. */
5838 oa = PL_opargs[opnum] >> OASHIFT;
5839 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5844 if (!numargs && defgv && whicharg == minargs + 1) {
5845 PUSHs(find_rundefsv2(
5846 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5847 cxstack[cxstack_ix].blk_oldcop->cop_seq
5850 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5854 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5859 if (!svp || !*svp || !SvROK(*svp)
5860 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5862 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5863 "Type of arg %d to &CORE::%s must be hash reference",
5864 whicharg, OP_DESC(PL_op->op_next)
5869 if (!numargs) PUSHs(NULL);
5870 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5871 /* no magic here, as the prototype will have added an extra
5872 refgen and we just want what was there before that */
5875 const bool constr = PL_op->op_private & whicharg;
5877 svp && *svp ? *svp : &PL_sv_undef,
5878 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5884 if (!numargs) goto try_defsv;
5886 const bool wantscalar =
5887 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5888 if (!svp || !*svp || !SvROK(*svp)
5889 /* We have to permit globrefs even for the \$ proto, as
5890 *foo is indistinguishable from ${\*foo}, and the proto-
5891 type permits the latter. */
5892 || SvTYPE(SvRV(*svp)) > (
5893 wantscalar ? SVt_PVLV
5894 : opnum == OP_LOCK || opnum == OP_UNDEF
5900 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5901 "Type of arg %d to &CORE::%s must be %s",
5902 whicharg, PL_op_name[opnum],
5904 ? "scalar reference"
5905 : opnum == OP_LOCK || opnum == OP_UNDEF
5906 ? "reference to one of [$@%&*]"
5907 : "reference to one of [$@%*]"
5910 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5911 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5912 /* Undo @_ localisation, so that sub exit does not undo
5913 part of our undeffing. */
5914 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5916 cx->cx_type &= ~ CXp_HASARGS;
5917 assert(!AvREAL(cx->blk_sub.argarray));
5922 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5934 if (PL_op->op_private & OPpOFFBYONE) {
5935 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5937 else cv = find_runcv(NULL);
5938 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5945 * c-indentation-style: bsd
5947 * indent-tabs-mode: nil
5950 * ex: set ts=8 sts=4 sw=4 et: