3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
32 #include "regcharclass.h"
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
46 #if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
53 /* variations on pp_null */
58 if (GIMME_V == G_SCALAR)
69 assert(SvTYPE(TARG) == SVt_PVAV);
70 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
71 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
72 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
74 if (PL_op->op_flags & OPf_REF) {
77 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
78 const I32 flags = is_lvalue_sub();
79 if (flags && !(flags & OPpENTERSUB_INARGS)) {
80 if (GIMME == G_SCALAR)
81 /* diag_listed_as: Can't return %s to lvalue scalar context */
82 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
88 if (gimme == G_ARRAY) {
89 /* XXX see also S_pushav in pp_hot.c */
90 const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
92 if (SvMAGICAL(TARG)) {
94 for (i=0; i < maxarg; i++) {
95 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
96 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
101 for (i=0; i < (PADOFFSET)maxarg; i++) {
102 SV * const sv = AvARRAY((const AV *)TARG)[i];
103 SP[i+1] = sv ? sv : &PL_sv_undef;
108 else if (gimme == G_SCALAR) {
109 SV* const sv = sv_newmortal();
110 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
111 sv_setiv(sv, maxarg);
122 assert(SvTYPE(TARG) == SVt_PVHV);
124 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
125 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
126 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
127 if (PL_op->op_flags & OPf_REF)
129 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
130 const I32 flags = is_lvalue_sub();
131 if (flags && !(flags & OPpENTERSUB_INARGS)) {
132 if (GIMME == G_SCALAR)
133 /* diag_listed_as: Can't return %s to lvalue scalar context */
134 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
139 if (gimme == G_ARRAY) {
140 RETURNOP(Perl_do_kv(aTHX));
142 else if ((PL_op->op_private & OPpTRUEBOOL
143 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
144 && block_gimme() == G_VOID ))
145 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
146 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
147 else if (gimme == G_SCALAR) {
148 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
157 assert(SvTYPE(TARG) == SVt_PVCV);
165 SvPADSTALE_off(TARG);
173 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
175 assert(SvTYPE(TARG) == SVt_PVCV);
178 if (CvISXSUB(mg->mg_obj)) { /* constant */
179 /* XXX Should we clone it here? */
180 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
181 to introcv and remove the SvPADSTALE_off. */
182 SAVEPADSVANDMORTALIZE(ARGTARG);
183 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
186 if (CvROOT(mg->mg_obj)) {
187 assert(CvCLONE(mg->mg_obj));
188 assert(!CvCLONED(mg->mg_obj));
190 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
191 SAVECLEARSV(PAD_SVl(ARGTARG));
198 static const char S_no_symref_sv[] =
199 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
201 /* In some cases this function inspects PL_op. If this function is called
202 for new op types, more bool parameters may need to be added in place of
205 When noinit is true, the absence of a gv will cause a retval of undef.
206 This is unrelated to the cv-to-gv assignment case.
210 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
213 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
216 sv = amagic_deref_call(sv, to_gv_amg);
220 if (SvTYPE(sv) == SVt_PVIO) {
221 GV * const gv = MUTABLE_GV(sv_newmortal());
222 gv_init(gv, 0, "__ANONIO__", 10, 0);
223 GvIOp(gv) = MUTABLE_IO(sv);
224 SvREFCNT_inc_void_NN(sv);
227 else if (!isGV_with_GP(sv)) {
228 Perl_die(aTHX_ "Not a GLOB reference");
232 if (!isGV_with_GP(sv)) {
234 /* If this is a 'my' scalar and flag is set then vivify
237 if (vivify_sv && sv != &PL_sv_undef) {
240 Perl_croak_no_modify();
241 if (cUNOP->op_targ) {
242 SV * const namesv = PAD_SV(cUNOP->op_targ);
243 HV *stash = CopSTASH(PL_curcop);
244 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
245 gv = MUTABLE_GV(newSV(0));
246 gv_init_sv(gv, stash, namesv, 0);
249 const char * const name = CopSTASHPV(PL_curcop);
250 gv = newGVgen_flags(name,
251 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
253 prepare_SV_for_RV(sv);
254 SvRV_set(sv, MUTABLE_SV(gv));
259 if (PL_op->op_flags & OPf_REF || strict) {
260 Perl_die(aTHX_ PL_no_usym, "a symbol");
262 if (ckWARN(WARN_UNINITIALIZED))
268 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
269 sv, GV_ADDMG, SVt_PVGV
278 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
282 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
283 == OPpDONT_INIT_GV) {
284 /* We are the target of a coderef assignment. Return
285 the scalar unchanged, and let pp_sasssign deal with
289 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
291 /* FAKE globs in the symbol table cause weird bugs (#77810) */
295 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
296 SV *newsv = sv_newmortal();
297 sv_setsv_flags(newsv, sv, 0);
309 sv, PL_op->op_private & OPpDEREF,
310 PL_op->op_private & HINT_STRICT_REFS,
311 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
312 || PL_op->op_type == OP_READLINE
314 if (PL_op->op_private & OPpLVAL_INTRO)
315 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
320 /* Helper function for pp_rv2sv and pp_rv2av */
322 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
323 const svtype type, SV ***spp)
327 PERL_ARGS_ASSERT_SOFTREF2XV;
329 if (PL_op->op_private & HINT_STRICT_REFS) {
331 Perl_die(aTHX_ S_no_symref_sv, sv,
332 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
334 Perl_die(aTHX_ PL_no_usym, what);
338 PL_op->op_flags & OPf_REF
340 Perl_die(aTHX_ PL_no_usym, what);
341 if (ckWARN(WARN_UNINITIALIZED))
343 if (type != SVt_PV && GIMME_V == G_ARRAY) {
347 **spp = &PL_sv_undef;
350 if ((PL_op->op_flags & OPf_SPECIAL) &&
351 !(PL_op->op_flags & OPf_MOD))
353 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
355 **spp = &PL_sv_undef;
360 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
373 sv = amagic_deref_call(sv, to_sv_amg);
377 switch (SvTYPE(sv)) {
383 DIE(aTHX_ "Not a SCALAR reference");
390 if (!isGV_with_GP(gv)) {
391 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
397 if (PL_op->op_flags & OPf_MOD) {
398 if (PL_op->op_private & OPpLVAL_INTRO) {
399 if (cUNOP->op_first->op_type == OP_NULL)
400 sv = save_scalar(MUTABLE_GV(TOPs));
402 sv = save_scalar(gv);
404 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
406 else if (PL_op->op_private & OPpDEREF)
407 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
416 AV * const av = MUTABLE_AV(TOPs);
417 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
419 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
421 *sv = newSV_type(SVt_PVMG);
422 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
426 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
435 if (PL_op->op_flags & OPf_MOD || LVRET) {
436 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
437 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
439 LvTARG(ret) = SvREFCNT_inc_simple(sv);
440 PUSHs(ret); /* no SvSETMAGIC */
444 const MAGIC * const mg = mg_find_mglob(sv);
445 if (mg && mg->mg_len != -1) {
447 STRLEN i = mg->mg_len;
448 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
449 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
462 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
464 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
465 == OPpMAY_RETURN_CONSTANT)
468 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
469 /* (But not in defined().) */
471 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
473 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
477 cv = MUTABLE_CV(&PL_sv_undef);
478 SETs(MUTABLE_SV(cv));
488 SV *ret = &PL_sv_undef;
490 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
491 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
492 const char * s = SvPVX_const(TOPs);
493 if (strnEQ(s, "CORE::", 6)) {
494 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
496 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
497 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
499 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
505 cv = sv_2cv(TOPs, &stash, &gv, 0);
507 ret = newSVpvn_flags(
508 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
518 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
520 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
522 PUSHs(MUTABLE_SV(cv));
536 if (GIMME != G_ARRAY) {
540 *MARK = &PL_sv_undef;
541 *MARK = refto(*MARK);
545 EXTEND_MORTAL(SP - MARK);
547 *MARK = refto(*MARK);
552 S_refto(pTHX_ SV *sv)
556 PERL_ARGS_ASSERT_REFTO;
558 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
561 if (!(sv = LvTARG(sv)))
564 SvREFCNT_inc_void_NN(sv);
566 else if (SvTYPE(sv) == SVt_PVAV) {
567 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
568 av_reify(MUTABLE_AV(sv));
570 SvREFCNT_inc_void_NN(sv);
572 else if (SvPADTMP(sv)) {
573 assert(!IS_PADGV(sv));
578 SvREFCNT_inc_void_NN(sv);
581 sv_upgrade(rv, SVt_IV);
590 SV * const sv = TOPs;
598 /* use the return value that is in a register, its the same as TARG */
599 TARG = sv_ref(TARG,SvRV(sv),TRUE);
614 stash = CopSTASH(PL_curcop);
615 if (SvTYPE(stash) != SVt_PVHV)
616 Perl_croak(aTHX_ "Attempt to bless into a freed package");
619 SV * const ssv = POPs;
623 if (!ssv) goto curstash;
626 if (!SvAMAGIC(ssv)) {
628 Perl_croak(aTHX_ "Attempt to bless into a reference");
630 /* SvAMAGIC is on here, but it only means potentially overloaded,
631 so after stringification: */
632 ptr = SvPV_nomg_const(ssv,len);
633 /* We need to check the flag again: */
634 if (!SvAMAGIC(ssv)) goto frog;
636 else ptr = SvPV_nomg_const(ssv,len);
638 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
639 "Explicit blessing to '' (assuming package main)");
640 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
643 (void)sv_bless(TOPs, stash);
653 const char * const elem = SvPV_const(sv, len);
654 GV * const gv = MUTABLE_GV(POPs);
659 /* elem will always be NUL terminated. */
660 const char * const second_letter = elem + 1;
663 if (len == 5 && strEQ(second_letter, "RRAY"))
665 tmpRef = MUTABLE_SV(GvAV(gv));
666 if (tmpRef && !AvREAL((const AV *)tmpRef)
667 && AvREIFY((const AV *)tmpRef))
668 av_reify(MUTABLE_AV(tmpRef));
672 if (len == 4 && strEQ(second_letter, "ODE"))
673 tmpRef = MUTABLE_SV(GvCVu(gv));
676 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
677 /* finally deprecated in 5.8.0 */
678 deprecate("*glob{FILEHANDLE}");
679 tmpRef = MUTABLE_SV(GvIOp(gv));
682 if (len == 6 && strEQ(second_letter, "ORMAT"))
683 tmpRef = MUTABLE_SV(GvFORM(gv));
686 if (len == 4 && strEQ(second_letter, "LOB"))
687 tmpRef = MUTABLE_SV(gv);
690 if (len == 4 && strEQ(second_letter, "ASH"))
691 tmpRef = MUTABLE_SV(GvHV(gv));
694 if (*second_letter == 'O' && !elem[2] && len == 2)
695 tmpRef = MUTABLE_SV(GvIOp(gv));
698 if (len == 4 && strEQ(second_letter, "AME"))
699 sv = newSVhek(GvNAME_HEK(gv));
702 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
703 const HV * const stash = GvSTASH(gv);
704 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
705 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
709 if (len == 6 && strEQ(second_letter, "CALAR"))
724 /* Pattern matching */
732 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
733 /* Historically, study was skipped in these cases. */
737 /* Make study a no-op. It's no longer useful and its existence
738 complicates matters elsewhere. */
747 if (PL_op->op_flags & OPf_STACKED)
749 else if (PL_op->op_private & OPpTARGET_MY)
755 if(PL_op->op_type == OP_TRANSR) {
757 const char * const pv = SvPV(sv,len);
758 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
763 TARG = sv_newmortal();
769 /* Lvalue operators. */
772 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
777 PERL_ARGS_ASSERT_DO_CHOMP;
779 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
781 if (SvTYPE(sv) == SVt_PVAV) {
783 AV *const av = MUTABLE_AV(sv);
784 const I32 max = AvFILL(av);
786 for (i = 0; i <= max; i++) {
787 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
788 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
789 do_chomp(retval, sv, chomping);
793 else if (SvTYPE(sv) == SVt_PVHV) {
794 HV* const hv = MUTABLE_HV(sv);
796 (void)hv_iterinit(hv);
797 while ((entry = hv_iternext(hv)))
798 do_chomp(retval, hv_iterval(hv,entry), chomping);
801 else if (SvREADONLY(sv)) {
802 Perl_croak_no_modify();
804 else if (SvIsCOW(sv)) {
805 sv_force_normal_flags(sv, 0);
810 /* XXX, here sv is utf8-ized as a side-effect!
811 If encoding.pm is used properly, almost string-generating
812 operations, including literal strings, chr(), input data, etc.
813 should have been utf8-ized already, right?
815 sv_recode_to_utf8(sv, PL_encoding);
821 char *temp_buffer = NULL;
830 while (len && s[-1] == '\n') {
837 STRLEN rslen, rs_charlen;
838 const char *rsptr = SvPV_const(PL_rs, rslen);
840 rs_charlen = SvUTF8(PL_rs)
844 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
845 /* Assumption is that rs is shorter than the scalar. */
847 /* RS is utf8, scalar is 8 bit. */
849 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
852 /* Cannot downgrade, therefore cannot possibly match
854 assert (temp_buffer == rsptr);
860 else if (PL_encoding) {
861 /* RS is 8 bit, encoding.pm is used.
862 * Do not recode PL_rs as a side-effect. */
863 svrecode = newSVpvn(rsptr, rslen);
864 sv_recode_to_utf8(svrecode, PL_encoding);
865 rsptr = SvPV_const(svrecode, rslen);
866 rs_charlen = sv_len_utf8(svrecode);
869 /* RS is 8 bit, scalar is utf8. */
870 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
884 if (memNE(s, rsptr, rslen))
886 SvIVX(retval) += rs_charlen;
889 s = SvPV_force_nomg_nolen(sv);
897 SvREFCNT_dec(svrecode);
899 Safefree(temp_buffer);
901 if (len && !SvPOK(sv))
902 s = SvPV_force_nomg(sv, len);
905 char * const send = s + len;
906 char * const start = s;
908 while (s > start && UTF8_IS_CONTINUATION(*s))
910 if (is_utf8_string((U8*)s, send - s)) {
911 sv_setpvn(retval, s, send - s);
913 SvCUR_set(sv, s - start);
919 sv_setpvs(retval, "");
923 sv_setpvn(retval, s, 1);
930 sv_setpvs(retval, "");
938 const bool chomping = PL_op->op_type == OP_SCHOMP;
942 do_chomp(TARG, TOPs, chomping);
949 dSP; dMARK; dTARGET; dORIGMARK;
950 const bool chomping = PL_op->op_type == OP_CHOMP;
955 do_chomp(TARG, *++MARK, chomping);
966 if (!PL_op->op_private) {
975 SV_CHECK_THINKFIRST_COW_DROP(sv);
977 switch (SvTYPE(sv)) {
981 av_undef(MUTABLE_AV(sv));
984 hv_undef(MUTABLE_HV(sv));
987 if (cv_const_sv((const CV *)sv))
988 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
989 "Constant subroutine %"SVf" undefined",
990 SVfARG(CvANON((const CV *)sv)
991 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
992 : sv_2mortal(newSVhek(
994 ? CvNAME_HEK((CV *)sv)
995 : GvENAME_HEK(CvGV((const CV *)sv))
1001 /* let user-undef'd sub keep its identity */
1002 GV* const gv = CvGV((const CV *)sv);
1003 HEK * const hek = CvNAME_HEK((CV *)sv);
1004 if (hek) share_hek_hek(hek);
1005 cv_undef(MUTABLE_CV(sv));
1006 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
1008 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
1014 assert(isGV_with_GP(sv));
1015 assert(!SvFAKE(sv));
1020 /* undef *Pkg::meth_name ... */
1022 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1023 && HvENAME_get(stash);
1025 if((stash = GvHV((const GV *)sv))) {
1026 if(HvENAME_get(stash))
1027 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1031 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1032 gp_free(MUTABLE_GV(sv));
1034 GvGP_set(sv, gp_ref(gp));
1035 #ifndef PERL_DONT_CREATE_GVSV
1036 GvSV(sv) = newSV(0);
1038 GvLINE(sv) = CopLINE(PL_curcop);
1039 GvEGV(sv) = MUTABLE_GV(sv);
1043 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1045 /* undef *Foo::ISA */
1046 if( strEQ(GvNAME((const GV *)sv), "ISA")
1047 && (stash = GvSTASH((const GV *)sv))
1048 && (method_changed || HvENAME(stash)) )
1049 mro_isa_changed_in(stash);
1050 else if(method_changed)
1051 mro_method_changed_in(
1052 GvSTASH((const GV *)sv)
1058 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1074 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1075 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1076 Perl_croak_no_modify();
1078 TARG = sv_newmortal();
1079 sv_setsv(TARG, TOPs);
1080 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1081 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1083 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1084 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1088 else sv_dec_nomg(TOPs);
1090 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1091 if (inc && !SvOK(TARG))
1097 /* Ordinary operators. */
1101 dSP; dATARGET; SV *svl, *svr;
1102 #ifdef PERL_PRESERVE_IVUV
1105 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1108 #ifdef PERL_PRESERVE_IVUV
1109 /* For integer to integer power, we do the calculation by hand wherever
1110 we're sure it is safe; otherwise we call pow() and try to convert to
1111 integer afterwards. */
1112 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1120 const IV iv = SvIVX(svr);
1124 goto float_it; /* Can't do negative powers this way. */
1128 baseuok = SvUOK(svl);
1130 baseuv = SvUVX(svl);
1132 const IV iv = SvIVX(svl);
1135 baseuok = TRUE; /* effectively it's a UV now */
1137 baseuv = -iv; /* abs, baseuok == false records sign */
1140 /* now we have integer ** positive integer. */
1143 /* foo & (foo - 1) is zero only for a power of 2. */
1144 if (!(baseuv & (baseuv - 1))) {
1145 /* We are raising power-of-2 to a positive integer.
1146 The logic here will work for any base (even non-integer
1147 bases) but it can be less accurate than
1148 pow (base,power) or exp (power * log (base)) when the
1149 intermediate values start to spill out of the mantissa.
1150 With powers of 2 we know this can't happen.
1151 And powers of 2 are the favourite thing for perl
1152 programmers to notice ** not doing what they mean. */
1154 NV base = baseuok ? baseuv : -(NV)baseuv;
1159 while (power >>= 1) {
1167 SvIV_please_nomg(svr);
1170 unsigned int highbit = 8 * sizeof(UV);
1171 unsigned int diff = 8 * sizeof(UV);
1172 while (diff >>= 1) {
1174 if (baseuv >> highbit) {
1178 /* we now have baseuv < 2 ** highbit */
1179 if (power * highbit <= 8 * sizeof(UV)) {
1180 /* result will definitely fit in UV, so use UV math
1181 on same algorithm as above */
1184 const bool odd_power = cBOOL(power & 1);
1188 while (power >>= 1) {
1195 if (baseuok || !odd_power)
1196 /* answer is positive */
1198 else if (result <= (UV)IV_MAX)
1199 /* answer negative, fits in IV */
1200 SETi( -(IV)result );
1201 else if (result == (UV)IV_MIN)
1202 /* 2's complement assumption: special case IV_MIN */
1205 /* answer negative, doesn't fit */
1206 SETn( -(NV)result );
1214 NV right = SvNV_nomg(svr);
1215 NV left = SvNV_nomg(svl);
1218 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1220 We are building perl with long double support and are on an AIX OS
1221 afflicted with a powl() function that wrongly returns NaNQ for any
1222 negative base. This was reported to IBM as PMR #23047-379 on
1223 03/06/2006. The problem exists in at least the following versions
1224 of AIX and the libm fileset, and no doubt others as well:
1226 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1227 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1228 AIX 5.2.0 bos.adt.libm 5.2.0.85
1230 So, until IBM fixes powl(), we provide the following workaround to
1231 handle the problem ourselves. Our logic is as follows: for
1232 negative bases (left), we use fmod(right, 2) to check if the
1233 exponent is an odd or even integer:
1235 - if odd, powl(left, right) == -powl(-left, right)
1236 - if even, powl(left, right) == powl(-left, right)
1238 If the exponent is not an integer, the result is rightly NaNQ, so
1239 we just return that (as NV_NAN).
1243 NV mod2 = Perl_fmod( right, 2.0 );
1244 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1245 SETn( -Perl_pow( -left, right) );
1246 } else if (mod2 == 0.0) { /* even integer */
1247 SETn( Perl_pow( -left, right) );
1248 } else { /* fractional power */
1252 SETn( Perl_pow( left, right) );
1255 SETn( Perl_pow( left, right) );
1256 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1258 #ifdef PERL_PRESERVE_IVUV
1260 SvIV_please_nomg(svr);
1268 dSP; dATARGET; SV *svl, *svr;
1269 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1272 #ifdef PERL_PRESERVE_IVUV
1273 if (SvIV_please_nomg(svr)) {
1274 /* Unless the left argument is integer in range we are going to have to
1275 use NV maths. Hence only attempt to coerce the right argument if
1276 we know the left is integer. */
1277 /* Left operand is defined, so is it IV? */
1278 if (SvIV_please_nomg(svl)) {
1279 bool auvok = SvUOK(svl);
1280 bool buvok = SvUOK(svr);
1281 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1282 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1291 const IV aiv = SvIVX(svl);
1294 auvok = TRUE; /* effectively it's a UV now */
1296 alow = -aiv; /* abs, auvok == false records sign */
1302 const IV biv = SvIVX(svr);
1305 buvok = TRUE; /* effectively it's a UV now */
1307 blow = -biv; /* abs, buvok == false records sign */
1311 /* If this does sign extension on unsigned it's time for plan B */
1312 ahigh = alow >> (4 * sizeof (UV));
1314 bhigh = blow >> (4 * sizeof (UV));
1316 if (ahigh && bhigh) {
1318 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1319 which is overflow. Drop to NVs below. */
1320 } else if (!ahigh && !bhigh) {
1321 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1322 so the unsigned multiply cannot overflow. */
1323 const UV product = alow * blow;
1324 if (auvok == buvok) {
1325 /* -ve * -ve or +ve * +ve gives a +ve result. */
1329 } else if (product <= (UV)IV_MIN) {
1330 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1331 /* -ve result, which could overflow an IV */
1333 SETi( -(IV)product );
1335 } /* else drop to NVs below. */
1337 /* One operand is large, 1 small */
1340 /* swap the operands */
1342 bhigh = blow; /* bhigh now the temp var for the swap */
1346 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1347 multiplies can't overflow. shift can, add can, -ve can. */
1348 product_middle = ahigh * blow;
1349 if (!(product_middle & topmask)) {
1350 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1352 product_middle <<= (4 * sizeof (UV));
1353 product_low = alow * blow;
1355 /* as for pp_add, UV + something mustn't get smaller.
1356 IIRC ANSI mandates this wrapping *behaviour* for
1357 unsigned whatever the actual representation*/
1358 product_low += product_middle;
1359 if (product_low >= product_middle) {
1360 /* didn't overflow */
1361 if (auvok == buvok) {
1362 /* -ve * -ve or +ve * +ve gives a +ve result. */
1364 SETu( product_low );
1366 } else if (product_low <= (UV)IV_MIN) {
1367 /* 2s complement assumption again */
1368 /* -ve result, which could overflow an IV */
1370 SETi( -(IV)product_low );
1372 } /* else drop to NVs below. */
1374 } /* product_middle too large */
1375 } /* ahigh && bhigh */
1380 NV right = SvNV_nomg(svr);
1381 NV left = SvNV_nomg(svl);
1383 SETn( left * right );
1390 dSP; dATARGET; SV *svl, *svr;
1391 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1394 /* Only try to do UV divide first
1395 if ((SLOPPYDIVIDE is true) or
1396 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1398 The assumption is that it is better to use floating point divide
1399 whenever possible, only doing integer divide first if we can't be sure.
1400 If NV_PRESERVES_UV is true then we know at compile time that no UV
1401 can be too large to preserve, so don't need to compile the code to
1402 test the size of UVs. */
1405 # define PERL_TRY_UV_DIVIDE
1406 /* ensure that 20./5. == 4. */
1408 # ifdef PERL_PRESERVE_IVUV
1409 # ifndef NV_PRESERVES_UV
1410 # define PERL_TRY_UV_DIVIDE
1415 #ifdef PERL_TRY_UV_DIVIDE
1416 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1417 bool left_non_neg = SvUOK(svl);
1418 bool right_non_neg = SvUOK(svr);
1422 if (right_non_neg) {
1426 const IV biv = SvIVX(svr);
1429 right_non_neg = TRUE; /* effectively it's a UV now */
1435 /* historically undef()/0 gives a "Use of uninitialized value"
1436 warning before dieing, hence this test goes here.
1437 If it were immediately before the second SvIV_please, then
1438 DIE() would be invoked before left was even inspected, so
1439 no inspection would give no warning. */
1441 DIE(aTHX_ "Illegal division by zero");
1447 const IV aiv = SvIVX(svl);
1450 left_non_neg = TRUE; /* effectively it's a UV now */
1459 /* For sloppy divide we always attempt integer division. */
1461 /* Otherwise we only attempt it if either or both operands
1462 would not be preserved by an NV. If both fit in NVs
1463 we fall through to the NV divide code below. However,
1464 as left >= right to ensure integer result here, we know that
1465 we can skip the test on the right operand - right big
1466 enough not to be preserved can't get here unless left is
1469 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1472 /* Integer division can't overflow, but it can be imprecise. */
1473 const UV result = left / right;
1474 if (result * right == left) {
1475 SP--; /* result is valid */
1476 if (left_non_neg == right_non_neg) {
1477 /* signs identical, result is positive. */
1481 /* 2s complement assumption */
1482 if (result <= (UV)IV_MIN)
1483 SETi( -(IV)result );
1485 /* It's exact but too negative for IV. */
1486 SETn( -(NV)result );
1489 } /* tried integer divide but it was not an integer result */
1490 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1491 } /* one operand wasn't SvIOK */
1492 #endif /* PERL_TRY_UV_DIVIDE */
1494 NV right = SvNV_nomg(svr);
1495 NV left = SvNV_nomg(svl);
1496 (void)POPs;(void)POPs;
1497 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1498 if (! Perl_isnan(right) && right == 0.0)
1502 DIE(aTHX_ "Illegal division by zero");
1503 PUSHn( left / right );
1511 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1515 bool left_neg = FALSE;
1516 bool right_neg = FALSE;
1517 bool use_double = FALSE;
1518 bool dright_valid = FALSE;
1521 SV * const svr = TOPs;
1522 SV * const svl = TOPm1s;
1523 if (SvIV_please_nomg(svr)) {
1524 right_neg = !SvUOK(svr);
1528 const IV biv = SvIVX(svr);
1531 right_neg = FALSE; /* effectively it's a UV now */
1538 dright = SvNV_nomg(svr);
1539 right_neg = dright < 0;
1542 if (dright < UV_MAX_P1) {
1543 right = U_V(dright);
1544 dright_valid = TRUE; /* In case we need to use double below. */
1550 /* At this point use_double is only true if right is out of range for
1551 a UV. In range NV has been rounded down to nearest UV and
1552 use_double false. */
1553 if (!use_double && SvIV_please_nomg(svl)) {
1554 left_neg = !SvUOK(svl);
1558 const IV aiv = SvIVX(svl);
1561 left_neg = FALSE; /* effectively it's a UV now */
1568 dleft = SvNV_nomg(svl);
1569 left_neg = dleft < 0;
1573 /* This should be exactly the 5.6 behaviour - if left and right are
1574 both in range for UV then use U_V() rather than floor. */
1576 if (dleft < UV_MAX_P1) {
1577 /* right was in range, so is dleft, so use UVs not double.
1581 /* left is out of range for UV, right was in range, so promote
1582 right (back) to double. */
1584 /* The +0.5 is used in 5.6 even though it is not strictly
1585 consistent with the implicit +0 floor in the U_V()
1586 inside the #if 1. */
1587 dleft = Perl_floor(dleft + 0.5);
1590 dright = Perl_floor(dright + 0.5);
1601 DIE(aTHX_ "Illegal modulus zero");
1603 dans = Perl_fmod(dleft, dright);
1604 if ((left_neg != right_neg) && dans)
1605 dans = dright - dans;
1608 sv_setnv(TARG, dans);
1614 DIE(aTHX_ "Illegal modulus zero");
1617 if ((left_neg != right_neg) && ans)
1620 /* XXX may warn: unary minus operator applied to unsigned type */
1621 /* could change -foo to be (~foo)+1 instead */
1622 if (ans <= ~((UV)IV_MAX)+1)
1623 sv_setiv(TARG, ~ans+1);
1625 sv_setnv(TARG, -(NV)ans);
1628 sv_setuv(TARG, ans);
1641 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1642 /* TODO: think of some way of doing list-repeat overloading ??? */
1647 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1653 const UV uv = SvUV_nomg(sv);
1655 count = IV_MAX; /* The best we can do? */
1659 count = SvIV_nomg(sv);
1662 else if (SvNOKp(sv)) {
1663 const NV nv = SvNV_nomg(sv);
1665 count = -1; /* An arbitrary negative integer */
1670 count = SvIV_nomg(sv);
1674 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1675 "Negative repeat count does nothing");
1678 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1680 static const char* const oom_list_extend = "Out of memory during list extend";
1681 const I32 items = SP - MARK;
1682 const I32 max = items * count;
1683 const U8 mod = PL_op->op_flags & OPf_MOD;
1685 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1686 /* Did the max computation overflow? */
1687 if (items > 0 && max > 0 && (max < items || max < count))
1688 Perl_croak(aTHX_ "%s", oom_list_extend);
1693 /* This code was intended to fix 20010809.028:
1696 for (($x =~ /./g) x 2) {
1697 print chop; # "abcdabcd" expected as output.
1700 * but that change (#11635) broke this code:
1702 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1704 * I can't think of a better fix that doesn't introduce
1705 * an efficiency hit by copying the SVs. The stack isn't
1706 * refcounted, and mortalisation obviously doesn't
1707 * Do The Right Thing when the stack has more than
1708 * one pointer to the same mortal value.
1712 *SP = sv_2mortal(newSVsv(*SP));
1717 if (mod && SvPADTMP(*SP)) {
1718 assert(!IS_PADGV(*SP));
1719 *SP = sv_mortalcopy(*SP);
1727 repeatcpy((char*)(MARK + items), (char*)MARK,
1728 items * sizeof(const SV *), count - 1);
1731 else if (count <= 0)
1734 else { /* Note: mark already snarfed by pp_list */
1735 SV * const tmpstr = POPs;
1738 static const char* const oom_string_extend =
1739 "Out of memory during string extend";
1742 sv_setsv_nomg(TARG, tmpstr);
1743 SvPV_force_nomg(TARG, len);
1744 isutf = DO_UTF8(TARG);
1749 const STRLEN max = (UV)count * len;
1750 if (len > MEM_SIZE_MAX / count)
1751 Perl_croak(aTHX_ "%s", oom_string_extend);
1752 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1753 SvGROW(TARG, max + 1);
1754 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1755 SvCUR_set(TARG, SvCUR(TARG) * count);
1757 *SvEND(TARG) = '\0';
1760 (void)SvPOK_only_UTF8(TARG);
1762 (void)SvPOK_only(TARG);
1764 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1765 /* The parser saw this as a list repeat, and there
1766 are probably several items on the stack. But we're
1767 in scalar context, and there's no pp_list to save us
1768 now. So drop the rest of the items -- robin@kitsite.com
1780 dSP; dATARGET; bool useleft; SV *svl, *svr;
1781 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1784 useleft = USE_LEFT(svl);
1785 #ifdef PERL_PRESERVE_IVUV
1786 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1787 "bad things" happen if you rely on signed integers wrapping. */
1788 if (SvIV_please_nomg(svr)) {
1789 /* Unless the left argument is integer in range we are going to have to
1790 use NV maths. Hence only attempt to coerce the right argument if
1791 we know the left is integer. */
1798 a_valid = auvok = 1;
1799 /* left operand is undef, treat as zero. */
1801 /* Left operand is defined, so is it IV? */
1802 if (SvIV_please_nomg(svl)) {
1803 if ((auvok = SvUOK(svl)))
1806 const IV aiv = SvIVX(svl);
1809 auvok = 1; /* Now acting as a sign flag. */
1810 } else { /* 2s complement assumption for IV_MIN */
1818 bool result_good = 0;
1821 bool buvok = SvUOK(svr);
1826 const IV biv = SvIVX(svr);
1833 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1834 else "IV" now, independent of how it came in.
1835 if a, b represents positive, A, B negative, a maps to -A etc
1840 all UV maths. negate result if A negative.
1841 subtract if signs same, add if signs differ. */
1843 if (auvok ^ buvok) {
1852 /* Must get smaller */
1857 if (result <= buv) {
1858 /* result really should be -(auv-buv). as its negation
1859 of true value, need to swap our result flag */
1871 if (result <= (UV)IV_MIN)
1872 SETi( -(IV)result );
1874 /* result valid, but out of range for IV. */
1875 SETn( -(NV)result );
1879 } /* Overflow, drop through to NVs. */
1884 NV value = SvNV_nomg(svr);
1888 /* left operand is undef, treat as zero - value */
1892 SETn( SvNV_nomg(svl) - value );
1899 dSP; dATARGET; SV *svl, *svr;
1900 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1904 const IV shift = SvIV_nomg(svr);
1905 if (PL_op->op_private & HINT_INTEGER) {
1906 const IV i = SvIV_nomg(svl);
1910 const UV u = SvUV_nomg(svl);
1919 dSP; dATARGET; SV *svl, *svr;
1920 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1924 const IV shift = SvIV_nomg(svr);
1925 if (PL_op->op_private & HINT_INTEGER) {
1926 const IV i = SvIV_nomg(svl);
1930 const UV u = SvUV_nomg(svl);
1942 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1946 (SvIOK_notUV(left) && SvIOK_notUV(right))
1947 ? (SvIVX(left) < SvIVX(right))
1948 : (do_ncmp(left, right) == -1)
1958 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1962 (SvIOK_notUV(left) && SvIOK_notUV(right))
1963 ? (SvIVX(left) > SvIVX(right))
1964 : (do_ncmp(left, right) == 1)
1974 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1978 (SvIOK_notUV(left) && SvIOK_notUV(right))
1979 ? (SvIVX(left) <= SvIVX(right))
1980 : (do_ncmp(left, right) <= 0)
1990 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1994 (SvIOK_notUV(left) && SvIOK_notUV(right))
1995 ? (SvIVX(left) >= SvIVX(right))
1996 : ( (do_ncmp(left, right) & 2) == 0)
2006 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2010 (SvIOK_notUV(left) && SvIOK_notUV(right))
2011 ? (SvIVX(left) != SvIVX(right))
2012 : (do_ncmp(left, right) != 0)
2017 /* compare left and right SVs. Returns:
2021 * 2: left or right was a NaN
2024 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2026 PERL_ARGS_ASSERT_DO_NCMP;
2027 #ifdef PERL_PRESERVE_IVUV
2028 /* Fortunately it seems NaN isn't IOK */
2029 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2031 const IV leftiv = SvIVX(left);
2032 if (!SvUOK(right)) {
2033 /* ## IV <=> IV ## */
2034 const IV rightiv = SvIVX(right);
2035 return (leftiv > rightiv) - (leftiv < rightiv);
2037 /* ## IV <=> UV ## */
2039 /* As (b) is a UV, it's >=0, so it must be < */
2042 const UV rightuv = SvUVX(right);
2043 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2048 /* ## UV <=> UV ## */
2049 const UV leftuv = SvUVX(left);
2050 const UV rightuv = SvUVX(right);
2051 return (leftuv > rightuv) - (leftuv < rightuv);
2053 /* ## UV <=> IV ## */
2055 const IV rightiv = SvIVX(right);
2057 /* As (a) is a UV, it's >=0, so it cannot be < */
2060 const UV leftuv = SvUVX(left);
2061 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2064 assert(0); /* NOTREACHED */
2068 NV const rnv = SvNV_nomg(right);
2069 NV const lnv = SvNV_nomg(left);
2071 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2072 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2075 return (lnv > rnv) - (lnv < rnv);
2094 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2097 value = do_ncmp(left, right);
2112 int amg_type = sle_amg;
2116 switch (PL_op->op_type) {
2135 tryAMAGICbin_MG(amg_type, AMGf_set);
2139 #ifdef USE_LOCALE_COLLATE
2140 (IN_LC_RUNTIME(LC_COLLATE))
2141 ? sv_cmp_locale_flags(left, right, 0)
2144 sv_cmp_flags(left, right, 0);
2145 SETs(boolSV(cmp * multiplier < rhs));
2153 tryAMAGICbin_MG(seq_amg, AMGf_set);
2156 SETs(boolSV(sv_eq_flags(left, right, 0)));
2164 tryAMAGICbin_MG(sne_amg, AMGf_set);
2167 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2175 tryAMAGICbin_MG(scmp_amg, 0);
2179 #ifdef USE_LOCALE_COLLATE
2180 (IN_LC_RUNTIME(LC_COLLATE))
2181 ? sv_cmp_locale_flags(left, right, 0)
2184 sv_cmp_flags(left, right, 0);
2193 tryAMAGICbin_MG(band_amg, AMGf_assign);
2196 if (SvNIOKp(left) || SvNIOKp(right)) {
2197 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2198 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2199 if (PL_op->op_private & HINT_INTEGER) {
2200 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2204 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2207 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2208 if (right_ro_nonnum) SvNIOK_off(right);
2211 do_vop(PL_op->op_type, TARG, left, right);
2221 const int op_type = PL_op->op_type;
2223 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2226 if (SvNIOKp(left) || SvNIOKp(right)) {
2227 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2228 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2229 if (PL_op->op_private & HINT_INTEGER) {
2230 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2231 const IV r = SvIV_nomg(right);
2232 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2236 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2237 const UV r = SvUV_nomg(right);
2238 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2241 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2242 if (right_ro_nonnum) SvNIOK_off(right);
2245 do_vop(op_type, TARG, left, right);
2252 PERL_STATIC_INLINE bool
2253 S_negate_string(pTHX)
2258 SV * const sv = TOPs;
2259 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2261 s = SvPV_nomg_const(sv, len);
2262 if (isIDFIRST(*s)) {
2263 sv_setpvs(TARG, "-");
2266 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2267 sv_setsv_nomg(TARG, sv);
2268 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2278 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2279 if (S_negate_string(aTHX)) return NORMAL;
2281 SV * const sv = TOPs;
2284 /* It's publicly an integer */
2287 if (SvIVX(sv) == IV_MIN) {
2288 /* 2s complement assumption. */
2289 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2293 else if (SvUVX(sv) <= IV_MAX) {
2298 else if (SvIVX(sv) != IV_MIN) {
2302 #ifdef PERL_PRESERVE_IVUV
2309 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2310 SETn(-SvNV_nomg(sv));
2311 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2312 goto oops_its_an_int;
2314 SETn(-SvNV_nomg(sv));
2322 tryAMAGICun_MG(not_amg, AMGf_set);
2323 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2330 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2334 if (PL_op->op_private & HINT_INTEGER) {
2335 const IV i = ~SvIV_nomg(sv);
2339 const UV u = ~SvUV_nomg(sv);
2348 sv_copypv_nomg(TARG, sv);
2349 tmps = (U8*)SvPV_nomg(TARG, len);
2352 /* Calculate exact length, let's not estimate. */
2357 U8 * const send = tmps + len;
2358 U8 * const origtmps = tmps;
2359 const UV utf8flags = UTF8_ALLOW_ANYUV;
2361 while (tmps < send) {
2362 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2364 targlen += UNISKIP(~c);
2370 /* Now rewind strings and write them. */
2377 Newx(result, targlen + 1, U8);
2379 while (tmps < send) {
2380 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2382 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2385 sv_usepvn_flags(TARG, (char*)result, targlen,
2386 SV_HAS_TRAILING_NUL);
2393 Newx(result, nchar + 1, U8);
2395 while (tmps < send) {
2396 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2401 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2410 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2413 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2418 for ( ; anum > 0; anum--, tmps++)
2426 /* integer versions of some of the above */
2431 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2434 SETi( left * right );
2443 tryAMAGICbin_MG(div_amg, AMGf_assign);
2446 IV value = SvIV_nomg(right);
2448 DIE(aTHX_ "Illegal division by zero");
2449 num = SvIV_nomg(left);
2451 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2455 value = num / value;
2461 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2468 /* This is the vanilla old i_modulo. */
2470 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2474 DIE(aTHX_ "Illegal modulus zero");
2475 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2479 SETi( left % right );
2484 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2489 /* This is the i_modulo with the workaround for the _moddi3 bug
2490 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2491 * See below for pp_i_modulo. */
2493 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2497 DIE(aTHX_ "Illegal modulus zero");
2498 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2502 SETi( left % PERL_ABS(right) );
2509 dVAR; dSP; dATARGET;
2510 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2514 DIE(aTHX_ "Illegal modulus zero");
2515 /* The assumption is to use hereafter the old vanilla version... */
2517 PL_ppaddr[OP_I_MODULO] =
2519 /* .. but if we have glibc, we might have a buggy _moddi3
2520 * (at least glicb 2.2.5 is known to have this bug), in other
2521 * words our integer modulus with negative quad as the second
2522 * argument might be broken. Test for this and re-patch the
2523 * opcode dispatch table if that is the case, remembering to
2524 * also apply the workaround so that this first round works
2525 * right, too. See [perl #9402] for more information. */
2529 /* Cannot do this check with inlined IV constants since
2530 * that seems to work correctly even with the buggy glibc. */
2532 /* Yikes, we have the bug.
2533 * Patch in the workaround version. */
2535 PL_ppaddr[OP_I_MODULO] =
2536 &Perl_pp_i_modulo_1;
2537 /* Make certain we work right this time, too. */
2538 right = PERL_ABS(right);
2541 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2545 SETi( left % right );
2554 tryAMAGICbin_MG(add_amg, AMGf_assign);
2556 dPOPTOPiirl_ul_nomg;
2557 SETi( left + right );
2565 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2567 dPOPTOPiirl_ul_nomg;
2568 SETi( left - right );
2576 tryAMAGICbin_MG(lt_amg, AMGf_set);
2579 SETs(boolSV(left < right));
2587 tryAMAGICbin_MG(gt_amg, AMGf_set);
2590 SETs(boolSV(left > right));
2598 tryAMAGICbin_MG(le_amg, AMGf_set);
2601 SETs(boolSV(left <= right));
2609 tryAMAGICbin_MG(ge_amg, AMGf_set);
2612 SETs(boolSV(left >= right));
2620 tryAMAGICbin_MG(eq_amg, AMGf_set);
2623 SETs(boolSV(left == right));
2631 tryAMAGICbin_MG(ne_amg, AMGf_set);
2634 SETs(boolSV(left != right));
2642 tryAMAGICbin_MG(ncmp_amg, 0);
2649 else if (left < right)
2661 tryAMAGICun_MG(neg_amg, 0);
2662 if (S_negate_string(aTHX)) return NORMAL;
2664 SV * const sv = TOPs;
2665 IV const i = SvIV_nomg(sv);
2671 /* High falutin' math. */
2676 tryAMAGICbin_MG(atan2_amg, 0);
2679 SETn(Perl_atan2(left, right));
2687 int amg_type = sin_amg;
2688 const char *neg_report = NULL;
2689 NV (*func)(NV) = Perl_sin;
2690 const int op_type = PL_op->op_type;
2707 amg_type = sqrt_amg;
2709 neg_report = "sqrt";
2714 tryAMAGICun_MG(amg_type, 0);
2716 SV * const arg = POPs;
2717 const NV value = SvNV_nomg(arg);
2719 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2720 SET_NUMERIC_STANDARD();
2721 /* diag_listed_as: Can't take log of %g */
2722 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2725 XPUSHn(func(value));
2730 /* Support Configure command-line overrides for rand() functions.
2731 After 5.005, perhaps we should replace this by Configure support
2732 for drand48(), random(), or rand(). For 5.005, though, maintain
2733 compatibility by calling rand() but allow the user to override it.
2734 See INSTALL for details. --Andy Dougherty 15 July 1998
2736 /* Now it's after 5.005, and Configure supports drand48() and random(),
2737 in addition to rand(). So the overrides should not be needed any more.
2738 --Jarkko Hietaniemi 27 September 1998
2743 if (!PL_srand_called) {
2744 (void)seedDrand01((Rand_seed_t)seed());
2745 PL_srand_called = TRUE;
2755 SV * const sv = POPs;
2761 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2769 sv_setnv_mg(TARG, value);
2780 if (MAXARG >= 1 && (TOPs || POPs)) {
2787 pv = SvPV(top, len);
2788 flags = grok_number(pv, len, &anum);
2790 if (!(flags & IS_NUMBER_IN_UV)) {
2791 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2792 "Integer overflow in srand");
2800 (void)seedDrand01((Rand_seed_t)anum);
2801 PL_srand_called = TRUE;
2805 /* Historically srand always returned true. We can avoid breaking
2807 sv_setpvs(TARG, "0 but true");
2816 tryAMAGICun_MG(int_amg, AMGf_numeric);
2818 SV * const sv = TOPs;
2819 const IV iv = SvIV_nomg(sv);
2820 /* XXX it's arguable that compiler casting to IV might be subtly
2821 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2822 else preferring IV has introduced a subtle behaviour change bug. OTOH
2823 relying on floating point to be accurate is a bug. */
2828 else if (SvIOK(sv)) {
2830 SETu(SvUV_nomg(sv));
2835 const NV value = SvNV_nomg(sv);
2837 if (value < (NV)UV_MAX + 0.5) {
2840 SETn(Perl_floor(value));
2844 if (value > (NV)IV_MIN - 0.5) {
2847 SETn(Perl_ceil(value));
2858 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2860 SV * const sv = TOPs;
2861 /* This will cache the NV value if string isn't actually integer */
2862 const IV iv = SvIV_nomg(sv);
2867 else if (SvIOK(sv)) {
2868 /* IVX is precise */
2870 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2878 /* 2s complement assumption. Also, not really needed as
2879 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2885 const NV value = SvNV_nomg(sv);
2899 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2903 SV* const sv = POPs;
2905 tmps = (SvPV_const(sv, len));
2907 /* If Unicode, try to downgrade
2908 * If not possible, croak. */
2909 SV* const tsv = sv_2mortal(newSVsv(sv));
2912 sv_utf8_downgrade(tsv, FALSE);
2913 tmps = SvPV_const(tsv, len);
2915 if (PL_op->op_type == OP_HEX)
2918 while (*tmps && len && isSPACE(*tmps))
2922 if (*tmps == 'x' || *tmps == 'X') {
2924 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2926 else if (*tmps == 'b' || *tmps == 'B')
2927 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2929 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2931 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2945 SV * const sv = TOPs;
2950 SETi(sv_len_utf8_nomg(sv));
2954 (void)SvPV_nomg_const(sv,len);
2958 if (!SvPADTMP(TARG)) {
2959 sv_setsv_nomg(TARG, &PL_sv_undef);
2967 /* Returns false if substring is completely outside original string.
2968 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2969 always be true for an explicit 0.
2972 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
2973 bool pos1_is_uv, IV len_iv,
2974 bool len_is_uv, STRLEN *posp,
2980 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2982 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2983 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2986 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2989 if (len_iv || len_is_uv) {
2990 if (!len_is_uv && len_iv < 0) {
2991 pos2_iv = curlen + len_iv;
2993 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2996 } else { /* len_iv >= 0 */
2997 if (!pos1_is_uv && pos1_iv < 0) {
2998 pos2_iv = pos1_iv + len_iv;
2999 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3001 if ((UV)len_iv > curlen-(UV)pos1_iv)
3004 pos2_iv = pos1_iv+len_iv;
3014 if (!pos2_is_uv && pos2_iv < 0) {
3015 if (!pos1_is_uv && pos1_iv < 0)
3019 else if (!pos1_is_uv && pos1_iv < 0)
3022 if ((UV)pos2_iv < (UV)pos1_iv)
3024 if ((UV)pos2_iv > curlen)
3027 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3028 *posp = (STRLEN)( (UV)pos1_iv );
3029 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3046 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3047 const bool rvalue = (GIMME_V != G_VOID);
3050 const char *repl = NULL;
3052 int num_args = PL_op->op_private & 7;
3053 bool repl_need_utf8_upgrade = FALSE;
3057 if(!(repl_sv = POPs)) num_args--;
3059 if ((len_sv = POPs)) {
3060 len_iv = SvIV(len_sv);
3061 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3066 pos1_iv = SvIV(pos_sv);
3067 pos1_is_uv = SvIOK_UV(pos_sv);
3069 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3074 if (lvalue && !repl_sv) {
3076 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3077 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3079 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3081 pos1_is_uv || pos1_iv >= 0
3082 ? (STRLEN)(UV)pos1_iv
3083 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3085 len_is_uv || len_iv > 0
3086 ? (STRLEN)(UV)len_iv
3087 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3090 PUSHs(ret); /* avoid SvSETMAGIC here */
3094 repl = SvPV_const(repl_sv, repl_len);
3097 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3098 "Attempt to use reference as lvalue in substr"
3100 tmps = SvPV_force_nomg(sv, curlen);
3101 if (DO_UTF8(repl_sv) && repl_len) {
3103 sv_utf8_upgrade_nomg(sv);
3107 else if (DO_UTF8(sv))
3108 repl_need_utf8_upgrade = TRUE;
3110 else tmps = SvPV_const(sv, curlen);
3112 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3113 if (utf8_curlen == curlen)
3116 curlen = utf8_curlen;
3122 STRLEN pos, len, byte_len, byte_pos;
3124 if (!translate_substr_offsets(
3125 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3129 byte_pos = utf8_curlen
3130 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3135 SvTAINTED_off(TARG); /* decontaminate */
3136 SvUTF8_off(TARG); /* decontaminate */
3137 sv_setpvn(TARG, tmps, byte_len);
3138 #ifdef USE_LOCALE_COLLATE
3139 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3146 SV* repl_sv_copy = NULL;
3148 if (repl_need_utf8_upgrade) {
3149 repl_sv_copy = newSVsv(repl_sv);
3150 sv_utf8_upgrade(repl_sv_copy);
3151 repl = SvPV_const(repl_sv_copy, repl_len);
3155 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3156 SvREFCNT_dec(repl_sv_copy);
3168 Perl_croak(aTHX_ "substr outside of string");
3169 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3176 const IV size = POPi;
3177 const IV offset = POPi;
3178 SV * const src = POPs;
3179 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3182 if (lvalue) { /* it's an lvalue! */
3183 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3184 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3186 LvTARG(ret) = SvREFCNT_inc_simple(src);
3187 LvTARGOFF(ret) = offset;
3188 LvTARGLEN(ret) = size;
3192 SvTAINTED_off(TARG); /* decontaminate */
3196 sv_setuv(ret, do_vecget(src, offset, size));
3212 const char *little_p;
3215 const bool is_index = PL_op->op_type == OP_INDEX;
3216 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3222 big_p = SvPV_const(big, biglen);
3223 little_p = SvPV_const(little, llen);
3225 big_utf8 = DO_UTF8(big);
3226 little_utf8 = DO_UTF8(little);
3227 if (big_utf8 ^ little_utf8) {
3228 /* One needs to be upgraded. */
3229 if (little_utf8 && !PL_encoding) {
3230 /* Well, maybe instead we might be able to downgrade the small
3232 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3235 /* If the large string is ISO-8859-1, and it's not possible to
3236 convert the small string to ISO-8859-1, then there is no
3237 way that it could be found anywhere by index. */
3242 /* At this point, pv is a malloc()ed string. So donate it to temp
3243 to ensure it will get free()d */
3244 little = temp = newSV(0);
3245 sv_usepvn(temp, pv, llen);
3246 little_p = SvPVX(little);
3249 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3252 sv_recode_to_utf8(temp, PL_encoding);
3254 sv_utf8_upgrade(temp);
3259 big_p = SvPV_const(big, biglen);
3262 little_p = SvPV_const(little, llen);
3266 if (SvGAMAGIC(big)) {
3267 /* Life just becomes a lot easier if I use a temporary here.
3268 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3269 will trigger magic and overloading again, as will fbm_instr()
3271 big = newSVpvn_flags(big_p, biglen,
3272 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3275 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3276 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3277 warn on undef, and we've already triggered a warning with the
3278 SvPV_const some lines above. We can't remove that, as we need to
3279 call some SvPV to trigger overloading early and find out if the
3281 This is all getting to messy. The API isn't quite clean enough,
3282 because data access has side effects.
3284 little = newSVpvn_flags(little_p, llen,
3285 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3286 little_p = SvPVX(little);
3290 offset = is_index ? 0 : biglen;
3292 if (big_utf8 && offset > 0)
3293 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3299 else if (offset > (SSize_t)biglen)
3301 if (!(little_p = is_index
3302 ? fbm_instr((unsigned char*)big_p + offset,
3303 (unsigned char*)big_p + biglen, little, 0)
3304 : rninstr(big_p, big_p + offset,
3305 little_p, little_p + llen)))
3308 retval = little_p - big_p;
3309 if (retval > 0 && big_utf8)
3310 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3320 dSP; dMARK; dORIGMARK; dTARGET;
3321 SvTAINTED_off(TARG);
3322 do_sprintf(TARG, SP-MARK, MARK+1);
3323 TAINT_IF(SvTAINTED(TARG));
3335 const U8 *s = (U8*)SvPV_const(argsv, len);
3337 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3338 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3339 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3340 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
3344 XPUSHu(DO_UTF8(argsv)
3345 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3359 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3360 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3362 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3363 && SvNV_nomg(top) < 0.0))) {
3364 if (ckWARN(WARN_UTF8)) {
3365 if (SvGMAGICAL(top)) {
3366 SV *top2 = sv_newmortal();
3367 sv_setsv_nomg(top2, top);
3370 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3371 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3373 value = UNICODE_REPLACEMENT;
3375 value = SvUV_nomg(top);
3378 SvUPGRADE(TARG,SVt_PV);
3380 if (value > 255 && !IN_BYTES) {
3381 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3382 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3383 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3385 (void)SvPOK_only(TARG);
3394 *tmps++ = (char)value;
3396 (void)SvPOK_only(TARG);
3398 if (PL_encoding && !IN_BYTES) {
3399 sv_recode_to_utf8(TARG, PL_encoding);
3401 if (SvCUR(TARG) == 0
3402 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3403 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3408 *tmps++ = (char)value;
3424 const char *tmps = SvPV_const(left, len);
3426 if (DO_UTF8(left)) {
3427 /* If Unicode, try to downgrade.
3428 * If not possible, croak.
3429 * Yes, we made this up. */
3430 SV* const tsv = sv_2mortal(newSVsv(left));
3433 sv_utf8_downgrade(tsv, FALSE);
3434 tmps = SvPV_const(tsv, len);
3436 # ifdef USE_ITHREADS
3438 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3439 /* This should be threadsafe because in ithreads there is only
3440 * one thread per interpreter. If this would not be true,
3441 * we would need a mutex to protect this malloc. */
3442 PL_reentrant_buffer->_crypt_struct_buffer =
3443 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3444 #if defined(__GLIBC__) || defined(__EMX__)
3445 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3446 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3447 /* work around glibc-2.2.5 bug */
3448 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3452 # endif /* HAS_CRYPT_R */
3453 # endif /* USE_ITHREADS */
3455 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3457 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3463 "The crypt() function is unimplemented due to excessive paranoia.");
3467 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3468 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3472 /* Actually is both lcfirst() and ucfirst(). Only the first character
3473 * changes. This means that possibly we can change in-place, ie., just
3474 * take the source and change that one character and store it back, but not
3475 * if read-only etc, or if the length changes */
3479 STRLEN slen; /* slen is the byte length of the whole SV. */
3482 bool inplace; /* ? Convert first char only, in-place */
3483 bool doing_utf8 = FALSE; /* ? using utf8 */
3484 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3485 const int op_type = PL_op->op_type;
3488 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3489 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3490 * stored as UTF-8 at s. */
3491 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3492 * lowercased) character stored in tmpbuf. May be either
3493 * UTF-8 or not, but in either case is the number of bytes */
3495 s = (const U8*)SvPV_const(source, slen);
3497 /* We may be able to get away with changing only the first character, in
3498 * place, but not if read-only, etc. Later we may discover more reasons to
3499 * not convert in-place. */
3500 inplace = !SvREADONLY(source)
3501 && ( SvPADTMP(source)
3502 || ( SvTEMP(source) && !SvSMAGICAL(source)
3503 && SvREFCNT(source) == 1));
3505 /* First calculate what the changed first character should be. This affects
3506 * whether we can just swap it out, leaving the rest of the string unchanged,
3507 * or even if have to convert the dest to UTF-8 when the source isn't */
3509 if (! slen) { /* If empty */
3510 need = 1; /* still need a trailing NUL */
3513 else if (DO_UTF8(source)) { /* Is the source utf8? */
3516 if (op_type == OP_UCFIRST) {
3517 #ifdef USE_LOCALE_CTYPE
3518 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3520 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3524 #ifdef USE_LOCALE_CTYPE
3525 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3527 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3531 /* we can't do in-place if the length changes. */
3532 if (ulen != tculen) inplace = FALSE;
3533 need = slen + 1 - ulen + tculen;
3535 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3536 * latin1 is treated as caseless. Note that a locale takes
3538 ulen = 1; /* Original character is 1 byte */
3539 tculen = 1; /* Most characters will require one byte, but this will
3540 * need to be overridden for the tricky ones */
3543 if (op_type == OP_LCFIRST) {
3545 /* lower case the first letter: no trickiness for any character */
3547 #ifdef USE_LOCALE_CTYPE
3548 (IN_LC_RUNTIME(LC_CTYPE))
3553 ? toLOWER_LATIN1(*s)
3557 #ifdef USE_LOCALE_CTYPE
3558 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3559 if (IN_UTF8_CTYPE_LOCALE) {
3563 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3564 locales have upper and title case
3568 else if (! IN_UNI_8_BIT) {
3569 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3570 * on EBCDIC machines whatever the
3571 * native function does */
3574 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3575 * UTF-8, which we treat as not in locale), and cased latin1 */
3577 #ifdef USE_LOCALE_CTYPE
3581 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3583 assert(tculen == 2);
3585 /* If the result is an upper Latin1-range character, it can
3586 * still be represented in one byte, which is its ordinal */
3587 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3588 *tmpbuf = (U8) title_ord;
3592 /* Otherwise it became more than one ASCII character (in
3593 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3594 * beyond Latin1, so the number of bytes changed, so can't
3595 * replace just the first character in place. */
3598 /* If the result won't fit in a byte, the entire result
3599 * will have to be in UTF-8. Assume worst case sizing in
3600 * conversion. (all latin1 characters occupy at most two
3602 if (title_ord > 255) {
3604 convert_source_to_utf8 = TRUE;
3605 need = slen * 2 + 1;
3607 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3608 * (both) characters whose title case is above 255 is
3612 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3613 need = slen + 1 + 1;
3617 } /* End of use Unicode (Latin1) semantics */
3618 } /* End of changing the case of the first character */
3620 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3621 * generate the result */
3624 /* We can convert in place. This means we change just the first
3625 * character without disturbing the rest; no need to grow */
3627 s = d = (U8*)SvPV_force_nomg(source, slen);
3633 /* Here, we can't convert in place; we earlier calculated how much
3634 * space we will need, so grow to accommodate that */
3635 SvUPGRADE(dest, SVt_PV);
3636 d = (U8*)SvGROW(dest, need);
3637 (void)SvPOK_only(dest);
3644 if (! convert_source_to_utf8) {
3646 /* Here both source and dest are in UTF-8, but have to create
3647 * the entire output. We initialize the result to be the
3648 * title/lower cased first character, and then append the rest
3650 sv_setpvn(dest, (char*)tmpbuf, tculen);
3652 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3656 const U8 *const send = s + slen;
3658 /* Here the dest needs to be in UTF-8, but the source isn't,
3659 * except we earlier UTF-8'd the first character of the source
3660 * into tmpbuf. First put that into dest, and then append the
3661 * rest of the source, converting it to UTF-8 as we go. */
3663 /* Assert tculen is 2 here because the only two characters that
3664 * get to this part of the code have 2-byte UTF-8 equivalents */
3666 *d++ = *(tmpbuf + 1);
3667 s++; /* We have just processed the 1st char */
3669 for (; s < send; s++) {
3670 d = uvchr_to_utf8(d, *s);
3673 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3677 else { /* in-place UTF-8. Just overwrite the first character */
3678 Copy(tmpbuf, d, tculen, U8);
3679 SvCUR_set(dest, need - 1);
3683 else { /* Neither source nor dest are in or need to be UTF-8 */
3685 if (inplace) { /* in-place, only need to change the 1st char */
3688 else { /* Not in-place */
3690 /* Copy the case-changed character(s) from tmpbuf */
3691 Copy(tmpbuf, d, tculen, U8);
3692 d += tculen - 1; /* Code below expects d to point to final
3693 * character stored */
3696 else { /* empty source */
3697 /* See bug #39028: Don't taint if empty */
3701 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3702 * the destination to retain that flag */
3703 if (SvUTF8(source) && ! IN_BYTES)
3706 if (!inplace) { /* Finish the rest of the string, unchanged */
3707 /* This will copy the trailing NUL */
3708 Copy(s + 1, d + 1, slen, U8);
3709 SvCUR_set(dest, need - 1);
3712 #ifdef USE_LOCALE_CTYPE
3713 if (IN_LC_RUNTIME(LC_CTYPE)) {
3718 if (dest != source && SvTAINTED(source))
3724 /* There's so much setup/teardown code common between uc and lc, I wonder if
3725 it would be worth merging the two, and just having a switch outside each
3726 of the three tight loops. There is less and less commonality though */
3739 if ((SvPADTMP(source)
3741 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3742 && !SvREADONLY(source) && SvPOK(source)
3745 #ifdef USE_LOCALE_CTYPE
3746 (IN_LC_RUNTIME(LC_CTYPE))
3747 ? ! IN_UTF8_CTYPE_LOCALE
3753 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3754 * make the loop tight, so we overwrite the source with the dest before
3755 * looking at it, and we need to look at the original source
3756 * afterwards. There would also need to be code added to handle
3757 * switching to not in-place in midstream if we run into characters
3758 * that change the length. Since being in locale overrides UNI_8_BIT,
3759 * that latter becomes irrelevant in the above test; instead for
3760 * locale, the size can't normally change, except if the locale is a
3763 s = d = (U8*)SvPV_force_nomg(source, len);
3770 s = (const U8*)SvPV_nomg_const(source, len);
3773 SvUPGRADE(dest, SVt_PV);
3774 d = (U8*)SvGROW(dest, min);
3775 (void)SvPOK_only(dest);
3780 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3781 to check DO_UTF8 again here. */
3783 if (DO_UTF8(source)) {
3784 const U8 *const send = s + len;
3785 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3787 /* All occurrences of these are to be moved to follow any other marks.
3788 * This is context-dependent. We may not be passed enough context to
3789 * move the iota subscript beyond all of them, but we do the best we can
3790 * with what we're given. The result is always better than if we
3791 * hadn't done this. And, the problem would only arise if we are
3792 * passed a character without all its combining marks, which would be
3793 * the caller's mistake. The information this is based on comes from a
3794 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3795 * itself) and so can't be checked properly to see if it ever gets
3796 * revised. But the likelihood of it changing is remote */
3797 bool in_iota_subscript = FALSE;
3803 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3805 /* A non-mark. Time to output the iota subscript */
3806 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3807 d += capital_iota_len;
3808 in_iota_subscript = FALSE;
3811 /* Then handle the current character. Get the changed case value
3812 * and copy it to the output buffer */
3815 #ifdef USE_LOCALE_CTYPE
3816 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
3818 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
3820 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3821 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3822 if (uv == GREEK_CAPITAL_LETTER_IOTA
3823 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3825 in_iota_subscript = TRUE;
3828 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3829 /* If the eventually required minimum size outgrows the
3830 * available space, we need to grow. */
3831 const UV o = d - (U8*)SvPVX_const(dest);
3833 /* If someone uppercases one million U+03B0s we SvGROW()
3834 * one million times. Or we could try guessing how much to
3835 * allocate without allocating too much. Such is life.
3836 * See corresponding comment in lc code for another option
3839 d = (U8*)SvPVX(dest) + o;
3841 Copy(tmpbuf, d, ulen, U8);
3846 if (in_iota_subscript) {
3847 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3848 d += capital_iota_len;
3853 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3855 else { /* Not UTF-8 */
3857 const U8 *const send = s + len;
3859 /* Use locale casing if in locale; regular style if not treating
3860 * latin1 as having case; otherwise the latin1 casing. Do the
3861 * whole thing in a tight loop, for speed, */
3862 #ifdef USE_LOCALE_CTYPE
3863 if (IN_LC_RUNTIME(LC_CTYPE)) {
3864 if (IN_UTF8_CTYPE_LOCALE) {
3867 for (; s < send; d++, s++)
3868 *d = (U8) toUPPER_LC(*s);
3872 if (! IN_UNI_8_BIT) {
3873 for (; s < send; d++, s++) {
3878 #ifdef USE_LOCALE_CTYPE
3881 for (; s < send; d++, s++) {
3882 *d = toUPPER_LATIN1_MOD(*s);
3883 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3887 /* The mainstream case is the tight loop above. To avoid
3888 * extra tests in that, all three characters that require
3889 * special handling are mapped by the MOD to the one tested
3891 * Use the source to distinguish between the three cases */
3893 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3895 /* uc() of this requires 2 characters, but they are
3896 * ASCII. If not enough room, grow the string */
3897 if (SvLEN(dest) < ++min) {
3898 const UV o = d - (U8*)SvPVX_const(dest);
3900 d = (U8*)SvPVX(dest) + o;
3902 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3903 continue; /* Back to the tight loop; still in ASCII */
3906 /* The other two special handling characters have their
3907 * upper cases outside the latin1 range, hence need to be
3908 * in UTF-8, so the whole result needs to be in UTF-8. So,
3909 * here we are somewhere in the middle of processing a
3910 * non-UTF-8 string, and realize that we will have to convert
3911 * the whole thing to UTF-8. What to do? There are
3912 * several possibilities. The simplest to code is to
3913 * convert what we have so far, set a flag, and continue on
3914 * in the loop. The flag would be tested each time through
3915 * the loop, and if set, the next character would be
3916 * converted to UTF-8 and stored. But, I (khw) didn't want
3917 * to slow down the mainstream case at all for this fairly
3918 * rare case, so I didn't want to add a test that didn't
3919 * absolutely have to be there in the loop, besides the
3920 * possibility that it would get too complicated for
3921 * optimizers to deal with. Another possibility is to just
3922 * give up, convert the source to UTF-8, and restart the
3923 * function that way. Another possibility is to convert
3924 * both what has already been processed and what is yet to
3925 * come separately to UTF-8, then jump into the loop that
3926 * handles UTF-8. But the most efficient time-wise of the
3927 * ones I could think of is what follows, and turned out to
3928 * not require much extra code. */
3930 /* Convert what we have so far into UTF-8, telling the
3931 * function that we know it should be converted, and to
3932 * allow extra space for what we haven't processed yet.
3933 * Assume the worst case space requirements for converting
3934 * what we haven't processed so far: that it will require
3935 * two bytes for each remaining source character, plus the
3936 * NUL at the end. This may cause the string pointer to
3937 * move, so re-find it. */
3939 len = d - (U8*)SvPVX_const(dest);
3940 SvCUR_set(dest, len);
3941 len = sv_utf8_upgrade_flags_grow(dest,
3942 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3944 d = (U8*)SvPVX(dest) + len;
3946 /* Now process the remainder of the source, converting to
3947 * upper and UTF-8. If a resulting byte is invariant in
3948 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3949 * append it to the output. */
3950 for (; s < send; s++) {
3951 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3955 /* Here have processed the whole source; no need to continue
3956 * with the outer loop. Each character has been converted
3957 * to upper case and converted to UTF-8 */
3960 } /* End of processing all latin1-style chars */
3961 } /* End of processing all chars */
3962 } /* End of source is not empty */
3964 if (source != dest) {
3965 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3966 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3968 } /* End of isn't utf8 */
3969 #ifdef USE_LOCALE_CTYPE
3970 if (IN_LC_RUNTIME(LC_CTYPE)) {
3975 if (dest != source && SvTAINTED(source))
3993 if ( ( SvPADTMP(source)
3994 || ( SvTEMP(source) && !SvSMAGICAL(source)
3995 && SvREFCNT(source) == 1 )
3997 && !SvREADONLY(source) && SvPOK(source)
3998 && !DO_UTF8(source)) {
4000 /* We can convert in place, as lowercasing anything in the latin1 range
4001 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4003 s = d = (U8*)SvPV_force_nomg(source, len);
4010 s = (const U8*)SvPV_nomg_const(source, len);
4013 SvUPGRADE(dest, SVt_PV);
4014 d = (U8*)SvGROW(dest, min);
4015 (void)SvPOK_only(dest);
4020 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4021 to check DO_UTF8 again here. */
4023 if (DO_UTF8(source)) {
4024 const U8 *const send = s + len;
4025 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4028 const STRLEN u = UTF8SKIP(s);
4031 #ifdef USE_LOCALE_CTYPE
4032 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4034 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4037 /* Here is where we would do context-sensitive actions. See the
4038 * commit message for 86510fb15 for why there isn't any */
4040 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4042 /* If the eventually required minimum size outgrows the
4043 * available space, we need to grow. */
4044 const UV o = d - (U8*)SvPVX_const(dest);
4046 /* If someone lowercases one million U+0130s we SvGROW() one
4047 * million times. Or we could try guessing how much to
4048 * allocate without allocating too much. Such is life.
4049 * Another option would be to grow an extra byte or two more
4050 * each time we need to grow, which would cut down the million
4051 * to 500K, with little waste */
4053 d = (U8*)SvPVX(dest) + o;
4056 /* Copy the newly lowercased letter to the output buffer we're
4058 Copy(tmpbuf, d, ulen, U8);
4061 } /* End of looping through the source string */
4064 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4065 } else { /* Not utf8 */
4067 const U8 *const send = s + len;
4069 /* Use locale casing if in locale; regular style if not treating
4070 * latin1 as having case; otherwise the latin1 casing. Do the
4071 * whole thing in a tight loop, for speed, */
4072 #ifdef USE_LOCALE_CTYPE
4073 if (IN_LC_RUNTIME(LC_CTYPE)) {
4074 for (; s < send; d++, s++)
4075 *d = toLOWER_LC(*s);
4079 if (! IN_UNI_8_BIT) {
4080 for (; s < send; d++, s++) {
4085 for (; s < send; d++, s++) {
4086 *d = toLOWER_LATIN1(*s);
4090 if (source != dest) {
4092 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4095 #ifdef USE_LOCALE_CTYPE
4096 if (IN_LC_RUNTIME(LC_CTYPE)) {
4101 if (dest != source && SvTAINTED(source))
4110 SV * const sv = TOPs;
4112 const char *s = SvPV_const(sv,len);
4114 SvUTF8_off(TARG); /* decontaminate */
4117 SvUPGRADE(TARG, SVt_PV);
4118 SvGROW(TARG, (len * 2) + 1);
4122 STRLEN ulen = UTF8SKIP(s);
4123 bool to_quote = FALSE;
4125 if (UTF8_IS_INVARIANT(*s)) {
4126 if (_isQUOTEMETA(*s)) {
4130 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4132 #ifdef USE_LOCALE_CTYPE
4133 /* In locale, we quote all non-ASCII Latin1 chars.
4134 * Otherwise use the quoting rules */
4136 IN_LC_RUNTIME(LC_CTYPE)
4139 _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4144 else if (is_QUOTEMETA_high(s)) {
4159 else if (IN_UNI_8_BIT) {
4161 if (_isQUOTEMETA(*s))
4167 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4168 * including everything above ASCII */
4170 if (!isWORDCHAR_A(*s))
4176 SvCUR_set(TARG, d - SvPVX_const(TARG));
4177 (void)SvPOK_only_UTF8(TARG);
4180 sv_setpvn(TARG, s, len);
4196 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4197 const bool full_folding = TRUE; /* This variable is here so we can easily
4198 move to more generality later */
4199 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4200 #ifdef USE_LOCALE_CTYPE
4201 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4205 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4206 * You are welcome(?) -Hugmeir
4214 s = (const U8*)SvPV_nomg_const(source, len);
4216 if (ckWARN(WARN_UNINITIALIZED))
4217 report_uninit(source);
4224 SvUPGRADE(dest, SVt_PV);
4225 d = (U8*)SvGROW(dest, min);
4226 (void)SvPOK_only(dest);
4231 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4233 const STRLEN u = UTF8SKIP(s);
4236 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4238 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4239 const UV o = d - (U8*)SvPVX_const(dest);
4241 d = (U8*)SvPVX(dest) + o;
4244 Copy(tmpbuf, d, ulen, U8);
4249 } /* Unflagged string */
4251 #ifdef USE_LOCALE_CTYPE
4252 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4253 if (IN_UTF8_CTYPE_LOCALE) {
4254 goto do_uni_folding;
4256 for (; s < send; d++, s++)
4257 *d = (U8) toFOLD_LC(*s);
4261 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4262 for (; s < send; d++, s++)
4266 #ifdef USE_LOCALE_CTYPE
4269 /* For ASCII and the Latin-1 range, there's only two troublesome
4270 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4271 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4272 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4273 * For the rest, the casefold is their lowercase. */
4274 for (; s < send; d++, s++) {
4275 if (*s == MICRO_SIGN) {
4276 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4277 * which is outside of the latin-1 range. There's a couple
4278 * of ways to deal with this -- khw discusses them in
4279 * pp_lc/uc, so go there :) What we do here is upgrade what
4280 * we had already casefolded, then enter an inner loop that
4281 * appends the rest of the characters as UTF-8. */
4282 len = d - (U8*)SvPVX_const(dest);
4283 SvCUR_set(dest, len);
4284 len = sv_utf8_upgrade_flags_grow(dest,
4285 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4286 /* The max expansion for latin1
4287 * chars is 1 byte becomes 2 */
4289 d = (U8*)SvPVX(dest) + len;
4291 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4294 for (; s < send; s++) {
4296 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4297 if UVCHR_IS_INVARIANT(fc) {
4299 && *s == LATIN_SMALL_LETTER_SHARP_S)
4308 Copy(tmpbuf, d, ulen, U8);
4314 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4315 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4316 * becomes "ss", which may require growing the SV. */
4317 if (SvLEN(dest) < ++min) {
4318 const UV o = d - (U8*)SvPVX_const(dest);
4320 d = (U8*)SvPVX(dest) + o;
4325 else { /* If it's not one of those two, the fold is their lower
4327 *d = toLOWER_LATIN1(*s);
4333 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4335 #ifdef USE_LOCALE_CTYPE
4336 if (IN_LC_RUNTIME(LC_CTYPE)) {
4341 if (SvTAINTED(source))
4351 dSP; dMARK; dORIGMARK;
4352 AV *const av = MUTABLE_AV(POPs);
4353 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4355 if (SvTYPE(av) == SVt_PVAV) {
4356 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4357 bool can_preserve = FALSE;
4363 can_preserve = SvCANEXISTDELETE(av);
4366 if (lval && localizing) {
4369 for (svp = MARK + 1; svp <= SP; svp++) {
4370 const SSize_t elem = SvIV(*svp);
4374 if (max > AvMAX(av))
4378 while (++MARK <= SP) {
4380 SSize_t elem = SvIV(*MARK);
4381 bool preeminent = TRUE;
4383 if (localizing && can_preserve) {
4384 /* If we can determine whether the element exist,
4385 * Try to preserve the existenceness of a tied array
4386 * element by using EXISTS and DELETE if possible.
4387 * Fallback to FETCH and STORE otherwise. */
4388 preeminent = av_exists(av, elem);
4391 svp = av_fetch(av, elem, lval);
4394 DIE(aTHX_ PL_no_aelem, elem);
4397 save_aelem(av, elem, svp);
4399 SAVEADELETE(av, elem);
4402 *MARK = svp ? *svp : &PL_sv_undef;
4405 if (GIMME != G_ARRAY) {
4407 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4416 AV *const av = MUTABLE_AV(POPs);
4417 I32 lval = (PL_op->op_flags & OPf_MOD);
4418 SSize_t items = SP - MARK;
4420 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4421 const I32 flags = is_lvalue_sub();
4423 if (!(flags & OPpENTERSUB_INARGS))
4424 /* diag_listed_as: Can't modify %s in %s */
4425 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4432 *(MARK+items*2-1) = *(MARK+items);
4438 while (++MARK <= SP) {
4441 svp = av_fetch(av, SvIV(*MARK), lval);
4443 if (!svp || !*svp || *svp == &PL_sv_undef) {
4444 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4446 *MARK = sv_mortalcopy(*MARK);
4448 *++MARK = svp ? *svp : &PL_sv_undef;
4450 if (GIMME != G_ARRAY) {
4451 MARK = SP - items*2;
4452 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4458 /* Smart dereferencing for keys, values and each */
4469 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4474 "Type of argument to %s must be unblessed hashref or arrayref",
4475 PL_op_desc[PL_op->op_type] );
4478 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4480 "Can't modify %s in %s",
4481 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4484 /* Delegate to correct function for op type */
4486 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4487 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4490 return (SvTYPE(sv) == SVt_PVHV)
4491 ? Perl_pp_each(aTHX)
4492 : Perl_pp_aeach(aTHX);
4499 AV *array = MUTABLE_AV(POPs);
4500 const I32 gimme = GIMME_V;
4501 IV *iterp = Perl_av_iter_p(aTHX_ array);
4502 const IV current = (*iterp)++;
4504 if (current > av_tindex(array)) {
4506 if (gimme == G_SCALAR)
4514 if (gimme == G_ARRAY) {
4515 SV **const element = av_fetch(array, current, 0);
4516 PUSHs(element ? *element : &PL_sv_undef);
4524 AV *array = MUTABLE_AV(POPs);
4525 const I32 gimme = GIMME_V;
4527 *Perl_av_iter_p(aTHX_ array) = 0;
4529 if (gimme == G_SCALAR) {
4531 PUSHi(av_tindex(array) + 1);
4533 else if (gimme == G_ARRAY) {
4534 IV n = Perl_av_len(aTHX_ array);
4539 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4540 for (i = 0; i <= n; i++) {
4545 for (i = 0; i <= n; i++) {
4546 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4547 PUSHs(elem ? *elem : &PL_sv_undef);
4554 /* Associative arrays. */
4559 HV * hash = MUTABLE_HV(POPs);
4561 const I32 gimme = GIMME_V;
4564 /* might clobber stack_sp */
4565 entry = hv_iternext(hash);
4570 SV* const sv = hv_iterkeysv(entry);
4571 PUSHs(sv); /* won't clobber stack_sp */
4572 if (gimme == G_ARRAY) {
4575 /* might clobber stack_sp */
4576 val = hv_iterval(hash, entry);
4581 else if (gimme == G_SCALAR)
4588 S_do_delete_local(pTHX)
4591 const I32 gimme = GIMME_V;
4594 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4595 SV **unsliced_keysv = sliced ? NULL : sp--;
4596 SV * const osv = POPs;
4597 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4599 const bool tied = SvRMAGICAL(osv)
4600 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4601 const bool can_preserve = SvCANEXISTDELETE(osv);
4602 const U32 type = SvTYPE(osv);
4603 SV ** const end = sliced ? SP : unsliced_keysv;
4605 if (type == SVt_PVHV) { /* hash element */
4606 HV * const hv = MUTABLE_HV(osv);
4607 while (++MARK <= end) {
4608 SV * const keysv = *MARK;
4610 bool preeminent = TRUE;
4612 preeminent = hv_exists_ent(hv, keysv, 0);
4614 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4621 sv = hv_delete_ent(hv, keysv, 0, 0);
4623 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4626 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4627 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4629 *MARK = sv_mortalcopy(sv);
4635 SAVEHDELETE(hv, keysv);
4636 *MARK = &PL_sv_undef;
4640 else if (type == SVt_PVAV) { /* array element */
4641 if (PL_op->op_flags & OPf_SPECIAL) {
4642 AV * const av = MUTABLE_AV(osv);
4643 while (++MARK <= end) {
4644 SSize_t idx = SvIV(*MARK);
4646 bool preeminent = TRUE;
4648 preeminent = av_exists(av, idx);
4650 SV **svp = av_fetch(av, idx, 1);
4657 sv = av_delete(av, idx, 0);
4659 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4662 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4664 *MARK = sv_mortalcopy(sv);
4670 SAVEADELETE(av, idx);
4671 *MARK = &PL_sv_undef;
4676 DIE(aTHX_ "panic: avhv_delete no longer supported");
4679 DIE(aTHX_ "Not a HASH reference");
4681 if (gimme == G_VOID)
4683 else if (gimme == G_SCALAR) {
4688 *++MARK = &PL_sv_undef;
4692 else if (gimme != G_VOID)
4693 PUSHs(*unsliced_keysv);
4704 if (PL_op->op_private & OPpLVAL_INTRO)
4705 return do_delete_local();
4708 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4710 if (PL_op->op_private & OPpSLICE) {
4712 HV * const hv = MUTABLE_HV(POPs);
4713 const U32 hvtype = SvTYPE(hv);
4714 if (hvtype == SVt_PVHV) { /* hash element */
4715 while (++MARK <= SP) {
4716 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4717 *MARK = sv ? sv : &PL_sv_undef;
4720 else if (hvtype == SVt_PVAV) { /* array element */
4721 if (PL_op->op_flags & OPf_SPECIAL) {
4722 while (++MARK <= SP) {
4723 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4724 *MARK = sv ? sv : &PL_sv_undef;
4729 DIE(aTHX_ "Not a HASH reference");
4732 else if (gimme == G_SCALAR) {
4737 *++MARK = &PL_sv_undef;
4743 HV * const hv = MUTABLE_HV(POPs);
4745 if (SvTYPE(hv) == SVt_PVHV)
4746 sv = hv_delete_ent(hv, keysv, discard, 0);
4747 else if (SvTYPE(hv) == SVt_PVAV) {
4748 if (PL_op->op_flags & OPf_SPECIAL)
4749 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4751 DIE(aTHX_ "panic: avhv_delete no longer supported");
4754 DIE(aTHX_ "Not a HASH reference");
4769 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4771 SV * const sv = POPs;
4772 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4775 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4780 hv = MUTABLE_HV(POPs);
4781 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4782 if (hv_exists_ent(hv, tmpsv, 0))
4785 else if (SvTYPE(hv) == SVt_PVAV) {
4786 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4787 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4792 DIE(aTHX_ "Not a HASH reference");
4799 dSP; dMARK; dORIGMARK;
4800 HV * const hv = MUTABLE_HV(POPs);
4801 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4802 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4803 bool can_preserve = FALSE;
4809 if (SvCANEXISTDELETE(hv))
4810 can_preserve = TRUE;
4813 while (++MARK <= SP) {
4814 SV * const keysv = *MARK;
4817 bool preeminent = TRUE;
4819 if (localizing && can_preserve) {
4820 /* If we can determine whether the element exist,
4821 * try to preserve the existenceness of a tied hash
4822 * element by using EXISTS and DELETE if possible.
4823 * Fallback to FETCH and STORE otherwise. */
4824 preeminent = hv_exists_ent(hv, keysv, 0);
4827 he = hv_fetch_ent(hv, keysv, lval, 0);
4828 svp = he ? &HeVAL(he) : NULL;
4831 if (!svp || !*svp || *svp == &PL_sv_undef) {
4832 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4835 if (HvNAME_get(hv) && isGV(*svp))
4836 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4837 else if (preeminent)
4838 save_helem_flags(hv, keysv, svp,
4839 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4841 SAVEHDELETE(hv, keysv);
4844 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4846 if (GIMME != G_ARRAY) {
4848 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4857 HV * const hv = MUTABLE_HV(POPs);
4858 I32 lval = (PL_op->op_flags & OPf_MOD);
4859 SSize_t items = SP - MARK;
4861 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4862 const I32 flags = is_lvalue_sub();
4864 if (!(flags & OPpENTERSUB_INARGS))
4865 /* diag_listed_as: Can't modify %s in %s */
4866 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4873 *(MARK+items*2-1) = *(MARK+items);
4879 while (++MARK <= SP) {
4880 SV * const keysv = *MARK;
4884 he = hv_fetch_ent(hv, keysv, lval, 0);
4885 svp = he ? &HeVAL(he) : NULL;
4888 if (!svp || !*svp || *svp == &PL_sv_undef) {
4889 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4891 *MARK = sv_mortalcopy(*MARK);
4893 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4895 if (GIMME != G_ARRAY) {
4896 MARK = SP - items*2;
4897 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4903 /* List operators. */
4907 I32 markidx = POPMARK;
4908 if (GIMME != G_ARRAY) {
4909 SV **mark = PL_stack_base + markidx;
4912 *MARK = *SP; /* unwanted list, return last item */
4914 *MARK = &PL_sv_undef;
4924 SV ** const lastrelem = PL_stack_sp;
4925 SV ** const lastlelem = PL_stack_base + POPMARK;
4926 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4927 SV ** const firstrelem = lastlelem + 1;
4928 I32 is_something_there = FALSE;
4929 const U8 mod = PL_op->op_flags & OPf_MOD;
4931 const I32 max = lastrelem - lastlelem;
4934 if (GIMME != G_ARRAY) {
4935 I32 ix = SvIV(*lastlelem);
4938 if (ix < 0 || ix >= max)
4939 *firstlelem = &PL_sv_undef;
4941 *firstlelem = firstrelem[ix];
4947 SP = firstlelem - 1;
4951 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4952 I32 ix = SvIV(*lelem);
4955 if (ix < 0 || ix >= max)
4956 *lelem = &PL_sv_undef;
4958 is_something_there = TRUE;
4959 if (!(*lelem = firstrelem[ix]))
4960 *lelem = &PL_sv_undef;
4961 else if (mod && SvPADTMP(*lelem)) {
4962 assert(!IS_PADGV(*lelem));
4963 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
4967 if (is_something_there)
4970 SP = firstlelem - 1;
4977 const I32 items = SP - MARK;
4978 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4980 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4981 ? newRV_noinc(av) : av);
4987 dSP; dMARK; dORIGMARK;
4988 HV* const hv = newHV();
4989 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
4990 ? newRV_noinc(MUTABLE_SV(hv))
4995 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5002 sv_setsv(val, *MARK);
5006 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5009 (void)hv_store_ent(hv,key,val,0);
5017 S_deref_plain_array(pTHX_ AV *ary)
5019 if (SvTYPE(ary) == SVt_PVAV) return ary;
5020 SvGETMAGIC((SV *)ary);
5021 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5022 Perl_die(aTHX_ "Not an ARRAY reference");
5023 else if (SvOBJECT(SvRV(ary)))
5024 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5025 return (AV *)SvRV(ary);
5028 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5029 # define DEREF_PLAIN_ARRAY(ary) \
5032 SvTYPE(aRrRay) == SVt_PVAV \
5034 : S_deref_plain_array(aTHX_ aRrRay); \
5037 # define DEREF_PLAIN_ARRAY(ary) \
5039 PL_Sv = (SV *)(ary), \
5040 SvTYPE(PL_Sv) == SVt_PVAV \
5042 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5048 dSP; dMARK; dORIGMARK;
5049 int num_args = (SP - MARK);
5050 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5059 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5062 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5063 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5070 offset = i = SvIV(*MARK);
5072 offset += AvFILLp(ary) + 1;
5074 DIE(aTHX_ PL_no_aelem, i);
5076 length = SvIVx(*MARK++);
5078 length += AvFILLp(ary) - offset + 1;
5084 length = AvMAX(ary) + 1; /* close enough to infinity */
5088 length = AvMAX(ary) + 1;
5090 if (offset > AvFILLp(ary) + 1) {
5092 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5093 offset = AvFILLp(ary) + 1;
5095 after = AvFILLp(ary) + 1 - (offset + length);
5096 if (after < 0) { /* not that much array */
5097 length += after; /* offset+length now in array */
5103 /* At this point, MARK .. SP-1 is our new LIST */
5106 diff = newlen - length;
5107 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5110 /* make new elements SVs now: avoid problems if they're from the array */
5111 for (dst = MARK, i = newlen; i; i--) {
5112 SV * const h = *dst;
5113 *dst++ = newSVsv(h);
5116 if (diff < 0) { /* shrinking the area */
5117 SV **tmparyval = NULL;
5119 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5120 Copy(MARK, tmparyval, newlen, SV*);
5123 MARK = ORIGMARK + 1;
5124 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5125 const bool real = cBOOL(AvREAL(ary));
5126 MEXTEND(MARK, length);
5128 EXTEND_MORTAL(length);
5129 for (i = 0, dst = MARK; i < length; i++) {
5130 if ((*dst = AvARRAY(ary)[i+offset])) {
5132 sv_2mortal(*dst); /* free them eventually */
5135 *dst = &PL_sv_undef;
5141 *MARK = AvARRAY(ary)[offset+length-1];
5144 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5145 SvREFCNT_dec(*dst++); /* free them now */
5148 AvFILLp(ary) += diff;
5150 /* pull up or down? */
5152 if (offset < after) { /* easier to pull up */
5153 if (offset) { /* esp. if nothing to pull */
5154 src = &AvARRAY(ary)[offset-1];
5155 dst = src - diff; /* diff is negative */
5156 for (i = offset; i > 0; i--) /* can't trust Copy */
5160 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5164 if (after) { /* anything to pull down? */
5165 src = AvARRAY(ary) + offset + length;
5166 dst = src + diff; /* diff is negative */
5167 Move(src, dst, after, SV*);
5169 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5170 /* avoid later double free */
5177 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5178 Safefree(tmparyval);
5181 else { /* no, expanding (or same) */
5182 SV** tmparyval = NULL;
5184 Newx(tmparyval, length, SV*); /* so remember deletion */
5185 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5188 if (diff > 0) { /* expanding */
5189 /* push up or down? */
5190 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5194 Move(src, dst, offset, SV*);
5196 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5198 AvFILLp(ary) += diff;
5201 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5202 av_extend(ary, AvFILLp(ary) + diff);
5203 AvFILLp(ary) += diff;
5206 dst = AvARRAY(ary) + AvFILLp(ary);
5208 for (i = after; i; i--) {
5216 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5219 MARK = ORIGMARK + 1;
5220 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5222 const bool real = cBOOL(AvREAL(ary));
5224 EXTEND_MORTAL(length);
5225 for (i = 0, dst = MARK; i < length; i++) {
5226 if ((*dst = tmparyval[i])) {
5228 sv_2mortal(*dst); /* free them eventually */
5230 else *dst = &PL_sv_undef;
5236 else if (length--) {
5237 *MARK = tmparyval[length];
5240 while (length-- > 0)
5241 SvREFCNT_dec(tmparyval[length]);
5245 *MARK = &PL_sv_undef;
5246 Safefree(tmparyval);
5250 mg_set(MUTABLE_SV(ary));
5258 dSP; dMARK; dORIGMARK; dTARGET;
5259 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5260 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5263 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5266 ENTER_with_name("call_PUSH");
5267 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5268 LEAVE_with_name("call_PUSH");
5272 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5273 PL_delaymagic = DM_DELAY;
5274 for (++MARK; MARK <= SP; MARK++) {
5276 if (*MARK) SvGETMAGIC(*MARK);
5279 sv_setsv_nomg(sv, *MARK);
5280 av_store(ary, AvFILLp(ary)+1, sv);
5282 if (PL_delaymagic & DM_ARRAY_ISA)
5283 mg_set(MUTABLE_SV(ary));
5288 if (OP_GIMME(PL_op, 0) != G_VOID) {
5289 PUSHi( AvFILL(ary) + 1 );
5297 AV * const av = PL_op->op_flags & OPf_SPECIAL
5298 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5299 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5303 (void)sv_2mortal(sv);
5310 dSP; dMARK; dORIGMARK; dTARGET;
5311 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5312 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5315 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5318 ENTER_with_name("call_UNSHIFT");
5319 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5320 LEAVE_with_name("call_UNSHIFT");
5325 av_unshift(ary, SP - MARK);
5327 SV * const sv = newSVsv(*++MARK);
5328 (void)av_store(ary, i++, sv);
5332 if (OP_GIMME(PL_op, 0) != G_VOID) {
5333 PUSHi( AvFILL(ary) + 1 );
5342 if (GIMME == G_ARRAY) {
5343 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5347 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5348 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5349 av = MUTABLE_AV((*SP));
5350 /* In-place reversing only happens in void context for the array
5351 * assignment. We don't need to push anything on the stack. */
5354 if (SvMAGICAL(av)) {
5356 SV *tmp = sv_newmortal();
5357 /* For SvCANEXISTDELETE */
5360 bool can_preserve = SvCANEXISTDELETE(av);
5362 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5366 if (!av_exists(av, i)) {
5367 if (av_exists(av, j)) {
5368 SV *sv = av_delete(av, j, 0);
5369 begin = *av_fetch(av, i, TRUE);
5370 sv_setsv_mg(begin, sv);
5374 else if (!av_exists(av, j)) {
5375 SV *sv = av_delete(av, i, 0);
5376 end = *av_fetch(av, j, TRUE);
5377 sv_setsv_mg(end, sv);
5382 begin = *av_fetch(av, i, TRUE);
5383 end = *av_fetch(av, j, TRUE);
5384 sv_setsv(tmp, begin);
5385 sv_setsv_mg(begin, end);
5386 sv_setsv_mg(end, tmp);
5390 SV **begin = AvARRAY(av);
5393 SV **end = begin + AvFILLp(av);
5395 while (begin < end) {
5396 SV * const tmp = *begin;
5407 SV * const tmp = *MARK;
5411 /* safe as long as stack cannot get extended in the above */
5422 SvUTF8_off(TARG); /* decontaminate */
5424 do_join(TARG, &PL_sv_no, MARK, SP);
5426 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5429 up = SvPV_force(TARG, len);
5431 if (DO_UTF8(TARG)) { /* first reverse each character */
5432 U8* s = (U8*)SvPVX(TARG);
5433 const U8* send = (U8*)(s + len);
5435 if (UTF8_IS_INVARIANT(*s)) {
5440 if (!utf8_to_uvchr_buf(s, send, 0))
5444 down = (char*)(s - 1);
5445 /* reverse this character */
5449 *down-- = (char)tmp;
5455 down = SvPVX(TARG) + len - 1;
5459 *down-- = (char)tmp;
5461 (void)SvPOK_only_UTF8(TARG);
5473 IV limit = POPi; /* note, negative is forever */
5474 SV * const sv = POPs;
5476 const char *s = SvPV_const(sv, len);
5477 const bool do_utf8 = DO_UTF8(sv);
5478 const char *strend = s + len;
5484 const STRLEN slen = do_utf8
5485 ? utf8_length((U8*)s, (U8*)strend)
5486 : (STRLEN)(strend - s);
5487 SSize_t maxiters = slen + 10;
5488 I32 trailing_empty = 0;
5490 const I32 origlimit = limit;
5493 const I32 gimme = GIMME_V;
5495 const I32 oldsave = PL_savestack_ix;
5496 U32 make_mortal = SVs_TEMP;
5501 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5506 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5509 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5510 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5513 if (pm->op_pmreplrootu.op_pmtargetoff) {
5514 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5517 if (pm->op_pmreplrootu.op_pmtargetgv) {
5518 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5529 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5531 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5538 for (i = AvFILLp(ary); i >= 0; i--)
5539 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5541 /* temporarily switch stacks */
5542 SAVESWITCHSTACK(PL_curstack, ary);
5546 base = SP - PL_stack_base;
5548 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5550 while (isSPACE_utf8(s))
5553 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5554 while (isSPACE_LC(*s))
5562 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5566 gimme_scalar = gimme == G_SCALAR && !ary;
5569 limit = maxiters + 2;
5570 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5573 /* this one uses 'm' and is a negative test */
5575 while (m < strend && ! isSPACE_utf8(m) ) {
5576 const int t = UTF8SKIP(m);
5577 /* isSPACE_utf8 returns FALSE for malform utf8 */
5584 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5586 while (m < strend && !isSPACE_LC(*m))
5589 while (m < strend && !isSPACE(*m))
5602 dstr = newSVpvn_flags(s, m-s,
5603 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5607 /* skip the whitespace found last */
5609 s = m + UTF8SKIP(m);
5613 /* this one uses 's' and is a positive test */
5615 while (s < strend && isSPACE_utf8(s) )
5618 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5620 while (s < strend && isSPACE_LC(*s))
5623 while (s < strend && isSPACE(*s))
5628 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5630 for (m = s; m < strend && *m != '\n'; m++)
5643 dstr = newSVpvn_flags(s, m-s,
5644 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5650 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5652 Pre-extend the stack, either the number of bytes or
5653 characters in the string or a limited amount, triggered by:
5655 my ($x, $y) = split //, $str;
5659 if (!gimme_scalar) {
5660 const U32 items = limit - 1;
5669 /* keep track of how many bytes we skip over */
5679 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5692 dstr = newSVpvn(s, 1);
5708 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5709 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5710 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5711 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5712 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5713 SV * const csv = CALLREG_INTUIT_STRING(rx);
5715 len = RX_MINLENRET(rx);
5716 if (len == 1 && !RX_UTF8(rx) && !tail) {
5717 const char c = *SvPV_nolen_const(csv);
5719 for (m = s; m < strend && *m != c; m++)
5730 dstr = newSVpvn_flags(s, m-s,
5731 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5734 /* The rx->minlen is in characters but we want to step
5735 * s ahead by bytes. */
5737 s = (char*)utf8_hop((U8*)m, len);
5739 s = m + len; /* Fake \n at the end */
5743 while (s < strend && --limit &&
5744 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5745 csv, multiline ? FBMrf_MULTILINE : 0)) )
5754 dstr = newSVpvn_flags(s, m-s,
5755 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5758 /* The rx->minlen is in characters but we want to step
5759 * s ahead by bytes. */
5761 s = (char*)utf8_hop((U8*)m, len);
5763 s = m + len; /* Fake \n at the end */
5768 maxiters += slen * RX_NPARENS(rx);
5769 while (s < strend && --limit)
5773 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5776 if (rex_return == 0)
5778 TAINT_IF(RX_MATCH_TAINTED(rx));
5779 /* we never pass the REXEC_COPY_STR flag, so it should
5780 * never get copied */
5781 assert(!RX_MATCH_COPIED(rx));
5782 m = RX_OFFS(rx)[0].start + orig;
5791 dstr = newSVpvn_flags(s, m-s,
5792 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5795 if (RX_NPARENS(rx)) {
5797 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5798 s = RX_OFFS(rx)[i].start + orig;
5799 m = RX_OFFS(rx)[i].end + orig;
5801 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5802 parens that didn't match -- they should be set to
5803 undef, not the empty string */
5811 if (m >= orig && s >= orig) {
5812 dstr = newSVpvn_flags(s, m-s,
5813 (do_utf8 ? SVf_UTF8 : 0)
5817 dstr = &PL_sv_undef; /* undef, not "" */
5823 s = RX_OFFS(rx)[0].end + orig;
5827 if (!gimme_scalar) {
5828 iters = (SP - PL_stack_base) - base;
5830 if (iters > maxiters)
5831 DIE(aTHX_ "Split loop");
5833 /* keep field after final delim? */
5834 if (s < strend || (iters && origlimit)) {
5835 if (!gimme_scalar) {
5836 const STRLEN l = strend - s;
5837 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5842 else if (!origlimit) {
5844 iters -= trailing_empty;
5846 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5847 if (TOPs && !make_mortal)
5849 *SP-- = &PL_sv_undef;
5856 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5860 if (SvSMAGICAL(ary)) {
5862 mg_set(MUTABLE_SV(ary));
5865 if (gimme == G_ARRAY) {
5867 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5874 ENTER_with_name("call_PUSH");
5875 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5876 LEAVE_with_name("call_PUSH");
5878 if (gimme == G_ARRAY) {
5880 /* EXTEND should not be needed - we just popped them */
5882 for (i=0; i < iters; i++) {
5883 SV **svp = av_fetch(ary, i, FALSE);
5884 PUSHs((svp) ? *svp : &PL_sv_undef);
5891 if (gimme == G_ARRAY)
5903 SV *const sv = PAD_SVl(PL_op->op_targ);
5905 if (SvPADSTALE(sv)) {
5908 RETURNOP(cLOGOP->op_other);
5910 RETURNOP(cLOGOP->op_next);
5919 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5920 || SvTYPE(retsv) == SVt_PVCV) {
5921 retsv = refto(retsv);
5928 PP(unimplemented_op)
5930 const Optype op_type = PL_op->op_type;
5931 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5932 with out of range op numbers - it only "special" cases op_custom.
5933 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5934 if we get here for a custom op then that means that the custom op didn't
5935 have an implementation. Given that OP_NAME() looks up the custom op
5936 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5937 registers &PL_unimplemented_op as the address of their custom op.
5938 NULL doesn't generate a useful error message. "custom" does. */
5939 const char *const name = op_type >= OP_max
5940 ? "[out of range]" : PL_op_name[PL_op->op_type];
5941 if(OP_IS_SOCKET(op_type))
5942 DIE(aTHX_ PL_no_sock_func, name);
5943 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5946 /* For sorting out arguments passed to a &CORE:: subroutine */
5950 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5951 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5952 AV * const at_ = GvAV(PL_defgv);
5953 SV **svp = at_ ? AvARRAY(at_) : NULL;
5954 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5955 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5956 bool seen_question = 0;
5957 const char *err = NULL;
5958 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5960 /* Count how many args there are first, to get some idea how far to
5961 extend the stack. */
5963 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5965 if (oa & OA_OPTIONAL) seen_question = 1;
5966 if (!seen_question) minargs++;
5970 if(numargs < minargs) err = "Not enough";
5971 else if(numargs > maxargs) err = "Too many";
5973 /* diag_listed_as: Too many arguments for %s */
5975 "%s arguments for %s", err,
5976 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5979 /* Reset the stack pointer. Without this, we end up returning our own
5980 arguments in list context, in addition to the values we are supposed
5981 to return. nextstate usually does this on sub entry, but we need
5982 to run the next op with the caller's hints, so we cannot have a
5984 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5986 if(!maxargs) RETURN;
5988 /* We do this here, rather than with a separate pushmark op, as it has
5989 to come in between two things this function does (stack reset and
5990 arg pushing). This seems the easiest way to do it. */
5993 (void)Perl_pp_pushmark(aTHX);
5996 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5997 PUTBACK; /* The code below can die in various places. */
5999 oa = PL_opargs[opnum] >> OASHIFT;
6000 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6005 if (!numargs && defgv && whicharg == minargs + 1) {
6006 PUSHs(find_rundefsv2(
6007 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6008 cxstack[cxstack_ix].blk_oldcop->cop_seq
6011 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6015 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6020 if (!svp || !*svp || !SvROK(*svp)
6021 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6023 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6024 "Type of arg %d to &CORE::%s must be hash reference",
6025 whicharg, OP_DESC(PL_op->op_next)
6030 if (!numargs) PUSHs(NULL);
6031 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6032 /* no magic here, as the prototype will have added an extra
6033 refgen and we just want what was there before that */
6036 const bool constr = PL_op->op_private & whicharg;
6038 svp && *svp ? *svp : &PL_sv_undef,
6039 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6045 if (!numargs) goto try_defsv;
6047 const bool wantscalar =
6048 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6049 if (!svp || !*svp || !SvROK(*svp)
6050 /* We have to permit globrefs even for the \$ proto, as
6051 *foo is indistinguishable from ${\*foo}, and the proto-
6052 type permits the latter. */
6053 || SvTYPE(SvRV(*svp)) > (
6054 wantscalar ? SVt_PVLV
6055 : opnum == OP_LOCK || opnum == OP_UNDEF
6061 "Type of arg %d to &CORE::%s must be %s",
6062 whicharg, PL_op_name[opnum],
6064 ? "scalar reference"
6065 : opnum == OP_LOCK || opnum == OP_UNDEF
6066 ? "reference to one of [$@%&*]"
6067 : "reference to one of [$@%*]"
6070 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6071 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6072 /* Undo @_ localisation, so that sub exit does not undo
6073 part of our undeffing. */
6074 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6076 cx->cx_type &= ~ CXp_HASARGS;
6077 assert(!AvREAL(cx->blk_sub.argarray));
6082 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6094 if (PL_op->op_private & OPpOFFBYONE) {
6095 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6097 else cv = find_runcv(NULL);
6098 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6105 * c-indentation-style: bsd
6107 * indent-tabs-mode: nil
6110 * ex: set ts=8 sts=4 sw=4 et: