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) = 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)) == OPpMAY_RETURN_CONSTANT)
461 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
462 /* (But not in defined().) */
464 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
466 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
470 cv = MUTABLE_CV(&PL_sv_undef);
471 SETs(MUTABLE_SV(cv));
481 SV *ret = &PL_sv_undef;
483 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
484 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
485 const char * s = SvPVX_const(TOPs);
486 if (strnEQ(s, "CORE::", 6)) {
487 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
488 if (!code || code == -KEY_CORE)
489 DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
490 SVfARG(newSVpvn_flags(
492 (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP
495 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
501 cv = sv_2cv(TOPs, &stash, &gv, 0);
503 ret = newSVpvn_flags(
504 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
514 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
516 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
518 PUSHs(MUTABLE_SV(cv));
532 if (GIMME != G_ARRAY) {
536 *MARK = &PL_sv_undef;
537 *MARK = refto(*MARK);
541 EXTEND_MORTAL(SP - MARK);
543 *MARK = refto(*MARK);
548 S_refto(pTHX_ SV *sv)
553 PERL_ARGS_ASSERT_REFTO;
555 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
558 if (!(sv = LvTARG(sv)))
561 SvREFCNT_inc_void_NN(sv);
563 else if (SvTYPE(sv) == SVt_PVAV) {
564 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
565 av_reify(MUTABLE_AV(sv));
567 SvREFCNT_inc_void_NN(sv);
569 else if (SvPADTMP(sv) && !IS_PADGV(sv))
573 SvREFCNT_inc_void_NN(sv);
576 sv_upgrade(rv, SVt_IV);
585 SV * const sv = POPs;
590 if (!sv || !SvROK(sv))
593 (void)sv_ref(TARG,SvRV(sv),TRUE);
605 stash = CopSTASH(PL_curcop);
607 SV * const ssv = POPs;
611 if (!ssv) goto curstash;
612 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
613 Perl_croak(aTHX_ "Attempt to bless into a reference");
614 ptr = SvPV_const(ssv,len);
616 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
617 "Explicit blessing to '' (assuming package main)");
618 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
621 (void)sv_bless(TOPs, stash);
631 const char * const elem = SvPV_const(sv, len);
632 GV * const gv = MUTABLE_GV(POPs);
637 /* elem will always be NUL terminated. */
638 const char * const second_letter = elem + 1;
641 if (len == 5 && strEQ(second_letter, "RRAY"))
643 tmpRef = MUTABLE_SV(GvAV(gv));
644 if (tmpRef && !AvREAL((const AV *)tmpRef)
645 && AvREIFY((const AV *)tmpRef))
646 av_reify(MUTABLE_AV(tmpRef));
650 if (len == 4 && strEQ(second_letter, "ODE"))
651 tmpRef = MUTABLE_SV(GvCVu(gv));
654 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
655 /* finally deprecated in 5.8.0 */
656 deprecate("*glob{FILEHANDLE}");
657 tmpRef = MUTABLE_SV(GvIOp(gv));
660 if (len == 6 && strEQ(second_letter, "ORMAT"))
661 tmpRef = MUTABLE_SV(GvFORM(gv));
664 if (len == 4 && strEQ(second_letter, "LOB"))
665 tmpRef = MUTABLE_SV(gv);
668 if (len == 4 && strEQ(second_letter, "ASH"))
669 tmpRef = MUTABLE_SV(GvHV(gv));
672 if (*second_letter == 'O' && !elem[2] && len == 2)
673 tmpRef = MUTABLE_SV(GvIOp(gv));
676 if (len == 4 && strEQ(second_letter, "AME"))
677 sv = newSVhek(GvNAME_HEK(gv));
680 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
681 const HV * const stash = GvSTASH(gv);
682 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
683 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
687 if (len == 6 && strEQ(second_letter, "CALAR"))
702 /* Pattern matching */
710 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
711 /* Historically, study was skipped in these cases. */
715 /* Make study a no-op. It's no longer useful and its existence
716 complicates matters elsewhere. */
725 if (PL_op->op_flags & OPf_STACKED)
727 else if (PL_op->op_private & OPpTARGET_MY)
733 if(PL_op->op_type == OP_TRANSR) {
735 const char * const pv = SvPV(sv,len);
736 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
741 TARG = sv_newmortal();
747 /* Lvalue operators. */
750 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
756 PERL_ARGS_ASSERT_DO_CHOMP;
758 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
760 if (SvTYPE(sv) == SVt_PVAV) {
762 AV *const av = MUTABLE_AV(sv);
763 const I32 max = AvFILL(av);
765 for (i = 0; i <= max; i++) {
766 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
767 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
768 do_chomp(retval, sv, chomping);
772 else if (SvTYPE(sv) == SVt_PVHV) {
773 HV* const hv = MUTABLE_HV(sv);
775 (void)hv_iterinit(hv);
776 while ((entry = hv_iternext(hv)))
777 do_chomp(retval, hv_iterval(hv,entry), chomping);
780 else if (SvREADONLY(sv)) {
781 Perl_croak_no_modify();
783 else if (SvIsCOW(sv)) {
784 sv_force_normal_flags(sv, 0);
789 /* XXX, here sv is utf8-ized as a side-effect!
790 If encoding.pm is used properly, almost string-generating
791 operations, including literal strings, chr(), input data, etc.
792 should have been utf8-ized already, right?
794 sv_recode_to_utf8(sv, PL_encoding);
800 char *temp_buffer = NULL;
809 while (len && s[-1] == '\n') {
816 STRLEN rslen, rs_charlen;
817 const char *rsptr = SvPV_const(PL_rs, rslen);
819 rs_charlen = SvUTF8(PL_rs)
823 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
824 /* Assumption is that rs is shorter than the scalar. */
826 /* RS is utf8, scalar is 8 bit. */
828 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
831 /* Cannot downgrade, therefore cannot possibly match
833 assert (temp_buffer == rsptr);
839 else if (PL_encoding) {
840 /* RS is 8 bit, encoding.pm is used.
841 * Do not recode PL_rs as a side-effect. */
842 svrecode = newSVpvn(rsptr, rslen);
843 sv_recode_to_utf8(svrecode, PL_encoding);
844 rsptr = SvPV_const(svrecode, rslen);
845 rs_charlen = sv_len_utf8(svrecode);
848 /* RS is 8 bit, scalar is utf8. */
849 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
863 if (memNE(s, rsptr, rslen))
865 SvIVX(retval) += rs_charlen;
868 s = SvPV_force_nomg_nolen(sv);
876 SvREFCNT_dec(svrecode);
878 Safefree(temp_buffer);
880 if (len && !SvPOK(sv))
881 s = SvPV_force_nomg(sv, len);
884 char * const send = s + len;
885 char * const start = s;
887 while (s > start && UTF8_IS_CONTINUATION(*s))
889 if (is_utf8_string((U8*)s, send - s)) {
890 sv_setpvn(retval, s, send - s);
892 SvCUR_set(sv, s - start);
898 sv_setpvs(retval, "");
902 sv_setpvn(retval, s, 1);
909 sv_setpvs(retval, "");
917 const bool chomping = PL_op->op_type == OP_SCHOMP;
921 do_chomp(TARG, TOPs, chomping);
928 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
929 const bool chomping = PL_op->op_type == OP_CHOMP;
934 do_chomp(TARG, *++MARK, chomping);
945 if (!PL_op->op_private) {
954 SV_CHECK_THINKFIRST_COW_DROP(sv);
956 switch (SvTYPE(sv)) {
960 av_undef(MUTABLE_AV(sv));
963 hv_undef(MUTABLE_HV(sv));
966 if (cv_const_sv((const CV *)sv))
967 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
968 "Constant subroutine %"SVf" undefined",
969 SVfARG(CvANON((const CV *)sv)
970 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
971 : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
975 /* let user-undef'd sub keep its identity */
976 GV* const gv = CvGV((const CV *)sv);
977 HEK * const hek = CvNAME_HEK((CV *)sv);
978 if (hek) share_hek_hek(hek);
979 cv_undef(MUTABLE_CV(sv));
980 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
982 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
988 assert(isGV_with_GP(sv));
994 /* undef *Pkg::meth_name ... */
996 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
997 && HvENAME_get(stash);
999 if((stash = GvHV((const GV *)sv))) {
1000 if(HvENAME_get(stash))
1001 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1005 gp_free(MUTABLE_GV(sv));
1007 GvGP_set(sv, gp_ref(gp));
1008 GvSV(sv) = newSV(0);
1009 GvLINE(sv) = CopLINE(PL_curcop);
1010 GvEGV(sv) = MUTABLE_GV(sv);
1014 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1016 /* undef *Foo::ISA */
1017 if( strEQ(GvNAME((const GV *)sv), "ISA")
1018 && (stash = GvSTASH((const GV *)sv))
1019 && (method_changed || HvENAME(stash)) )
1020 mro_isa_changed_in(stash);
1021 else if(method_changed)
1022 mro_method_changed_in(
1023 GvSTASH((const GV *)sv)
1029 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1045 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1046 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1047 Perl_croak_no_modify();
1049 TARG = sv_newmortal();
1050 sv_setsv(TARG, TOPs);
1051 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1052 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1054 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1055 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1059 else sv_dec_nomg(TOPs);
1061 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1062 if (inc && !SvOK(TARG))
1068 /* Ordinary operators. */
1072 dVAR; dSP; dATARGET; SV *svl, *svr;
1073 #ifdef PERL_PRESERVE_IVUV
1076 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1079 #ifdef PERL_PRESERVE_IVUV
1080 /* For integer to integer power, we do the calculation by hand wherever
1081 we're sure it is safe; otherwise we call pow() and try to convert to
1082 integer afterwards. */
1083 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1091 const IV iv = SvIVX(svr);
1095 goto float_it; /* Can't do negative powers this way. */
1099 baseuok = SvUOK(svl);
1101 baseuv = SvUVX(svl);
1103 const IV iv = SvIVX(svl);
1106 baseuok = TRUE; /* effectively it's a UV now */
1108 baseuv = -iv; /* abs, baseuok == false records sign */
1111 /* now we have integer ** positive integer. */
1114 /* foo & (foo - 1) is zero only for a power of 2. */
1115 if (!(baseuv & (baseuv - 1))) {
1116 /* We are raising power-of-2 to a positive integer.
1117 The logic here will work for any base (even non-integer
1118 bases) but it can be less accurate than
1119 pow (base,power) or exp (power * log (base)) when the
1120 intermediate values start to spill out of the mantissa.
1121 With powers of 2 we know this can't happen.
1122 And powers of 2 are the favourite thing for perl
1123 programmers to notice ** not doing what they mean. */
1125 NV base = baseuok ? baseuv : -(NV)baseuv;
1130 while (power >>= 1) {
1138 SvIV_please_nomg(svr);
1141 unsigned int highbit = 8 * sizeof(UV);
1142 unsigned int diff = 8 * sizeof(UV);
1143 while (diff >>= 1) {
1145 if (baseuv >> highbit) {
1149 /* we now have baseuv < 2 ** highbit */
1150 if (power * highbit <= 8 * sizeof(UV)) {
1151 /* result will definitely fit in UV, so use UV math
1152 on same algorithm as above */
1155 const bool odd_power = cBOOL(power & 1);
1159 while (power >>= 1) {
1166 if (baseuok || !odd_power)
1167 /* answer is positive */
1169 else if (result <= (UV)IV_MAX)
1170 /* answer negative, fits in IV */
1171 SETi( -(IV)result );
1172 else if (result == (UV)IV_MIN)
1173 /* 2's complement assumption: special case IV_MIN */
1176 /* answer negative, doesn't fit */
1177 SETn( -(NV)result );
1185 NV right = SvNV_nomg(svr);
1186 NV left = SvNV_nomg(svl);
1189 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1191 We are building perl with long double support and are on an AIX OS
1192 afflicted with a powl() function that wrongly returns NaNQ for any
1193 negative base. This was reported to IBM as PMR #23047-379 on
1194 03/06/2006. The problem exists in at least the following versions
1195 of AIX and the libm fileset, and no doubt others as well:
1197 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1198 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1199 AIX 5.2.0 bos.adt.libm 5.2.0.85
1201 So, until IBM fixes powl(), we provide the following workaround to
1202 handle the problem ourselves. Our logic is as follows: for
1203 negative bases (left), we use fmod(right, 2) to check if the
1204 exponent is an odd or even integer:
1206 - if odd, powl(left, right) == -powl(-left, right)
1207 - if even, powl(left, right) == powl(-left, right)
1209 If the exponent is not an integer, the result is rightly NaNQ, so
1210 we just return that (as NV_NAN).
1214 NV mod2 = Perl_fmod( right, 2.0 );
1215 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1216 SETn( -Perl_pow( -left, right) );
1217 } else if (mod2 == 0.0) { /* even integer */
1218 SETn( Perl_pow( -left, right) );
1219 } else { /* fractional power */
1223 SETn( Perl_pow( left, right) );
1226 SETn( Perl_pow( left, right) );
1227 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1229 #ifdef PERL_PRESERVE_IVUV
1231 SvIV_please_nomg(svr);
1239 dVAR; dSP; dATARGET; SV *svl, *svr;
1240 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1243 #ifdef PERL_PRESERVE_IVUV
1244 if (SvIV_please_nomg(svr)) {
1245 /* Unless the left argument is integer in range we are going to have to
1246 use NV maths. Hence only attempt to coerce the right argument if
1247 we know the left is integer. */
1248 /* Left operand is defined, so is it IV? */
1249 if (SvIV_please_nomg(svl)) {
1250 bool auvok = SvUOK(svl);
1251 bool buvok = SvUOK(svr);
1252 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1253 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1262 const IV aiv = SvIVX(svl);
1265 auvok = TRUE; /* effectively it's a UV now */
1267 alow = -aiv; /* abs, auvok == false records sign */
1273 const IV biv = SvIVX(svr);
1276 buvok = TRUE; /* effectively it's a UV now */
1278 blow = -biv; /* abs, buvok == false records sign */
1282 /* If this does sign extension on unsigned it's time for plan B */
1283 ahigh = alow >> (4 * sizeof (UV));
1285 bhigh = blow >> (4 * sizeof (UV));
1287 if (ahigh && bhigh) {
1289 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1290 which is overflow. Drop to NVs below. */
1291 } else if (!ahigh && !bhigh) {
1292 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1293 so the unsigned multiply cannot overflow. */
1294 const UV product = alow * blow;
1295 if (auvok == buvok) {
1296 /* -ve * -ve or +ve * +ve gives a +ve result. */
1300 } else if (product <= (UV)IV_MIN) {
1301 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1302 /* -ve result, which could overflow an IV */
1304 SETi( -(IV)product );
1306 } /* else drop to NVs below. */
1308 /* One operand is large, 1 small */
1311 /* swap the operands */
1313 bhigh = blow; /* bhigh now the temp var for the swap */
1317 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1318 multiplies can't overflow. shift can, add can, -ve can. */
1319 product_middle = ahigh * blow;
1320 if (!(product_middle & topmask)) {
1321 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1323 product_middle <<= (4 * sizeof (UV));
1324 product_low = alow * blow;
1326 /* as for pp_add, UV + something mustn't get smaller.
1327 IIRC ANSI mandates this wrapping *behaviour* for
1328 unsigned whatever the actual representation*/
1329 product_low += product_middle;
1330 if (product_low >= product_middle) {
1331 /* didn't overflow */
1332 if (auvok == buvok) {
1333 /* -ve * -ve or +ve * +ve gives a +ve result. */
1335 SETu( product_low );
1337 } else if (product_low <= (UV)IV_MIN) {
1338 /* 2s complement assumption again */
1339 /* -ve result, which could overflow an IV */
1341 SETi( -(IV)product_low );
1343 } /* else drop to NVs below. */
1345 } /* product_middle too large */
1346 } /* ahigh && bhigh */
1351 NV right = SvNV_nomg(svr);
1352 NV left = SvNV_nomg(svl);
1354 SETn( left * right );
1361 dVAR; dSP; dATARGET; SV *svl, *svr;
1362 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1365 /* Only try to do UV divide first
1366 if ((SLOPPYDIVIDE is true) or
1367 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1369 The assumption is that it is better to use floating point divide
1370 whenever possible, only doing integer divide first if we can't be sure.
1371 If NV_PRESERVES_UV is true then we know at compile time that no UV
1372 can be too large to preserve, so don't need to compile the code to
1373 test the size of UVs. */
1376 # define PERL_TRY_UV_DIVIDE
1377 /* ensure that 20./5. == 4. */
1379 # ifdef PERL_PRESERVE_IVUV
1380 # ifndef NV_PRESERVES_UV
1381 # define PERL_TRY_UV_DIVIDE
1386 #ifdef PERL_TRY_UV_DIVIDE
1387 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1388 bool left_non_neg = SvUOK(svl);
1389 bool right_non_neg = SvUOK(svr);
1393 if (right_non_neg) {
1397 const IV biv = SvIVX(svr);
1400 right_non_neg = TRUE; /* effectively it's a UV now */
1406 /* historically undef()/0 gives a "Use of uninitialized value"
1407 warning before dieing, hence this test goes here.
1408 If it were immediately before the second SvIV_please, then
1409 DIE() would be invoked before left was even inspected, so
1410 no inspection would give no warning. */
1412 DIE(aTHX_ "Illegal division by zero");
1418 const IV aiv = SvIVX(svl);
1421 left_non_neg = TRUE; /* effectively it's a UV now */
1430 /* For sloppy divide we always attempt integer division. */
1432 /* Otherwise we only attempt it if either or both operands
1433 would not be preserved by an NV. If both fit in NVs
1434 we fall through to the NV divide code below. However,
1435 as left >= right to ensure integer result here, we know that
1436 we can skip the test on the right operand - right big
1437 enough not to be preserved can't get here unless left is
1440 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1443 /* Integer division can't overflow, but it can be imprecise. */
1444 const UV result = left / right;
1445 if (result * right == left) {
1446 SP--; /* result is valid */
1447 if (left_non_neg == right_non_neg) {
1448 /* signs identical, result is positive. */
1452 /* 2s complement assumption */
1453 if (result <= (UV)IV_MIN)
1454 SETi( -(IV)result );
1456 /* It's exact but too negative for IV. */
1457 SETn( -(NV)result );
1460 } /* tried integer divide but it was not an integer result */
1461 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1462 } /* one operand wasn't SvIOK */
1463 #endif /* PERL_TRY_UV_DIVIDE */
1465 NV right = SvNV_nomg(svr);
1466 NV left = SvNV_nomg(svl);
1467 (void)POPs;(void)POPs;
1468 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1469 if (! Perl_isnan(right) && right == 0.0)
1473 DIE(aTHX_ "Illegal division by zero");
1474 PUSHn( left / right );
1481 dVAR; dSP; dATARGET;
1482 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1486 bool left_neg = FALSE;
1487 bool right_neg = FALSE;
1488 bool use_double = FALSE;
1489 bool dright_valid = FALSE;
1492 SV * const svr = TOPs;
1493 SV * const svl = TOPm1s;
1494 if (SvIV_please_nomg(svr)) {
1495 right_neg = !SvUOK(svr);
1499 const IV biv = SvIVX(svr);
1502 right_neg = FALSE; /* effectively it's a UV now */
1509 dright = SvNV_nomg(svr);
1510 right_neg = dright < 0;
1513 if (dright < UV_MAX_P1) {
1514 right = U_V(dright);
1515 dright_valid = TRUE; /* In case we need to use double below. */
1521 /* At this point use_double is only true if right is out of range for
1522 a UV. In range NV has been rounded down to nearest UV and
1523 use_double false. */
1524 if (!use_double && SvIV_please_nomg(svl)) {
1525 left_neg = !SvUOK(svl);
1529 const IV aiv = SvIVX(svl);
1532 left_neg = FALSE; /* effectively it's a UV now */
1539 dleft = SvNV_nomg(svl);
1540 left_neg = dleft < 0;
1544 /* This should be exactly the 5.6 behaviour - if left and right are
1545 both in range for UV then use U_V() rather than floor. */
1547 if (dleft < UV_MAX_P1) {
1548 /* right was in range, so is dleft, so use UVs not double.
1552 /* left is out of range for UV, right was in range, so promote
1553 right (back) to double. */
1555 /* The +0.5 is used in 5.6 even though it is not strictly
1556 consistent with the implicit +0 floor in the U_V()
1557 inside the #if 1. */
1558 dleft = Perl_floor(dleft + 0.5);
1561 dright = Perl_floor(dright + 0.5);
1572 DIE(aTHX_ "Illegal modulus zero");
1574 dans = Perl_fmod(dleft, dright);
1575 if ((left_neg != right_neg) && dans)
1576 dans = dright - dans;
1579 sv_setnv(TARG, dans);
1585 DIE(aTHX_ "Illegal modulus zero");
1588 if ((left_neg != right_neg) && ans)
1591 /* XXX may warn: unary minus operator applied to unsigned type */
1592 /* could change -foo to be (~foo)+1 instead */
1593 if (ans <= ~((UV)IV_MAX)+1)
1594 sv_setiv(TARG, ~ans+1);
1596 sv_setnv(TARG, -(NV)ans);
1599 sv_setuv(TARG, ans);
1608 dVAR; dSP; dATARGET;
1612 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1613 /* TODO: think of some way of doing list-repeat overloading ??? */
1618 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1624 const UV uv = SvUV_nomg(sv);
1626 count = IV_MAX; /* The best we can do? */
1630 const IV iv = SvIV_nomg(sv);
1637 else if (SvNOKp(sv)) {
1638 const NV nv = SvNV_nomg(sv);
1645 count = SvIV_nomg(sv);
1647 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1649 static const char oom_list_extend[] = "Out of memory during list extend";
1650 const I32 items = SP - MARK;
1651 const I32 max = items * count;
1653 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1654 /* Did the max computation overflow? */
1655 if (items > 0 && max > 0 && (max < items || max < count))
1656 Perl_croak(aTHX_ oom_list_extend);
1661 /* This code was intended to fix 20010809.028:
1664 for (($x =~ /./g) x 2) {
1665 print chop; # "abcdabcd" expected as output.
1668 * but that change (#11635) broke this code:
1670 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1672 * I can't think of a better fix that doesn't introduce
1673 * an efficiency hit by copying the SVs. The stack isn't
1674 * refcounted, and mortalisation obviously doesn't
1675 * Do The Right Thing when the stack has more than
1676 * one pointer to the same mortal value.
1680 *SP = sv_2mortal(newSVsv(*SP));
1690 repeatcpy((char*)(MARK + items), (char*)MARK,
1691 items * sizeof(const SV *), count - 1);
1694 else if (count <= 0)
1697 else { /* Note: mark already snarfed by pp_list */
1698 SV * const tmpstr = POPs;
1701 static const char oom_string_extend[] =
1702 "Out of memory during string extend";
1705 sv_setsv_nomg(TARG, tmpstr);
1706 SvPV_force_nomg(TARG, len);
1707 isutf = DO_UTF8(TARG);
1712 const STRLEN max = (UV)count * len;
1713 if (len > MEM_SIZE_MAX / count)
1714 Perl_croak(aTHX_ oom_string_extend);
1715 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1716 SvGROW(TARG, max + 1);
1717 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1718 SvCUR_set(TARG, SvCUR(TARG) * count);
1720 *SvEND(TARG) = '\0';
1723 (void)SvPOK_only_UTF8(TARG);
1725 (void)SvPOK_only(TARG);
1727 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1728 /* The parser saw this as a list repeat, and there
1729 are probably several items on the stack. But we're
1730 in scalar context, and there's no pp_list to save us
1731 now. So drop the rest of the items -- robin@kitsite.com
1743 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1744 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1747 useleft = USE_LEFT(svl);
1748 #ifdef PERL_PRESERVE_IVUV
1749 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1750 "bad things" happen if you rely on signed integers wrapping. */
1751 if (SvIV_please_nomg(svr)) {
1752 /* Unless the left argument is integer in range we are going to have to
1753 use NV maths. Hence only attempt to coerce the right argument if
1754 we know the left is integer. */
1761 a_valid = auvok = 1;
1762 /* left operand is undef, treat as zero. */
1764 /* Left operand is defined, so is it IV? */
1765 if (SvIV_please_nomg(svl)) {
1766 if ((auvok = SvUOK(svl)))
1769 const IV aiv = SvIVX(svl);
1772 auvok = 1; /* Now acting as a sign flag. */
1773 } else { /* 2s complement assumption for IV_MIN */
1781 bool result_good = 0;
1784 bool buvok = SvUOK(svr);
1789 const IV biv = SvIVX(svr);
1796 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1797 else "IV" now, independent of how it came in.
1798 if a, b represents positive, A, B negative, a maps to -A etc
1803 all UV maths. negate result if A negative.
1804 subtract if signs same, add if signs differ. */
1806 if (auvok ^ buvok) {
1815 /* Must get smaller */
1820 if (result <= buv) {
1821 /* result really should be -(auv-buv). as its negation
1822 of true value, need to swap our result flag */
1834 if (result <= (UV)IV_MIN)
1835 SETi( -(IV)result );
1837 /* result valid, but out of range for IV. */
1838 SETn( -(NV)result );
1842 } /* Overflow, drop through to NVs. */
1847 NV value = SvNV_nomg(svr);
1851 /* left operand is undef, treat as zero - value */
1855 SETn( SvNV_nomg(svl) - value );
1862 dVAR; dSP; dATARGET; SV *svl, *svr;
1863 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1867 const IV shift = SvIV_nomg(svr);
1868 if (PL_op->op_private & HINT_INTEGER) {
1869 const IV i = SvIV_nomg(svl);
1873 const UV u = SvUV_nomg(svl);
1882 dVAR; dSP; dATARGET; SV *svl, *svr;
1883 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1887 const IV shift = SvIV_nomg(svr);
1888 if (PL_op->op_private & HINT_INTEGER) {
1889 const IV i = SvIV_nomg(svl);
1893 const UV u = SvUV_nomg(svl);
1905 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1909 (SvIOK_notUV(left) && SvIOK_notUV(right))
1910 ? (SvIVX(left) < SvIVX(right))
1911 : (do_ncmp(left, right) == -1)
1921 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1925 (SvIOK_notUV(left) && SvIOK_notUV(right))
1926 ? (SvIVX(left) > SvIVX(right))
1927 : (do_ncmp(left, right) == 1)
1937 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1941 (SvIOK_notUV(left) && SvIOK_notUV(right))
1942 ? (SvIVX(left) <= SvIVX(right))
1943 : (do_ncmp(left, right) <= 0)
1953 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1957 (SvIOK_notUV(left) && SvIOK_notUV(right))
1958 ? (SvIVX(left) >= SvIVX(right))
1959 : ( (do_ncmp(left, right) & 2) == 0)
1969 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1973 (SvIOK_notUV(left) && SvIOK_notUV(right))
1974 ? (SvIVX(left) != SvIVX(right))
1975 : (do_ncmp(left, right) != 0)
1980 /* compare left and right SVs. Returns:
1984 * 2: left or right was a NaN
1987 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1991 PERL_ARGS_ASSERT_DO_NCMP;
1992 #ifdef PERL_PRESERVE_IVUV
1993 /* Fortunately it seems NaN isn't IOK */
1994 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
1996 const IV leftiv = SvIVX(left);
1997 if (!SvUOK(right)) {
1998 /* ## IV <=> IV ## */
1999 const IV rightiv = SvIVX(right);
2000 return (leftiv > rightiv) - (leftiv < rightiv);
2002 /* ## IV <=> UV ## */
2004 /* As (b) is a UV, it's >=0, so it must be < */
2007 const UV rightuv = SvUVX(right);
2008 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2013 /* ## UV <=> UV ## */
2014 const UV leftuv = SvUVX(left);
2015 const UV rightuv = SvUVX(right);
2016 return (leftuv > rightuv) - (leftuv < rightuv);
2018 /* ## UV <=> IV ## */
2020 const IV rightiv = SvIVX(right);
2022 /* As (a) is a UV, it's >=0, so it cannot be < */
2025 const UV leftuv = SvUVX(left);
2026 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2029 assert(0); /* NOTREACHED */
2033 NV const rnv = SvNV_nomg(right);
2034 NV const lnv = SvNV_nomg(left);
2036 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2037 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2040 return (lnv > rnv) - (lnv < rnv);
2059 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2062 value = do_ncmp(left, right);
2077 int amg_type = sle_amg;
2081 switch (PL_op->op_type) {
2100 tryAMAGICbin_MG(amg_type, AMGf_set);
2103 const int cmp = (IN_LOCALE_RUNTIME
2104 ? sv_cmp_locale_flags(left, right, 0)
2105 : sv_cmp_flags(left, right, 0));
2106 SETs(boolSV(cmp * multiplier < rhs));
2114 tryAMAGICbin_MG(seq_amg, AMGf_set);
2117 SETs(boolSV(sv_eq_flags(left, right, 0)));
2125 tryAMAGICbin_MG(sne_amg, AMGf_set);
2128 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2136 tryAMAGICbin_MG(scmp_amg, 0);
2139 const int cmp = (IN_LOCALE_RUNTIME
2140 ? sv_cmp_locale_flags(left, right, 0)
2141 : sv_cmp_flags(left, right, 0));
2149 dVAR; dSP; dATARGET;
2150 tryAMAGICbin_MG(band_amg, AMGf_assign);
2153 if (SvNIOKp(left) || SvNIOKp(right)) {
2154 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2155 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2156 if (PL_op->op_private & HINT_INTEGER) {
2157 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2161 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2164 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2165 if (right_ro_nonnum) SvNIOK_off(right);
2168 do_vop(PL_op->op_type, TARG, left, right);
2177 dVAR; dSP; dATARGET;
2178 const int op_type = PL_op->op_type;
2180 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2183 if (SvNIOKp(left) || SvNIOKp(right)) {
2184 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2185 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2186 if (PL_op->op_private & HINT_INTEGER) {
2187 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2188 const IV r = SvIV_nomg(right);
2189 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2193 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2194 const UV r = SvUV_nomg(right);
2195 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2198 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2199 if (right_ro_nonnum) SvNIOK_off(right);
2202 do_vop(op_type, TARG, left, right);
2209 PERL_STATIC_INLINE bool
2210 S_negate_string(pTHX)
2215 SV * const sv = TOPs;
2216 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2218 s = SvPV_nomg_const(sv, len);
2219 if (isIDFIRST(*s)) {
2220 sv_setpvs(TARG, "-");
2223 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2224 sv_setsv_nomg(TARG, sv);
2225 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2235 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2236 if (S_negate_string(aTHX)) return NORMAL;
2238 SV * const sv = TOPs;
2241 /* It's publicly an integer */
2244 if (SvIVX(sv) == IV_MIN) {
2245 /* 2s complement assumption. */
2246 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2249 else if (SvUVX(sv) <= IV_MAX) {
2254 else if (SvIVX(sv) != IV_MIN) {
2258 #ifdef PERL_PRESERVE_IVUV
2265 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2266 SETn(-SvNV_nomg(sv));
2267 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2268 goto oops_its_an_int;
2270 SETn(-SvNV_nomg(sv));
2278 tryAMAGICun_MG(not_amg, AMGf_set);
2279 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2286 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2290 if (PL_op->op_private & HINT_INTEGER) {
2291 const IV i = ~SvIV_nomg(sv);
2295 const UV u = ~SvUV_nomg(sv);
2304 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2305 sv_setsv_nomg(TARG, sv);
2306 tmps = (U8*)SvPV_force_nomg(TARG, len);
2309 /* Calculate exact length, let's not estimate. */
2314 U8 * const send = tmps + len;
2315 U8 * const origtmps = tmps;
2316 const UV utf8flags = UTF8_ALLOW_ANYUV;
2318 while (tmps < send) {
2319 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2321 targlen += UNISKIP(~c);
2327 /* Now rewind strings and write them. */
2334 Newx(result, targlen + 1, U8);
2336 while (tmps < send) {
2337 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2339 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2342 sv_usepvn_flags(TARG, (char*)result, targlen,
2343 SV_HAS_TRAILING_NUL);
2350 Newx(result, nchar + 1, U8);
2352 while (tmps < send) {
2353 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2358 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2367 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2370 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2375 for ( ; anum > 0; anum--, tmps++)
2383 /* integer versions of some of the above */
2387 dVAR; dSP; dATARGET;
2388 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2391 SETi( left * right );
2399 dVAR; dSP; dATARGET;
2400 tryAMAGICbin_MG(div_amg, AMGf_assign);
2403 IV value = SvIV_nomg(right);
2405 DIE(aTHX_ "Illegal division by zero");
2406 num = SvIV_nomg(left);
2408 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2412 value = num / value;
2418 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2425 /* This is the vanilla old i_modulo. */
2426 dVAR; dSP; dATARGET;
2427 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2431 DIE(aTHX_ "Illegal modulus zero");
2432 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2436 SETi( left % right );
2441 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2446 /* This is the i_modulo with the workaround for the _moddi3 bug
2447 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2448 * See below for pp_i_modulo. */
2449 dVAR; dSP; dATARGET;
2450 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2454 DIE(aTHX_ "Illegal modulus zero");
2455 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2459 SETi( left % PERL_ABS(right) );
2466 dVAR; dSP; dATARGET;
2467 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2471 DIE(aTHX_ "Illegal modulus zero");
2472 /* The assumption is to use hereafter the old vanilla version... */
2474 PL_ppaddr[OP_I_MODULO] =
2476 /* .. but if we have glibc, we might have a buggy _moddi3
2477 * (at least glicb 2.2.5 is known to have this bug), in other
2478 * words our integer modulus with negative quad as the second
2479 * argument might be broken. Test for this and re-patch the
2480 * opcode dispatch table if that is the case, remembering to
2481 * also apply the workaround so that this first round works
2482 * right, too. See [perl #9402] for more information. */
2486 /* Cannot do this check with inlined IV constants since
2487 * that seems to work correctly even with the buggy glibc. */
2489 /* Yikes, we have the bug.
2490 * Patch in the workaround version. */
2492 PL_ppaddr[OP_I_MODULO] =
2493 &Perl_pp_i_modulo_1;
2494 /* Make certain we work right this time, too. */
2495 right = PERL_ABS(right);
2498 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2502 SETi( left % right );
2510 dVAR; dSP; dATARGET;
2511 tryAMAGICbin_MG(add_amg, AMGf_assign);
2513 dPOPTOPiirl_ul_nomg;
2514 SETi( left + right );
2521 dVAR; dSP; dATARGET;
2522 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2524 dPOPTOPiirl_ul_nomg;
2525 SETi( left - right );
2533 tryAMAGICbin_MG(lt_amg, AMGf_set);
2536 SETs(boolSV(left < right));
2544 tryAMAGICbin_MG(gt_amg, AMGf_set);
2547 SETs(boolSV(left > right));
2555 tryAMAGICbin_MG(le_amg, AMGf_set);
2558 SETs(boolSV(left <= right));
2566 tryAMAGICbin_MG(ge_amg, AMGf_set);
2569 SETs(boolSV(left >= right));
2577 tryAMAGICbin_MG(eq_amg, AMGf_set);
2580 SETs(boolSV(left == right));
2588 tryAMAGICbin_MG(ne_amg, AMGf_set);
2591 SETs(boolSV(left != right));
2599 tryAMAGICbin_MG(ncmp_amg, 0);
2606 else if (left < right)
2618 tryAMAGICun_MG(neg_amg, 0);
2619 if (S_negate_string(aTHX)) return NORMAL;
2621 SV * const sv = TOPs;
2622 IV const i = SvIV_nomg(sv);
2628 /* High falutin' math. */
2633 tryAMAGICbin_MG(atan2_amg, 0);
2636 SETn(Perl_atan2(left, right));
2644 int amg_type = sin_amg;
2645 const char *neg_report = NULL;
2646 NV (*func)(NV) = Perl_sin;
2647 const int op_type = PL_op->op_type;
2664 amg_type = sqrt_amg;
2666 neg_report = "sqrt";
2671 tryAMAGICun_MG(amg_type, 0);
2673 SV * const arg = POPs;
2674 const NV value = SvNV_nomg(arg);
2676 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2677 SET_NUMERIC_STANDARD();
2678 /* diag_listed_as: Can't take log of %g */
2679 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2682 XPUSHn(func(value));
2687 /* Support Configure command-line overrides for rand() functions.
2688 After 5.005, perhaps we should replace this by Configure support
2689 for drand48(), random(), or rand(). For 5.005, though, maintain
2690 compatibility by calling rand() but allow the user to override it.
2691 See INSTALL for details. --Andy Dougherty 15 July 1998
2693 /* Now it's after 5.005, and Configure supports drand48() and random(),
2694 in addition to rand(). So the overrides should not be needed any more.
2695 --Jarkko Hietaniemi 27 September 1998
2698 #ifndef HAS_DRAND48_PROTO
2699 extern double drand48 (void);
2705 if (!PL_srand_called) {
2706 (void)seedDrand01((Rand_seed_t)seed());
2707 PL_srand_called = TRUE;
2717 SV * const sv = POPs;
2723 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2731 sv_setnv_mg(TARG, value);
2742 if (MAXARG >= 1 && (TOPs || POPs)) {
2749 pv = SvPV(top, len);
2750 flags = grok_number(pv, len, &anum);
2752 if (!(flags & IS_NUMBER_IN_UV)) {
2753 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2754 "Integer overflow in srand");
2762 (void)seedDrand01((Rand_seed_t)anum);
2763 PL_srand_called = TRUE;
2767 /* Historically srand always returned true. We can avoid breaking
2769 sv_setpvs(TARG, "0 but true");
2778 tryAMAGICun_MG(int_amg, AMGf_numeric);
2780 SV * const sv = TOPs;
2781 const IV iv = SvIV_nomg(sv);
2782 /* XXX it's arguable that compiler casting to IV might be subtly
2783 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2784 else preferring IV has introduced a subtle behaviour change bug. OTOH
2785 relying on floating point to be accurate is a bug. */
2790 else if (SvIOK(sv)) {
2792 SETu(SvUV_nomg(sv));
2797 const NV value = SvNV_nomg(sv);
2799 if (value < (NV)UV_MAX + 0.5) {
2802 SETn(Perl_floor(value));
2806 if (value > (NV)IV_MIN - 0.5) {
2809 SETn(Perl_ceil(value));
2820 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2822 SV * const sv = TOPs;
2823 /* This will cache the NV value if string isn't actually integer */
2824 const IV iv = SvIV_nomg(sv);
2829 else if (SvIOK(sv)) {
2830 /* IVX is precise */
2832 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2840 /* 2s complement assumption. Also, not really needed as
2841 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2847 const NV value = SvNV_nomg(sv);
2861 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2865 SV* const sv = POPs;
2867 tmps = (SvPV_const(sv, len));
2869 /* If Unicode, try to downgrade
2870 * If not possible, croak. */
2871 SV* const tsv = sv_2mortal(newSVsv(sv));
2874 sv_utf8_downgrade(tsv, FALSE);
2875 tmps = SvPV_const(tsv, len);
2877 if (PL_op->op_type == OP_HEX)
2880 while (*tmps && len && isSPACE(*tmps))
2884 if (*tmps == 'x' || *tmps == 'X') {
2886 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2888 else if (*tmps == 'b' || *tmps == 'B')
2889 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2891 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2893 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2907 SV * const sv = TOPs;
2912 SETi(sv_len_utf8_nomg(sv));
2916 (void)SvPV_nomg_const(sv,len);
2920 if (!SvPADTMP(TARG)) {
2921 sv_setsv_nomg(TARG, &PL_sv_undef);
2929 /* Returns false if substring is completely outside original string.
2930 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2931 always be true for an explicit 0.
2934 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2935 bool pos1_is_uv, IV len_iv,
2936 bool len_is_uv, STRLEN *posp,
2942 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2944 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2945 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2948 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2951 if (len_iv || len_is_uv) {
2952 if (!len_is_uv && len_iv < 0) {
2953 pos2_iv = curlen + len_iv;
2955 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2958 } else { /* len_iv >= 0 */
2959 if (!pos1_is_uv && pos1_iv < 0) {
2960 pos2_iv = pos1_iv + len_iv;
2961 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2963 if ((UV)len_iv > curlen-(UV)pos1_iv)
2966 pos2_iv = pos1_iv+len_iv;
2976 if (!pos2_is_uv && pos2_iv < 0) {
2977 if (!pos1_is_uv && pos1_iv < 0)
2981 else if (!pos1_is_uv && pos1_iv < 0)
2984 if ((UV)pos2_iv < (UV)pos1_iv)
2986 if ((UV)pos2_iv > curlen)
2989 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2990 *posp = (STRLEN)( (UV)pos1_iv );
2991 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3008 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3009 const bool rvalue = (GIMME_V != G_VOID);
3012 const char *repl = NULL;
3014 int num_args = PL_op->op_private & 7;
3015 bool repl_need_utf8_upgrade = FALSE;
3019 if(!(repl_sv = POPs)) num_args--;
3021 if ((len_sv = POPs)) {
3022 len_iv = SvIV(len_sv);
3023 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3028 pos1_iv = SvIV(pos_sv);
3029 pos1_is_uv = SvIOK_UV(pos_sv);
3031 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3036 if (lvalue && !repl_sv) {
3038 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3039 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3041 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3043 pos1_is_uv || pos1_iv >= 0
3044 ? (STRLEN)(UV)pos1_iv
3045 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3047 len_is_uv || len_iv > 0
3048 ? (STRLEN)(UV)len_iv
3049 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3052 PUSHs(ret); /* avoid SvSETMAGIC here */
3056 repl = SvPV_const(repl_sv, repl_len);
3059 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3060 "Attempt to use reference as lvalue in substr"
3062 tmps = SvPV_force_nomg(sv, curlen);
3063 if (DO_UTF8(repl_sv) && repl_len) {
3065 sv_utf8_upgrade_nomg(sv);
3069 else if (DO_UTF8(sv))
3070 repl_need_utf8_upgrade = TRUE;
3072 else tmps = SvPV_const(sv, curlen);
3074 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3075 if (utf8_curlen == curlen)
3078 curlen = utf8_curlen;
3084 STRLEN pos, len, byte_len, byte_pos;
3086 if (!translate_substr_offsets(
3087 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3091 byte_pos = utf8_curlen
3092 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3097 SvTAINTED_off(TARG); /* decontaminate */
3098 SvUTF8_off(TARG); /* decontaminate */
3099 sv_setpvn(TARG, tmps, byte_len);
3100 #ifdef USE_LOCALE_COLLATE
3101 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3108 SV* repl_sv_copy = NULL;
3110 if (repl_need_utf8_upgrade) {
3111 repl_sv_copy = newSVsv(repl_sv);
3112 sv_utf8_upgrade(repl_sv_copy);
3113 repl = SvPV_const(repl_sv_copy, repl_len);
3117 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3118 SvREFCNT_dec(repl_sv_copy);
3130 Perl_croak(aTHX_ "substr outside of string");
3131 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3138 const IV size = POPi;
3139 const IV offset = POPi;
3140 SV * const src = POPs;
3141 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3144 if (lvalue) { /* it's an lvalue! */
3145 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3146 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3148 LvTARG(ret) = SvREFCNT_inc_simple(src);
3149 LvTARGOFF(ret) = offset;
3150 LvTARGLEN(ret) = size;
3154 SvTAINTED_off(TARG); /* decontaminate */
3158 sv_setuv(ret, do_vecget(src, offset, size));
3174 const char *little_p;
3177 const bool is_index = PL_op->op_type == OP_INDEX;
3178 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3184 big_p = SvPV_const(big, biglen);
3185 little_p = SvPV_const(little, llen);
3187 big_utf8 = DO_UTF8(big);
3188 little_utf8 = DO_UTF8(little);
3189 if (big_utf8 ^ little_utf8) {
3190 /* One needs to be upgraded. */
3191 if (little_utf8 && !PL_encoding) {
3192 /* Well, maybe instead we might be able to downgrade the small
3194 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3197 /* If the large string is ISO-8859-1, and it's not possible to
3198 convert the small string to ISO-8859-1, then there is no
3199 way that it could be found anywhere by index. */
3204 /* At this point, pv is a malloc()ed string. So donate it to temp
3205 to ensure it will get free()d */
3206 little = temp = newSV(0);
3207 sv_usepvn(temp, pv, llen);
3208 little_p = SvPVX(little);
3211 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3214 sv_recode_to_utf8(temp, PL_encoding);
3216 sv_utf8_upgrade(temp);
3221 big_p = SvPV_const(big, biglen);
3224 little_p = SvPV_const(little, llen);
3228 if (SvGAMAGIC(big)) {
3229 /* Life just becomes a lot easier if I use a temporary here.
3230 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3231 will trigger magic and overloading again, as will fbm_instr()
3233 big = newSVpvn_flags(big_p, biglen,
3234 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3237 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3238 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3239 warn on undef, and we've already triggered a warning with the
3240 SvPV_const some lines above. We can't remove that, as we need to
3241 call some SvPV to trigger overloading early and find out if the
3243 This is all getting to messy. The API isn't quite clean enough,
3244 because data access has side effects.
3246 little = newSVpvn_flags(little_p, llen,
3247 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3248 little_p = SvPVX(little);
3252 offset = is_index ? 0 : biglen;
3254 if (big_utf8 && offset > 0)
3255 sv_pos_u2b(big, &offset, 0);
3261 else if (offset > (I32)biglen)
3263 if (!(little_p = is_index
3264 ? fbm_instr((unsigned char*)big_p + offset,
3265 (unsigned char*)big_p + biglen, little, 0)
3266 : rninstr(big_p, big_p + offset,
3267 little_p, little_p + llen)))
3270 retval = little_p - big_p;
3271 if (retval > 0 && big_utf8)
3272 sv_pos_b2u(big, &retval);
3282 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3283 SvTAINTED_off(TARG);
3284 do_sprintf(TARG, SP-MARK, MARK+1);
3285 TAINT_IF(SvTAINTED(TARG));
3297 const U8 *s = (U8*)SvPV_const(argsv, len);
3299 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3300 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3301 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3305 XPUSHu(DO_UTF8(argsv) ?
3306 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3320 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3321 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3323 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3324 && SvNV_nomg(top) < 0.0))) {
3325 if (ckWARN(WARN_UTF8)) {
3326 if (SvGMAGICAL(top)) {
3327 SV *top2 = sv_newmortal();
3328 sv_setsv_nomg(top2, top);
3331 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3332 "Invalid negative number (%"SVf") in chr", top);
3334 value = UNICODE_REPLACEMENT;
3336 value = SvUV_nomg(top);
3339 SvUPGRADE(TARG,SVt_PV);
3341 if (value > 255 && !IN_BYTES) {
3342 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3343 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3344 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3346 (void)SvPOK_only(TARG);
3355 *tmps++ = (char)value;
3357 (void)SvPOK_only(TARG);
3359 if (PL_encoding && !IN_BYTES) {
3360 sv_recode_to_utf8(TARG, PL_encoding);
3362 if (SvCUR(TARG) == 0
3363 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3364 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3369 *tmps++ = (char)value;
3385 const char *tmps = SvPV_const(left, len);
3387 if (DO_UTF8(left)) {
3388 /* If Unicode, try to downgrade.
3389 * If not possible, croak.
3390 * Yes, we made this up. */
3391 SV* const tsv = sv_2mortal(newSVsv(left));
3394 sv_utf8_downgrade(tsv, FALSE);
3395 tmps = SvPV_const(tsv, len);
3397 # ifdef USE_ITHREADS
3399 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3400 /* This should be threadsafe because in ithreads there is only
3401 * one thread per interpreter. If this would not be true,
3402 * we would need a mutex to protect this malloc. */
3403 PL_reentrant_buffer->_crypt_struct_buffer =
3404 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3405 #if defined(__GLIBC__) || defined(__EMX__)
3406 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3407 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3408 /* work around glibc-2.2.5 bug */
3409 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3413 # endif /* HAS_CRYPT_R */
3414 # endif /* USE_ITHREADS */
3416 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3418 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3424 "The crypt() function is unimplemented due to excessive paranoia.");
3428 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3429 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3431 /* Generates code to store a unicode codepoint c that is known to occupy
3432 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
3433 * and p is advanced to point to the next available byte after the two bytes */
3434 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3436 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3437 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3442 /* Actually is both lcfirst() and ucfirst(). Only the first character
3443 * changes. This means that possibly we can change in-place, ie., just
3444 * take the source and change that one character and store it back, but not
3445 * if read-only etc, or if the length changes */
3450 STRLEN slen; /* slen is the byte length of the whole SV. */
3453 bool inplace; /* ? Convert first char only, in-place */
3454 bool doing_utf8 = FALSE; /* ? using utf8 */
3455 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3456 const int op_type = PL_op->op_type;
3459 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3460 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3461 * stored as UTF-8 at s. */
3462 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3463 * lowercased) character stored in tmpbuf. May be either
3464 * UTF-8 or not, but in either case is the number of bytes */
3465 bool tainted = FALSE;
3469 s = (const U8*)SvPV_nomg_const(source, slen);
3471 if (ckWARN(WARN_UNINITIALIZED))
3472 report_uninit(source);
3477 /* We may be able to get away with changing only the first character, in
3478 * place, but not if read-only, etc. Later we may discover more reasons to
3479 * not convert in-place. */
3480 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3482 /* First calculate what the changed first character should be. This affects
3483 * whether we can just swap it out, leaving the rest of the string unchanged,
3484 * or even if have to convert the dest to UTF-8 when the source isn't */
3486 if (! slen) { /* If empty */
3487 need = 1; /* still need a trailing NUL */
3490 else if (DO_UTF8(source)) { /* Is the source utf8? */
3493 if (op_type == OP_UCFIRST) {
3494 _to_utf8_title_flags(s, tmpbuf, &tculen,
3495 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3498 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3499 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3502 /* we can't do in-place if the length changes. */
3503 if (ulen != tculen) inplace = FALSE;
3504 need = slen + 1 - ulen + tculen;
3506 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3507 * latin1 is treated as caseless. Note that a locale takes
3509 ulen = 1; /* Original character is 1 byte */
3510 tculen = 1; /* Most characters will require one byte, but this will
3511 * need to be overridden for the tricky ones */
3514 if (op_type == OP_LCFIRST) {
3516 /* lower case the first letter: no trickiness for any character */
3517 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3518 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3521 else if (IN_LOCALE_RUNTIME) {
3522 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3523 * have upper and title case different
3526 else if (! IN_UNI_8_BIT) {
3527 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3528 * on EBCDIC machines whatever the
3529 * native function does */
3531 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3532 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3534 assert(tculen == 2);
3536 /* If the result is an upper Latin1-range character, it can
3537 * still be represented in one byte, which is its ordinal */
3538 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3539 *tmpbuf = (U8) title_ord;
3543 /* Otherwise it became more than one ASCII character (in
3544 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3545 * beyond Latin1, so the number of bytes changed, so can't
3546 * replace just the first character in place. */
3549 /* If the result won't fit in a byte, the entire result will
3550 * have to be in UTF-8. Assume worst case sizing in
3551 * conversion. (all latin1 characters occupy at most two bytes
3553 if (title_ord > 255) {
3555 convert_source_to_utf8 = TRUE;
3556 need = slen * 2 + 1;
3558 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3559 * (both) characters whose title case is above 255 is
3563 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3564 need = slen + 1 + 1;
3568 } /* End of use Unicode (Latin1) semantics */
3569 } /* End of changing the case of the first character */
3571 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3572 * generate the result */
3575 /* We can convert in place. This means we change just the first
3576 * character without disturbing the rest; no need to grow */
3578 s = d = (U8*)SvPV_force_nomg(source, slen);
3584 /* Here, we can't convert in place; we earlier calculated how much
3585 * space we will need, so grow to accommodate that */
3586 SvUPGRADE(dest, SVt_PV);
3587 d = (U8*)SvGROW(dest, need);
3588 (void)SvPOK_only(dest);
3595 if (! convert_source_to_utf8) {
3597 /* Here both source and dest are in UTF-8, but have to create
3598 * the entire output. We initialize the result to be the
3599 * title/lower cased first character, and then append the rest
3601 sv_setpvn(dest, (char*)tmpbuf, tculen);
3603 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3607 const U8 *const send = s + slen;
3609 /* Here the dest needs to be in UTF-8, but the source isn't,
3610 * except we earlier UTF-8'd the first character of the source
3611 * into tmpbuf. First put that into dest, and then append the
3612 * rest of the source, converting it to UTF-8 as we go. */
3614 /* Assert tculen is 2 here because the only two characters that
3615 * get to this part of the code have 2-byte UTF-8 equivalents */
3617 *d++ = *(tmpbuf + 1);
3618 s++; /* We have just processed the 1st char */
3620 for (; s < send; s++) {
3621 d = uvchr_to_utf8(d, *s);
3624 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3628 else { /* in-place UTF-8. Just overwrite the first character */
3629 Copy(tmpbuf, d, tculen, U8);
3630 SvCUR_set(dest, need - 1);
3638 else { /* Neither source nor dest are in or need to be UTF-8 */
3640 if (IN_LOCALE_RUNTIME) {
3644 if (inplace) { /* in-place, only need to change the 1st char */
3647 else { /* Not in-place */
3649 /* Copy the case-changed character(s) from tmpbuf */
3650 Copy(tmpbuf, d, tculen, U8);
3651 d += tculen - 1; /* Code below expects d to point to final
3652 * character stored */
3655 else { /* empty source */
3656 /* See bug #39028: Don't taint if empty */
3660 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3661 * the destination to retain that flag */
3665 if (!inplace) { /* Finish the rest of the string, unchanged */
3666 /* This will copy the trailing NUL */
3667 Copy(s + 1, d + 1, slen, U8);
3668 SvCUR_set(dest, need - 1);
3671 if (dest != source && SvTAINTED(source))
3677 /* There's so much setup/teardown code common between uc and lc, I wonder if
3678 it would be worth merging the two, and just having a switch outside each
3679 of the three tight loops. There is less and less commonality though */
3693 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3694 && SvTEMP(source) && !DO_UTF8(source)
3695 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3697 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3698 * make the loop tight, so we overwrite the source with the dest before
3699 * looking at it, and we need to look at the original source
3700 * afterwards. There would also need to be code added to handle
3701 * switching to not in-place in midstream if we run into characters
3702 * that change the length.
3705 s = d = (U8*)SvPV_force_nomg(source, len);
3712 /* The old implementation would copy source into TARG at this point.
3713 This had the side effect that if source was undef, TARG was now
3714 an undefined SV with PADTMP set, and they don't warn inside
3715 sv_2pv_flags(). However, we're now getting the PV direct from
3716 source, which doesn't have PADTMP set, so it would warn. Hence the
3720 s = (const U8*)SvPV_nomg_const(source, len);
3722 if (ckWARN(WARN_UNINITIALIZED))
3723 report_uninit(source);
3729 SvUPGRADE(dest, SVt_PV);
3730 d = (U8*)SvGROW(dest, min);
3731 (void)SvPOK_only(dest);
3736 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3737 to check DO_UTF8 again here. */
3739 if (DO_UTF8(source)) {
3740 const U8 *const send = s + len;
3741 U8 tmpbuf[UTF8_MAXBYTES+1];
3742 bool tainted = FALSE;
3744 /* All occurrences of these are to be moved to follow any other marks.
3745 * This is context-dependent. We may not be passed enough context to
3746 * move the iota subscript beyond all of them, but we do the best we can
3747 * with what we're given. The result is always better than if we
3748 * hadn't done this. And, the problem would only arise if we are
3749 * passed a character without all its combining marks, which would be
3750 * the caller's mistake. The information this is based on comes from a
3751 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3752 * itself) and so can't be checked properly to see if it ever gets
3753 * revised. But the likelihood of it changing is remote */
3754 bool in_iota_subscript = FALSE;
3760 if (in_iota_subscript && ! is_utf8_mark(s)) {
3762 /* A non-mark. Time to output the iota subscript */
3763 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3764 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3766 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3767 in_iota_subscript = FALSE;
3770 /* Then handle the current character. Get the changed case value
3771 * and copy it to the output buffer */
3774 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3775 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3776 if (uv == GREEK_CAPITAL_LETTER_IOTA
3777 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3779 in_iota_subscript = TRUE;
3782 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3783 /* If the eventually required minimum size outgrows the
3784 * available space, we need to grow. */
3785 const UV o = d - (U8*)SvPVX_const(dest);
3787 /* If someone uppercases one million U+03B0s we SvGROW()
3788 * one million times. Or we could try guessing how much to
3789 * allocate without allocating too much. Such is life.
3790 * See corresponding comment in lc code for another option
3793 d = (U8*)SvPVX(dest) + o;
3795 Copy(tmpbuf, d, ulen, U8);
3800 if (in_iota_subscript) {
3801 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3806 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3812 else { /* Not UTF-8 */
3814 const U8 *const send = s + len;
3816 /* Use locale casing if in locale; regular style if not treating
3817 * latin1 as having case; otherwise the latin1 casing. Do the
3818 * whole thing in a tight loop, for speed, */
3819 if (IN_LOCALE_RUNTIME) {
3822 for (; s < send; d++, s++)
3823 *d = toUPPER_LC(*s);
3825 else if (! IN_UNI_8_BIT) {
3826 for (; s < send; d++, s++) {
3831 for (; s < send; d++, s++) {
3832 *d = toUPPER_LATIN1_MOD(*s);
3833 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
3835 /* The mainstream case is the tight loop above. To avoid
3836 * extra tests in that, all three characters that require
3837 * special handling are mapped by the MOD to the one tested
3839 * Use the source to distinguish between the three cases */
3841 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3843 /* uc() of this requires 2 characters, but they are
3844 * ASCII. If not enough room, grow the string */
3845 if (SvLEN(dest) < ++min) {
3846 const UV o = d - (U8*)SvPVX_const(dest);
3848 d = (U8*)SvPVX(dest) + o;
3850 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3851 continue; /* Back to the tight loop; still in ASCII */
3854 /* The other two special handling characters have their
3855 * upper cases outside the latin1 range, hence need to be
3856 * in UTF-8, so the whole result needs to be in UTF-8. So,
3857 * here we are somewhere in the middle of processing a
3858 * non-UTF-8 string, and realize that we will have to convert
3859 * the whole thing to UTF-8. What to do? There are
3860 * several possibilities. The simplest to code is to
3861 * convert what we have so far, set a flag, and continue on
3862 * in the loop. The flag would be tested each time through
3863 * the loop, and if set, the next character would be
3864 * converted to UTF-8 and stored. But, I (khw) didn't want
3865 * to slow down the mainstream case at all for this fairly
3866 * rare case, so I didn't want to add a test that didn't
3867 * absolutely have to be there in the loop, besides the
3868 * possibility that it would get too complicated for
3869 * optimizers to deal with. Another possibility is to just
3870 * give up, convert the source to UTF-8, and restart the
3871 * function that way. Another possibility is to convert
3872 * both what has already been processed and what is yet to
3873 * come separately to UTF-8, then jump into the loop that
3874 * handles UTF-8. But the most efficient time-wise of the
3875 * ones I could think of is what follows, and turned out to
3876 * not require much extra code. */
3878 /* Convert what we have so far into UTF-8, telling the
3879 * function that we know it should be converted, and to
3880 * allow extra space for what we haven't processed yet.
3881 * Assume the worst case space requirements for converting
3882 * what we haven't processed so far: that it will require
3883 * two bytes for each remaining source character, plus the
3884 * NUL at the end. This may cause the string pointer to
3885 * move, so re-find it. */
3887 len = d - (U8*)SvPVX_const(dest);
3888 SvCUR_set(dest, len);
3889 len = sv_utf8_upgrade_flags_grow(dest,
3890 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3892 d = (U8*)SvPVX(dest) + len;
3894 /* Now process the remainder of the source, converting to
3895 * upper and UTF-8. If a resulting byte is invariant in
3896 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3897 * append it to the output. */
3898 for (; s < send; s++) {
3899 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3903 /* Here have processed the whole source; no need to continue
3904 * with the outer loop. Each character has been converted
3905 * to upper case and converted to UTF-8 */
3908 } /* End of processing all latin1-style chars */
3909 } /* End of processing all chars */
3910 } /* End of source is not empty */
3912 if (source != dest) {
3913 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3914 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3916 } /* End of isn't utf8 */
3917 if (dest != source && SvTAINTED(source))
3936 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3937 && SvTEMP(source) && !DO_UTF8(source)) {
3939 /* We can convert in place, as lowercasing anything in the latin1 range
3940 * (or else DO_UTF8 would have been on) doesn't lengthen it */
3942 s = d = (U8*)SvPV_force_nomg(source, len);
3949 /* The old implementation would copy source into TARG at this point.
3950 This had the side effect that if source was undef, TARG was now
3951 an undefined SV with PADTMP set, and they don't warn inside
3952 sv_2pv_flags(). However, we're now getting the PV direct from
3953 source, which doesn't have PADTMP set, so it would warn. Hence the
3957 s = (const U8*)SvPV_nomg_const(source, len);
3959 if (ckWARN(WARN_UNINITIALIZED))
3960 report_uninit(source);
3966 SvUPGRADE(dest, SVt_PV);
3967 d = (U8*)SvGROW(dest, min);
3968 (void)SvPOK_only(dest);
3973 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3974 to check DO_UTF8 again here. */
3976 if (DO_UTF8(source)) {
3977 const U8 *const send = s + len;
3978 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3979 bool tainted = FALSE;
3982 const STRLEN u = UTF8SKIP(s);
3985 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3986 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3988 /* Here is where we would do context-sensitive actions. See the
3989 * commit message for this comment for why there isn't any */
3991 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3993 /* If the eventually required minimum size outgrows the
3994 * available space, we need to grow. */
3995 const UV o = d - (U8*)SvPVX_const(dest);
3997 /* If someone lowercases one million U+0130s we SvGROW() one
3998 * million times. Or we could try guessing how much to
3999 * allocate without allocating too much. Such is life.
4000 * Another option would be to grow an extra byte or two more
4001 * each time we need to grow, which would cut down the million
4002 * to 500K, with little waste */
4004 d = (U8*)SvPVX(dest) + o;
4007 /* Copy the newly lowercased letter to the output buffer we're
4009 Copy(tmpbuf, d, ulen, U8);
4012 } /* End of looping through the source string */
4015 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4020 } else { /* Not utf8 */
4022 const U8 *const send = s + len;
4024 /* Use locale casing if in locale; regular style if not treating
4025 * latin1 as having case; otherwise the latin1 casing. Do the
4026 * whole thing in a tight loop, for speed, */
4027 if (IN_LOCALE_RUNTIME) {
4030 for (; s < send; d++, s++)
4031 *d = toLOWER_LC(*s);
4033 else if (! IN_UNI_8_BIT) {
4034 for (; s < send; d++, s++) {
4039 for (; s < send; d++, s++) {
4040 *d = toLOWER_LATIN1(*s);
4044 if (source != dest) {
4046 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4049 if (dest != source && SvTAINTED(source))
4058 SV * const sv = TOPs;
4060 const char *s = SvPV_const(sv,len);
4062 SvUTF8_off(TARG); /* decontaminate */
4065 SvUPGRADE(TARG, SVt_PV);
4066 SvGROW(TARG, (len * 2) + 1);
4070 STRLEN ulen = UTF8SKIP(s);
4071 bool to_quote = FALSE;
4073 if (UTF8_IS_INVARIANT(*s)) {
4074 if (_isQUOTEMETA(*s)) {
4078 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4080 /* In locale, we quote all non-ASCII Latin1 chars.
4081 * Otherwise use the quoting rules */
4082 if (IN_LOCALE_RUNTIME
4083 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
4088 else if (is_QUOTEMETA_high(s)) {
4103 else if (IN_UNI_8_BIT) {
4105 if (_isQUOTEMETA(*s))
4111 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4112 * including everything above ASCII */
4114 if (!isWORDCHAR_A(*s))
4120 SvCUR_set(TARG, d - SvPVX_const(TARG));
4121 (void)SvPOK_only_UTF8(TARG);
4124 sv_setpvn(TARG, s, len);
4141 U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
4142 const bool full_folding = TRUE;
4143 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4144 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4146 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4147 * You are welcome(?) -Hugmeir
4155 s = (const U8*)SvPV_nomg_const(source, len);
4157 if (ckWARN(WARN_UNINITIALIZED))
4158 report_uninit(source);
4165 SvUPGRADE(dest, SVt_PV);
4166 d = (U8*)SvGROW(dest, min);
4167 (void)SvPOK_only(dest);
4172 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4173 bool tainted = FALSE;
4175 const STRLEN u = UTF8SKIP(s);
4178 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4180 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4181 const UV o = d - (U8*)SvPVX_const(dest);
4183 d = (U8*)SvPVX(dest) + o;
4186 Copy(tmpbuf, d, ulen, U8);
4195 } /* Unflagged string */
4197 /* For locale, bytes, and nothing, the behavior is supposed to be the
4200 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4203 for (; s < send; d++, s++)
4204 *d = toLOWER_LC(*s);
4206 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4207 for (; s < send; d++, s++)
4211 /* For ASCII and the Latin-1 range, there's only two troublesome folds,
4212 * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full casefolding
4213 * becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4214 * \x{3BC} (\N{GREEK SMALL LETTER MU}) -- For the rest, the casefold is
4217 for (; s < send; d++, s++) {
4218 if (*s == MICRO_SIGN) {
4219 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, which
4220 * is outside of the latin-1 range. There's a couple of ways to
4221 * deal with this -- khw discusses them in pp_lc/uc, so go there :)
4222 * What we do here is upgrade what we had already casefolded,
4223 * then enter an inner loop that appends the rest of the characters
4226 len = d - (U8*)SvPVX_const(dest);
4227 SvCUR_set(dest, len);
4228 len = sv_utf8_upgrade_flags_grow(dest,
4229 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4230 /* The max expansion for latin1
4231 * chars is 1 byte becomes 2 */
4233 d = (U8*)SvPVX(dest) + len;
4235 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU);
4237 for (; s < send; s++) {
4239 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4240 if UNI_IS_INVARIANT(fc) {
4241 if ( full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4249 Copy(tmpbuf, d, ulen, U8);
4255 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4256 /* Under full casefolding, LATIN SMALL LETTER SHARP S becomes "ss",
4257 * which may require growing the SV.
4259 if (SvLEN(dest) < ++min) {
4260 const UV o = d - (U8*)SvPVX_const(dest);
4262 d = (U8*)SvPVX(dest) + o;
4267 else { /* If it's not one of those two, the fold is their lower case */
4268 *d = toLOWER_LATIN1(*s);
4274 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4276 if (SvTAINTED(source))
4286 dVAR; dSP; dMARK; dORIGMARK;
4287 AV *const av = MUTABLE_AV(POPs);
4288 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4290 if (SvTYPE(av) == SVt_PVAV) {
4291 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4292 bool can_preserve = FALSE;
4298 can_preserve = SvCANEXISTDELETE(av);
4301 if (lval && localizing) {
4304 for (svp = MARK + 1; svp <= SP; svp++) {
4305 const I32 elem = SvIV(*svp);
4309 if (max > AvMAX(av))
4313 while (++MARK <= SP) {
4315 I32 elem = SvIV(*MARK);
4316 bool preeminent = TRUE;
4318 if (localizing && can_preserve) {
4319 /* If we can determine whether the element exist,
4320 * Try to preserve the existenceness of a tied array
4321 * element by using EXISTS and DELETE if possible.
4322 * Fallback to FETCH and STORE otherwise. */
4323 preeminent = av_exists(av, elem);
4326 svp = av_fetch(av, elem, lval);
4328 if (!svp || *svp == &PL_sv_undef)
4329 DIE(aTHX_ PL_no_aelem, elem);
4332 save_aelem(av, elem, svp);
4334 SAVEADELETE(av, elem);
4337 *MARK = svp ? *svp : &PL_sv_undef;
4340 if (GIMME != G_ARRAY) {
4342 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4348 /* Smart dereferencing for keys, values and each */
4360 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4365 "Type of argument to %s must be unblessed hashref or arrayref",
4366 PL_op_desc[PL_op->op_type] );
4369 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4371 "Can't modify %s in %s",
4372 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4375 /* Delegate to correct function for op type */
4377 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4378 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4381 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4389 AV *array = MUTABLE_AV(POPs);
4390 const I32 gimme = GIMME_V;
4391 IV *iterp = Perl_av_iter_p(aTHX_ array);
4392 const IV current = (*iterp)++;
4394 if (current > av_len(array)) {
4396 if (gimme == G_SCALAR)
4404 if (gimme == G_ARRAY) {
4405 SV **const element = av_fetch(array, current, 0);
4406 PUSHs(element ? *element : &PL_sv_undef);
4415 AV *array = MUTABLE_AV(POPs);
4416 const I32 gimme = GIMME_V;
4418 *Perl_av_iter_p(aTHX_ array) = 0;
4420 if (gimme == G_SCALAR) {
4422 PUSHi(av_len(array) + 1);
4424 else if (gimme == G_ARRAY) {
4425 IV n = Perl_av_len(aTHX_ array);
4430 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4431 for (i = 0; i <= n; i++) {
4436 for (i = 0; i <= n; i++) {
4437 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4438 PUSHs(elem ? *elem : &PL_sv_undef);
4445 /* Associative arrays. */
4451 HV * hash = MUTABLE_HV(POPs);
4453 const I32 gimme = GIMME_V;
4456 /* might clobber stack_sp */
4457 entry = hv_iternext(hash);
4462 SV* const sv = hv_iterkeysv(entry);
4463 PUSHs(sv); /* won't clobber stack_sp */
4464 if (gimme == G_ARRAY) {
4467 /* might clobber stack_sp */
4468 val = hv_iterval(hash, entry);
4473 else if (gimme == G_SCALAR)
4480 S_do_delete_local(pTHX)
4484 const I32 gimme = GIMME_V;
4487 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4488 SV *unsliced_keysv = sliced ? NULL : POPs;
4489 SV * const osv = POPs;
4490 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4492 const bool tied = SvRMAGICAL(osv)
4493 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4494 const bool can_preserve = SvCANEXISTDELETE(osv);
4495 const U32 type = SvTYPE(osv);
4496 SV ** const end = sliced ? SP : &unsliced_keysv;
4498 if (type == SVt_PVHV) { /* hash element */
4499 HV * const hv = MUTABLE_HV(osv);
4500 while (++MARK <= end) {
4501 SV * const keysv = *MARK;
4503 bool preeminent = TRUE;
4505 preeminent = hv_exists_ent(hv, keysv, 0);
4507 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4514 sv = hv_delete_ent(hv, keysv, 0, 0);
4515 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4518 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4519 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4521 *MARK = sv_mortalcopy(sv);
4527 SAVEHDELETE(hv, keysv);
4528 *MARK = &PL_sv_undef;
4532 else if (type == SVt_PVAV) { /* array element */
4533 if (PL_op->op_flags & OPf_SPECIAL) {
4534 AV * const av = MUTABLE_AV(osv);
4535 while (++MARK <= end) {
4536 I32 idx = SvIV(*MARK);
4538 bool preeminent = TRUE;
4540 preeminent = av_exists(av, idx);
4542 SV **svp = av_fetch(av, idx, 1);
4549 sv = av_delete(av, idx, 0);
4550 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4553 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4555 *MARK = sv_mortalcopy(sv);
4561 SAVEADELETE(av, idx);
4562 *MARK = &PL_sv_undef;
4567 DIE(aTHX_ "panic: avhv_delete no longer supported");
4570 DIE(aTHX_ "Not a HASH reference");
4572 if (gimme == G_VOID)
4574 else if (gimme == G_SCALAR) {
4579 *++MARK = &PL_sv_undef;
4583 else if (gimme != G_VOID)
4584 PUSHs(unsliced_keysv);
4596 if (PL_op->op_private & OPpLVAL_INTRO)
4597 return do_delete_local();
4600 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4602 if (PL_op->op_private & OPpSLICE) {
4604 HV * const hv = MUTABLE_HV(POPs);
4605 const U32 hvtype = SvTYPE(hv);
4606 if (hvtype == SVt_PVHV) { /* hash element */
4607 while (++MARK <= SP) {
4608 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4609 *MARK = sv ? sv : &PL_sv_undef;
4612 else if (hvtype == SVt_PVAV) { /* array element */
4613 if (PL_op->op_flags & OPf_SPECIAL) {
4614 while (++MARK <= SP) {
4615 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4616 *MARK = sv ? sv : &PL_sv_undef;
4621 DIE(aTHX_ "Not a HASH reference");
4624 else if (gimme == G_SCALAR) {
4629 *++MARK = &PL_sv_undef;
4635 HV * const hv = MUTABLE_HV(POPs);
4637 if (SvTYPE(hv) == SVt_PVHV)
4638 sv = hv_delete_ent(hv, keysv, discard, 0);
4639 else if (SvTYPE(hv) == SVt_PVAV) {
4640 if (PL_op->op_flags & OPf_SPECIAL)
4641 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4643 DIE(aTHX_ "panic: avhv_delete no longer supported");
4646 DIE(aTHX_ "Not a HASH reference");
4662 if (PL_op->op_private & OPpEXISTS_SUB) {
4664 SV * const sv = POPs;
4665 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4668 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4673 hv = MUTABLE_HV(POPs);
4674 if (SvTYPE(hv) == SVt_PVHV) {
4675 if (hv_exists_ent(hv, tmpsv, 0))
4678 else if (SvTYPE(hv) == SVt_PVAV) {
4679 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4680 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4685 DIE(aTHX_ "Not a HASH reference");
4692 dVAR; dSP; dMARK; dORIGMARK;
4693 HV * const hv = MUTABLE_HV(POPs);
4694 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4695 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4696 bool can_preserve = FALSE;
4702 if (SvCANEXISTDELETE(hv))
4703 can_preserve = TRUE;
4706 while (++MARK <= SP) {
4707 SV * const keysv = *MARK;
4710 bool preeminent = TRUE;
4712 if (localizing && can_preserve) {
4713 /* If we can determine whether the element exist,
4714 * try to preserve the existenceness of a tied hash
4715 * element by using EXISTS and DELETE if possible.
4716 * Fallback to FETCH and STORE otherwise. */
4717 preeminent = hv_exists_ent(hv, keysv, 0);
4720 he = hv_fetch_ent(hv, keysv, lval, 0);
4721 svp = he ? &HeVAL(he) : NULL;
4724 if (!svp || !*svp || *svp == &PL_sv_undef) {
4725 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4728 if (HvNAME_get(hv) && isGV(*svp))
4729 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4730 else if (preeminent)
4731 save_helem_flags(hv, keysv, svp,
4732 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4734 SAVEHDELETE(hv, keysv);
4737 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4739 if (GIMME != G_ARRAY) {
4741 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4747 /* List operators. */
4752 if (GIMME != G_ARRAY) {
4754 *MARK = *SP; /* unwanted list, return last item */
4756 *MARK = &PL_sv_undef;
4766 SV ** const lastrelem = PL_stack_sp;
4767 SV ** const lastlelem = PL_stack_base + POPMARK;
4768 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4769 SV ** const firstrelem = lastlelem + 1;
4770 I32 is_something_there = FALSE;
4772 const I32 max = lastrelem - lastlelem;
4775 if (GIMME != G_ARRAY) {
4776 I32 ix = SvIV(*lastlelem);
4779 if (ix < 0 || ix >= max)
4780 *firstlelem = &PL_sv_undef;
4782 *firstlelem = firstrelem[ix];
4788 SP = firstlelem - 1;
4792 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4793 I32 ix = SvIV(*lelem);
4796 if (ix < 0 || ix >= max)
4797 *lelem = &PL_sv_undef;
4799 is_something_there = TRUE;
4800 if (!(*lelem = firstrelem[ix]))
4801 *lelem = &PL_sv_undef;
4804 if (is_something_there)
4807 SP = firstlelem - 1;
4813 dVAR; dSP; dMARK; dORIGMARK;
4814 const I32 items = SP - MARK;
4815 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4816 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4817 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4818 ? newRV_noinc(av) : av);
4824 dVAR; dSP; dMARK; dORIGMARK;
4825 HV* const hv = (HV *)sv_2mortal((SV *)newHV());
4829 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4836 sv_setsv(val, *MARK);
4840 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4843 (void)hv_store_ent(hv,key,val,0);
4846 if (PL_op->op_flags & OPf_SPECIAL)
4847 mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
4848 else XPUSHs(MUTABLE_SV(hv));
4853 S_deref_plain_array(pTHX_ AV *ary)
4855 if (SvTYPE(ary) == SVt_PVAV) return ary;
4856 SvGETMAGIC((SV *)ary);
4857 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4858 Perl_die(aTHX_ "Not an ARRAY reference");
4859 else if (SvOBJECT(SvRV(ary)))
4860 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4861 return (AV *)SvRV(ary);
4864 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4865 # define DEREF_PLAIN_ARRAY(ary) \
4868 SvTYPE(aRrRay) == SVt_PVAV \
4870 : S_deref_plain_array(aTHX_ aRrRay); \
4873 # define DEREF_PLAIN_ARRAY(ary) \
4875 PL_Sv = (SV *)(ary), \
4876 SvTYPE(PL_Sv) == SVt_PVAV \
4878 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4884 dVAR; dSP; dMARK; dORIGMARK;
4885 int num_args = (SP - MARK);
4886 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4895 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4898 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4899 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4906 offset = i = SvIV(*MARK);
4908 offset += AvFILLp(ary) + 1;
4910 DIE(aTHX_ PL_no_aelem, i);
4912 length = SvIVx(*MARK++);
4914 length += AvFILLp(ary) - offset + 1;
4920 length = AvMAX(ary) + 1; /* close enough to infinity */
4924 length = AvMAX(ary) + 1;
4926 if (offset > AvFILLp(ary) + 1) {
4928 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4929 offset = AvFILLp(ary) + 1;
4931 after = AvFILLp(ary) + 1 - (offset + length);
4932 if (after < 0) { /* not that much array */
4933 length += after; /* offset+length now in array */
4939 /* At this point, MARK .. SP-1 is our new LIST */
4942 diff = newlen - length;
4943 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4946 /* make new elements SVs now: avoid problems if they're from the array */
4947 for (dst = MARK, i = newlen; i; i--) {
4948 SV * const h = *dst;
4949 *dst++ = newSVsv(h);
4952 if (diff < 0) { /* shrinking the area */
4953 SV **tmparyval = NULL;
4955 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4956 Copy(MARK, tmparyval, newlen, SV*);
4959 MARK = ORIGMARK + 1;
4960 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4961 MEXTEND(MARK, length);
4962 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4964 EXTEND_MORTAL(length);
4965 for (i = length, dst = MARK; i; i--) {
4966 sv_2mortal(*dst); /* free them eventually */
4973 *MARK = AvARRAY(ary)[offset+length-1];
4976 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4977 SvREFCNT_dec(*dst++); /* free them now */
4980 AvFILLp(ary) += diff;
4982 /* pull up or down? */
4984 if (offset < after) { /* easier to pull up */
4985 if (offset) { /* esp. if nothing to pull */
4986 src = &AvARRAY(ary)[offset-1];
4987 dst = src - diff; /* diff is negative */
4988 for (i = offset; i > 0; i--) /* can't trust Copy */
4992 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4996 if (after) { /* anything to pull down? */
4997 src = AvARRAY(ary) + offset + length;
4998 dst = src + diff; /* diff is negative */
4999 Move(src, dst, after, SV*);
5001 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5002 /* avoid later double free */
5006 dst[--i] = &PL_sv_undef;
5009 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5010 Safefree(tmparyval);
5013 else { /* no, expanding (or same) */
5014 SV** tmparyval = NULL;
5016 Newx(tmparyval, length, SV*); /* so remember deletion */
5017 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5020 if (diff > 0) { /* expanding */
5021 /* push up or down? */
5022 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5026 Move(src, dst, offset, SV*);
5028 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5030 AvFILLp(ary) += diff;
5033 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5034 av_extend(ary, AvFILLp(ary) + diff);
5035 AvFILLp(ary) += diff;
5038 dst = AvARRAY(ary) + AvFILLp(ary);
5040 for (i = after; i; i--) {
5048 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5051 MARK = ORIGMARK + 1;
5052 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5054 Copy(tmparyval, MARK, length, SV*);
5056 EXTEND_MORTAL(length);
5057 for (i = length, dst = MARK; i; i--) {
5058 sv_2mortal(*dst); /* free them eventually */
5065 else if (length--) {
5066 *MARK = tmparyval[length];
5069 while (length-- > 0)
5070 SvREFCNT_dec(tmparyval[length]);
5074 *MARK = &PL_sv_undef;
5075 Safefree(tmparyval);
5079 mg_set(MUTABLE_SV(ary));
5087 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5088 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5089 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5092 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5095 ENTER_with_name("call_PUSH");
5096 call_method("PUSH",G_SCALAR|G_DISCARD);
5097 LEAVE_with_name("call_PUSH");
5101 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5102 PL_delaymagic = DM_DELAY;
5103 for (++MARK; MARK <= SP; MARK++) {
5105 if (*MARK) SvGETMAGIC(*MARK);
5108 sv_setsv_nomg(sv, *MARK);
5109 av_store(ary, AvFILLp(ary)+1, sv);
5111 if (PL_delaymagic & DM_ARRAY_ISA)
5112 mg_set(MUTABLE_SV(ary));
5117 if (OP_GIMME(PL_op, 0) != G_VOID) {
5118 PUSHi( AvFILL(ary) + 1 );
5127 AV * const av = PL_op->op_flags & OPf_SPECIAL
5128 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5129 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5133 (void)sv_2mortal(sv);
5140 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5141 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5142 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5145 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5148 ENTER_with_name("call_UNSHIFT");
5149 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5150 LEAVE_with_name("call_UNSHIFT");
5155 av_unshift(ary, SP - MARK);
5157 SV * const sv = newSVsv(*++MARK);
5158 (void)av_store(ary, i++, sv);
5162 if (OP_GIMME(PL_op, 0) != G_VOID) {
5163 PUSHi( AvFILL(ary) + 1 );
5172 if (GIMME == G_ARRAY) {
5173 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5177 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5178 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5179 av = MUTABLE_AV((*SP));
5180 /* In-place reversing only happens in void context for the array
5181 * assignment. We don't need to push anything on the stack. */
5184 if (SvMAGICAL(av)) {
5186 SV *tmp = sv_newmortal();
5187 /* For SvCANEXISTDELETE */
5190 bool can_preserve = SvCANEXISTDELETE(av);
5192 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5196 if (!av_exists(av, i)) {
5197 if (av_exists(av, j)) {
5198 SV *sv = av_delete(av, j, 0);
5199 begin = *av_fetch(av, i, TRUE);
5200 sv_setsv_mg(begin, sv);
5204 else if (!av_exists(av, j)) {
5205 SV *sv = av_delete(av, i, 0);
5206 end = *av_fetch(av, j, TRUE);
5207 sv_setsv_mg(end, sv);
5212 begin = *av_fetch(av, i, TRUE);
5213 end = *av_fetch(av, j, TRUE);
5214 sv_setsv(tmp, begin);
5215 sv_setsv_mg(begin, end);
5216 sv_setsv_mg(end, tmp);
5220 SV **begin = AvARRAY(av);
5223 SV **end = begin + AvFILLp(av);
5225 while (begin < end) {
5226 SV * const tmp = *begin;
5237 SV * const tmp = *MARK;
5241 /* safe as long as stack cannot get extended in the above */
5252 SvUTF8_off(TARG); /* decontaminate */
5254 do_join(TARG, &PL_sv_no, MARK, SP);
5256 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5257 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5258 report_uninit(TARG);
5261 up = SvPV_force(TARG, len);
5263 if (DO_UTF8(TARG)) { /* first reverse each character */
5264 U8* s = (U8*)SvPVX(TARG);
5265 const U8* send = (U8*)(s + len);
5267 if (UTF8_IS_INVARIANT(*s)) {
5272 if (!utf8_to_uvchr_buf(s, send, 0))
5276 down = (char*)(s - 1);
5277 /* reverse this character */
5281 *down-- = (char)tmp;
5287 down = SvPVX(TARG) + len - 1;
5291 *down-- = (char)tmp;
5293 (void)SvPOK_only_UTF8(TARG);
5305 IV limit = POPi; /* note, negative is forever */
5306 SV * const sv = POPs;
5308 const char *s = SvPV_const(sv, len);
5309 const bool do_utf8 = DO_UTF8(sv);
5310 const bool skipwhite = PL_op->op_flags & OPf_SPECIAL;
5311 const char *strend = s + len;
5317 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5318 I32 maxiters = slen + 10;
5319 I32 trailing_empty = 0;
5321 const I32 origlimit = limit;
5324 const I32 gimme = GIMME_V;
5326 const I32 oldsave = PL_savestack_ix;
5327 U32 make_mortal = SVs_TEMP;
5332 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5337 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5340 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5341 (RX_EXTFLAGS(rx) & RXf_WHITE || skipwhite));
5343 RX_MATCH_UTF8_set(rx, do_utf8);
5346 if (pm->op_pmreplrootu.op_pmtargetoff) {
5347 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5350 if (pm->op_pmreplrootu.op_pmtargetgv) {
5351 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5356 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5362 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5364 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5371 for (i = AvFILLp(ary); i >= 0; i--)
5372 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5374 /* temporarily switch stacks */
5375 SAVESWITCHSTACK(PL_curstack, ary);
5379 base = SP - PL_stack_base;
5383 while (*s == ' ' || is_utf8_space((U8*)s))
5386 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5387 while (isSPACE_LC(*s))
5395 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5399 gimme_scalar = gimme == G_SCALAR && !ary;
5402 limit = maxiters + 2;
5403 if (RX_EXTFLAGS(rx) & RXf_WHITE || skipwhite) {
5406 /* this one uses 'm' and is a negative test */
5408 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5409 const int t = UTF8SKIP(m);
5410 /* is_utf8_space returns FALSE for malform utf8 */
5417 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5418 while (m < strend && !isSPACE_LC(*m))
5421 while (m < strend && !isSPACE(*m))
5434 dstr = newSVpvn_flags(s, m-s,
5435 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5439 /* skip the whitespace found last */
5441 s = m + UTF8SKIP(m);
5445 /* this one uses 's' and is a positive test */
5447 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5450 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5451 while (s < strend && isSPACE_LC(*s))
5454 while (s < strend && isSPACE(*s))
5459 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5461 for (m = s; m < strend && *m != '\n'; m++)
5474 dstr = newSVpvn_flags(s, m-s,
5475 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5481 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5483 Pre-extend the stack, either the number of bytes or
5484 characters in the string or a limited amount, triggered by:
5486 my ($x, $y) = split //, $str;
5490 if (!gimme_scalar) {
5491 const U32 items = limit - 1;
5500 /* keep track of how many bytes we skip over */
5510 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5523 dstr = newSVpvn(s, 1);
5539 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5540 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5541 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5542 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5543 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5544 SV * const csv = CALLREG_INTUIT_STRING(rx);
5546 len = RX_MINLENRET(rx);
5547 if (len == 1 && !RX_UTF8(rx) && !tail) {
5548 const char c = *SvPV_nolen_const(csv);
5550 for (m = s; m < strend && *m != c; m++)
5561 dstr = newSVpvn_flags(s, m-s,
5562 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5565 /* The rx->minlen is in characters but we want to step
5566 * s ahead by bytes. */
5568 s = (char*)utf8_hop((U8*)m, len);
5570 s = m + len; /* Fake \n at the end */
5574 while (s < strend && --limit &&
5575 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5576 csv, multiline ? FBMrf_MULTILINE : 0)) )
5585 dstr = newSVpvn_flags(s, m-s,
5586 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5589 /* The rx->minlen is in characters but we want to step
5590 * s ahead by bytes. */
5592 s = (char*)utf8_hop((U8*)m, len);
5594 s = m + len; /* Fake \n at the end */
5599 maxiters += slen * RX_NPARENS(rx);
5600 while (s < strend && --limit)
5604 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5607 if (rex_return == 0)
5609 TAINT_IF(RX_MATCH_TAINTED(rx));
5610 /* we never pass the REXEC_COPY_STR flag, so it should
5611 * never get copied */
5612 assert(!RX_MATCH_COPIED(rx));
5613 m = RX_OFFS(rx)[0].start + orig;
5622 dstr = newSVpvn_flags(s, m-s,
5623 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5626 if (RX_NPARENS(rx)) {
5628 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5629 s = RX_OFFS(rx)[i].start + orig;
5630 m = RX_OFFS(rx)[i].end + orig;
5632 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5633 parens that didn't match -- they should be set to
5634 undef, not the empty string */
5642 if (m >= orig && s >= orig) {
5643 dstr = newSVpvn_flags(s, m-s,
5644 (do_utf8 ? SVf_UTF8 : 0)
5648 dstr = &PL_sv_undef; /* undef, not "" */
5654 s = RX_OFFS(rx)[0].end + orig;
5658 if (!gimme_scalar) {
5659 iters = (SP - PL_stack_base) - base;
5661 if (iters > maxiters)
5662 DIE(aTHX_ "Split loop");
5664 /* keep field after final delim? */
5665 if (s < strend || (iters && origlimit)) {
5666 if (!gimme_scalar) {
5667 const STRLEN l = strend - s;
5668 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5673 else if (!origlimit) {
5675 iters -= trailing_empty;
5677 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5678 if (TOPs && !make_mortal)
5680 *SP-- = &PL_sv_undef;
5687 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5691 if (SvSMAGICAL(ary)) {
5693 mg_set(MUTABLE_SV(ary));
5696 if (gimme == G_ARRAY) {
5698 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5705 ENTER_with_name("call_PUSH");
5706 call_method("PUSH",G_SCALAR|G_DISCARD);
5707 LEAVE_with_name("call_PUSH");
5709 if (gimme == G_ARRAY) {
5711 /* EXTEND should not be needed - we just popped them */
5713 for (i=0; i < iters; i++) {
5714 SV **svp = av_fetch(ary, i, FALSE);
5715 PUSHs((svp) ? *svp : &PL_sv_undef);
5722 if (gimme == G_ARRAY)
5734 SV *const sv = PAD_SVl(PL_op->op_targ);
5736 if (SvPADSTALE(sv)) {
5739 RETURNOP(cLOGOP->op_other);
5741 RETURNOP(cLOGOP->op_next);
5751 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5752 || SvTYPE(retsv) == SVt_PVCV) {
5753 retsv = refto(retsv);
5760 PP(unimplemented_op)
5763 const Optype op_type = PL_op->op_type;
5764 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5765 with out of range op numbers - it only "special" cases op_custom.
5766 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5767 if we get here for a custom op then that means that the custom op didn't
5768 have an implementation. Given that OP_NAME() looks up the custom op
5769 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5770 registers &PL_unimplemented_op as the address of their custom op.
5771 NULL doesn't generate a useful error message. "custom" does. */
5772 const char *const name = op_type >= OP_max
5773 ? "[out of range]" : PL_op_name[PL_op->op_type];
5774 if(OP_IS_SOCKET(op_type))
5775 DIE(aTHX_ PL_no_sock_func, name);
5776 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5779 /* For sorting out arguments passed to a &CORE:: subroutine */
5783 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5784 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5785 AV * const at_ = GvAV(PL_defgv);
5786 SV **svp = at_ ? AvARRAY(at_) : NULL;
5787 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5788 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5789 bool seen_question = 0;
5790 const char *err = NULL;
5791 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5793 /* Count how many args there are first, to get some idea how far to
5794 extend the stack. */
5796 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5798 if (oa & OA_OPTIONAL) seen_question = 1;
5799 if (!seen_question) minargs++;
5803 if(numargs < minargs) err = "Not enough";
5804 else if(numargs > maxargs) err = "Too many";
5806 /* diag_listed_as: Too many arguments for %s */
5808 "%s arguments for %s", err,
5809 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5812 /* Reset the stack pointer. Without this, we end up returning our own
5813 arguments in list context, in addition to the values we are supposed
5814 to return. nextstate usually does this on sub entry, but we need
5815 to run the next op with the caller's hints, so we cannot have a
5817 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5819 if(!maxargs) RETURN;
5821 /* We do this here, rather than with a separate pushmark op, as it has
5822 to come in between two things this function does (stack reset and
5823 arg pushing). This seems the easiest way to do it. */
5826 (void)Perl_pp_pushmark(aTHX);
5829 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5830 PUTBACK; /* The code below can die in various places. */
5832 oa = PL_opargs[opnum] >> OASHIFT;
5833 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5838 if (!numargs && defgv && whicharg == minargs + 1) {
5839 PUSHs(find_rundefsv2(
5840 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5841 cxstack[cxstack_ix].blk_oldcop->cop_seq
5844 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5848 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5853 if (!svp || !*svp || !SvROK(*svp)
5854 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5856 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5857 "Type of arg %d to &CORE::%s must be hash reference",
5858 whicharg, OP_DESC(PL_op->op_next)
5863 if (!numargs) PUSHs(NULL);
5864 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5865 /* no magic here, as the prototype will have added an extra
5866 refgen and we just want what was there before that */
5869 const bool constr = PL_op->op_private & whicharg;
5871 svp && *svp ? *svp : &PL_sv_undef,
5872 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5878 if (!numargs) goto try_defsv;
5880 const bool wantscalar =
5881 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5882 if (!svp || !*svp || !SvROK(*svp)
5883 /* We have to permit globrefs even for the \$ proto, as
5884 *foo is indistinguishable from ${\*foo}, and the proto-
5885 type permits the latter. */
5886 || SvTYPE(SvRV(*svp)) > (
5887 wantscalar ? SVt_PVLV
5888 : opnum == OP_LOCK || opnum == OP_UNDEF
5894 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5895 "Type of arg %d to &CORE::%s must be %s",
5896 whicharg, PL_op_name[opnum],
5898 ? "scalar reference"
5899 : opnum == OP_LOCK || opnum == OP_UNDEF
5900 ? "reference to one of [$@%&*]"
5901 : "reference to one of [$@%*]"
5904 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5905 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5906 /* Undo @_ localisation, so that sub exit does not undo
5907 part of our undeffing. */
5908 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5910 cx->cx_type &= ~ CXp_HASARGS;
5911 assert(!AvREAL(cx->blk_sub.argarray));
5916 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5928 if (PL_op->op_private & OPpOFFBYONE) {
5929 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5931 else cv = find_runcv(NULL);
5932 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5939 * c-indentation-style: bsd
5941 * indent-tabs-mode: nil
5944 * ex: set ts=8 sts=4 sw=4 et: