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 /* variations on pp_null */
56 if (GIMME_V == G_SCALAR)
67 assert(SvTYPE(TARG) == SVt_PVAV);
68 if (PL_op->op_private & OPpLVAL_INTRO)
69 if (!(PL_op->op_private & OPpPAD_STATE))
70 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
72 if (PL_op->op_flags & OPf_REF) {
75 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
76 const I32 flags = is_lvalue_sub();
77 if (flags && !(flags & OPpENTERSUB_INARGS)) {
78 if (GIMME == G_SCALAR)
79 /* diag_listed_as: Can't return %s to lvalue scalar context */
80 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
86 if (gimme == G_ARRAY) {
87 /* XXX see also S_pushav in pp_hot.c */
88 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
90 if (SvMAGICAL(TARG)) {
92 for (i=0; i < (U32)maxarg; i++) {
93 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
94 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
98 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
102 else if (gimme == G_SCALAR) {
103 SV* const sv = sv_newmortal();
104 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
105 sv_setiv(sv, maxarg);
116 assert(SvTYPE(TARG) == SVt_PVHV);
118 if (PL_op->op_private & OPpLVAL_INTRO)
119 if (!(PL_op->op_private & OPpPAD_STATE))
120 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
121 if (PL_op->op_flags & OPf_REF)
123 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
124 const I32 flags = is_lvalue_sub();
125 if (flags && !(flags & OPpENTERSUB_INARGS)) {
126 if (GIMME == G_SCALAR)
127 /* diag_listed_as: Can't return %s to lvalue scalar context */
128 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
133 if (gimme == G_ARRAY) {
134 RETURNOP(Perl_do_kv(aTHX));
136 else if ((PL_op->op_private & OPpTRUEBOOL
137 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
138 && block_gimme() == G_VOID ))
139 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
140 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
141 else if (gimme == G_SCALAR) {
142 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
151 assert(SvTYPE(TARG) == SVt_PVCV);
159 SvPADSTALE_off(TARG);
167 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
169 assert(SvTYPE(TARG) == SVt_PVCV);
172 if (CvISXSUB(mg->mg_obj)) { /* constant */
173 /* XXX Should we clone it here? */
174 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
175 to introcv and remove the SvPADSTALE_off. */
176 SAVEPADSVANDMORTALIZE(ARGTARG);
177 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
180 if (CvROOT(mg->mg_obj)) {
181 assert(CvCLONE(mg->mg_obj));
182 assert(!CvCLONED(mg->mg_obj));
184 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
185 SAVECLEARSV(PAD_SVl(ARGTARG));
192 static const char S_no_symref_sv[] =
193 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
195 /* In some cases this function inspects PL_op. If this function is called
196 for new op types, more bool parameters may need to be added in place of
199 When noinit is true, the absence of a gv will cause a retval of undef.
200 This is unrelated to the cv-to-gv assignment case.
204 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
208 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
211 sv = amagic_deref_call(sv, to_gv_amg);
215 if (SvTYPE(sv) == SVt_PVIO) {
216 GV * const gv = MUTABLE_GV(sv_newmortal());
217 gv_init(gv, 0, "__ANONIO__", 10, 0);
218 GvIOp(gv) = MUTABLE_IO(sv);
219 SvREFCNT_inc_void_NN(sv);
222 else if (!isGV_with_GP(sv))
223 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
226 if (!isGV_with_GP(sv)) {
228 /* If this is a 'my' scalar and flag is set then vivify
231 if (vivify_sv && sv != &PL_sv_undef) {
234 Perl_croak_no_modify();
235 if (cUNOP->op_targ) {
236 SV * const namesv = PAD_SV(cUNOP->op_targ);
237 gv = MUTABLE_GV(newSV(0));
238 gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0);
241 const char * const name = CopSTASHPV(PL_curcop);
242 gv = newGVgen_flags(name,
243 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
245 prepare_SV_for_RV(sv);
246 SvRV_set(sv, MUTABLE_SV(gv));
251 if (PL_op->op_flags & OPf_REF || strict)
252 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
253 if (ckWARN(WARN_UNINITIALIZED))
259 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
260 sv, GV_ADDMG, SVt_PVGV
270 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
273 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
274 == OPpDONT_INIT_GV) {
275 /* We are the target of a coderef assignment. Return
276 the scalar unchanged, and let pp_sasssign deal with
280 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
282 /* FAKE globs in the symbol table cause weird bugs (#77810) */
286 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
287 SV *newsv = sv_newmortal();
288 sv_setsv_flags(newsv, sv, 0);
300 sv, PL_op->op_private & OPpDEREF,
301 PL_op->op_private & HINT_STRICT_REFS,
302 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
303 || PL_op->op_type == OP_READLINE
305 if (PL_op->op_private & OPpLVAL_INTRO)
306 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
311 /* Helper function for pp_rv2sv and pp_rv2av */
313 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
314 const svtype type, SV ***spp)
319 PERL_ARGS_ASSERT_SOFTREF2XV;
321 if (PL_op->op_private & HINT_STRICT_REFS) {
323 Perl_die(aTHX_ S_no_symref_sv, sv,
324 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
326 Perl_die(aTHX_ PL_no_usym, what);
330 PL_op->op_flags & OPf_REF
332 Perl_die(aTHX_ PL_no_usym, what);
333 if (ckWARN(WARN_UNINITIALIZED))
335 if (type != SVt_PV && GIMME_V == G_ARRAY) {
339 **spp = &PL_sv_undef;
342 if ((PL_op->op_flags & OPf_SPECIAL) &&
343 !(PL_op->op_flags & OPf_MOD))
345 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
347 **spp = &PL_sv_undef;
352 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
365 sv = amagic_deref_call(sv, to_sv_amg);
369 switch (SvTYPE(sv)) {
375 DIE(aTHX_ "Not a SCALAR reference");
382 if (!isGV_with_GP(gv)) {
383 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
389 if (PL_op->op_flags & OPf_MOD) {
390 if (PL_op->op_private & OPpLVAL_INTRO) {
391 if (cUNOP->op_first->op_type == OP_NULL)
392 sv = save_scalar(MUTABLE_GV(TOPs));
394 sv = save_scalar(gv);
396 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
398 else if (PL_op->op_private & OPpDEREF)
399 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
408 AV * const av = MUTABLE_AV(TOPs);
409 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
411 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
413 *sv = newSV_type(SVt_PVMG);
414 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
418 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
427 if (PL_op->op_flags & OPf_MOD || LVRET) {
428 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
429 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
431 LvTARG(ret) = SvREFCNT_inc_simple(sv);
432 PUSHs(ret); /* no SvSETMAGIC */
436 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
437 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
438 if (mg && mg->mg_len >= 0) {
456 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
458 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
459 == OPpMAY_RETURN_CONSTANT)
462 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
463 /* (But not in defined().) */
465 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
467 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
471 cv = MUTABLE_CV(&PL_sv_undef);
472 SETs(MUTABLE_SV(cv));
482 SV *ret = &PL_sv_undef;
484 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
485 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
486 const char * s = SvPVX_const(TOPs);
487 if (strnEQ(s, "CORE::", 6)) {
488 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
489 if (!code || code == -KEY_CORE)
490 DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
491 SVfARG(newSVpvn_flags(
493 (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP
496 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
502 cv = sv_2cv(TOPs, &stash, &gv, 0);
504 ret = newSVpvn_flags(
505 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
515 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
517 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
519 PUSHs(MUTABLE_SV(cv));
533 if (GIMME != G_ARRAY) {
537 *MARK = &PL_sv_undef;
538 *MARK = refto(*MARK);
542 EXTEND_MORTAL(SP - MARK);
544 *MARK = refto(*MARK);
549 S_refto(pTHX_ SV *sv)
554 PERL_ARGS_ASSERT_REFTO;
556 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
559 if (!(sv = LvTARG(sv)))
562 SvREFCNT_inc_void_NN(sv);
564 else if (SvTYPE(sv) == SVt_PVAV) {
565 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
566 av_reify(MUTABLE_AV(sv));
568 SvREFCNT_inc_void_NN(sv);
570 else if (SvPADTMP(sv) && !IS_PADGV(sv))
574 SvREFCNT_inc_void_NN(sv);
577 sv_upgrade(rv, SVt_IV);
586 SV * const sv = POPs;
591 if (!sv || !SvROK(sv))
594 (void)sv_ref(TARG,SvRV(sv),TRUE);
606 stash = CopSTASH(PL_curcop);
608 SV * const ssv = POPs;
612 if (!ssv) goto curstash;
613 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
614 Perl_croak(aTHX_ "Attempt to bless into a reference");
615 ptr = SvPV_const(ssv,len);
617 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
618 "Explicit blessing to '' (assuming package main)");
619 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
622 (void)sv_bless(TOPs, stash);
632 const char * const elem = SvPV_const(sv, len);
633 GV * const gv = MUTABLE_GV(POPs);
638 /* elem will always be NUL terminated. */
639 const char * const second_letter = elem + 1;
642 if (len == 5 && strEQ(second_letter, "RRAY"))
644 tmpRef = MUTABLE_SV(GvAV(gv));
645 if (tmpRef && !AvREAL((const AV *)tmpRef)
646 && AvREIFY((const AV *)tmpRef))
647 av_reify(MUTABLE_AV(tmpRef));
651 if (len == 4 && strEQ(second_letter, "ODE"))
652 tmpRef = MUTABLE_SV(GvCVu(gv));
655 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
656 /* finally deprecated in 5.8.0 */
657 deprecate("*glob{FILEHANDLE}");
658 tmpRef = MUTABLE_SV(GvIOp(gv));
661 if (len == 6 && strEQ(second_letter, "ORMAT"))
662 tmpRef = MUTABLE_SV(GvFORM(gv));
665 if (len == 4 && strEQ(second_letter, "LOB"))
666 tmpRef = MUTABLE_SV(gv);
669 if (len == 4 && strEQ(second_letter, "ASH"))
670 tmpRef = MUTABLE_SV(GvHV(gv));
673 if (*second_letter == 'O' && !elem[2] && len == 2)
674 tmpRef = MUTABLE_SV(GvIOp(gv));
677 if (len == 4 && strEQ(second_letter, "AME"))
678 sv = newSVhek(GvNAME_HEK(gv));
681 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
682 const HV * const stash = GvSTASH(gv);
683 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
684 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
688 if (len == 6 && strEQ(second_letter, "CALAR"))
703 /* Pattern matching */
711 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
712 /* Historically, study was skipped in these cases. */
716 /* Make study a no-op. It's no longer useful and its existence
717 complicates matters elsewhere. */
726 if (PL_op->op_flags & OPf_STACKED)
728 else if (PL_op->op_private & OPpTARGET_MY)
734 if(PL_op->op_type == OP_TRANSR) {
736 const char * const pv = SvPV(sv,len);
737 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
742 TARG = sv_newmortal();
748 /* Lvalue operators. */
751 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
757 PERL_ARGS_ASSERT_DO_CHOMP;
759 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
761 if (SvTYPE(sv) == SVt_PVAV) {
763 AV *const av = MUTABLE_AV(sv);
764 const I32 max = AvFILL(av);
766 for (i = 0; i <= max; i++) {
767 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
768 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
769 do_chomp(retval, sv, chomping);
773 else if (SvTYPE(sv) == SVt_PVHV) {
774 HV* const hv = MUTABLE_HV(sv);
776 (void)hv_iterinit(hv);
777 while ((entry = hv_iternext(hv)))
778 do_chomp(retval, hv_iterval(hv,entry), chomping);
781 else if (SvREADONLY(sv)) {
782 Perl_croak_no_modify();
784 else if (SvIsCOW(sv)) {
785 sv_force_normal_flags(sv, 0);
790 /* XXX, here sv is utf8-ized as a side-effect!
791 If encoding.pm is used properly, almost string-generating
792 operations, including literal strings, chr(), input data, etc.
793 should have been utf8-ized already, right?
795 sv_recode_to_utf8(sv, PL_encoding);
801 char *temp_buffer = NULL;
810 while (len && s[-1] == '\n') {
817 STRLEN rslen, rs_charlen;
818 const char *rsptr = SvPV_const(PL_rs, rslen);
820 rs_charlen = SvUTF8(PL_rs)
824 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
825 /* Assumption is that rs is shorter than the scalar. */
827 /* RS is utf8, scalar is 8 bit. */
829 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
832 /* Cannot downgrade, therefore cannot possibly match
834 assert (temp_buffer == rsptr);
840 else if (PL_encoding) {
841 /* RS is 8 bit, encoding.pm is used.
842 * Do not recode PL_rs as a side-effect. */
843 svrecode = newSVpvn(rsptr, rslen);
844 sv_recode_to_utf8(svrecode, PL_encoding);
845 rsptr = SvPV_const(svrecode, rslen);
846 rs_charlen = sv_len_utf8(svrecode);
849 /* RS is 8 bit, scalar is utf8. */
850 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
864 if (memNE(s, rsptr, rslen))
866 SvIVX(retval) += rs_charlen;
869 s = SvPV_force_nomg_nolen(sv);
877 SvREFCNT_dec(svrecode);
879 Safefree(temp_buffer);
881 if (len && !SvPOK(sv))
882 s = SvPV_force_nomg(sv, len);
885 char * const send = s + len;
886 char * const start = s;
888 while (s > start && UTF8_IS_CONTINUATION(*s))
890 if (is_utf8_string((U8*)s, send - s)) {
891 sv_setpvn(retval, s, send - s);
893 SvCUR_set(sv, s - start);
899 sv_setpvs(retval, "");
903 sv_setpvn(retval, s, 1);
910 sv_setpvs(retval, "");
918 const bool chomping = PL_op->op_type == OP_SCHOMP;
922 do_chomp(TARG, TOPs, chomping);
929 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
930 const bool chomping = PL_op->op_type == OP_CHOMP;
935 do_chomp(TARG, *++MARK, chomping);
946 if (!PL_op->op_private) {
955 SV_CHECK_THINKFIRST_COW_DROP(sv);
957 switch (SvTYPE(sv)) {
961 av_undef(MUTABLE_AV(sv));
964 hv_undef(MUTABLE_HV(sv));
967 if (cv_const_sv((const CV *)sv))
968 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
969 "Constant subroutine %"SVf" undefined",
970 SVfARG(CvANON((const CV *)sv)
971 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
972 : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
976 /* let user-undef'd sub keep its identity */
977 GV* const gv = CvGV((const CV *)sv);
978 HEK * const hek = CvNAME_HEK((CV *)sv);
979 if (hek) share_hek_hek(hek);
980 cv_undef(MUTABLE_CV(sv));
981 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
983 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
989 assert(isGV_with_GP(sv));
995 /* undef *Pkg::meth_name ... */
997 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
998 && HvENAME_get(stash);
1000 if((stash = GvHV((const GV *)sv))) {
1001 if(HvENAME_get(stash))
1002 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1006 gp_free(MUTABLE_GV(sv));
1008 GvGP_set(sv, gp_ref(gp));
1009 GvSV(sv) = newSV(0);
1010 GvLINE(sv) = CopLINE(PL_curcop);
1011 GvEGV(sv) = MUTABLE_GV(sv);
1015 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1017 /* undef *Foo::ISA */
1018 if( strEQ(GvNAME((const GV *)sv), "ISA")
1019 && (stash = GvSTASH((const GV *)sv))
1020 && (method_changed || HvENAME(stash)) )
1021 mro_isa_changed_in(stash);
1022 else if(method_changed)
1023 mro_method_changed_in(
1024 GvSTASH((const GV *)sv)
1030 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1046 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1047 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1048 Perl_croak_no_modify();
1050 TARG = sv_newmortal();
1051 sv_setsv(TARG, TOPs);
1052 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1053 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1055 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1056 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1060 else sv_dec_nomg(TOPs);
1062 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1063 if (inc && !SvOK(TARG))
1069 /* Ordinary operators. */
1073 dVAR; dSP; dATARGET; SV *svl, *svr;
1074 #ifdef PERL_PRESERVE_IVUV
1077 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1080 #ifdef PERL_PRESERVE_IVUV
1081 /* For integer to integer power, we do the calculation by hand wherever
1082 we're sure it is safe; otherwise we call pow() and try to convert to
1083 integer afterwards. */
1084 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1092 const IV iv = SvIVX(svr);
1096 goto float_it; /* Can't do negative powers this way. */
1100 baseuok = SvUOK(svl);
1102 baseuv = SvUVX(svl);
1104 const IV iv = SvIVX(svl);
1107 baseuok = TRUE; /* effectively it's a UV now */
1109 baseuv = -iv; /* abs, baseuok == false records sign */
1112 /* now we have integer ** positive integer. */
1115 /* foo & (foo - 1) is zero only for a power of 2. */
1116 if (!(baseuv & (baseuv - 1))) {
1117 /* We are raising power-of-2 to a positive integer.
1118 The logic here will work for any base (even non-integer
1119 bases) but it can be less accurate than
1120 pow (base,power) or exp (power * log (base)) when the
1121 intermediate values start to spill out of the mantissa.
1122 With powers of 2 we know this can't happen.
1123 And powers of 2 are the favourite thing for perl
1124 programmers to notice ** not doing what they mean. */
1126 NV base = baseuok ? baseuv : -(NV)baseuv;
1131 while (power >>= 1) {
1139 SvIV_please_nomg(svr);
1142 unsigned int highbit = 8 * sizeof(UV);
1143 unsigned int diff = 8 * sizeof(UV);
1144 while (diff >>= 1) {
1146 if (baseuv >> highbit) {
1150 /* we now have baseuv < 2 ** highbit */
1151 if (power * highbit <= 8 * sizeof(UV)) {
1152 /* result will definitely fit in UV, so use UV math
1153 on same algorithm as above */
1156 const bool odd_power = cBOOL(power & 1);
1160 while (power >>= 1) {
1167 if (baseuok || !odd_power)
1168 /* answer is positive */
1170 else if (result <= (UV)IV_MAX)
1171 /* answer negative, fits in IV */
1172 SETi( -(IV)result );
1173 else if (result == (UV)IV_MIN)
1174 /* 2's complement assumption: special case IV_MIN */
1177 /* answer negative, doesn't fit */
1178 SETn( -(NV)result );
1186 NV right = SvNV_nomg(svr);
1187 NV left = SvNV_nomg(svl);
1190 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1192 We are building perl with long double support and are on an AIX OS
1193 afflicted with a powl() function that wrongly returns NaNQ for any
1194 negative base. This was reported to IBM as PMR #23047-379 on
1195 03/06/2006. The problem exists in at least the following versions
1196 of AIX and the libm fileset, and no doubt others as well:
1198 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1199 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1200 AIX 5.2.0 bos.adt.libm 5.2.0.85
1202 So, until IBM fixes powl(), we provide the following workaround to
1203 handle the problem ourselves. Our logic is as follows: for
1204 negative bases (left), we use fmod(right, 2) to check if the
1205 exponent is an odd or even integer:
1207 - if odd, powl(left, right) == -powl(-left, right)
1208 - if even, powl(left, right) == powl(-left, right)
1210 If the exponent is not an integer, the result is rightly NaNQ, so
1211 we just return that (as NV_NAN).
1215 NV mod2 = Perl_fmod( right, 2.0 );
1216 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1217 SETn( -Perl_pow( -left, right) );
1218 } else if (mod2 == 0.0) { /* even integer */
1219 SETn( Perl_pow( -left, right) );
1220 } else { /* fractional power */
1224 SETn( Perl_pow( left, right) );
1227 SETn( Perl_pow( left, right) );
1228 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1230 #ifdef PERL_PRESERVE_IVUV
1232 SvIV_please_nomg(svr);
1240 dVAR; dSP; dATARGET; SV *svl, *svr;
1241 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1244 #ifdef PERL_PRESERVE_IVUV
1245 if (SvIV_please_nomg(svr)) {
1246 /* Unless the left argument is integer in range we are going to have to
1247 use NV maths. Hence only attempt to coerce the right argument if
1248 we know the left is integer. */
1249 /* Left operand is defined, so is it IV? */
1250 if (SvIV_please_nomg(svl)) {
1251 bool auvok = SvUOK(svl);
1252 bool buvok = SvUOK(svr);
1253 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1254 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1263 const IV aiv = SvIVX(svl);
1266 auvok = TRUE; /* effectively it's a UV now */
1268 alow = -aiv; /* abs, auvok == false records sign */
1274 const IV biv = SvIVX(svr);
1277 buvok = TRUE; /* effectively it's a UV now */
1279 blow = -biv; /* abs, buvok == false records sign */
1283 /* If this does sign extension on unsigned it's time for plan B */
1284 ahigh = alow >> (4 * sizeof (UV));
1286 bhigh = blow >> (4 * sizeof (UV));
1288 if (ahigh && bhigh) {
1290 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1291 which is overflow. Drop to NVs below. */
1292 } else if (!ahigh && !bhigh) {
1293 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1294 so the unsigned multiply cannot overflow. */
1295 const UV product = alow * blow;
1296 if (auvok == buvok) {
1297 /* -ve * -ve or +ve * +ve gives a +ve result. */
1301 } else if (product <= (UV)IV_MIN) {
1302 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1303 /* -ve result, which could overflow an IV */
1305 SETi( -(IV)product );
1307 } /* else drop to NVs below. */
1309 /* One operand is large, 1 small */
1312 /* swap the operands */
1314 bhigh = blow; /* bhigh now the temp var for the swap */
1318 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1319 multiplies can't overflow. shift can, add can, -ve can. */
1320 product_middle = ahigh * blow;
1321 if (!(product_middle & topmask)) {
1322 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1324 product_middle <<= (4 * sizeof (UV));
1325 product_low = alow * blow;
1327 /* as for pp_add, UV + something mustn't get smaller.
1328 IIRC ANSI mandates this wrapping *behaviour* for
1329 unsigned whatever the actual representation*/
1330 product_low += product_middle;
1331 if (product_low >= product_middle) {
1332 /* didn't overflow */
1333 if (auvok == buvok) {
1334 /* -ve * -ve or +ve * +ve gives a +ve result. */
1336 SETu( product_low );
1338 } else if (product_low <= (UV)IV_MIN) {
1339 /* 2s complement assumption again */
1340 /* -ve result, which could overflow an IV */
1342 SETi( -(IV)product_low );
1344 } /* else drop to NVs below. */
1346 } /* product_middle too large */
1347 } /* ahigh && bhigh */
1352 NV right = SvNV_nomg(svr);
1353 NV left = SvNV_nomg(svl);
1355 SETn( left * right );
1362 dVAR; dSP; dATARGET; SV *svl, *svr;
1363 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1366 /* Only try to do UV divide first
1367 if ((SLOPPYDIVIDE is true) or
1368 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1370 The assumption is that it is better to use floating point divide
1371 whenever possible, only doing integer divide first if we can't be sure.
1372 If NV_PRESERVES_UV is true then we know at compile time that no UV
1373 can be too large to preserve, so don't need to compile the code to
1374 test the size of UVs. */
1377 # define PERL_TRY_UV_DIVIDE
1378 /* ensure that 20./5. == 4. */
1380 # ifdef PERL_PRESERVE_IVUV
1381 # ifndef NV_PRESERVES_UV
1382 # define PERL_TRY_UV_DIVIDE
1387 #ifdef PERL_TRY_UV_DIVIDE
1388 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1389 bool left_non_neg = SvUOK(svl);
1390 bool right_non_neg = SvUOK(svr);
1394 if (right_non_neg) {
1398 const IV biv = SvIVX(svr);
1401 right_non_neg = TRUE; /* effectively it's a UV now */
1407 /* historically undef()/0 gives a "Use of uninitialized value"
1408 warning before dieing, hence this test goes here.
1409 If it were immediately before the second SvIV_please, then
1410 DIE() would be invoked before left was even inspected, so
1411 no inspection would give no warning. */
1413 DIE(aTHX_ "Illegal division by zero");
1419 const IV aiv = SvIVX(svl);
1422 left_non_neg = TRUE; /* effectively it's a UV now */
1431 /* For sloppy divide we always attempt integer division. */
1433 /* Otherwise we only attempt it if either or both operands
1434 would not be preserved by an NV. If both fit in NVs
1435 we fall through to the NV divide code below. However,
1436 as left >= right to ensure integer result here, we know that
1437 we can skip the test on the right operand - right big
1438 enough not to be preserved can't get here unless left is
1441 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1444 /* Integer division can't overflow, but it can be imprecise. */
1445 const UV result = left / right;
1446 if (result * right == left) {
1447 SP--; /* result is valid */
1448 if (left_non_neg == right_non_neg) {
1449 /* signs identical, result is positive. */
1453 /* 2s complement assumption */
1454 if (result <= (UV)IV_MIN)
1455 SETi( -(IV)result );
1457 /* It's exact but too negative for IV. */
1458 SETn( -(NV)result );
1461 } /* tried integer divide but it was not an integer result */
1462 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1463 } /* one operand wasn't SvIOK */
1464 #endif /* PERL_TRY_UV_DIVIDE */
1466 NV right = SvNV_nomg(svr);
1467 NV left = SvNV_nomg(svl);
1468 (void)POPs;(void)POPs;
1469 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1470 if (! Perl_isnan(right) && right == 0.0)
1474 DIE(aTHX_ "Illegal division by zero");
1475 PUSHn( left / right );
1482 dVAR; dSP; dATARGET;
1483 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1487 bool left_neg = FALSE;
1488 bool right_neg = FALSE;
1489 bool use_double = FALSE;
1490 bool dright_valid = FALSE;
1493 SV * const svr = TOPs;
1494 SV * const svl = TOPm1s;
1495 if (SvIV_please_nomg(svr)) {
1496 right_neg = !SvUOK(svr);
1500 const IV biv = SvIVX(svr);
1503 right_neg = FALSE; /* effectively it's a UV now */
1510 dright = SvNV_nomg(svr);
1511 right_neg = dright < 0;
1514 if (dright < UV_MAX_P1) {
1515 right = U_V(dright);
1516 dright_valid = TRUE; /* In case we need to use double below. */
1522 /* At this point use_double is only true if right is out of range for
1523 a UV. In range NV has been rounded down to nearest UV and
1524 use_double false. */
1525 if (!use_double && SvIV_please_nomg(svl)) {
1526 left_neg = !SvUOK(svl);
1530 const IV aiv = SvIVX(svl);
1533 left_neg = FALSE; /* effectively it's a UV now */
1540 dleft = SvNV_nomg(svl);
1541 left_neg = dleft < 0;
1545 /* This should be exactly the 5.6 behaviour - if left and right are
1546 both in range for UV then use U_V() rather than floor. */
1548 if (dleft < UV_MAX_P1) {
1549 /* right was in range, so is dleft, so use UVs not double.
1553 /* left is out of range for UV, right was in range, so promote
1554 right (back) to double. */
1556 /* The +0.5 is used in 5.6 even though it is not strictly
1557 consistent with the implicit +0 floor in the U_V()
1558 inside the #if 1. */
1559 dleft = Perl_floor(dleft + 0.5);
1562 dright = Perl_floor(dright + 0.5);
1573 DIE(aTHX_ "Illegal modulus zero");
1575 dans = Perl_fmod(dleft, dright);
1576 if ((left_neg != right_neg) && dans)
1577 dans = dright - dans;
1580 sv_setnv(TARG, dans);
1586 DIE(aTHX_ "Illegal modulus zero");
1589 if ((left_neg != right_neg) && ans)
1592 /* XXX may warn: unary minus operator applied to unsigned type */
1593 /* could change -foo to be (~foo)+1 instead */
1594 if (ans <= ~((UV)IV_MAX)+1)
1595 sv_setiv(TARG, ~ans+1);
1597 sv_setnv(TARG, -(NV)ans);
1600 sv_setuv(TARG, ans);
1609 dVAR; dSP; dATARGET;
1613 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1614 /* TODO: think of some way of doing list-repeat overloading ??? */
1619 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1625 const UV uv = SvUV_nomg(sv);
1627 count = IV_MAX; /* The best we can do? */
1631 const IV iv = SvIV_nomg(sv);
1638 else if (SvNOKp(sv)) {
1639 const NV nv = SvNV_nomg(sv);
1646 count = SvIV_nomg(sv);
1648 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1650 static const char* const oom_list_extend = "Out of memory during list extend";
1651 const I32 items = SP - MARK;
1652 const I32 max = items * count;
1654 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1655 /* Did the max computation overflow? */
1656 if (items > 0 && max > 0 && (max < items || max < count))
1657 Perl_croak(aTHX_ oom_list_extend);
1662 /* This code was intended to fix 20010809.028:
1665 for (($x =~ /./g) x 2) {
1666 print chop; # "abcdabcd" expected as output.
1669 * but that change (#11635) broke this code:
1671 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1673 * I can't think of a better fix that doesn't introduce
1674 * an efficiency hit by copying the SVs. The stack isn't
1675 * refcounted, and mortalisation obviously doesn't
1676 * Do The Right Thing when the stack has more than
1677 * one pointer to the same mortal value.
1681 *SP = sv_2mortal(newSVsv(*SP));
1691 repeatcpy((char*)(MARK + items), (char*)MARK,
1692 items * sizeof(const SV *), count - 1);
1695 else if (count <= 0)
1698 else { /* Note: mark already snarfed by pp_list */
1699 SV * const tmpstr = POPs;
1702 static const char* const oom_string_extend =
1703 "Out of memory during string extend";
1706 sv_setsv_nomg(TARG, tmpstr);
1707 SvPV_force_nomg(TARG, len);
1708 isutf = DO_UTF8(TARG);
1713 const STRLEN max = (UV)count * len;
1714 if (len > MEM_SIZE_MAX / count)
1715 Perl_croak(aTHX_ oom_string_extend);
1716 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1717 SvGROW(TARG, max + 1);
1718 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1719 SvCUR_set(TARG, SvCUR(TARG) * count);
1721 *SvEND(TARG) = '\0';
1724 (void)SvPOK_only_UTF8(TARG);
1726 (void)SvPOK_only(TARG);
1728 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1729 /* The parser saw this as a list repeat, and there
1730 are probably several items on the stack. But we're
1731 in scalar context, and there's no pp_list to save us
1732 now. So drop the rest of the items -- robin@kitsite.com
1744 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1745 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1748 useleft = USE_LEFT(svl);
1749 #ifdef PERL_PRESERVE_IVUV
1750 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1751 "bad things" happen if you rely on signed integers wrapping. */
1752 if (SvIV_please_nomg(svr)) {
1753 /* Unless the left argument is integer in range we are going to have to
1754 use NV maths. Hence only attempt to coerce the right argument if
1755 we know the left is integer. */
1762 a_valid = auvok = 1;
1763 /* left operand is undef, treat as zero. */
1765 /* Left operand is defined, so is it IV? */
1766 if (SvIV_please_nomg(svl)) {
1767 if ((auvok = SvUOK(svl)))
1770 const IV aiv = SvIVX(svl);
1773 auvok = 1; /* Now acting as a sign flag. */
1774 } else { /* 2s complement assumption for IV_MIN */
1782 bool result_good = 0;
1785 bool buvok = SvUOK(svr);
1790 const IV biv = SvIVX(svr);
1797 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1798 else "IV" now, independent of how it came in.
1799 if a, b represents positive, A, B negative, a maps to -A etc
1804 all UV maths. negate result if A negative.
1805 subtract if signs same, add if signs differ. */
1807 if (auvok ^ buvok) {
1816 /* Must get smaller */
1821 if (result <= buv) {
1822 /* result really should be -(auv-buv). as its negation
1823 of true value, need to swap our result flag */
1835 if (result <= (UV)IV_MIN)
1836 SETi( -(IV)result );
1838 /* result valid, but out of range for IV. */
1839 SETn( -(NV)result );
1843 } /* Overflow, drop through to NVs. */
1848 NV value = SvNV_nomg(svr);
1852 /* left operand is undef, treat as zero - value */
1856 SETn( SvNV_nomg(svl) - value );
1863 dVAR; dSP; dATARGET; SV *svl, *svr;
1864 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1868 const IV shift = SvIV_nomg(svr);
1869 if (PL_op->op_private & HINT_INTEGER) {
1870 const IV i = SvIV_nomg(svl);
1874 const UV u = SvUV_nomg(svl);
1883 dVAR; dSP; dATARGET; SV *svl, *svr;
1884 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1888 const IV shift = SvIV_nomg(svr);
1889 if (PL_op->op_private & HINT_INTEGER) {
1890 const IV i = SvIV_nomg(svl);
1894 const UV u = SvUV_nomg(svl);
1906 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1910 (SvIOK_notUV(left) && SvIOK_notUV(right))
1911 ? (SvIVX(left) < SvIVX(right))
1912 : (do_ncmp(left, right) == -1)
1922 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1926 (SvIOK_notUV(left) && SvIOK_notUV(right))
1927 ? (SvIVX(left) > SvIVX(right))
1928 : (do_ncmp(left, right) == 1)
1938 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1942 (SvIOK_notUV(left) && SvIOK_notUV(right))
1943 ? (SvIVX(left) <= SvIVX(right))
1944 : (do_ncmp(left, right) <= 0)
1954 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1958 (SvIOK_notUV(left) && SvIOK_notUV(right))
1959 ? (SvIVX(left) >= SvIVX(right))
1960 : ( (do_ncmp(left, right) & 2) == 0)
1970 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1974 (SvIOK_notUV(left) && SvIOK_notUV(right))
1975 ? (SvIVX(left) != SvIVX(right))
1976 : (do_ncmp(left, right) != 0)
1981 /* compare left and right SVs. Returns:
1985 * 2: left or right was a NaN
1988 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1992 PERL_ARGS_ASSERT_DO_NCMP;
1993 #ifdef PERL_PRESERVE_IVUV
1994 /* Fortunately it seems NaN isn't IOK */
1995 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
1997 const IV leftiv = SvIVX(left);
1998 if (!SvUOK(right)) {
1999 /* ## IV <=> IV ## */
2000 const IV rightiv = SvIVX(right);
2001 return (leftiv > rightiv) - (leftiv < rightiv);
2003 /* ## IV <=> UV ## */
2005 /* As (b) is a UV, it's >=0, so it must be < */
2008 const UV rightuv = SvUVX(right);
2009 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2014 /* ## UV <=> UV ## */
2015 const UV leftuv = SvUVX(left);
2016 const UV rightuv = SvUVX(right);
2017 return (leftuv > rightuv) - (leftuv < rightuv);
2019 /* ## UV <=> IV ## */
2021 const IV rightiv = SvIVX(right);
2023 /* As (a) is a UV, it's >=0, so it cannot be < */
2026 const UV leftuv = SvUVX(left);
2027 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2030 assert(0); /* NOTREACHED */
2034 NV const rnv = SvNV_nomg(right);
2035 NV const lnv = SvNV_nomg(left);
2037 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2038 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2041 return (lnv > rnv) - (lnv < rnv);
2060 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2063 value = do_ncmp(left, right);
2078 int amg_type = sle_amg;
2082 switch (PL_op->op_type) {
2101 tryAMAGICbin_MG(amg_type, AMGf_set);
2104 const int cmp = (IN_LOCALE_RUNTIME
2105 ? sv_cmp_locale_flags(left, right, 0)
2106 : sv_cmp_flags(left, right, 0));
2107 SETs(boolSV(cmp * multiplier < rhs));
2115 tryAMAGICbin_MG(seq_amg, AMGf_set);
2118 SETs(boolSV(sv_eq_flags(left, right, 0)));
2126 tryAMAGICbin_MG(sne_amg, AMGf_set);
2129 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2137 tryAMAGICbin_MG(scmp_amg, 0);
2140 const int cmp = (IN_LOCALE_RUNTIME
2141 ? sv_cmp_locale_flags(left, right, 0)
2142 : sv_cmp_flags(left, right, 0));
2150 dVAR; dSP; dATARGET;
2151 tryAMAGICbin_MG(band_amg, AMGf_assign);
2154 if (SvNIOKp(left) || SvNIOKp(right)) {
2155 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2156 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2157 if (PL_op->op_private & HINT_INTEGER) {
2158 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2162 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2165 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2166 if (right_ro_nonnum) SvNIOK_off(right);
2169 do_vop(PL_op->op_type, TARG, left, right);
2178 dVAR; dSP; dATARGET;
2179 const int op_type = PL_op->op_type;
2181 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2184 if (SvNIOKp(left) || SvNIOKp(right)) {
2185 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2186 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2187 if (PL_op->op_private & HINT_INTEGER) {
2188 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2189 const IV r = SvIV_nomg(right);
2190 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2194 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2195 const UV r = SvUV_nomg(right);
2196 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2199 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2200 if (right_ro_nonnum) SvNIOK_off(right);
2203 do_vop(op_type, TARG, left, right);
2210 PERL_STATIC_INLINE bool
2211 S_negate_string(pTHX)
2216 SV * const sv = TOPs;
2217 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2219 s = SvPV_nomg_const(sv, len);
2220 if (isIDFIRST(*s)) {
2221 sv_setpvs(TARG, "-");
2224 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2225 sv_setsv_nomg(TARG, sv);
2226 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2236 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2237 if (S_negate_string(aTHX)) return NORMAL;
2239 SV * const sv = TOPs;
2242 /* It's publicly an integer */
2245 if (SvIVX(sv) == IV_MIN) {
2246 /* 2s complement assumption. */
2247 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2251 else if (SvUVX(sv) <= IV_MAX) {
2256 else if (SvIVX(sv) != IV_MIN) {
2260 #ifdef PERL_PRESERVE_IVUV
2267 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2268 SETn(-SvNV_nomg(sv));
2269 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2270 goto oops_its_an_int;
2272 SETn(-SvNV_nomg(sv));
2280 tryAMAGICun_MG(not_amg, AMGf_set);
2281 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2288 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2292 if (PL_op->op_private & HINT_INTEGER) {
2293 const IV i = ~SvIV_nomg(sv);
2297 const UV u = ~SvUV_nomg(sv);
2306 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2307 sv_setsv_nomg(TARG, sv);
2308 tmps = (U8*)SvPV_force_nomg(TARG, len);
2311 /* Calculate exact length, let's not estimate. */
2316 U8 * const send = tmps + len;
2317 U8 * const origtmps = tmps;
2318 const UV utf8flags = UTF8_ALLOW_ANYUV;
2320 while (tmps < send) {
2321 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2323 targlen += UNISKIP(~c);
2329 /* Now rewind strings and write them. */
2336 Newx(result, targlen + 1, U8);
2338 while (tmps < send) {
2339 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2341 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2344 sv_usepvn_flags(TARG, (char*)result, targlen,
2345 SV_HAS_TRAILING_NUL);
2352 Newx(result, nchar + 1, U8);
2354 while (tmps < send) {
2355 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2360 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2369 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2372 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2377 for ( ; anum > 0; anum--, tmps++)
2385 /* integer versions of some of the above */
2389 dVAR; dSP; dATARGET;
2390 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2393 SETi( left * right );
2401 dVAR; dSP; dATARGET;
2402 tryAMAGICbin_MG(div_amg, AMGf_assign);
2405 IV value = SvIV_nomg(right);
2407 DIE(aTHX_ "Illegal division by zero");
2408 num = SvIV_nomg(left);
2410 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2414 value = num / value;
2420 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2427 /* This is the vanilla old i_modulo. */
2428 dVAR; dSP; dATARGET;
2429 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2433 DIE(aTHX_ "Illegal modulus zero");
2434 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2438 SETi( left % right );
2443 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2448 /* This is the i_modulo with the workaround for the _moddi3 bug
2449 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2450 * See below for pp_i_modulo. */
2451 dVAR; dSP; dATARGET;
2452 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2456 DIE(aTHX_ "Illegal modulus zero");
2457 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2461 SETi( left % PERL_ABS(right) );
2468 dVAR; dSP; dATARGET;
2469 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2473 DIE(aTHX_ "Illegal modulus zero");
2474 /* The assumption is to use hereafter the old vanilla version... */
2476 PL_ppaddr[OP_I_MODULO] =
2478 /* .. but if we have glibc, we might have a buggy _moddi3
2479 * (at least glicb 2.2.5 is known to have this bug), in other
2480 * words our integer modulus with negative quad as the second
2481 * argument might be broken. Test for this and re-patch the
2482 * opcode dispatch table if that is the case, remembering to
2483 * also apply the workaround so that this first round works
2484 * right, too. See [perl #9402] for more information. */
2488 /* Cannot do this check with inlined IV constants since
2489 * that seems to work correctly even with the buggy glibc. */
2491 /* Yikes, we have the bug.
2492 * Patch in the workaround version. */
2494 PL_ppaddr[OP_I_MODULO] =
2495 &Perl_pp_i_modulo_1;
2496 /* Make certain we work right this time, too. */
2497 right = PERL_ABS(right);
2500 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2504 SETi( left % right );
2512 dVAR; dSP; dATARGET;
2513 tryAMAGICbin_MG(add_amg, AMGf_assign);
2515 dPOPTOPiirl_ul_nomg;
2516 SETi( left + right );
2523 dVAR; dSP; dATARGET;
2524 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2526 dPOPTOPiirl_ul_nomg;
2527 SETi( left - right );
2535 tryAMAGICbin_MG(lt_amg, AMGf_set);
2538 SETs(boolSV(left < right));
2546 tryAMAGICbin_MG(gt_amg, AMGf_set);
2549 SETs(boolSV(left > right));
2557 tryAMAGICbin_MG(le_amg, AMGf_set);
2560 SETs(boolSV(left <= right));
2568 tryAMAGICbin_MG(ge_amg, AMGf_set);
2571 SETs(boolSV(left >= right));
2579 tryAMAGICbin_MG(eq_amg, AMGf_set);
2582 SETs(boolSV(left == right));
2590 tryAMAGICbin_MG(ne_amg, AMGf_set);
2593 SETs(boolSV(left != right));
2601 tryAMAGICbin_MG(ncmp_amg, 0);
2608 else if (left < right)
2620 tryAMAGICun_MG(neg_amg, 0);
2621 if (S_negate_string(aTHX)) return NORMAL;
2623 SV * const sv = TOPs;
2624 IV const i = SvIV_nomg(sv);
2630 /* High falutin' math. */
2635 tryAMAGICbin_MG(atan2_amg, 0);
2638 SETn(Perl_atan2(left, right));
2646 int amg_type = sin_amg;
2647 const char *neg_report = NULL;
2648 NV (*func)(NV) = Perl_sin;
2649 const int op_type = PL_op->op_type;
2666 amg_type = sqrt_amg;
2668 neg_report = "sqrt";
2673 tryAMAGICun_MG(amg_type, 0);
2675 SV * const arg = POPs;
2676 const NV value = SvNV_nomg(arg);
2678 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2679 SET_NUMERIC_STANDARD();
2680 /* diag_listed_as: Can't take log of %g */
2681 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2684 XPUSHn(func(value));
2689 /* Support Configure command-line overrides for rand() functions.
2690 After 5.005, perhaps we should replace this by Configure support
2691 for drand48(), random(), or rand(). For 5.005, though, maintain
2692 compatibility by calling rand() but allow the user to override it.
2693 See INSTALL for details. --Andy Dougherty 15 July 1998
2695 /* Now it's after 5.005, and Configure supports drand48() and random(),
2696 in addition to rand(). So the overrides should not be needed any more.
2697 --Jarkko Hietaniemi 27 September 1998
2700 #ifndef HAS_DRAND48_PROTO
2701 extern double drand48 (void);
2707 if (!PL_srand_called) {
2708 (void)seedDrand01((Rand_seed_t)seed());
2709 PL_srand_called = TRUE;
2719 SV * const sv = POPs;
2725 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2733 sv_setnv_mg(TARG, value);
2744 if (MAXARG >= 1 && (TOPs || POPs)) {
2751 pv = SvPV(top, len);
2752 flags = grok_number(pv, len, &anum);
2754 if (!(flags & IS_NUMBER_IN_UV)) {
2755 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2756 "Integer overflow in srand");
2764 (void)seedDrand01((Rand_seed_t)anum);
2765 PL_srand_called = TRUE;
2769 /* Historically srand always returned true. We can avoid breaking
2771 sv_setpvs(TARG, "0 but true");
2780 tryAMAGICun_MG(int_amg, AMGf_numeric);
2782 SV * const sv = TOPs;
2783 const IV iv = SvIV_nomg(sv);
2784 /* XXX it's arguable that compiler casting to IV might be subtly
2785 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2786 else preferring IV has introduced a subtle behaviour change bug. OTOH
2787 relying on floating point to be accurate is a bug. */
2792 else if (SvIOK(sv)) {
2794 SETu(SvUV_nomg(sv));
2799 const NV value = SvNV_nomg(sv);
2801 if (value < (NV)UV_MAX + 0.5) {
2804 SETn(Perl_floor(value));
2808 if (value > (NV)IV_MIN - 0.5) {
2811 SETn(Perl_ceil(value));
2822 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2824 SV * const sv = TOPs;
2825 /* This will cache the NV value if string isn't actually integer */
2826 const IV iv = SvIV_nomg(sv);
2831 else if (SvIOK(sv)) {
2832 /* IVX is precise */
2834 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2842 /* 2s complement assumption. Also, not really needed as
2843 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2849 const NV value = SvNV_nomg(sv);
2863 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2867 SV* const sv = POPs;
2869 tmps = (SvPV_const(sv, len));
2871 /* If Unicode, try to downgrade
2872 * If not possible, croak. */
2873 SV* const tsv = sv_2mortal(newSVsv(sv));
2876 sv_utf8_downgrade(tsv, FALSE);
2877 tmps = SvPV_const(tsv, len);
2879 if (PL_op->op_type == OP_HEX)
2882 while (*tmps && len && isSPACE(*tmps))
2886 if (*tmps == 'x' || *tmps == 'X') {
2888 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2890 else if (*tmps == 'b' || *tmps == 'B')
2891 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2893 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2895 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2909 SV * const sv = TOPs;
2914 SETi(sv_len_utf8_nomg(sv));
2918 (void)SvPV_nomg_const(sv,len);
2922 if (!SvPADTMP(TARG)) {
2923 sv_setsv_nomg(TARG, &PL_sv_undef);
2931 /* Returns false if substring is completely outside original string.
2932 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2933 always be true for an explicit 0.
2936 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2937 bool pos1_is_uv, IV len_iv,
2938 bool len_is_uv, STRLEN *posp,
2944 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2946 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2947 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2950 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2953 if (len_iv || len_is_uv) {
2954 if (!len_is_uv && len_iv < 0) {
2955 pos2_iv = curlen + len_iv;
2957 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2960 } else { /* len_iv >= 0 */
2961 if (!pos1_is_uv && pos1_iv < 0) {
2962 pos2_iv = pos1_iv + len_iv;
2963 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2965 if ((UV)len_iv > curlen-(UV)pos1_iv)
2968 pos2_iv = pos1_iv+len_iv;
2978 if (!pos2_is_uv && pos2_iv < 0) {
2979 if (!pos1_is_uv && pos1_iv < 0)
2983 else if (!pos1_is_uv && pos1_iv < 0)
2986 if ((UV)pos2_iv < (UV)pos1_iv)
2988 if ((UV)pos2_iv > curlen)
2991 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2992 *posp = (STRLEN)( (UV)pos1_iv );
2993 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3010 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3011 const bool rvalue = (GIMME_V != G_VOID);
3014 const char *repl = NULL;
3016 int num_args = PL_op->op_private & 7;
3017 bool repl_need_utf8_upgrade = FALSE;
3021 if(!(repl_sv = POPs)) num_args--;
3023 if ((len_sv = POPs)) {
3024 len_iv = SvIV(len_sv);
3025 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3030 pos1_iv = SvIV(pos_sv);
3031 pos1_is_uv = SvIOK_UV(pos_sv);
3033 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3038 if (lvalue && !repl_sv) {
3040 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3041 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3043 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3045 pos1_is_uv || pos1_iv >= 0
3046 ? (STRLEN)(UV)pos1_iv
3047 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3049 len_is_uv || len_iv > 0
3050 ? (STRLEN)(UV)len_iv
3051 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3054 PUSHs(ret); /* avoid SvSETMAGIC here */
3058 repl = SvPV_const(repl_sv, repl_len);
3061 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3062 "Attempt to use reference as lvalue in substr"
3064 tmps = SvPV_force_nomg(sv, curlen);
3065 if (DO_UTF8(repl_sv) && repl_len) {
3067 sv_utf8_upgrade_nomg(sv);
3071 else if (DO_UTF8(sv))
3072 repl_need_utf8_upgrade = TRUE;
3074 else tmps = SvPV_const(sv, curlen);
3076 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3077 if (utf8_curlen == curlen)
3080 curlen = utf8_curlen;
3086 STRLEN pos, len, byte_len, byte_pos;
3088 if (!translate_substr_offsets(
3089 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3093 byte_pos = utf8_curlen
3094 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3099 SvTAINTED_off(TARG); /* decontaminate */
3100 SvUTF8_off(TARG); /* decontaminate */
3101 sv_setpvn(TARG, tmps, byte_len);
3102 #ifdef USE_LOCALE_COLLATE
3103 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3110 SV* repl_sv_copy = NULL;
3112 if (repl_need_utf8_upgrade) {
3113 repl_sv_copy = newSVsv(repl_sv);
3114 sv_utf8_upgrade(repl_sv_copy);
3115 repl = SvPV_const(repl_sv_copy, repl_len);
3119 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3120 SvREFCNT_dec(repl_sv_copy);
3132 Perl_croak(aTHX_ "substr outside of string");
3133 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3140 const IV size = POPi;
3141 const IV offset = POPi;
3142 SV * const src = POPs;
3143 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3146 if (lvalue) { /* it's an lvalue! */
3147 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3148 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3150 LvTARG(ret) = SvREFCNT_inc_simple(src);
3151 LvTARGOFF(ret) = offset;
3152 LvTARGLEN(ret) = size;
3156 SvTAINTED_off(TARG); /* decontaminate */
3160 sv_setuv(ret, do_vecget(src, offset, size));
3176 const char *little_p;
3179 const bool is_index = PL_op->op_type == OP_INDEX;
3180 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3186 big_p = SvPV_const(big, biglen);
3187 little_p = SvPV_const(little, llen);
3189 big_utf8 = DO_UTF8(big);
3190 little_utf8 = DO_UTF8(little);
3191 if (big_utf8 ^ little_utf8) {
3192 /* One needs to be upgraded. */
3193 if (little_utf8 && !PL_encoding) {
3194 /* Well, maybe instead we might be able to downgrade the small
3196 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3199 /* If the large string is ISO-8859-1, and it's not possible to
3200 convert the small string to ISO-8859-1, then there is no
3201 way that it could be found anywhere by index. */
3206 /* At this point, pv is a malloc()ed string. So donate it to temp
3207 to ensure it will get free()d */
3208 little = temp = newSV(0);
3209 sv_usepvn(temp, pv, llen);
3210 little_p = SvPVX(little);
3213 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3216 sv_recode_to_utf8(temp, PL_encoding);
3218 sv_utf8_upgrade(temp);
3223 big_p = SvPV_const(big, biglen);
3226 little_p = SvPV_const(little, llen);
3230 if (SvGAMAGIC(big)) {
3231 /* Life just becomes a lot easier if I use a temporary here.
3232 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3233 will trigger magic and overloading again, as will fbm_instr()
3235 big = newSVpvn_flags(big_p, biglen,
3236 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3239 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3240 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3241 warn on undef, and we've already triggered a warning with the
3242 SvPV_const some lines above. We can't remove that, as we need to
3243 call some SvPV to trigger overloading early and find out if the
3245 This is all getting to messy. The API isn't quite clean enough,
3246 because data access has side effects.
3248 little = newSVpvn_flags(little_p, llen,
3249 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3250 little_p = SvPVX(little);
3254 offset = is_index ? 0 : biglen;
3256 if (big_utf8 && offset > 0)
3257 sv_pos_u2b(big, &offset, 0);
3263 else if (offset > (I32)biglen)
3265 if (!(little_p = is_index
3266 ? fbm_instr((unsigned char*)big_p + offset,
3267 (unsigned char*)big_p + biglen, little, 0)
3268 : rninstr(big_p, big_p + offset,
3269 little_p, little_p + llen)))
3272 retval = little_p - big_p;
3273 if (retval > 0 && big_utf8)
3274 sv_pos_b2u(big, &retval);
3284 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3285 SvTAINTED_off(TARG);
3286 do_sprintf(TARG, SP-MARK, MARK+1);
3287 TAINT_IF(SvTAINTED(TARG));
3299 const U8 *s = (U8*)SvPV_const(argsv, len);
3301 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3302 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3303 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3307 XPUSHu(DO_UTF8(argsv) ?
3308 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3322 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3323 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3325 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3326 && SvNV_nomg(top) < 0.0))) {
3327 if (ckWARN(WARN_UTF8)) {
3328 if (SvGMAGICAL(top)) {
3329 SV *top2 = sv_newmortal();
3330 sv_setsv_nomg(top2, top);
3333 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3334 "Invalid negative number (%"SVf") in chr", top);
3336 value = UNICODE_REPLACEMENT;
3338 value = SvUV_nomg(top);
3341 SvUPGRADE(TARG,SVt_PV);
3343 if (value > 255 && !IN_BYTES) {
3344 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3345 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3346 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3348 (void)SvPOK_only(TARG);
3357 *tmps++ = (char)value;
3359 (void)SvPOK_only(TARG);
3361 if (PL_encoding && !IN_BYTES) {
3362 sv_recode_to_utf8(TARG, PL_encoding);
3364 if (SvCUR(TARG) == 0
3365 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3366 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3371 *tmps++ = (char)value;
3387 const char *tmps = SvPV_const(left, len);
3389 if (DO_UTF8(left)) {
3390 /* If Unicode, try to downgrade.
3391 * If not possible, croak.
3392 * Yes, we made this up. */
3393 SV* const tsv = sv_2mortal(newSVsv(left));
3396 sv_utf8_downgrade(tsv, FALSE);
3397 tmps = SvPV_const(tsv, len);
3399 # ifdef USE_ITHREADS
3401 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3402 /* This should be threadsafe because in ithreads there is only
3403 * one thread per interpreter. If this would not be true,
3404 * we would need a mutex to protect this malloc. */
3405 PL_reentrant_buffer->_crypt_struct_buffer =
3406 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3407 #if defined(__GLIBC__) || defined(__EMX__)
3408 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3409 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3410 /* work around glibc-2.2.5 bug */
3411 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3415 # endif /* HAS_CRYPT_R */
3416 # endif /* USE_ITHREADS */
3418 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3420 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3426 "The crypt() function is unimplemented due to excessive paranoia.");
3430 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3431 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3433 /* Generates code to store a unicode codepoint c that is known to occupy
3434 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
3435 * and p is advanced to point to the next available byte after the two bytes */
3436 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3438 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3439 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3444 /* Actually is both lcfirst() and ucfirst(). Only the first character
3445 * changes. This means that possibly we can change in-place, ie., just
3446 * take the source and change that one character and store it back, but not
3447 * if read-only etc, or if the length changes */
3452 STRLEN slen; /* slen is the byte length of the whole SV. */
3455 bool inplace; /* ? Convert first char only, in-place */
3456 bool doing_utf8 = FALSE; /* ? using utf8 */
3457 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3458 const int op_type = PL_op->op_type;
3461 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3462 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3463 * stored as UTF-8 at s. */
3464 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3465 * lowercased) character stored in tmpbuf. May be either
3466 * UTF-8 or not, but in either case is the number of bytes */
3467 bool tainted = FALSE;
3471 s = (const U8*)SvPV_nomg_const(source, slen);
3473 if (ckWARN(WARN_UNINITIALIZED))
3474 report_uninit(source);
3479 /* We may be able to get away with changing only the first character, in
3480 * place, but not if read-only, etc. Later we may discover more reasons to
3481 * not convert in-place. */
3482 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3484 /* First calculate what the changed first character should be. This affects
3485 * whether we can just swap it out, leaving the rest of the string unchanged,
3486 * or even if have to convert the dest to UTF-8 when the source isn't */
3488 if (! slen) { /* If empty */
3489 need = 1; /* still need a trailing NUL */
3492 else if (DO_UTF8(source)) { /* Is the source utf8? */
3495 if (op_type == OP_UCFIRST) {
3496 _to_utf8_title_flags(s, tmpbuf, &tculen,
3497 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3500 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3501 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3504 /* we can't do in-place if the length changes. */
3505 if (ulen != tculen) inplace = FALSE;
3506 need = slen + 1 - ulen + tculen;
3508 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3509 * latin1 is treated as caseless. Note that a locale takes
3511 ulen = 1; /* Original character is 1 byte */
3512 tculen = 1; /* Most characters will require one byte, but this will
3513 * need to be overridden for the tricky ones */
3516 if (op_type == OP_LCFIRST) {
3518 /* lower case the first letter: no trickiness for any character */
3519 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3520 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3523 else if (IN_LOCALE_RUNTIME) {
3524 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3525 * have upper and title case different
3528 else if (! IN_UNI_8_BIT) {
3529 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3530 * on EBCDIC machines whatever the
3531 * native function does */
3533 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3534 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3536 assert(tculen == 2);
3538 /* If the result is an upper Latin1-range character, it can
3539 * still be represented in one byte, which is its ordinal */
3540 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3541 *tmpbuf = (U8) title_ord;
3545 /* Otherwise it became more than one ASCII character (in
3546 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3547 * beyond Latin1, so the number of bytes changed, so can't
3548 * replace just the first character in place. */
3551 /* If the result won't fit in a byte, the entire result
3552 * will have to be in UTF-8. Assume worst case sizing in
3553 * conversion. (all latin1 characters occupy at most two
3555 if (title_ord > 255) {
3557 convert_source_to_utf8 = TRUE;
3558 need = slen * 2 + 1;
3560 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3561 * (both) characters whose title case is above 255 is
3565 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3566 need = slen + 1 + 1;
3570 } /* End of use Unicode (Latin1) semantics */
3571 } /* End of changing the case of the first character */
3573 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3574 * generate the result */
3577 /* We can convert in place. This means we change just the first
3578 * character without disturbing the rest; no need to grow */
3580 s = d = (U8*)SvPV_force_nomg(source, slen);
3586 /* Here, we can't convert in place; we earlier calculated how much
3587 * space we will need, so grow to accommodate that */
3588 SvUPGRADE(dest, SVt_PV);
3589 d = (U8*)SvGROW(dest, need);
3590 (void)SvPOK_only(dest);
3597 if (! convert_source_to_utf8) {
3599 /* Here both source and dest are in UTF-8, but have to create
3600 * the entire output. We initialize the result to be the
3601 * title/lower cased first character, and then append the rest
3603 sv_setpvn(dest, (char*)tmpbuf, tculen);
3605 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3609 const U8 *const send = s + slen;
3611 /* Here the dest needs to be in UTF-8, but the source isn't,
3612 * except we earlier UTF-8'd the first character of the source
3613 * into tmpbuf. First put that into dest, and then append the
3614 * rest of the source, converting it to UTF-8 as we go. */
3616 /* Assert tculen is 2 here because the only two characters that
3617 * get to this part of the code have 2-byte UTF-8 equivalents */
3619 *d++ = *(tmpbuf + 1);
3620 s++; /* We have just processed the 1st char */
3622 for (; s < send; s++) {
3623 d = uvchr_to_utf8(d, *s);
3626 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3630 else { /* in-place UTF-8. Just overwrite the first character */
3631 Copy(tmpbuf, d, tculen, U8);
3632 SvCUR_set(dest, need - 1);
3640 else { /* Neither source nor dest are in or need to be UTF-8 */
3642 if (IN_LOCALE_RUNTIME) {
3646 if (inplace) { /* in-place, only need to change the 1st char */
3649 else { /* Not in-place */
3651 /* Copy the case-changed character(s) from tmpbuf */
3652 Copy(tmpbuf, d, tculen, U8);
3653 d += tculen - 1; /* Code below expects d to point to final
3654 * character stored */
3657 else { /* empty source */
3658 /* See bug #39028: Don't taint if empty */
3662 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3663 * the destination to retain that flag */
3667 if (!inplace) { /* Finish the rest of the string, unchanged */
3668 /* This will copy the trailing NUL */
3669 Copy(s + 1, d + 1, slen, U8);
3670 SvCUR_set(dest, need - 1);
3673 if (dest != source && SvTAINTED(source))
3679 /* There's so much setup/teardown code common between uc and lc, I wonder if
3680 it would be worth merging the two, and just having a switch outside each
3681 of the three tight loops. There is less and less commonality though */
3695 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3696 && SvTEMP(source) && !DO_UTF8(source)
3697 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3699 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3700 * make the loop tight, so we overwrite the source with the dest before
3701 * looking at it, and we need to look at the original source
3702 * afterwards. There would also need to be code added to handle
3703 * switching to not in-place in midstream if we run into characters
3704 * that change the length.
3707 s = d = (U8*)SvPV_force_nomg(source, len);
3714 /* The old implementation would copy source into TARG at this point.
3715 This had the side effect that if source was undef, TARG was now
3716 an undefined SV with PADTMP set, and they don't warn inside
3717 sv_2pv_flags(). However, we're now getting the PV direct from
3718 source, which doesn't have PADTMP set, so it would warn. Hence the
3722 s = (const U8*)SvPV_nomg_const(source, len);
3724 if (ckWARN(WARN_UNINITIALIZED))
3725 report_uninit(source);
3731 SvUPGRADE(dest, SVt_PV);
3732 d = (U8*)SvGROW(dest, min);
3733 (void)SvPOK_only(dest);
3738 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3739 to check DO_UTF8 again here. */
3741 if (DO_UTF8(source)) {
3742 const U8 *const send = s + len;
3743 U8 tmpbuf[UTF8_MAXBYTES+1];
3744 bool tainted = FALSE;
3746 /* All occurrences of these are to be moved to follow any other marks.
3747 * This is context-dependent. We may not be passed enough context to
3748 * move the iota subscript beyond all of them, but we do the best we can
3749 * with what we're given. The result is always better than if we
3750 * hadn't done this. And, the problem would only arise if we are
3751 * passed a character without all its combining marks, which would be
3752 * the caller's mistake. The information this is based on comes from a
3753 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3754 * itself) and so can't be checked properly to see if it ever gets
3755 * revised. But the likelihood of it changing is remote */
3756 bool in_iota_subscript = FALSE;
3762 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3764 /* A non-mark. Time to output the iota subscript */
3765 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3766 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3768 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3769 in_iota_subscript = FALSE;
3772 /* Then handle the current character. Get the changed case value
3773 * and copy it to the output buffer */
3776 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3777 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3778 if (uv == GREEK_CAPITAL_LETTER_IOTA
3779 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3781 in_iota_subscript = TRUE;
3784 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3785 /* If the eventually required minimum size outgrows the
3786 * available space, we need to grow. */
3787 const UV o = d - (U8*)SvPVX_const(dest);
3789 /* If someone uppercases one million U+03B0s we SvGROW()
3790 * one million times. Or we could try guessing how much to
3791 * allocate without allocating too much. Such is life.
3792 * See corresponding comment in lc code for another option
3795 d = (U8*)SvPVX(dest) + o;
3797 Copy(tmpbuf, d, ulen, U8);
3802 if (in_iota_subscript) {
3803 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3808 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3814 else { /* Not UTF-8 */
3816 const U8 *const send = s + len;
3818 /* Use locale casing if in locale; regular style if not treating
3819 * latin1 as having case; otherwise the latin1 casing. Do the
3820 * whole thing in a tight loop, for speed, */
3821 if (IN_LOCALE_RUNTIME) {
3824 for (; s < send; d++, s++)
3825 *d = toUPPER_LC(*s);
3827 else if (! IN_UNI_8_BIT) {
3828 for (; s < send; d++, s++) {
3833 for (; s < send; d++, s++) {
3834 *d = toUPPER_LATIN1_MOD(*s);
3835 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3839 /* The mainstream case is the tight loop above. To avoid
3840 * extra tests in that, all three characters that require
3841 * special handling are mapped by the MOD to the one tested
3843 * Use the source to distinguish between the three cases */
3845 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3847 /* uc() of this requires 2 characters, but they are
3848 * ASCII. If not enough room, grow the string */
3849 if (SvLEN(dest) < ++min) {
3850 const UV o = d - (U8*)SvPVX_const(dest);
3852 d = (U8*)SvPVX(dest) + o;
3854 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3855 continue; /* Back to the tight loop; still in ASCII */
3858 /* The other two special handling characters have their
3859 * upper cases outside the latin1 range, hence need to be
3860 * in UTF-8, so the whole result needs to be in UTF-8. So,
3861 * here we are somewhere in the middle of processing a
3862 * non-UTF-8 string, and realize that we will have to convert
3863 * the whole thing to UTF-8. What to do? There are
3864 * several possibilities. The simplest to code is to
3865 * convert what we have so far, set a flag, and continue on
3866 * in the loop. The flag would be tested each time through
3867 * the loop, and if set, the next character would be
3868 * converted to UTF-8 and stored. But, I (khw) didn't want
3869 * to slow down the mainstream case at all for this fairly
3870 * rare case, so I didn't want to add a test that didn't
3871 * absolutely have to be there in the loop, besides the
3872 * possibility that it would get too complicated for
3873 * optimizers to deal with. Another possibility is to just
3874 * give up, convert the source to UTF-8, and restart the
3875 * function that way. Another possibility is to convert
3876 * both what has already been processed and what is yet to
3877 * come separately to UTF-8, then jump into the loop that
3878 * handles UTF-8. But the most efficient time-wise of the
3879 * ones I could think of is what follows, and turned out to
3880 * not require much extra code. */
3882 /* Convert what we have so far into UTF-8, telling the
3883 * function that we know it should be converted, and to
3884 * allow extra space for what we haven't processed yet.
3885 * Assume the worst case space requirements for converting
3886 * what we haven't processed so far: that it will require
3887 * two bytes for each remaining source character, plus the
3888 * NUL at the end. This may cause the string pointer to
3889 * move, so re-find it. */
3891 len = d - (U8*)SvPVX_const(dest);
3892 SvCUR_set(dest, len);
3893 len = sv_utf8_upgrade_flags_grow(dest,
3894 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3896 d = (U8*)SvPVX(dest) + len;
3898 /* Now process the remainder of the source, converting to
3899 * upper and UTF-8. If a resulting byte is invariant in
3900 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3901 * append it to the output. */
3902 for (; s < send; s++) {
3903 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3907 /* Here have processed the whole source; no need to continue
3908 * with the outer loop. Each character has been converted
3909 * to upper case and converted to UTF-8 */
3912 } /* End of processing all latin1-style chars */
3913 } /* End of processing all chars */
3914 } /* End of source is not empty */
3916 if (source != dest) {
3917 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3918 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3920 } /* End of isn't utf8 */
3921 if (dest != source && SvTAINTED(source))
3940 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3941 && SvTEMP(source) && !DO_UTF8(source)) {
3943 /* We can convert in place, as lowercasing anything in the latin1 range
3944 * (or else DO_UTF8 would have been on) doesn't lengthen it */
3946 s = d = (U8*)SvPV_force_nomg(source, len);
3953 /* The old implementation would copy source into TARG at this point.
3954 This had the side effect that if source was undef, TARG was now
3955 an undefined SV with PADTMP set, and they don't warn inside
3956 sv_2pv_flags(). However, we're now getting the PV direct from
3957 source, which doesn't have PADTMP set, so it would warn. Hence the
3961 s = (const U8*)SvPV_nomg_const(source, len);
3963 if (ckWARN(WARN_UNINITIALIZED))
3964 report_uninit(source);
3970 SvUPGRADE(dest, SVt_PV);
3971 d = (U8*)SvGROW(dest, min);
3972 (void)SvPOK_only(dest);
3977 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3978 to check DO_UTF8 again here. */
3980 if (DO_UTF8(source)) {
3981 const U8 *const send = s + len;
3982 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3983 bool tainted = FALSE;
3986 const STRLEN u = UTF8SKIP(s);
3989 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3990 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3992 /* Here is where we would do context-sensitive actions. See the
3993 * commit message for this comment for why there isn't any */
3995 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3997 /* If the eventually required minimum size outgrows the
3998 * available space, we need to grow. */
3999 const UV o = d - (U8*)SvPVX_const(dest);
4001 /* If someone lowercases one million U+0130s we SvGROW() one
4002 * million times. Or we could try guessing how much to
4003 * allocate without allocating too much. Such is life.
4004 * Another option would be to grow an extra byte or two more
4005 * each time we need to grow, which would cut down the million
4006 * to 500K, with little waste */
4008 d = (U8*)SvPVX(dest) + o;
4011 /* Copy the newly lowercased letter to the output buffer we're
4013 Copy(tmpbuf, d, ulen, U8);
4016 } /* End of looping through the source string */
4019 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4024 } else { /* Not utf8 */
4026 const U8 *const send = s + len;
4028 /* Use locale casing if in locale; regular style if not treating
4029 * latin1 as having case; otherwise the latin1 casing. Do the
4030 * whole thing in a tight loop, for speed, */
4031 if (IN_LOCALE_RUNTIME) {
4034 for (; s < send; d++, s++)
4035 *d = toLOWER_LC(*s);
4037 else if (! IN_UNI_8_BIT) {
4038 for (; s < send; d++, s++) {
4043 for (; s < send; d++, s++) {
4044 *d = toLOWER_LATIN1(*s);
4048 if (source != dest) {
4050 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4053 if (dest != source && SvTAINTED(source))
4062 SV * const sv = TOPs;
4064 const char *s = SvPV_const(sv,len);
4066 SvUTF8_off(TARG); /* decontaminate */
4069 SvUPGRADE(TARG, SVt_PV);
4070 SvGROW(TARG, (len * 2) + 1);
4074 STRLEN ulen = UTF8SKIP(s);
4075 bool to_quote = FALSE;
4077 if (UTF8_IS_INVARIANT(*s)) {
4078 if (_isQUOTEMETA(*s)) {
4082 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4084 /* In locale, we quote all non-ASCII Latin1 chars.
4085 * Otherwise use the quoting rules */
4086 if (IN_LOCALE_RUNTIME
4087 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
4092 else if (is_QUOTEMETA_high(s)) {
4107 else if (IN_UNI_8_BIT) {
4109 if (_isQUOTEMETA(*s))
4115 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4116 * including everything above ASCII */
4118 if (!isWORDCHAR_A(*s))
4124 SvCUR_set(TARG, d - SvPVX_const(TARG));
4125 (void)SvPOK_only_UTF8(TARG);
4128 sv_setpvn(TARG, s, len);
4145 U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
4146 const bool full_folding = TRUE;
4147 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4148 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4150 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4151 * You are welcome(?) -Hugmeir
4159 s = (const U8*)SvPV_nomg_const(source, len);
4161 if (ckWARN(WARN_UNINITIALIZED))
4162 report_uninit(source);
4169 SvUPGRADE(dest, SVt_PV);
4170 d = (U8*)SvGROW(dest, min);
4171 (void)SvPOK_only(dest);
4176 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4177 bool tainted = FALSE;
4179 const STRLEN u = UTF8SKIP(s);
4182 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4184 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4185 const UV o = d - (U8*)SvPVX_const(dest);
4187 d = (U8*)SvPVX(dest) + o;
4190 Copy(tmpbuf, d, ulen, U8);
4199 } /* Unflagged string */
4201 /* For locale, bytes, and nothing, the behavior is supposed to be the
4204 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4207 for (; s < send; d++, s++)
4208 *d = toLOWER_LC(*s);
4210 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4211 for (; s < send; d++, s++)
4215 /* For ASCII and the Latin-1 range, there's only two troublesome
4216 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4217 * casefolding becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which
4218 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4219 * For the rest, the casefold is their lowercase. */
4220 for (; s < send; d++, s++) {
4221 if (*s == MICRO_SIGN) {
4222 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4223 * which is outside of the latin-1 range. There's a couple
4224 * of ways to deal with this -- khw discusses them in
4225 * pp_lc/uc, so go there :) What we do here is upgrade what
4226 * we had already casefolded, then enter an inner loop that
4227 * appends the rest of the characters as UTF-8. */
4228 len = d - (U8*)SvPVX_const(dest);
4229 SvCUR_set(dest, len);
4230 len = sv_utf8_upgrade_flags_grow(dest,
4231 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4232 /* The max expansion for latin1
4233 * chars is 1 byte becomes 2 */
4235 d = (U8*)SvPVX(dest) + len;
4237 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU);
4239 for (; s < send; s++) {
4241 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4242 if UNI_IS_INVARIANT(fc) {
4244 && *s == LATIN_SMALL_LETTER_SHARP_S)
4253 Copy(tmpbuf, d, ulen, U8);
4259 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4260 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4261 * becomes "ss", which may require growing the SV. */
4262 if (SvLEN(dest) < ++min) {
4263 const UV o = d - (U8*)SvPVX_const(dest);
4265 d = (U8*)SvPVX(dest) + o;
4270 else { /* If it's not one of those two, the fold is their lower
4272 *d = toLOWER_LATIN1(*s);
4278 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4280 if (SvTAINTED(source))
4290 dVAR; dSP; dMARK; dORIGMARK;
4291 AV *const av = MUTABLE_AV(POPs);
4292 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4294 if (SvTYPE(av) == SVt_PVAV) {
4295 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4296 bool can_preserve = FALSE;
4302 can_preserve = SvCANEXISTDELETE(av);
4305 if (lval && localizing) {
4308 for (svp = MARK + 1; svp <= SP; svp++) {
4309 const I32 elem = SvIV(*svp);
4313 if (max > AvMAX(av))
4317 while (++MARK <= SP) {
4319 I32 elem = SvIV(*MARK);
4320 bool preeminent = TRUE;
4322 if (localizing && can_preserve) {
4323 /* If we can determine whether the element exist,
4324 * Try to preserve the existenceness of a tied array
4325 * element by using EXISTS and DELETE if possible.
4326 * Fallback to FETCH and STORE otherwise. */
4327 preeminent = av_exists(av, elem);
4330 svp = av_fetch(av, elem, lval);
4332 if (!svp || *svp == &PL_sv_undef)
4333 DIE(aTHX_ PL_no_aelem, elem);
4336 save_aelem(av, elem, svp);
4338 SAVEADELETE(av, elem);
4341 *MARK = svp ? *svp : &PL_sv_undef;
4344 if (GIMME != G_ARRAY) {
4346 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4352 /* Smart dereferencing for keys, values and each */
4364 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4369 "Type of argument to %s must be unblessed hashref or arrayref",
4370 PL_op_desc[PL_op->op_type] );
4373 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4375 "Can't modify %s in %s",
4376 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4379 /* Delegate to correct function for op type */
4381 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4382 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4385 return (SvTYPE(sv) == SVt_PVHV)
4386 ? Perl_pp_each(aTHX)
4387 : Perl_pp_aeach(aTHX);
4395 AV *array = MUTABLE_AV(POPs);
4396 const I32 gimme = GIMME_V;
4397 IV *iterp = Perl_av_iter_p(aTHX_ array);
4398 const IV current = (*iterp)++;
4400 if (current > av_len(array)) {
4402 if (gimme == G_SCALAR)
4410 if (gimme == G_ARRAY) {
4411 SV **const element = av_fetch(array, current, 0);
4412 PUSHs(element ? *element : &PL_sv_undef);
4421 AV *array = MUTABLE_AV(POPs);
4422 const I32 gimme = GIMME_V;
4424 *Perl_av_iter_p(aTHX_ array) = 0;
4426 if (gimme == G_SCALAR) {
4428 PUSHi(av_len(array) + 1);
4430 else if (gimme == G_ARRAY) {
4431 IV n = Perl_av_len(aTHX_ array);
4436 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4437 for (i = 0; i <= n; i++) {
4442 for (i = 0; i <= n; i++) {
4443 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4444 PUSHs(elem ? *elem : &PL_sv_undef);
4451 /* Associative arrays. */
4457 HV * hash = MUTABLE_HV(POPs);
4459 const I32 gimme = GIMME_V;
4462 /* might clobber stack_sp */
4463 entry = hv_iternext(hash);
4468 SV* const sv = hv_iterkeysv(entry);
4469 PUSHs(sv); /* won't clobber stack_sp */
4470 if (gimme == G_ARRAY) {
4473 /* might clobber stack_sp */
4474 val = hv_iterval(hash, entry);
4479 else if (gimme == G_SCALAR)
4486 S_do_delete_local(pTHX)
4490 const I32 gimme = GIMME_V;
4493 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4494 SV *unsliced_keysv = sliced ? NULL : POPs;
4495 SV * const osv = POPs;
4496 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4498 const bool tied = SvRMAGICAL(osv)
4499 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4500 const bool can_preserve = SvCANEXISTDELETE(osv);
4501 const U32 type = SvTYPE(osv);
4502 SV ** const end = sliced ? SP : &unsliced_keysv;
4504 if (type == SVt_PVHV) { /* hash element */
4505 HV * const hv = MUTABLE_HV(osv);
4506 while (++MARK <= end) {
4507 SV * const keysv = *MARK;
4509 bool preeminent = TRUE;
4511 preeminent = hv_exists_ent(hv, keysv, 0);
4513 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4520 sv = hv_delete_ent(hv, keysv, 0, 0);
4521 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4524 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4525 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4527 *MARK = sv_mortalcopy(sv);
4533 SAVEHDELETE(hv, keysv);
4534 *MARK = &PL_sv_undef;
4538 else if (type == SVt_PVAV) { /* array element */
4539 if (PL_op->op_flags & OPf_SPECIAL) {
4540 AV * const av = MUTABLE_AV(osv);
4541 while (++MARK <= end) {
4542 I32 idx = SvIV(*MARK);
4544 bool preeminent = TRUE;
4546 preeminent = av_exists(av, idx);
4548 SV **svp = av_fetch(av, idx, 1);
4555 sv = av_delete(av, idx, 0);
4556 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4559 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4561 *MARK = sv_mortalcopy(sv);
4567 SAVEADELETE(av, idx);
4568 *MARK = &PL_sv_undef;
4573 DIE(aTHX_ "panic: avhv_delete no longer supported");
4576 DIE(aTHX_ "Not a HASH reference");
4578 if (gimme == G_VOID)
4580 else if (gimme == G_SCALAR) {
4585 *++MARK = &PL_sv_undef;
4589 else if (gimme != G_VOID)
4590 PUSHs(unsliced_keysv);
4602 if (PL_op->op_private & OPpLVAL_INTRO)
4603 return do_delete_local();
4606 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4608 if (PL_op->op_private & OPpSLICE) {
4610 HV * const hv = MUTABLE_HV(POPs);
4611 const U32 hvtype = SvTYPE(hv);
4612 if (hvtype == SVt_PVHV) { /* hash element */
4613 while (++MARK <= SP) {
4614 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4615 *MARK = sv ? sv : &PL_sv_undef;
4618 else if (hvtype == SVt_PVAV) { /* array element */
4619 if (PL_op->op_flags & OPf_SPECIAL) {
4620 while (++MARK <= SP) {
4621 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4622 *MARK = sv ? sv : &PL_sv_undef;
4627 DIE(aTHX_ "Not a HASH reference");
4630 else if (gimme == G_SCALAR) {
4635 *++MARK = &PL_sv_undef;
4641 HV * const hv = MUTABLE_HV(POPs);
4643 if (SvTYPE(hv) == SVt_PVHV)
4644 sv = hv_delete_ent(hv, keysv, discard, 0);
4645 else if (SvTYPE(hv) == SVt_PVAV) {
4646 if (PL_op->op_flags & OPf_SPECIAL)
4647 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4649 DIE(aTHX_ "panic: avhv_delete no longer supported");
4652 DIE(aTHX_ "Not a HASH reference");
4668 if (PL_op->op_private & OPpEXISTS_SUB) {
4670 SV * const sv = POPs;
4671 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4674 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4679 hv = MUTABLE_HV(POPs);
4680 if (SvTYPE(hv) == SVt_PVHV) {
4681 if (hv_exists_ent(hv, tmpsv, 0))
4684 else if (SvTYPE(hv) == SVt_PVAV) {
4685 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4686 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4691 DIE(aTHX_ "Not a HASH reference");
4698 dVAR; dSP; dMARK; dORIGMARK;
4699 HV * const hv = MUTABLE_HV(POPs);
4700 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4701 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4702 bool can_preserve = FALSE;
4708 if (SvCANEXISTDELETE(hv))
4709 can_preserve = TRUE;
4712 while (++MARK <= SP) {
4713 SV * const keysv = *MARK;
4716 bool preeminent = TRUE;
4718 if (localizing && can_preserve) {
4719 /* If we can determine whether the element exist,
4720 * try to preserve the existenceness of a tied hash
4721 * element by using EXISTS and DELETE if possible.
4722 * Fallback to FETCH and STORE otherwise. */
4723 preeminent = hv_exists_ent(hv, keysv, 0);
4726 he = hv_fetch_ent(hv, keysv, lval, 0);
4727 svp = he ? &HeVAL(he) : NULL;
4730 if (!svp || !*svp || *svp == &PL_sv_undef) {
4731 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4734 if (HvNAME_get(hv) && isGV(*svp))
4735 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4736 else if (preeminent)
4737 save_helem_flags(hv, keysv, svp,
4738 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4740 SAVEHDELETE(hv, keysv);
4743 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4745 if (GIMME != G_ARRAY) {
4747 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4753 /* List operators. */
4758 if (GIMME != G_ARRAY) {
4760 *MARK = *SP; /* unwanted list, return last item */
4762 *MARK = &PL_sv_undef;
4772 SV ** const lastrelem = PL_stack_sp;
4773 SV ** const lastlelem = PL_stack_base + POPMARK;
4774 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4775 SV ** const firstrelem = lastlelem + 1;
4776 I32 is_something_there = FALSE;
4778 const I32 max = lastrelem - lastlelem;
4781 if (GIMME != G_ARRAY) {
4782 I32 ix = SvIV(*lastlelem);
4785 if (ix < 0 || ix >= max)
4786 *firstlelem = &PL_sv_undef;
4788 *firstlelem = firstrelem[ix];
4794 SP = firstlelem - 1;
4798 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4799 I32 ix = SvIV(*lelem);
4802 if (ix < 0 || ix >= max)
4803 *lelem = &PL_sv_undef;
4805 is_something_there = TRUE;
4806 if (!(*lelem = firstrelem[ix]))
4807 *lelem = &PL_sv_undef;
4810 if (is_something_there)
4813 SP = firstlelem - 1;
4819 dVAR; dSP; dMARK; dORIGMARK;
4820 const I32 items = SP - MARK;
4821 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4822 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4823 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4824 ? newRV_noinc(av) : av);
4830 dVAR; dSP; dMARK; dORIGMARK;
4831 HV* const hv = (HV *)sv_2mortal((SV *)newHV());
4835 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4842 sv_setsv(val, *MARK);
4846 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4849 (void)hv_store_ent(hv,key,val,0);
4852 if (PL_op->op_flags & OPf_SPECIAL)
4853 mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
4854 else XPUSHs(MUTABLE_SV(hv));
4859 S_deref_plain_array(pTHX_ AV *ary)
4861 if (SvTYPE(ary) == SVt_PVAV) return ary;
4862 SvGETMAGIC((SV *)ary);
4863 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4864 Perl_die(aTHX_ "Not an ARRAY reference");
4865 else if (SvOBJECT(SvRV(ary)))
4866 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4867 return (AV *)SvRV(ary);
4870 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4871 # define DEREF_PLAIN_ARRAY(ary) \
4874 SvTYPE(aRrRay) == SVt_PVAV \
4876 : S_deref_plain_array(aTHX_ aRrRay); \
4879 # define DEREF_PLAIN_ARRAY(ary) \
4881 PL_Sv = (SV *)(ary), \
4882 SvTYPE(PL_Sv) == SVt_PVAV \
4884 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4890 dVAR; dSP; dMARK; dORIGMARK;
4891 int num_args = (SP - MARK);
4892 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4901 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4904 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4905 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4912 offset = i = SvIV(*MARK);
4914 offset += AvFILLp(ary) + 1;
4916 DIE(aTHX_ PL_no_aelem, i);
4918 length = SvIVx(*MARK++);
4920 length += AvFILLp(ary) - offset + 1;
4926 length = AvMAX(ary) + 1; /* close enough to infinity */
4930 length = AvMAX(ary) + 1;
4932 if (offset > AvFILLp(ary) + 1) {
4934 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4935 offset = AvFILLp(ary) + 1;
4937 after = AvFILLp(ary) + 1 - (offset + length);
4938 if (after < 0) { /* not that much array */
4939 length += after; /* offset+length now in array */
4945 /* At this point, MARK .. SP-1 is our new LIST */
4948 diff = newlen - length;
4949 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4952 /* make new elements SVs now: avoid problems if they're from the array */
4953 for (dst = MARK, i = newlen; i; i--) {
4954 SV * const h = *dst;
4955 *dst++ = newSVsv(h);
4958 if (diff < 0) { /* shrinking the area */
4959 SV **tmparyval = NULL;
4961 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4962 Copy(MARK, tmparyval, newlen, SV*);
4965 MARK = ORIGMARK + 1;
4966 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4967 MEXTEND(MARK, length);
4968 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4970 EXTEND_MORTAL(length);
4971 for (i = length, dst = MARK; i; i--) {
4972 sv_2mortal(*dst); /* free them eventually */
4979 *MARK = AvARRAY(ary)[offset+length-1];
4982 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4983 SvREFCNT_dec(*dst++); /* free them now */
4986 AvFILLp(ary) += diff;
4988 /* pull up or down? */
4990 if (offset < after) { /* easier to pull up */
4991 if (offset) { /* esp. if nothing to pull */
4992 src = &AvARRAY(ary)[offset-1];
4993 dst = src - diff; /* diff is negative */
4994 for (i = offset; i > 0; i--) /* can't trust Copy */
4998 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5002 if (after) { /* anything to pull down? */
5003 src = AvARRAY(ary) + offset + length;
5004 dst = src + diff; /* diff is negative */
5005 Move(src, dst, after, SV*);
5007 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5008 /* avoid later double free */
5012 dst[--i] = &PL_sv_undef;
5015 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5016 Safefree(tmparyval);
5019 else { /* no, expanding (or same) */
5020 SV** tmparyval = NULL;
5022 Newx(tmparyval, length, SV*); /* so remember deletion */
5023 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5026 if (diff > 0) { /* expanding */
5027 /* push up or down? */
5028 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5032 Move(src, dst, offset, SV*);
5034 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5036 AvFILLp(ary) += diff;
5039 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5040 av_extend(ary, AvFILLp(ary) + diff);
5041 AvFILLp(ary) += diff;
5044 dst = AvARRAY(ary) + AvFILLp(ary);
5046 for (i = after; i; i--) {
5054 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5057 MARK = ORIGMARK + 1;
5058 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5060 Copy(tmparyval, MARK, length, SV*);
5062 EXTEND_MORTAL(length);
5063 for (i = length, dst = MARK; i; i--) {
5064 sv_2mortal(*dst); /* free them eventually */
5071 else if (length--) {
5072 *MARK = tmparyval[length];
5075 while (length-- > 0)
5076 SvREFCNT_dec(tmparyval[length]);
5080 *MARK = &PL_sv_undef;
5081 Safefree(tmparyval);
5085 mg_set(MUTABLE_SV(ary));
5093 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5094 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5095 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5098 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5101 ENTER_with_name("call_PUSH");
5102 call_method("PUSH",G_SCALAR|G_DISCARD);
5103 LEAVE_with_name("call_PUSH");
5107 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5108 PL_delaymagic = DM_DELAY;
5109 for (++MARK; MARK <= SP; MARK++) {
5111 if (*MARK) SvGETMAGIC(*MARK);
5114 sv_setsv_nomg(sv, *MARK);
5115 av_store(ary, AvFILLp(ary)+1, sv);
5117 if (PL_delaymagic & DM_ARRAY_ISA)
5118 mg_set(MUTABLE_SV(ary));
5123 if (OP_GIMME(PL_op, 0) != G_VOID) {
5124 PUSHi( AvFILL(ary) + 1 );
5133 AV * const av = PL_op->op_flags & OPf_SPECIAL
5134 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5135 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5139 (void)sv_2mortal(sv);
5146 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5147 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5148 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5151 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5154 ENTER_with_name("call_UNSHIFT");
5155 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5156 LEAVE_with_name("call_UNSHIFT");
5161 av_unshift(ary, SP - MARK);
5163 SV * const sv = newSVsv(*++MARK);
5164 (void)av_store(ary, i++, sv);
5168 if (OP_GIMME(PL_op, 0) != G_VOID) {
5169 PUSHi( AvFILL(ary) + 1 );
5178 if (GIMME == G_ARRAY) {
5179 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5183 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5184 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5185 av = MUTABLE_AV((*SP));
5186 /* In-place reversing only happens in void context for the array
5187 * assignment. We don't need to push anything on the stack. */
5190 if (SvMAGICAL(av)) {
5192 SV *tmp = sv_newmortal();
5193 /* For SvCANEXISTDELETE */
5196 bool can_preserve = SvCANEXISTDELETE(av);
5198 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5202 if (!av_exists(av, i)) {
5203 if (av_exists(av, j)) {
5204 SV *sv = av_delete(av, j, 0);
5205 begin = *av_fetch(av, i, TRUE);
5206 sv_setsv_mg(begin, sv);
5210 else if (!av_exists(av, j)) {
5211 SV *sv = av_delete(av, i, 0);
5212 end = *av_fetch(av, j, TRUE);
5213 sv_setsv_mg(end, sv);
5218 begin = *av_fetch(av, i, TRUE);
5219 end = *av_fetch(av, j, TRUE);
5220 sv_setsv(tmp, begin);
5221 sv_setsv_mg(begin, end);
5222 sv_setsv_mg(end, tmp);
5226 SV **begin = AvARRAY(av);
5229 SV **end = begin + AvFILLp(av);
5231 while (begin < end) {
5232 SV * const tmp = *begin;
5243 SV * const tmp = *MARK;
5247 /* safe as long as stack cannot get extended in the above */
5258 SvUTF8_off(TARG); /* decontaminate */
5260 do_join(TARG, &PL_sv_no, MARK, SP);
5262 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5263 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5264 report_uninit(TARG);
5267 up = SvPV_force(TARG, len);
5269 if (DO_UTF8(TARG)) { /* first reverse each character */
5270 U8* s = (U8*)SvPVX(TARG);
5271 const U8* send = (U8*)(s + len);
5273 if (UTF8_IS_INVARIANT(*s)) {
5278 if (!utf8_to_uvchr_buf(s, send, 0))
5282 down = (char*)(s - 1);
5283 /* reverse this character */
5287 *down-- = (char)tmp;
5293 down = SvPVX(TARG) + len - 1;
5297 *down-- = (char)tmp;
5299 (void)SvPOK_only_UTF8(TARG);
5311 IV limit = POPi; /* note, negative is forever */
5312 SV * const sv = POPs;
5314 const char *s = SvPV_const(sv, len);
5315 const bool do_utf8 = DO_UTF8(sv);
5316 const bool skipwhite = PL_op->op_flags & OPf_SPECIAL;
5317 const char *strend = s + len;
5323 const STRLEN slen = do_utf8
5324 ? utf8_length((U8*)s, (U8*)strend)
5325 : (STRLEN)(strend - s);
5326 I32 maxiters = slen + 10;
5327 I32 trailing_empty = 0;
5329 const I32 origlimit = limit;
5332 const I32 gimme = GIMME_V;
5334 const I32 oldsave = PL_savestack_ix;
5335 U32 make_mortal = SVs_TEMP;
5340 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5345 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5348 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5349 (RX_EXTFLAGS(rx) & RXf_WHITE || skipwhite));
5351 RX_MATCH_UTF8_set(rx, do_utf8);
5354 if (pm->op_pmreplrootu.op_pmtargetoff) {
5355 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5358 if (pm->op_pmreplrootu.op_pmtargetgv) {
5359 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5370 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5372 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5379 for (i = AvFILLp(ary); i >= 0; i--)
5380 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5382 /* temporarily switch stacks */
5383 SAVESWITCHSTACK(PL_curstack, ary);
5387 base = SP - PL_stack_base;
5391 while (isSPACE_utf8(s))
5394 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5395 while (isSPACE_LC(*s))
5403 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5407 gimme_scalar = gimme == G_SCALAR && !ary;
5410 limit = maxiters + 2;
5411 if (RX_EXTFLAGS(rx) & RXf_WHITE || skipwhite) {
5414 /* this one uses 'm' and is a negative test */
5416 while (m < strend && ! isSPACE_utf8(m) ) {
5417 const int t = UTF8SKIP(m);
5418 /* isSPACE_utf8 returns FALSE for malform utf8 */
5425 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5427 while (m < strend && !isSPACE_LC(*m))
5430 while (m < strend && !isSPACE(*m))
5443 dstr = newSVpvn_flags(s, m-s,
5444 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5448 /* skip the whitespace found last */
5450 s = m + UTF8SKIP(m);
5454 /* this one uses 's' and is a positive test */
5456 while (s < strend && isSPACE_utf8(s) )
5459 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5461 while (s < strend && isSPACE_LC(*s))
5464 while (s < strend && isSPACE(*s))
5469 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5471 for (m = s; m < strend && *m != '\n'; m++)
5484 dstr = newSVpvn_flags(s, m-s,
5485 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5491 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5493 Pre-extend the stack, either the number of bytes or
5494 characters in the string or a limited amount, triggered by:
5496 my ($x, $y) = split //, $str;
5500 if (!gimme_scalar) {
5501 const U32 items = limit - 1;
5510 /* keep track of how many bytes we skip over */
5520 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5533 dstr = newSVpvn(s, 1);
5549 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5550 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5551 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5552 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5553 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5554 SV * const csv = CALLREG_INTUIT_STRING(rx);
5556 len = RX_MINLENRET(rx);
5557 if (len == 1 && !RX_UTF8(rx) && !tail) {
5558 const char c = *SvPV_nolen_const(csv);
5560 for (m = s; m < strend && *m != c; m++)
5571 dstr = newSVpvn_flags(s, m-s,
5572 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5575 /* The rx->minlen is in characters but we want to step
5576 * s ahead by bytes. */
5578 s = (char*)utf8_hop((U8*)m, len);
5580 s = m + len; /* Fake \n at the end */
5584 while (s < strend && --limit &&
5585 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5586 csv, multiline ? FBMrf_MULTILINE : 0)) )
5595 dstr = newSVpvn_flags(s, m-s,
5596 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5599 /* The rx->minlen is in characters but we want to step
5600 * s ahead by bytes. */
5602 s = (char*)utf8_hop((U8*)m, len);
5604 s = m + len; /* Fake \n at the end */
5609 maxiters += slen * RX_NPARENS(rx);
5610 while (s < strend && --limit)
5614 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5617 if (rex_return == 0)
5619 TAINT_IF(RX_MATCH_TAINTED(rx));
5620 /* we never pass the REXEC_COPY_STR flag, so it should
5621 * never get copied */
5622 assert(!RX_MATCH_COPIED(rx));
5623 m = RX_OFFS(rx)[0].start + orig;
5632 dstr = newSVpvn_flags(s, m-s,
5633 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5636 if (RX_NPARENS(rx)) {
5638 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5639 s = RX_OFFS(rx)[i].start + orig;
5640 m = RX_OFFS(rx)[i].end + orig;
5642 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5643 parens that didn't match -- they should be set to
5644 undef, not the empty string */
5652 if (m >= orig && s >= orig) {
5653 dstr = newSVpvn_flags(s, m-s,
5654 (do_utf8 ? SVf_UTF8 : 0)
5658 dstr = &PL_sv_undef; /* undef, not "" */
5664 s = RX_OFFS(rx)[0].end + orig;
5668 if (!gimme_scalar) {
5669 iters = (SP - PL_stack_base) - base;
5671 if (iters > maxiters)
5672 DIE(aTHX_ "Split loop");
5674 /* keep field after final delim? */
5675 if (s < strend || (iters && origlimit)) {
5676 if (!gimme_scalar) {
5677 const STRLEN l = strend - s;
5678 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5683 else if (!origlimit) {
5685 iters -= trailing_empty;
5687 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5688 if (TOPs && !make_mortal)
5690 *SP-- = &PL_sv_undef;
5697 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5701 if (SvSMAGICAL(ary)) {
5703 mg_set(MUTABLE_SV(ary));
5706 if (gimme == G_ARRAY) {
5708 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5715 ENTER_with_name("call_PUSH");
5716 call_method("PUSH",G_SCALAR|G_DISCARD);
5717 LEAVE_with_name("call_PUSH");
5719 if (gimme == G_ARRAY) {
5721 /* EXTEND should not be needed - we just popped them */
5723 for (i=0; i < iters; i++) {
5724 SV **svp = av_fetch(ary, i, FALSE);
5725 PUSHs((svp) ? *svp : &PL_sv_undef);
5732 if (gimme == G_ARRAY)
5744 SV *const sv = PAD_SVl(PL_op->op_targ);
5746 if (SvPADSTALE(sv)) {
5749 RETURNOP(cLOGOP->op_other);
5751 RETURNOP(cLOGOP->op_next);
5761 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5762 || SvTYPE(retsv) == SVt_PVCV) {
5763 retsv = refto(retsv);
5770 PP(unimplemented_op)
5773 const Optype op_type = PL_op->op_type;
5774 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5775 with out of range op numbers - it only "special" cases op_custom.
5776 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5777 if we get here for a custom op then that means that the custom op didn't
5778 have an implementation. Given that OP_NAME() looks up the custom op
5779 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5780 registers &PL_unimplemented_op as the address of their custom op.
5781 NULL doesn't generate a useful error message. "custom" does. */
5782 const char *const name = op_type >= OP_max
5783 ? "[out of range]" : PL_op_name[PL_op->op_type];
5784 if(OP_IS_SOCKET(op_type))
5785 DIE(aTHX_ PL_no_sock_func, name);
5786 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5789 /* For sorting out arguments passed to a &CORE:: subroutine */
5793 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5794 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5795 AV * const at_ = GvAV(PL_defgv);
5796 SV **svp = at_ ? AvARRAY(at_) : NULL;
5797 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5798 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5799 bool seen_question = 0;
5800 const char *err = NULL;
5801 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5803 /* Count how many args there are first, to get some idea how far to
5804 extend the stack. */
5806 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5808 if (oa & OA_OPTIONAL) seen_question = 1;
5809 if (!seen_question) minargs++;
5813 if(numargs < minargs) err = "Not enough";
5814 else if(numargs > maxargs) err = "Too many";
5816 /* diag_listed_as: Too many arguments for %s */
5818 "%s arguments for %s", err,
5819 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5822 /* Reset the stack pointer. Without this, we end up returning our own
5823 arguments in list context, in addition to the values we are supposed
5824 to return. nextstate usually does this on sub entry, but we need
5825 to run the next op with the caller's hints, so we cannot have a
5827 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5829 if(!maxargs) RETURN;
5831 /* We do this here, rather than with a separate pushmark op, as it has
5832 to come in between two things this function does (stack reset and
5833 arg pushing). This seems the easiest way to do it. */
5836 (void)Perl_pp_pushmark(aTHX);
5839 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5840 PUTBACK; /* The code below can die in various places. */
5842 oa = PL_opargs[opnum] >> OASHIFT;
5843 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5848 if (!numargs && defgv && whicharg == minargs + 1) {
5849 PUSHs(find_rundefsv2(
5850 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5851 cxstack[cxstack_ix].blk_oldcop->cop_seq
5854 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5858 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5863 if (!svp || !*svp || !SvROK(*svp)
5864 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5866 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5867 "Type of arg %d to &CORE::%s must be hash reference",
5868 whicharg, OP_DESC(PL_op->op_next)
5873 if (!numargs) PUSHs(NULL);
5874 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5875 /* no magic here, as the prototype will have added an extra
5876 refgen and we just want what was there before that */
5879 const bool constr = PL_op->op_private & whicharg;
5881 svp && *svp ? *svp : &PL_sv_undef,
5882 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5888 if (!numargs) goto try_defsv;
5890 const bool wantscalar =
5891 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5892 if (!svp || !*svp || !SvROK(*svp)
5893 /* We have to permit globrefs even for the \$ proto, as
5894 *foo is indistinguishable from ${\*foo}, and the proto-
5895 type permits the latter. */
5896 || SvTYPE(SvRV(*svp)) > (
5897 wantscalar ? SVt_PVLV
5898 : opnum == OP_LOCK || opnum == OP_UNDEF
5904 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5905 "Type of arg %d to &CORE::%s must be %s",
5906 whicharg, PL_op_name[opnum],
5908 ? "scalar reference"
5909 : opnum == OP_LOCK || opnum == OP_UNDEF
5910 ? "reference to one of [$@%&*]"
5911 : "reference to one of [$@%*]"
5914 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5915 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5916 /* Undo @_ localisation, so that sub exit does not undo
5917 part of our undeffing. */
5918 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5920 cx->cx_type &= ~ CXp_HASARGS;
5921 assert(!AvREAL(cx->blk_sub.argarray));
5926 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5938 if (PL_op->op_private & OPpOFFBYONE) {
5939 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5941 else cv = find_runcv(NULL);
5942 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5949 * c-indentation-style: bsd
5951 * indent-tabs-mode: nil
5954 * ex: set ts=8 sts=4 sw=4 et: