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.
33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
34 it, since pid_t is an integral type.
37 #ifdef NEED_GETPID_PROTO
38 extern Pid_t getpid (void);
42 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
43 * This switches them over to IEEE.
45 #if defined(LIBM_LIB_VERSION)
46 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
49 /* variations on pp_null */
55 if (GIMME_V == G_SCALAR)
66 assert(SvTYPE(TARG) == SVt_PVAV);
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 if (!(PL_op->op_private & OPpPAD_STATE))
69 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
71 if (PL_op->op_flags & OPf_REF) {
75 if (GIMME == G_SCALAR)
76 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
81 if (gimme == G_ARRAY) {
82 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
84 if (SvMAGICAL(TARG)) {
86 for (i=0; i < (U32)maxarg; i++) {
87 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
88 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
92 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
96 else if (gimme == G_SCALAR) {
97 SV* const sv = sv_newmortal();
98 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
110 assert(SvTYPE(TARG) == SVt_PVHV);
112 if (PL_op->op_private & OPpLVAL_INTRO)
113 if (!(PL_op->op_private & OPpPAD_STATE))
114 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
115 if (PL_op->op_flags & OPf_REF)
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
123 if (gimme == G_ARRAY) {
124 RETURNOP(Perl_do_kv(aTHX));
126 else if (gimme == G_SCALAR) {
127 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
135 static const char S_no_symref_sv[] =
136 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
142 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
146 sv = amagic_deref_call(sv, to_gv_amg);
150 if (SvTYPE(sv) == SVt_PVIO) {
151 GV * const gv = MUTABLE_GV(sv_newmortal());
152 gv_init(gv, 0, "", 0, 0);
153 GvIOp(gv) = MUTABLE_IO(sv);
154 SvREFCNT_inc_void_NN(sv);
157 else if (!isGV_with_GP(sv))
158 DIE(aTHX_ "Not a GLOB reference");
161 if (!isGV_with_GP(sv)) {
162 if (!SvOK(sv) && sv != &PL_sv_undef) {
163 /* If this is a 'my' scalar and flag is set then vivify
167 Perl_croak_no_modify(aTHX);
168 if (PL_op->op_private & OPpDEREF) {
170 if (cUNOP->op_targ) {
172 SV * const namesv = PAD_SV(cUNOP->op_targ);
173 const char * const name = SvPV(namesv, len);
174 gv = MUTABLE_GV(newSV(0));
175 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
178 const char * const name = CopSTASHPV(PL_curcop);
181 prepare_SV_for_RV(sv);
182 SvRV_set(sv, MUTABLE_SV(gv));
187 if (PL_op->op_flags & OPf_REF ||
188 PL_op->op_private & HINT_STRICT_REFS)
189 DIE(aTHX_ PL_no_usym, "a symbol");
190 if (ckWARN(WARN_UNINITIALIZED))
194 if ((PL_op->op_flags & OPf_SPECIAL) &&
195 !(PL_op->op_flags & OPf_MOD))
197 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
199 && (!is_gv_magical_sv(sv,0)
200 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
207 if (PL_op->op_private & HINT_STRICT_REFS)
208 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
209 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
210 == OPpDONT_INIT_GV) {
211 /* We are the target of a coderef assignment. Return
212 the scalar unchanged, and let pp_sasssign deal with
216 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
218 /* FAKE globs in the symbol table cause weird bugs (#77810) */
219 if (sv) SvFAKE_off(sv);
222 if (sv && SvFAKE(sv)) {
223 SV *newsv = sv_newmortal();
224 sv_setsv_flags(newsv, sv, 0);
228 if (PL_op->op_private & OPpLVAL_INTRO)
229 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
234 /* Helper function for pp_rv2sv and pp_rv2av */
236 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
237 const svtype type, SV ***spp)
242 PERL_ARGS_ASSERT_SOFTREF2XV;
244 if (PL_op->op_private & HINT_STRICT_REFS) {
246 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
248 Perl_die(aTHX_ PL_no_usym, what);
252 PL_op->op_flags & OPf_REF &&
253 PL_op->op_next->op_type != OP_BOOLKEYS
255 Perl_die(aTHX_ PL_no_usym, what);
256 if (ckWARN(WARN_UNINITIALIZED))
258 if (type != SVt_PV && GIMME_V == G_ARRAY) {
262 **spp = &PL_sv_undef;
265 if ((PL_op->op_flags & OPf_SPECIAL) &&
266 !(PL_op->op_flags & OPf_MOD))
268 gv = gv_fetchsv(sv, 0, type);
270 && (!is_gv_magical_sv(sv,0)
271 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
273 **spp = &PL_sv_undef;
278 gv = gv_fetchsv(sv, GV_ADD, type);
288 if (!(PL_op->op_private & OPpDEREFed))
292 sv = amagic_deref_call(sv, to_sv_amg);
297 switch (SvTYPE(sv)) {
303 DIE(aTHX_ "Not a SCALAR reference");
310 if (!isGV_with_GP(gv)) {
311 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
317 if (PL_op->op_flags & OPf_MOD) {
318 if (PL_op->op_private & OPpLVAL_INTRO) {
319 if (cUNOP->op_first->op_type == OP_NULL)
320 sv = save_scalar(MUTABLE_GV(TOPs));
322 sv = save_scalar(gv);
324 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
326 else if (PL_op->op_private & OPpDEREF)
327 vivify_ref(sv, PL_op->op_private & OPpDEREF);
336 AV * const av = MUTABLE_AV(TOPs);
337 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
339 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
341 *sv = newSV_type(SVt_PVMG);
342 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
346 SETs(sv_2mortal(newSViv(
347 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
357 if (PL_op->op_flags & OPf_MOD || LVRET) {
358 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
359 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
361 LvTARG(ret) = SvREFCNT_inc_simple(sv);
362 PUSHs(ret); /* no SvSETMAGIC */
366 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
367 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
368 if (mg && mg->mg_len >= 0) {
373 PUSHi(i + CopARYBASE_get(PL_curcop));
386 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
388 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
391 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
392 /* (But not in defined().) */
394 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
397 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
398 if ((PL_op->op_private & OPpLVAL_INTRO)) {
399 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
402 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
405 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
409 cv = MUTABLE_CV(&PL_sv_undef);
410 SETs(MUTABLE_SV(cv));
420 SV *ret = &PL_sv_undef;
422 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
423 const char * s = SvPVX_const(TOPs);
424 if (strnEQ(s, "CORE::", 6)) {
425 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
426 if (code < 0) { /* Overridable. */
427 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
428 int i = 0, n = 0, seen_question = 0, defgv = 0;
430 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
432 if (code == -KEY_chop || code == -KEY_chomp
433 || code == -KEY_exec || code == -KEY_system)
435 if (code == -KEY_mkdir) {
436 ret = newSVpvs_flags("_;$", SVs_TEMP);
439 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
440 ret = newSVpvs_flags("+", SVs_TEMP);
443 if (code == -KEY_push || code == -KEY_unshift) {
444 ret = newSVpvs_flags("+@", SVs_TEMP);
447 if (code == -KEY_pop || code == -KEY_shift) {
448 ret = newSVpvs_flags(";+", SVs_TEMP);
451 if (code == -KEY_splice) {
452 ret = newSVpvs_flags("+;$$@", SVs_TEMP);
455 if (code == -KEY_tied || code == -KEY_untie) {
456 ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
459 if (code == -KEY_tie) {
460 ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
463 if (code == -KEY_readpipe) {
464 s = "CORE::backtick";
466 while (i < MAXO) { /* The slow way. */
467 if (strEQ(s + 6, PL_op_name[i])
468 || strEQ(s + 6, PL_op_desc[i]))
474 goto nonesuch; /* Should not happen... */
476 defgv = PL_opargs[i] & OA_DEFGV;
477 oa = PL_opargs[i] >> OASHIFT;
479 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
483 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
484 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
485 /* But globs are already references (kinda) */
486 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
490 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
493 if (defgv && str[n - 1] == '$')
496 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
498 else if (code) /* Non-Overridable */
500 else { /* None such */
502 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
506 cv = sv_2cv(TOPs, &stash, &gv, 0);
508 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
517 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
519 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
521 PUSHs(MUTABLE_SV(cv));
535 if (GIMME != G_ARRAY) {
539 *MARK = &PL_sv_undef;
540 *MARK = refto(*MARK);
544 EXTEND_MORTAL(SP - MARK);
546 *MARK = refto(*MARK);
551 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) && !IS_PADGV(sv))
576 SvREFCNT_inc_void_NN(sv);
579 sv_upgrade(rv, SVt_IV);
589 SV * const sv = POPs;
594 if (!sv || !SvROK(sv))
597 pv = sv_reftype(SvRV(sv),TRUE);
598 PUSHp(pv, strlen(pv));
608 stash = CopSTASH(PL_curcop);
610 SV * const ssv = POPs;
614 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
615 Perl_croak(aTHX_ "Attempt to bless into a reference");
616 ptr = SvPV_const(ssv,len);
618 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
619 "Explicit blessing to '' (assuming package main)");
620 stash = gv_stashpvn(ptr, len, GV_ADD);
623 (void)sv_bless(TOPs, stash);
632 const char * const elem = SvPV_nolen_const(sv);
633 GV * const gv = MUTABLE_GV(POPs);
638 /* elem will always be NUL terminated. */
639 const char * const second_letter = elem + 1;
642 if (strEQ(second_letter, "RRAY"))
643 tmpRef = MUTABLE_SV(GvAV(gv));
646 if (strEQ(second_letter, "ODE"))
647 tmpRef = MUTABLE_SV(GvCVu(gv));
650 if (strEQ(second_letter, "ILEHANDLE")) {
651 /* finally deprecated in 5.8.0 */
652 deprecate("*glob{FILEHANDLE}");
653 tmpRef = MUTABLE_SV(GvIOp(gv));
656 if (strEQ(second_letter, "ORMAT"))
657 tmpRef = MUTABLE_SV(GvFORM(gv));
660 if (strEQ(second_letter, "LOB"))
661 tmpRef = MUTABLE_SV(gv);
664 if (strEQ(second_letter, "ASH"))
665 tmpRef = MUTABLE_SV(GvHV(gv));
668 if (*second_letter == 'O' && !elem[2])
669 tmpRef = MUTABLE_SV(GvIOp(gv));
672 if (strEQ(second_letter, "AME"))
673 sv = newSVhek(GvNAME_HEK(gv));
676 if (strEQ(second_letter, "ACKAGE")) {
677 const HV * const stash = GvSTASH(gv);
678 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
679 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
683 if (strEQ(second_letter, "CALAR"))
698 /* Pattern matching */
703 register unsigned char *s;
706 register I32 *sfirst;
710 if (sv == PL_lastscream) {
714 s = (unsigned char*)(SvPV(sv, len));
716 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
717 /* No point in studying a zero length string, and not safe to study
718 anything that doesn't appear to be a simple scalar (and hence might
719 change between now and when the regexp engine runs without our set
720 magic ever running) such as a reference to an object with overloaded
726 SvSCREAM_off(PL_lastscream);
727 SvREFCNT_dec(PL_lastscream);
729 PL_lastscream = SvREFCNT_inc_simple(sv);
731 s = (unsigned char*)(SvPV(sv, len));
735 if (pos > PL_maxscream) {
736 if (PL_maxscream < 0) {
737 PL_maxscream = pos + 80;
738 Newx(PL_screamfirst, 256, I32);
739 Newx(PL_screamnext, PL_maxscream, I32);
742 PL_maxscream = pos + pos / 4;
743 Renew(PL_screamnext, PL_maxscream, I32);
747 sfirst = PL_screamfirst;
748 snext = PL_screamnext;
750 if (!sfirst || !snext)
751 DIE(aTHX_ "do_study: out of memory");
753 for (ch = 256; ch; --ch)
758 register const I32 ch = s[pos];
760 snext[pos] = sfirst[ch] - pos;
767 /* piggyback on m//g magic */
768 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
777 if (PL_op->op_flags & OPf_STACKED)
779 else if (PL_op->op_private & OPpTARGET_MY)
785 TARG = sv_newmortal();
786 if(PL_op->op_type == OP_TRANSR) {
787 SV * const newsv = newSVsv(sv);
791 else PUSHi(do_trans(sv));
795 /* Lvalue operators. */
798 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
804 PERL_ARGS_ASSERT_DO_CHOMP;
806 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
808 if (SvTYPE(sv) == SVt_PVAV) {
810 AV *const av = MUTABLE_AV(sv);
811 const I32 max = AvFILL(av);
813 for (i = 0; i <= max; i++) {
814 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
815 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
816 do_chomp(retval, sv, chomping);
820 else if (SvTYPE(sv) == SVt_PVHV) {
821 HV* const hv = MUTABLE_HV(sv);
823 (void)hv_iterinit(hv);
824 while ((entry = hv_iternext(hv)))
825 do_chomp(retval, hv_iterval(hv,entry), chomping);
828 else if (SvREADONLY(sv)) {
830 /* SV is copy-on-write */
831 sv_force_normal_flags(sv, 0);
834 Perl_croak_no_modify(aTHX);
839 /* XXX, here sv is utf8-ized as a side-effect!
840 If encoding.pm is used properly, almost string-generating
841 operations, including literal strings, chr(), input data, etc.
842 should have been utf8-ized already, right?
844 sv_recode_to_utf8(sv, PL_encoding);
850 char *temp_buffer = NULL;
859 while (len && s[-1] == '\n') {
866 STRLEN rslen, rs_charlen;
867 const char *rsptr = SvPV_const(PL_rs, rslen);
869 rs_charlen = SvUTF8(PL_rs)
873 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
874 /* Assumption is that rs is shorter than the scalar. */
876 /* RS is utf8, scalar is 8 bit. */
878 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
881 /* Cannot downgrade, therefore cannot possibly match
883 assert (temp_buffer == rsptr);
889 else if (PL_encoding) {
890 /* RS is 8 bit, encoding.pm is used.
891 * Do not recode PL_rs as a side-effect. */
892 svrecode = newSVpvn(rsptr, rslen);
893 sv_recode_to_utf8(svrecode, PL_encoding);
894 rsptr = SvPV_const(svrecode, rslen);
895 rs_charlen = sv_len_utf8(svrecode);
898 /* RS is 8 bit, scalar is utf8. */
899 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
913 if (memNE(s, rsptr, rslen))
915 SvIVX(retval) += rs_charlen;
918 s = SvPV_force_nolen(sv);
926 SvREFCNT_dec(svrecode);
928 Safefree(temp_buffer);
930 if (len && !SvPOK(sv))
931 s = SvPV_force_nomg(sv, len);
934 char * const send = s + len;
935 char * const start = s;
937 while (s > start && UTF8_IS_CONTINUATION(*s))
939 if (is_utf8_string((U8*)s, send - s)) {
940 sv_setpvn(retval, s, send - s);
942 SvCUR_set(sv, s - start);
948 sv_setpvs(retval, "");
952 sv_setpvn(retval, s, 1);
959 sv_setpvs(retval, "");
967 const bool chomping = PL_op->op_type == OP_SCHOMP;
971 do_chomp(TARG, TOPs, chomping);
978 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
979 const bool chomping = PL_op->op_type == OP_CHOMP;
984 do_chomp(TARG, *++MARK, chomping);
995 if (!PL_op->op_private) {
1004 SV_CHECK_THINKFIRST_COW_DROP(sv);
1006 switch (SvTYPE(sv)) {
1010 av_undef(MUTABLE_AV(sv));
1013 hv_undef(MUTABLE_HV(sv));
1016 if (cv_const_sv((const CV *)sv))
1017 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
1018 CvANON((const CV *)sv) ? "(anonymous)"
1019 : GvENAME(CvGV((const CV *)sv)));
1023 /* let user-undef'd sub keep its identity */
1024 GV* const gv = CvGV((const CV *)sv);
1025 cv_undef(MUTABLE_CV(sv));
1026 CvGV_set(MUTABLE_CV(sv), gv);
1031 SvSetMagicSV(sv, &PL_sv_undef);
1034 else if (isGV_with_GP(sv)) {
1038 /* undef *Pkg::meth_name ... */
1040 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1041 && HvENAME_get(stash);
1043 if((stash = GvHV((const GV *)sv))) {
1044 if(HvENAME_get(stash))
1045 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1049 gp_free(MUTABLE_GV(sv));
1051 GvGP_set(sv, gp_ref(gp));
1052 GvSV(sv) = newSV(0);
1053 GvLINE(sv) = CopLINE(PL_curcop);
1054 GvEGV(sv) = MUTABLE_GV(sv);
1058 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1060 /* undef *Foo::ISA */
1061 if( strEQ(GvNAME((const GV *)sv), "ISA")
1062 && (stash = GvSTASH((const GV *)sv))
1063 && (method_changed || HvENAME(stash)) )
1064 mro_isa_changed_in(stash);
1065 else if(method_changed)
1066 mro_method_changed_in(
1067 GvSTASH((const GV *)sv)
1074 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1089 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1090 Perl_croak_no_modify(aTHX);
1091 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1092 && SvIVX(TOPs) != IV_MIN)
1094 SvIV_set(TOPs, SvIVX(TOPs) - 1);
1095 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1106 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1107 Perl_croak_no_modify(aTHX);
1109 TARG = sv_newmortal();
1110 sv_setsv(TARG, TOPs);
1111 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1112 && SvIVX(TOPs) != IV_MAX)
1114 SvIV_set(TOPs, SvIVX(TOPs) + 1);
1115 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1120 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1130 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1131 Perl_croak_no_modify(aTHX);
1133 TARG = sv_newmortal();
1134 sv_setsv(TARG, TOPs);
1135 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1136 && SvIVX(TOPs) != IV_MIN)
1138 SvIV_set(TOPs, SvIVX(TOPs) - 1);
1139 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1148 /* Ordinary operators. */
1152 dVAR; dSP; dATARGET; SV *svl, *svr;
1153 #ifdef PERL_PRESERVE_IVUV
1156 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1159 #ifdef PERL_PRESERVE_IVUV
1160 /* For integer to integer power, we do the calculation by hand wherever
1161 we're sure it is safe; otherwise we call pow() and try to convert to
1162 integer afterwards. */
1164 SvIV_please_nomg(svr);
1166 SvIV_please_nomg(svl);
1175 const IV iv = SvIVX(svr);
1179 goto float_it; /* Can't do negative powers this way. */
1183 baseuok = SvUOK(svl);
1185 baseuv = SvUVX(svl);
1187 const IV iv = SvIVX(svl);
1190 baseuok = TRUE; /* effectively it's a UV now */
1192 baseuv = -iv; /* abs, baseuok == false records sign */
1195 /* now we have integer ** positive integer. */
1198 /* foo & (foo - 1) is zero only for a power of 2. */
1199 if (!(baseuv & (baseuv - 1))) {
1200 /* We are raising power-of-2 to a positive integer.
1201 The logic here will work for any base (even non-integer
1202 bases) but it can be less accurate than
1203 pow (base,power) or exp (power * log (base)) when the
1204 intermediate values start to spill out of the mantissa.
1205 With powers of 2 we know this can't happen.
1206 And powers of 2 are the favourite thing for perl
1207 programmers to notice ** not doing what they mean. */
1209 NV base = baseuok ? baseuv : -(NV)baseuv;
1214 while (power >>= 1) {
1222 SvIV_please_nomg(svr);
1225 register unsigned int highbit = 8 * sizeof(UV);
1226 register unsigned int diff = 8 * sizeof(UV);
1227 while (diff >>= 1) {
1229 if (baseuv >> highbit) {
1233 /* we now have baseuv < 2 ** highbit */
1234 if (power * highbit <= 8 * sizeof(UV)) {
1235 /* result will definitely fit in UV, so use UV math
1236 on same algorithm as above */
1237 register UV result = 1;
1238 register UV base = baseuv;
1239 const bool odd_power = cBOOL(power & 1);
1243 while (power >>= 1) {
1250 if (baseuok || !odd_power)
1251 /* answer is positive */
1253 else if (result <= (UV)IV_MAX)
1254 /* answer negative, fits in IV */
1255 SETi( -(IV)result );
1256 else if (result == (UV)IV_MIN)
1257 /* 2's complement assumption: special case IV_MIN */
1260 /* answer negative, doesn't fit */
1261 SETn( -(NV)result );
1271 NV right = SvNV_nomg(svr);
1272 NV left = SvNV_nomg(svl);
1275 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1277 We are building perl with long double support and are on an AIX OS
1278 afflicted with a powl() function that wrongly returns NaNQ for any
1279 negative base. This was reported to IBM as PMR #23047-379 on
1280 03/06/2006. The problem exists in at least the following versions
1281 of AIX and the libm fileset, and no doubt others as well:
1283 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1284 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1285 AIX 5.2.0 bos.adt.libm 5.2.0.85
1287 So, until IBM fixes powl(), we provide the following workaround to
1288 handle the problem ourselves. Our logic is as follows: for
1289 negative bases (left), we use fmod(right, 2) to check if the
1290 exponent is an odd or even integer:
1292 - if odd, powl(left, right) == -powl(-left, right)
1293 - if even, powl(left, right) == powl(-left, right)
1295 If the exponent is not an integer, the result is rightly NaNQ, so
1296 we just return that (as NV_NAN).
1300 NV mod2 = Perl_fmod( right, 2.0 );
1301 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1302 SETn( -Perl_pow( -left, right) );
1303 } else if (mod2 == 0.0) { /* even integer */
1304 SETn( Perl_pow( -left, right) );
1305 } else { /* fractional power */
1309 SETn( Perl_pow( left, right) );
1312 SETn( Perl_pow( left, right) );
1313 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1315 #ifdef PERL_PRESERVE_IVUV
1317 SvIV_please_nomg(svr);
1325 dVAR; dSP; dATARGET; SV *svl, *svr;
1326 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1329 #ifdef PERL_PRESERVE_IVUV
1330 SvIV_please_nomg(svr);
1332 /* Unless the left argument is integer in range we are going to have to
1333 use NV maths. Hence only attempt to coerce the right argument if
1334 we know the left is integer. */
1335 /* Left operand is defined, so is it IV? */
1336 SvIV_please_nomg(svl);
1338 bool auvok = SvUOK(svl);
1339 bool buvok = SvUOK(svr);
1340 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1341 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1350 const IV aiv = SvIVX(svl);
1353 auvok = TRUE; /* effectively it's a UV now */
1355 alow = -aiv; /* abs, auvok == false records sign */
1361 const IV biv = SvIVX(svr);
1364 buvok = TRUE; /* effectively it's a UV now */
1366 blow = -biv; /* abs, buvok == false records sign */
1370 /* If this does sign extension on unsigned it's time for plan B */
1371 ahigh = alow >> (4 * sizeof (UV));
1373 bhigh = blow >> (4 * sizeof (UV));
1375 if (ahigh && bhigh) {
1377 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1378 which is overflow. Drop to NVs below. */
1379 } else if (!ahigh && !bhigh) {
1380 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1381 so the unsigned multiply cannot overflow. */
1382 const UV product = alow * blow;
1383 if (auvok == buvok) {
1384 /* -ve * -ve or +ve * +ve gives a +ve result. */
1388 } else if (product <= (UV)IV_MIN) {
1389 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1390 /* -ve result, which could overflow an IV */
1392 SETi( -(IV)product );
1394 } /* else drop to NVs below. */
1396 /* One operand is large, 1 small */
1399 /* swap the operands */
1401 bhigh = blow; /* bhigh now the temp var for the swap */
1405 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1406 multiplies can't overflow. shift can, add can, -ve can. */
1407 product_middle = ahigh * blow;
1408 if (!(product_middle & topmask)) {
1409 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1411 product_middle <<= (4 * sizeof (UV));
1412 product_low = alow * blow;
1414 /* as for pp_add, UV + something mustn't get smaller.
1415 IIRC ANSI mandates this wrapping *behaviour* for
1416 unsigned whatever the actual representation*/
1417 product_low += product_middle;
1418 if (product_low >= product_middle) {
1419 /* didn't overflow */
1420 if (auvok == buvok) {
1421 /* -ve * -ve or +ve * +ve gives a +ve result. */
1423 SETu( product_low );
1425 } else if (product_low <= (UV)IV_MIN) {
1426 /* 2s complement assumption again */
1427 /* -ve result, which could overflow an IV */
1429 SETi( -(IV)product_low );
1431 } /* else drop to NVs below. */
1433 } /* product_middle too large */
1434 } /* ahigh && bhigh */
1439 NV right = SvNV_nomg(svr);
1440 NV left = SvNV_nomg(svl);
1442 SETn( left * right );
1449 dVAR; dSP; dATARGET; SV *svl, *svr;
1450 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1453 /* Only try to do UV divide first
1454 if ((SLOPPYDIVIDE is true) or
1455 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1457 The assumption is that it is better to use floating point divide
1458 whenever possible, only doing integer divide first if we can't be sure.
1459 If NV_PRESERVES_UV is true then we know at compile time that no UV
1460 can be too large to preserve, so don't need to compile the code to
1461 test the size of UVs. */
1464 # define PERL_TRY_UV_DIVIDE
1465 /* ensure that 20./5. == 4. */
1467 # ifdef PERL_PRESERVE_IVUV
1468 # ifndef NV_PRESERVES_UV
1469 # define PERL_TRY_UV_DIVIDE
1474 #ifdef PERL_TRY_UV_DIVIDE
1475 SvIV_please_nomg(svr);
1477 SvIV_please_nomg(svl);
1479 bool left_non_neg = SvUOK(svl);
1480 bool right_non_neg = SvUOK(svr);
1484 if (right_non_neg) {
1488 const IV biv = SvIVX(svr);
1491 right_non_neg = TRUE; /* effectively it's a UV now */
1497 /* historically undef()/0 gives a "Use of uninitialized value"
1498 warning before dieing, hence this test goes here.
1499 If it were immediately before the second SvIV_please, then
1500 DIE() would be invoked before left was even inspected, so
1501 no inspection would give no warning. */
1503 DIE(aTHX_ "Illegal division by zero");
1509 const IV aiv = SvIVX(svl);
1512 left_non_neg = TRUE; /* effectively it's a UV now */
1521 /* For sloppy divide we always attempt integer division. */
1523 /* Otherwise we only attempt it if either or both operands
1524 would not be preserved by an NV. If both fit in NVs
1525 we fall through to the NV divide code below. However,
1526 as left >= right to ensure integer result here, we know that
1527 we can skip the test on the right operand - right big
1528 enough not to be preserved can't get here unless left is
1531 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1534 /* Integer division can't overflow, but it can be imprecise. */
1535 const UV result = left / right;
1536 if (result * right == left) {
1537 SP--; /* result is valid */
1538 if (left_non_neg == right_non_neg) {
1539 /* signs identical, result is positive. */
1543 /* 2s complement assumption */
1544 if (result <= (UV)IV_MIN)
1545 SETi( -(IV)result );
1547 /* It's exact but too negative for IV. */
1548 SETn( -(NV)result );
1551 } /* tried integer divide but it was not an integer result */
1552 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1553 } /* left wasn't SvIOK */
1554 } /* right wasn't SvIOK */
1555 #endif /* PERL_TRY_UV_DIVIDE */
1557 NV right = SvNV_nomg(svr);
1558 NV left = SvNV_nomg(svl);
1559 (void)POPs;(void)POPs;
1560 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1561 if (! Perl_isnan(right) && right == 0.0)
1565 DIE(aTHX_ "Illegal division by zero");
1566 PUSHn( left / right );
1573 dVAR; dSP; dATARGET;
1574 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1578 bool left_neg = FALSE;
1579 bool right_neg = FALSE;
1580 bool use_double = FALSE;
1581 bool dright_valid = FALSE;
1584 SV * const svr = TOPs;
1585 SV * const svl = TOPm1s;
1586 SvIV_please_nomg(svr);
1588 right_neg = !SvUOK(svr);
1592 const IV biv = SvIVX(svr);
1595 right_neg = FALSE; /* effectively it's a UV now */
1602 dright = SvNV_nomg(svr);
1603 right_neg = dright < 0;
1606 if (dright < UV_MAX_P1) {
1607 right = U_V(dright);
1608 dright_valid = TRUE; /* In case we need to use double below. */
1614 /* At this point use_double is only true if right is out of range for
1615 a UV. In range NV has been rounded down to nearest UV and
1616 use_double false. */
1617 SvIV_please_nomg(svl);
1618 if (!use_double && SvIOK(svl)) {
1620 left_neg = !SvUOK(svl);
1624 const IV aiv = SvIVX(svl);
1627 left_neg = FALSE; /* effectively it's a UV now */
1635 dleft = SvNV_nomg(svl);
1636 left_neg = dleft < 0;
1640 /* This should be exactly the 5.6 behaviour - if left and right are
1641 both in range for UV then use U_V() rather than floor. */
1643 if (dleft < UV_MAX_P1) {
1644 /* right was in range, so is dleft, so use UVs not double.
1648 /* left is out of range for UV, right was in range, so promote
1649 right (back) to double. */
1651 /* The +0.5 is used in 5.6 even though it is not strictly
1652 consistent with the implicit +0 floor in the U_V()
1653 inside the #if 1. */
1654 dleft = Perl_floor(dleft + 0.5);
1657 dright = Perl_floor(dright + 0.5);
1668 DIE(aTHX_ "Illegal modulus zero");
1670 dans = Perl_fmod(dleft, dright);
1671 if ((left_neg != right_neg) && dans)
1672 dans = dright - dans;
1675 sv_setnv(TARG, dans);
1681 DIE(aTHX_ "Illegal modulus zero");
1684 if ((left_neg != right_neg) && ans)
1687 /* XXX may warn: unary minus operator applied to unsigned type */
1688 /* could change -foo to be (~foo)+1 instead */
1689 if (ans <= ~((UV)IV_MAX)+1)
1690 sv_setiv(TARG, ~ans+1);
1692 sv_setnv(TARG, -(NV)ans);
1695 sv_setuv(TARG, ans);
1704 dVAR; dSP; dATARGET;
1708 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1709 /* TODO: think of some way of doing list-repeat overloading ??? */
1714 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1720 const UV uv = SvUV_nomg(sv);
1722 count = IV_MAX; /* The best we can do? */
1726 const IV iv = SvIV_nomg(sv);
1733 else if (SvNOKp(sv)) {
1734 const NV nv = SvNV_nomg(sv);
1741 count = SvIV_nomg(sv);
1743 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1745 static const char oom_list_extend[] = "Out of memory during list extend";
1746 const I32 items = SP - MARK;
1747 const I32 max = items * count;
1749 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1750 /* Did the max computation overflow? */
1751 if (items > 0 && max > 0 && (max < items || max < count))
1752 Perl_croak(aTHX_ oom_list_extend);
1757 /* This code was intended to fix 20010809.028:
1760 for (($x =~ /./g) x 2) {
1761 print chop; # "abcdabcd" expected as output.
1764 * but that change (#11635) broke this code:
1766 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1768 * I can't think of a better fix that doesn't introduce
1769 * an efficiency hit by copying the SVs. The stack isn't
1770 * refcounted, and mortalisation obviously doesn't
1771 * Do The Right Thing when the stack has more than
1772 * one pointer to the same mortal value.
1776 *SP = sv_2mortal(newSVsv(*SP));
1786 repeatcpy((char*)(MARK + items), (char*)MARK,
1787 items * sizeof(const SV *), count - 1);
1790 else if (count <= 0)
1793 else { /* Note: mark already snarfed by pp_list */
1794 SV * const tmpstr = POPs;
1797 static const char oom_string_extend[] =
1798 "Out of memory during string extend";
1801 sv_setsv_nomg(TARG, tmpstr);
1802 SvPV_force_nomg(TARG, len);
1803 isutf = DO_UTF8(TARG);
1808 const STRLEN max = (UV)count * len;
1809 if (len > MEM_SIZE_MAX / count)
1810 Perl_croak(aTHX_ oom_string_extend);
1811 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1812 SvGROW(TARG, max + 1);
1813 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1814 SvCUR_set(TARG, SvCUR(TARG) * count);
1816 *SvEND(TARG) = '\0';
1819 (void)SvPOK_only_UTF8(TARG);
1821 (void)SvPOK_only(TARG);
1823 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1824 /* The parser saw this as a list repeat, and there
1825 are probably several items on the stack. But we're
1826 in scalar context, and there's no pp_list to save us
1827 now. So drop the rest of the items -- robin@kitsite.com
1839 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1840 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1843 useleft = USE_LEFT(svl);
1844 #ifdef PERL_PRESERVE_IVUV
1845 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1846 "bad things" happen if you rely on signed integers wrapping. */
1847 SvIV_please_nomg(svr);
1849 /* Unless the left argument is integer in range we are going to have to
1850 use NV maths. Hence only attempt to coerce the right argument if
1851 we know the left is integer. */
1852 register UV auv = 0;
1858 a_valid = auvok = 1;
1859 /* left operand is undef, treat as zero. */
1861 /* Left operand is defined, so is it IV? */
1862 SvIV_please_nomg(svl);
1864 if ((auvok = SvUOK(svl)))
1867 register const IV aiv = SvIVX(svl);
1870 auvok = 1; /* Now acting as a sign flag. */
1871 } else { /* 2s complement assumption for IV_MIN */
1879 bool result_good = 0;
1882 bool buvok = SvUOK(svr);
1887 register const IV biv = SvIVX(svr);
1894 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1895 else "IV" now, independent of how it came in.
1896 if a, b represents positive, A, B negative, a maps to -A etc
1901 all UV maths. negate result if A negative.
1902 subtract if signs same, add if signs differ. */
1904 if (auvok ^ buvok) {
1913 /* Must get smaller */
1918 if (result <= buv) {
1919 /* result really should be -(auv-buv). as its negation
1920 of true value, need to swap our result flag */
1932 if (result <= (UV)IV_MIN)
1933 SETi( -(IV)result );
1935 /* result valid, but out of range for IV. */
1936 SETn( -(NV)result );
1940 } /* Overflow, drop through to NVs. */
1945 NV value = SvNV_nomg(svr);
1949 /* left operand is undef, treat as zero - value */
1953 SETn( SvNV_nomg(svl) - value );
1960 dVAR; dSP; dATARGET; SV *svl, *svr;
1961 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1965 const IV shift = SvIV_nomg(svr);
1966 if (PL_op->op_private & HINT_INTEGER) {
1967 const IV i = SvIV_nomg(svl);
1971 const UV u = SvUV_nomg(svl);
1980 dVAR; dSP; dATARGET; SV *svl, *svr;
1981 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1985 const IV shift = SvIV_nomg(svr);
1986 if (PL_op->op_private & HINT_INTEGER) {
1987 const IV i = SvIV_nomg(svl);
1991 const UV u = SvUV_nomg(svl);
2001 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2002 #ifdef PERL_PRESERVE_IVUV
2003 SvIV_please_nomg(TOPs);
2005 SvIV_please_nomg(TOPm1s);
2006 if (SvIOK(TOPm1s)) {
2007 bool auvok = SvUOK(TOPm1s);
2008 bool buvok = SvUOK(TOPs);
2010 if (!auvok && !buvok) { /* ## IV < IV ## */
2011 const IV aiv = SvIVX(TOPm1s);
2012 const IV biv = SvIVX(TOPs);
2015 SETs(boolSV(aiv < biv));
2018 if (auvok && buvok) { /* ## UV < UV ## */
2019 const UV auv = SvUVX(TOPm1s);
2020 const UV buv = SvUVX(TOPs);
2023 SETs(boolSV(auv < buv));
2026 if (auvok) { /* ## UV < IV ## */
2028 const IV biv = SvIVX(TOPs);
2031 /* As (a) is a UV, it's >=0, so it cannot be < */
2036 SETs(boolSV(auv < (UV)biv));
2039 { /* ## IV < UV ## */
2040 const IV aiv = SvIVX(TOPm1s);
2044 /* As (b) is a UV, it's >=0, so it must be < */
2051 SETs(boolSV((UV)aiv < buv));
2057 #ifndef NV_PRESERVES_UV
2058 #ifdef PERL_PRESERVE_IVUV
2061 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2063 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
2068 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2070 if (Perl_isnan(left) || Perl_isnan(right))
2072 SETs(boolSV(left < right));
2075 SETs(boolSV(SvNV_nomg(TOPs) < value));
2084 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2085 #ifdef PERL_PRESERVE_IVUV
2086 SvIV_please_nomg(TOPs);
2088 SvIV_please_nomg(TOPm1s);
2089 if (SvIOK(TOPm1s)) {
2090 bool auvok = SvUOK(TOPm1s);
2091 bool buvok = SvUOK(TOPs);
2093 if (!auvok && !buvok) { /* ## IV > IV ## */
2094 const IV aiv = SvIVX(TOPm1s);
2095 const IV biv = SvIVX(TOPs);
2098 SETs(boolSV(aiv > biv));
2101 if (auvok && buvok) { /* ## UV > UV ## */
2102 const UV auv = SvUVX(TOPm1s);
2103 const UV buv = SvUVX(TOPs);
2106 SETs(boolSV(auv > buv));
2109 if (auvok) { /* ## UV > IV ## */
2111 const IV biv = SvIVX(TOPs);
2115 /* As (a) is a UV, it's >=0, so it must be > */
2120 SETs(boolSV(auv > (UV)biv));
2123 { /* ## IV > UV ## */
2124 const IV aiv = SvIVX(TOPm1s);
2128 /* As (b) is a UV, it's >=0, so it cannot be > */
2135 SETs(boolSV((UV)aiv > buv));
2141 #ifndef NV_PRESERVES_UV
2142 #ifdef PERL_PRESERVE_IVUV
2145 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2147 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
2152 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2154 if (Perl_isnan(left) || Perl_isnan(right))
2156 SETs(boolSV(left > right));
2159 SETs(boolSV(SvNV_nomg(TOPs) > value));
2168 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2169 #ifdef PERL_PRESERVE_IVUV
2170 SvIV_please_nomg(TOPs);
2172 SvIV_please_nomg(TOPm1s);
2173 if (SvIOK(TOPm1s)) {
2174 bool auvok = SvUOK(TOPm1s);
2175 bool buvok = SvUOK(TOPs);
2177 if (!auvok && !buvok) { /* ## IV <= IV ## */
2178 const IV aiv = SvIVX(TOPm1s);
2179 const IV biv = SvIVX(TOPs);
2182 SETs(boolSV(aiv <= biv));
2185 if (auvok && buvok) { /* ## UV <= UV ## */
2186 UV auv = SvUVX(TOPm1s);
2187 UV buv = SvUVX(TOPs);
2190 SETs(boolSV(auv <= buv));
2193 if (auvok) { /* ## UV <= IV ## */
2195 const IV biv = SvIVX(TOPs);
2199 /* As (a) is a UV, it's >=0, so a cannot be <= */
2204 SETs(boolSV(auv <= (UV)biv));
2207 { /* ## IV <= UV ## */
2208 const IV aiv = SvIVX(TOPm1s);
2212 /* As (b) is a UV, it's >=0, so a must be <= */
2219 SETs(boolSV((UV)aiv <= buv));
2225 #ifndef NV_PRESERVES_UV
2226 #ifdef PERL_PRESERVE_IVUV
2229 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2231 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2236 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2238 if (Perl_isnan(left) || Perl_isnan(right))
2240 SETs(boolSV(left <= right));
2243 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2252 tryAMAGICbin_MG(ge_amg,AMGf_set|AMGf_numeric);
2253 #ifdef PERL_PRESERVE_IVUV
2254 SvIV_please_nomg(TOPs);
2256 SvIV_please_nomg(TOPm1s);
2257 if (SvIOK(TOPm1s)) {
2258 bool auvok = SvUOK(TOPm1s);
2259 bool buvok = SvUOK(TOPs);
2261 if (!auvok && !buvok) { /* ## IV >= IV ## */
2262 const IV aiv = SvIVX(TOPm1s);
2263 const IV biv = SvIVX(TOPs);
2266 SETs(boolSV(aiv >= biv));
2269 if (auvok && buvok) { /* ## UV >= UV ## */
2270 const UV auv = SvUVX(TOPm1s);
2271 const UV buv = SvUVX(TOPs);
2274 SETs(boolSV(auv >= buv));
2277 if (auvok) { /* ## UV >= IV ## */
2279 const IV biv = SvIVX(TOPs);
2283 /* As (a) is a UV, it's >=0, so it must be >= */
2288 SETs(boolSV(auv >= (UV)biv));
2291 { /* ## IV >= UV ## */
2292 const IV aiv = SvIVX(TOPm1s);
2296 /* As (b) is a UV, it's >=0, so a cannot be >= */
2303 SETs(boolSV((UV)aiv >= buv));
2309 #ifndef NV_PRESERVES_UV
2310 #ifdef PERL_PRESERVE_IVUV
2313 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2315 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2320 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2322 if (Perl_isnan(left) || Perl_isnan(right))
2324 SETs(boolSV(left >= right));
2327 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2336 tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric);
2337 #ifndef NV_PRESERVES_UV
2338 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2340 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2344 #ifdef PERL_PRESERVE_IVUV
2345 SvIV_please_nomg(TOPs);
2347 SvIV_please_nomg(TOPm1s);
2348 if (SvIOK(TOPm1s)) {
2349 const bool auvok = SvUOK(TOPm1s);
2350 const bool buvok = SvUOK(TOPs);
2352 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2353 /* Casting IV to UV before comparison isn't going to matter
2354 on 2s complement. On 1s complement or sign&magnitude
2355 (if we have any of them) it could make negative zero
2356 differ from normal zero. As I understand it. (Need to
2357 check - is negative zero implementation defined behaviour
2359 const UV buv = SvUVX(POPs);
2360 const UV auv = SvUVX(TOPs);
2362 SETs(boolSV(auv != buv));
2365 { /* ## Mixed IV,UV ## */
2369 /* != is commutative so swap if needed (save code) */
2371 /* swap. top of stack (b) is the iv */
2375 /* As (a) is a UV, it's >0, so it cannot be == */
2384 /* As (b) is a UV, it's >0, so it cannot be == */
2388 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2390 SETs(boolSV((UV)iv != uv));
2397 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2399 if (Perl_isnan(left) || Perl_isnan(right))
2401 SETs(boolSV(left != right));
2404 SETs(boolSV(SvNV_nomg(TOPs) != value));
2413 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2414 #ifndef NV_PRESERVES_UV
2415 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2416 const UV right = PTR2UV(SvRV(POPs));
2417 const UV left = PTR2UV(SvRV(TOPs));
2418 SETi((left > right) - (left < right));
2422 #ifdef PERL_PRESERVE_IVUV
2423 /* Fortunately it seems NaN isn't IOK */
2424 SvIV_please_nomg(TOPs);
2426 SvIV_please_nomg(TOPm1s);
2427 if (SvIOK(TOPm1s)) {
2428 const bool leftuvok = SvUOK(TOPm1s);
2429 const bool rightuvok = SvUOK(TOPs);
2431 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2432 const IV leftiv = SvIVX(TOPm1s);
2433 const IV rightiv = SvIVX(TOPs);
2435 if (leftiv > rightiv)
2437 else if (leftiv < rightiv)
2441 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2442 const UV leftuv = SvUVX(TOPm1s);
2443 const UV rightuv = SvUVX(TOPs);
2445 if (leftuv > rightuv)
2447 else if (leftuv < rightuv)
2451 } else if (leftuvok) { /* ## UV <=> IV ## */
2452 const IV rightiv = SvIVX(TOPs);
2454 /* As (a) is a UV, it's >=0, so it cannot be < */
2457 const UV leftuv = SvUVX(TOPm1s);
2458 if (leftuv > (UV)rightiv) {
2460 } else if (leftuv < (UV)rightiv) {
2466 } else { /* ## IV <=> UV ## */
2467 const IV leftiv = SvIVX(TOPm1s);
2469 /* As (b) is a UV, it's >=0, so it must be < */
2472 const UV rightuv = SvUVX(TOPs);
2473 if ((UV)leftiv > rightuv) {
2475 } else if ((UV)leftiv < rightuv) {
2493 if (Perl_isnan(left) || Perl_isnan(right)) {
2497 value = (left > right) - (left < right);
2501 else if (left < right)
2503 else if (left > right)
2519 int amg_type = sle_amg;
2523 switch (PL_op->op_type) {
2542 tryAMAGICbin_MG(amg_type, AMGf_set);
2545 const int cmp = (IN_LOCALE_RUNTIME
2546 ? sv_cmp_locale_flags(left, right, 0)
2547 : sv_cmp_flags(left, right, 0));
2548 SETs(boolSV(cmp * multiplier < rhs));
2556 tryAMAGICbin_MG(seq_amg, AMGf_set);
2559 SETs(boolSV(sv_eq_flags(left, right, 0)));
2567 tryAMAGICbin_MG(sne_amg, AMGf_set);
2570 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2578 tryAMAGICbin_MG(scmp_amg, 0);
2581 const int cmp = (IN_LOCALE_RUNTIME
2582 ? sv_cmp_locale_flags(left, right, 0)
2583 : sv_cmp_flags(left, right, 0));
2591 dVAR; dSP; dATARGET;
2592 tryAMAGICbin_MG(band_amg, AMGf_assign);
2595 if (SvNIOKp(left) || SvNIOKp(right)) {
2596 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2597 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2598 if (PL_op->op_private & HINT_INTEGER) {
2599 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2603 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2606 if (left_ro_nonnum) SvNIOK_off(left);
2607 if (right_ro_nonnum) SvNIOK_off(right);
2610 do_vop(PL_op->op_type, TARG, left, right);
2619 dVAR; dSP; dATARGET;
2620 const int op_type = PL_op->op_type;
2622 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2625 if (SvNIOKp(left) || SvNIOKp(right)) {
2626 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2627 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2628 if (PL_op->op_private & HINT_INTEGER) {
2629 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2630 const IV r = SvIV_nomg(right);
2631 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2635 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2636 const UV r = SvUV_nomg(right);
2637 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2640 if (left_ro_nonnum) SvNIOK_off(left);
2641 if (right_ro_nonnum) SvNIOK_off(right);
2644 do_vop(op_type, TARG, left, right);
2654 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2656 SV * const sv = TOPs;
2657 const int flags = SvFLAGS(sv);
2659 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2663 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2664 /* It's publicly an integer, or privately an integer-not-float */
2667 if (SvIVX(sv) == IV_MIN) {
2668 /* 2s complement assumption. */
2669 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2672 else if (SvUVX(sv) <= IV_MAX) {
2677 else if (SvIVX(sv) != IV_MIN) {
2681 #ifdef PERL_PRESERVE_IVUV
2689 SETn(-SvNV_nomg(sv));
2690 else if (SvPOKp(sv)) {
2692 const char * const s = SvPV_nomg_const(sv, len);
2693 if (isIDFIRST(*s)) {
2694 sv_setpvs(TARG, "-");
2697 else if (*s == '+' || *s == '-') {
2698 sv_setsv_nomg(TARG, sv);
2699 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2701 else if (DO_UTF8(sv)) {
2702 SvIV_please_nomg(sv);
2704 goto oops_its_an_int;
2706 sv_setnv(TARG, -SvNV_nomg(sv));
2708 sv_setpvs(TARG, "-");
2713 SvIV_please_nomg(sv);
2715 goto oops_its_an_int;
2716 sv_setnv(TARG, -SvNV_nomg(sv));
2721 SETn(-SvNV_nomg(sv));
2729 tryAMAGICun_MG(not_amg, AMGf_set);
2730 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2737 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2741 if (PL_op->op_private & HINT_INTEGER) {
2742 const IV i = ~SvIV_nomg(sv);
2746 const UV u = ~SvUV_nomg(sv);
2755 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2756 sv_setsv_nomg(TARG, sv);
2757 tmps = (U8*)SvPV_force_nomg(TARG, len);
2760 /* Calculate exact length, let's not estimate. */
2765 U8 * const send = tmps + len;
2766 U8 * const origtmps = tmps;
2767 const UV utf8flags = UTF8_ALLOW_ANYUV;
2769 while (tmps < send) {
2770 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2772 targlen += UNISKIP(~c);
2778 /* Now rewind strings and write them. */
2785 Newx(result, targlen + 1, U8);
2787 while (tmps < send) {
2788 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2790 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2793 sv_usepvn_flags(TARG, (char*)result, targlen,
2794 SV_HAS_TRAILING_NUL);
2801 Newx(result, nchar + 1, U8);
2803 while (tmps < send) {
2804 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2809 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2817 register long *tmpl;
2818 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2821 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2826 for ( ; anum > 0; anum--, tmps++)
2834 /* integer versions of some of the above */
2838 dVAR; dSP; dATARGET;
2839 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2842 SETi( left * right );
2850 dVAR; dSP; dATARGET;
2851 tryAMAGICbin_MG(div_amg, AMGf_assign);
2854 IV value = SvIV_nomg(right);
2856 DIE(aTHX_ "Illegal division by zero");
2857 num = SvIV_nomg(left);
2859 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2863 value = num / value;
2869 #if defined(__GLIBC__) && IVSIZE == 8
2876 /* This is the vanilla old i_modulo. */
2877 dVAR; dSP; dATARGET;
2878 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2882 DIE(aTHX_ "Illegal modulus zero");
2883 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2887 SETi( left % right );
2892 #if defined(__GLIBC__) && IVSIZE == 8
2897 /* This is the i_modulo with the workaround for the _moddi3 bug
2898 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2899 * See below for pp_i_modulo. */
2900 dVAR; dSP; dATARGET;
2901 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2905 DIE(aTHX_ "Illegal modulus zero");
2906 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2910 SETi( left % PERL_ABS(right) );
2917 dVAR; dSP; dATARGET;
2918 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2922 DIE(aTHX_ "Illegal modulus zero");
2923 /* The assumption is to use hereafter the old vanilla version... */
2925 PL_ppaddr[OP_I_MODULO] =
2927 /* .. but if we have glibc, we might have a buggy _moddi3
2928 * (at least glicb 2.2.5 is known to have this bug), in other
2929 * words our integer modulus with negative quad as the second
2930 * argument might be broken. Test for this and re-patch the
2931 * opcode dispatch table if that is the case, remembering to
2932 * also apply the workaround so that this first round works
2933 * right, too. See [perl #9402] for more information. */
2937 /* Cannot do this check with inlined IV constants since
2938 * that seems to work correctly even with the buggy glibc. */
2940 /* Yikes, we have the bug.
2941 * Patch in the workaround version. */
2943 PL_ppaddr[OP_I_MODULO] =
2944 &Perl_pp_i_modulo_1;
2945 /* Make certain we work right this time, too. */
2946 right = PERL_ABS(right);
2949 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2953 SETi( left % right );
2961 dVAR; dSP; dATARGET;
2962 tryAMAGICbin_MG(add_amg, AMGf_assign);
2964 dPOPTOPiirl_ul_nomg;
2965 SETi( left + right );
2972 dVAR; dSP; dATARGET;
2973 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2975 dPOPTOPiirl_ul_nomg;
2976 SETi( left - right );
2984 tryAMAGICbin_MG(lt_amg, AMGf_set);
2987 SETs(boolSV(left < right));
2995 tryAMAGICbin_MG(gt_amg, AMGf_set);
2998 SETs(boolSV(left > right));
3006 tryAMAGICbin_MG(le_amg, AMGf_set);
3009 SETs(boolSV(left <= right));
3017 tryAMAGICbin_MG(ge_amg, AMGf_set);
3020 SETs(boolSV(left >= right));
3028 tryAMAGICbin_MG(eq_amg, AMGf_set);
3031 SETs(boolSV(left == right));
3039 tryAMAGICbin_MG(ne_amg, AMGf_set);
3042 SETs(boolSV(left != right));
3050 tryAMAGICbin_MG(ncmp_amg, 0);
3057 else if (left < right)
3069 tryAMAGICun_MG(neg_amg, 0);
3071 SV * const sv = TOPs;
3072 IV const i = SvIV_nomg(sv);
3078 /* High falutin' math. */
3083 tryAMAGICbin_MG(atan2_amg, 0);
3086 SETn(Perl_atan2(left, right));
3094 int amg_type = sin_amg;
3095 const char *neg_report = NULL;
3096 NV (*func)(NV) = Perl_sin;
3097 const int op_type = PL_op->op_type;
3114 amg_type = sqrt_amg;
3116 neg_report = "sqrt";
3121 tryAMAGICun_MG(amg_type, 0);
3123 SV * const arg = POPs;
3124 const NV value = SvNV_nomg(arg);
3126 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
3127 SET_NUMERIC_STANDARD();
3128 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3131 XPUSHn(func(value));
3136 /* Support Configure command-line overrides for rand() functions.
3137 After 5.005, perhaps we should replace this by Configure support
3138 for drand48(), random(), or rand(). For 5.005, though, maintain
3139 compatibility by calling rand() but allow the user to override it.
3140 See INSTALL for details. --Andy Dougherty 15 July 1998
3142 /* Now it's after 5.005, and Configure supports drand48() and random(),
3143 in addition to rand(). So the overrides should not be needed any more.
3144 --Jarkko Hietaniemi 27 September 1998
3147 #ifndef HAS_DRAND48_PROTO
3148 extern double drand48 (void);
3161 if (!PL_srand_called) {
3162 (void)seedDrand01((Rand_seed_t)seed());
3163 PL_srand_called = TRUE;
3173 const UV anum = (MAXARG < 1) ? seed() : POPu;
3174 (void)seedDrand01((Rand_seed_t)anum);
3175 PL_srand_called = TRUE;
3179 /* Historically srand always returned true. We can avoid breaking
3181 sv_setpvs(TARG, "0 but true");
3190 tryAMAGICun_MG(int_amg, AMGf_numeric);
3192 SV * const sv = TOPs;
3193 const IV iv = SvIV_nomg(sv);
3194 /* XXX it's arguable that compiler casting to IV might be subtly
3195 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3196 else preferring IV has introduced a subtle behaviour change bug. OTOH
3197 relying on floating point to be accurate is a bug. */
3202 else if (SvIOK(sv)) {
3204 SETu(SvUV_nomg(sv));
3209 const NV value = SvNV_nomg(sv);
3211 if (value < (NV)UV_MAX + 0.5) {
3214 SETn(Perl_floor(value));
3218 if (value > (NV)IV_MIN - 0.5) {
3221 SETn(Perl_ceil(value));
3232 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3234 SV * const sv = TOPs;
3235 /* This will cache the NV value if string isn't actually integer */
3236 const IV iv = SvIV_nomg(sv);
3241 else if (SvIOK(sv)) {
3242 /* IVX is precise */
3244 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3252 /* 2s complement assumption. Also, not really needed as
3253 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3259 const NV value = SvNV_nomg(sv);
3273 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3277 SV* const sv = POPs;
3279 tmps = (SvPV_const(sv, len));
3281 /* If Unicode, try to downgrade
3282 * If not possible, croak. */
3283 SV* const tsv = sv_2mortal(newSVsv(sv));
3286 sv_utf8_downgrade(tsv, FALSE);
3287 tmps = SvPV_const(tsv, len);
3289 if (PL_op->op_type == OP_HEX)
3292 while (*tmps && len && isSPACE(*tmps))
3296 if (*tmps == 'x' || *tmps == 'X') {
3298 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3300 else if (*tmps == 'b' || *tmps == 'B')
3301 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3303 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3305 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3319 SV * const sv = TOPs;
3321 if (SvGAMAGIC(sv)) {
3322 /* For an overloaded or magic scalar, we can't know in advance if
3323 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3324 it likes to cache the length. Maybe that should be a documented
3329 = sv_2pv_flags(sv, &len,
3330 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3333 sv_setsv(TARG, &PL_sv_undef);
3336 else if (DO_UTF8(sv)) {
3337 SETi(utf8_length((U8*)p, (U8*)p + len));
3341 } else if (SvOK(sv)) {
3342 /* Neither magic nor overloaded. */
3344 SETi(sv_len_utf8(sv));
3348 sv_setsv_nomg(TARG, &PL_sv_undef);
3368 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3370 const IV arybase = CopARYBASE_get(PL_curcop);
3372 const char *repl = NULL;
3374 const int num_args = PL_op->op_private & 7;
3375 bool repl_need_utf8_upgrade = FALSE;
3376 bool repl_is_utf8 = FALSE;
3381 repl = SvPV_const(repl_sv, repl_len);
3382 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3385 len_iv = SvIV(len_sv);
3386 len_is_uv = SvIOK_UV(len_sv);
3389 pos1_iv = SvIV(pos_sv);
3390 pos1_is_uv = SvIOK_UV(pos_sv);
3396 sv_utf8_upgrade(sv);
3398 else if (DO_UTF8(sv))
3399 repl_need_utf8_upgrade = TRUE;
3401 tmps = SvPV_const(sv, curlen);
3403 utf8_curlen = sv_len_utf8(sv);
3404 if (utf8_curlen == curlen)
3407 curlen = utf8_curlen;
3412 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3413 UV pos1_uv = pos1_iv-arybase;
3414 /* Overflow can occur when $[ < 0 */
3415 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3420 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3421 goto bound_fail; /* $[=3; substr($_,2,...) */
3423 else { /* pos < $[ */
3424 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3429 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3434 if (pos1_is_uv || pos1_iv > 0) {
3435 if ((UV)pos1_iv > curlen)
3440 if (!len_is_uv && len_iv < 0) {
3441 pos2_iv = curlen + len_iv;
3443 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3446 } else { /* len_iv >= 0 */
3447 if (!pos1_is_uv && pos1_iv < 0) {
3448 pos2_iv = pos1_iv + len_iv;
3449 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3451 if ((UV)len_iv > curlen-(UV)pos1_iv)
3454 pos2_iv = pos1_iv+len_iv;
3464 if (!pos2_is_uv && pos2_iv < 0) {
3465 if (!pos1_is_uv && pos1_iv < 0)
3469 else if (!pos1_is_uv && pos1_iv < 0)
3472 if ((UV)pos2_iv < (UV)pos1_iv)
3474 if ((UV)pos2_iv > curlen)
3478 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3479 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3480 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3481 STRLEN byte_len = len;
3482 STRLEN byte_pos = utf8_curlen
3483 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3485 if (lvalue && !repl) {
3488 if (!SvGMAGICAL(sv)) {
3490 SvPV_force_nolen(sv);
3491 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3492 "Attempt to use reference as lvalue in substr");
3494 if (isGV_with_GP(sv))
3495 SvPV_force_nolen(sv);
3496 else if (SvOK(sv)) /* is it defined ? */
3497 (void)SvPOK_only_UTF8(sv);
3499 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3502 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3503 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3505 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3506 LvTARGOFF(ret) = pos;
3507 LvTARGLEN(ret) = len;
3510 PUSHs(ret); /* avoid SvSETMAGIC here */
3514 SvTAINTED_off(TARG); /* decontaminate */
3515 SvUTF8_off(TARG); /* decontaminate */
3518 sv_setpvn(TARG, tmps, byte_len);
3519 #ifdef USE_LOCALE_COLLATE
3520 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3526 SV* repl_sv_copy = NULL;
3528 if (repl_need_utf8_upgrade) {
3529 repl_sv_copy = newSVsv(repl_sv);
3530 sv_utf8_upgrade(repl_sv_copy);
3531 repl = SvPV_const(repl_sv_copy, repl_len);
3532 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3536 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3539 SvREFCNT_dec(repl_sv_copy);
3549 Perl_croak(aTHX_ "substr outside of string");
3550 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3557 register const IV size = POPi;
3558 register const IV offset = POPi;
3559 register SV * const src = POPs;
3560 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3563 if (lvalue) { /* it's an lvalue! */
3564 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3565 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3567 LvTARG(ret) = SvREFCNT_inc_simple(src);
3568 LvTARGOFF(ret) = offset;
3569 LvTARGLEN(ret) = size;
3573 SvTAINTED_off(TARG); /* decontaminate */
3577 sv_setuv(ret, do_vecget(src, offset, size));
3593 const char *little_p;
3594 const I32 arybase = CopARYBASE_get(PL_curcop);
3597 const bool is_index = PL_op->op_type == OP_INDEX;
3600 /* arybase is in characters, like offset, so combine prior to the
3601 UTF-8 to bytes calculation. */
3602 offset = POPi - arybase;
3606 big_p = SvPV_const(big, biglen);
3607 little_p = SvPV_const(little, llen);
3609 big_utf8 = DO_UTF8(big);
3610 little_utf8 = DO_UTF8(little);
3611 if (big_utf8 ^ little_utf8) {
3612 /* One needs to be upgraded. */
3613 if (little_utf8 && !PL_encoding) {
3614 /* Well, maybe instead we might be able to downgrade the small
3616 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3619 /* If the large string is ISO-8859-1, and it's not possible to
3620 convert the small string to ISO-8859-1, then there is no
3621 way that it could be found anywhere by index. */
3626 /* At this point, pv is a malloc()ed string. So donate it to temp
3627 to ensure it will get free()d */
3628 little = temp = newSV(0);
3629 sv_usepvn(temp, pv, llen);
3630 little_p = SvPVX(little);
3633 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3636 sv_recode_to_utf8(temp, PL_encoding);
3638 sv_utf8_upgrade(temp);
3643 big_p = SvPV_const(big, biglen);
3646 little_p = SvPV_const(little, llen);
3650 if (SvGAMAGIC(big)) {
3651 /* Life just becomes a lot easier if I use a temporary here.
3652 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3653 will trigger magic and overloading again, as will fbm_instr()
3655 big = newSVpvn_flags(big_p, biglen,
3656 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3659 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3660 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3661 warn on undef, and we've already triggered a warning with the
3662 SvPV_const some lines above. We can't remove that, as we need to
3663 call some SvPV to trigger overloading early and find out if the
3665 This is all getting to messy. The API isn't quite clean enough,
3666 because data access has side effects.
3668 little = newSVpvn_flags(little_p, llen,
3669 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3670 little_p = SvPVX(little);
3674 offset = is_index ? 0 : biglen;
3676 if (big_utf8 && offset > 0)
3677 sv_pos_u2b(big, &offset, 0);
3683 else if (offset > (I32)biglen)
3685 if (!(little_p = is_index
3686 ? fbm_instr((unsigned char*)big_p + offset,
3687 (unsigned char*)big_p + biglen, little, 0)
3688 : rninstr(big_p, big_p + offset,
3689 little_p, little_p + llen)))
3692 retval = little_p - big_p;
3693 if (retval > 0 && big_utf8)
3694 sv_pos_b2u(big, &retval);
3698 PUSHi(retval + arybase);
3704 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3705 if (SvTAINTED(MARK[1]))
3706 TAINT_PROPER("sprintf");
3707 SvTAINTED_off(TARG);
3708 do_sprintf(TARG, SP-MARK, MARK+1);
3709 TAINT_IF(SvTAINTED(TARG));
3721 const U8 *s = (U8*)SvPV_const(argsv, len);
3723 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3724 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3725 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3729 XPUSHu(DO_UTF8(argsv) ?
3730 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3742 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3744 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3746 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3748 (void) POPs; /* Ignore the argument value. */
3749 value = UNICODE_REPLACEMENT;
3755 SvUPGRADE(TARG,SVt_PV);
3757 if (value > 255 && !IN_BYTES) {
3758 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3759 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3760 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3762 (void)SvPOK_only(TARG);
3771 *tmps++ = (char)value;
3773 (void)SvPOK_only(TARG);
3775 if (PL_encoding && !IN_BYTES) {
3776 sv_recode_to_utf8(TARG, PL_encoding);
3778 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3779 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3783 *tmps++ = (char)value;
3799 const char *tmps = SvPV_const(left, len);
3801 if (DO_UTF8(left)) {
3802 /* If Unicode, try to downgrade.
3803 * If not possible, croak.
3804 * Yes, we made this up. */
3805 SV* const tsv = sv_2mortal(newSVsv(left));
3808 sv_utf8_downgrade(tsv, FALSE);
3809 tmps = SvPV_const(tsv, len);
3811 # ifdef USE_ITHREADS
3813 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3814 /* This should be threadsafe because in ithreads there is only
3815 * one thread per interpreter. If this would not be true,
3816 * we would need a mutex to protect this malloc. */
3817 PL_reentrant_buffer->_crypt_struct_buffer =
3818 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3819 #if defined(__GLIBC__) || defined(__EMX__)
3820 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3821 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3822 /* work around glibc-2.2.5 bug */
3823 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3827 # endif /* HAS_CRYPT_R */
3828 # endif /* USE_ITHREADS */
3830 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3832 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3838 "The crypt() function is unimplemented due to excessive paranoia.");
3842 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3843 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3845 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3846 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3847 * See http://www.unicode.org/unicode/reports/tr16 */
3848 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3849 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3851 /* Below are several macros that generate code */
3852 /* Generates code to store a unicode codepoint c that is known to occupy
3853 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3854 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3856 *(p) = UTF8_TWO_BYTE_HI(c); \
3857 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3860 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3861 * available byte after the two bytes */
3862 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3864 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3865 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3868 /* Generates code to store the upper case of latin1 character l which is known
3869 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3870 * are only two characters that fit this description, and this macro knows
3871 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3873 #define STORE_NON_LATIN1_UC(p, l) \
3875 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3876 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3877 } else { /* Must be the following letter */ \
3878 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3882 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3883 * after the character stored */
3884 #define CAT_NON_LATIN1_UC(p, l) \
3886 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3887 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3889 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3893 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3894 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3895 * and must require two bytes to store it. Advances p to point to the next
3896 * available position */
3897 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3899 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3900 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3901 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3902 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3903 } else {/* else is one of the other two special cases */ \
3904 CAT_NON_LATIN1_UC((p), (l)); \
3910 /* Actually is both lcfirst() and ucfirst(). Only the first character
3911 * changes. This means that possibly we can change in-place, ie., just
3912 * take the source and change that one character and store it back, but not
3913 * if read-only etc, or if the length changes */
3918 STRLEN slen; /* slen is the byte length of the whole SV. */
3921 bool inplace; /* ? Convert first char only, in-place */
3922 bool doing_utf8 = FALSE; /* ? using utf8 */
3923 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3924 const int op_type = PL_op->op_type;
3927 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3928 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3929 * stored as UTF-8 at s. */
3930 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3931 * lowercased) character stored in tmpbuf. May be either
3932 * UTF-8 or not, but in either case is the number of bytes */
3936 s = (const U8*)SvPV_nomg_const(source, slen);
3938 if (ckWARN(WARN_UNINITIALIZED))
3939 report_uninit(source);
3944 /* We may be able to get away with changing only the first character, in
3945 * place, but not if read-only, etc. Later we may discover more reasons to
3946 * not convert in-place. */
3947 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3949 /* First calculate what the changed first character should be. This affects
3950 * whether we can just swap it out, leaving the rest of the string unchanged,
3951 * or even if have to convert the dest to UTF-8 when the source isn't */
3953 if (! slen) { /* If empty */
3954 need = 1; /* still need a trailing NUL */
3956 else if (DO_UTF8(source)) { /* Is the source utf8? */
3959 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3960 * and doesn't allow for the user to specify their own. When code is added to
3961 * detect if there is a user-defined mapping in force here, and if so to use
3962 * that, then the code below can be compiled. The detection would be a good
3963 * thing anyway, as currently the user-defined mappings only work on utf8
3964 * strings, and thus depend on the chosen internal storage method, which is a
3966 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3967 if (UTF8_IS_INVARIANT(*s)) {
3969 /* An invariant source character is either ASCII or, in EBCDIC, an
3970 * ASCII equivalent or a caseless C1 control. In both these cases,
3971 * the lower and upper cases of any character are also invariants
3972 * (and title case is the same as upper case). So it is safe to
3973 * use the simple case change macros which avoid the overhead of
3974 * the general functions. Note that if perl were to be extended to
3975 * do locale handling in UTF-8 strings, this wouldn't be true in,
3976 * for example, Lithuanian or Turkic. */
3977 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3981 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3984 /* Similarly, if the source character isn't invariant but is in the
3985 * latin1 range (or EBCDIC equivalent thereof), we have the case
3986 * changes compiled into perl, and can avoid the overhead of the
3987 * general functions. In this range, the characters are stored as
3988 * two UTF-8 bytes, and it so happens that any changed-case version
3989 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3993 /* Convert the two source bytes to a single Unicode code point
3994 * value, change case and save for below */
3995 chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3996 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3997 U8 lower = toLOWER_LATIN1(chr);
3998 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
4000 else { /* ucfirst */
4001 U8 upper = toUPPER_LATIN1_MOD(chr);
4003 /* Most of the latin1 range characters are well-behaved. Their
4004 * title and upper cases are the same, and are also in the
4005 * latin1 range. The macro above returns their upper (hence
4006 * title) case, and all that need be done is to save the result
4007 * for below. However, several characters are problematic, and
4008 * have to be handled specially. The MOD in the macro name
4009 * above means that these tricky characters all get mapped to
4010 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
4011 * This mapping saves some tests for the majority of the
4014 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
4016 /* Not tricky. Just save it. */
4017 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
4019 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
4021 /* This one is tricky because it is two characters long,
4022 * though the UTF-8 is still two bytes, so the stored
4023 * length doesn't change */
4024 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
4025 *(tmpbuf + 1) = 's';
4029 /* The other two have their title and upper cases the same,
4030 * but are tricky because the changed-case characters
4031 * aren't in the latin1 range. They, however, do fit into
4032 * two UTF-8 bytes */
4033 STORE_NON_LATIN1_UC(tmpbuf, chr);
4038 #endif /* end of dont want to break user-defined casing */
4040 /* Here, can't short-cut the general case */
4042 utf8_to_uvchr(s, &ulen);
4043 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
4044 else toLOWER_utf8(s, tmpbuf, &tculen);
4046 /* we can't do in-place if the length changes. */
4047 if (ulen != tculen) inplace = FALSE;
4048 need = slen + 1 - ulen + tculen;
4049 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4053 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
4054 * latin1 is treated as caseless. Note that a locale takes
4056 tculen = 1; /* Most characters will require one byte, but this will
4057 * need to be overridden for the tricky ones */
4060 if (op_type == OP_LCFIRST) {
4062 /* lower case the first letter: no trickiness for any character */
4063 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
4064 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
4067 else if (IN_LOCALE_RUNTIME) {
4068 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
4069 * have upper and title case different
4072 else if (! IN_UNI_8_BIT) {
4073 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
4074 * on EBCDIC machines whatever the
4075 * native function does */
4077 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
4078 *tmpbuf = toUPPER_LATIN1_MOD(*s);
4080 /* tmpbuf now has the correct title case for all latin1 characters
4081 * except for the several ones that have tricky handling. All
4082 * of these are mapped by the MOD to the letter below. */
4083 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
4085 /* The length is going to change, with all three of these, so
4086 * can't replace just the first character */
4089 /* We use the original to distinguish between these tricky
4091 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4092 /* Two character title case 'Ss', but can remain non-UTF-8 */
4095 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
4100 /* The other two tricky ones have their title case outside
4101 * latin1. It is the same as their upper case. */
4103 STORE_NON_LATIN1_UC(tmpbuf, *s);
4105 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
4106 * and their upper cases is 2. */
4109 /* The entire result will have to be in UTF-8. Assume worst
4110 * case sizing in conversion. (all latin1 characters occupy
4111 * at most two bytes in utf8) */
4112 convert_source_to_utf8 = TRUE;
4113 need = slen * 2 + 1;
4115 } /* End of is one of the three special chars */
4116 } /* End of use Unicode (Latin1) semantics */
4117 } /* End of changing the case of the first character */
4119 /* Here, have the first character's changed case stored in tmpbuf. Ready to
4120 * generate the result */
4123 /* We can convert in place. This means we change just the first
4124 * character without disturbing the rest; no need to grow */
4126 s = d = (U8*)SvPV_force_nomg(source, slen);
4132 /* Here, we can't convert in place; we earlier calculated how much
4133 * space we will need, so grow to accommodate that */
4134 SvUPGRADE(dest, SVt_PV);
4135 d = (U8*)SvGROW(dest, need);
4136 (void)SvPOK_only(dest);
4143 if (! convert_source_to_utf8) {
4145 /* Here both source and dest are in UTF-8, but have to create
4146 * the entire output. We initialize the result to be the
4147 * title/lower cased first character, and then append the rest
4149 sv_setpvn(dest, (char*)tmpbuf, tculen);
4151 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4155 const U8 *const send = s + slen;
4157 /* Here the dest needs to be in UTF-8, but the source isn't,
4158 * except we earlier UTF-8'd the first character of the source
4159 * into tmpbuf. First put that into dest, and then append the
4160 * rest of the source, converting it to UTF-8 as we go. */
4162 /* Assert tculen is 2 here because the only two characters that
4163 * get to this part of the code have 2-byte UTF-8 equivalents */
4165 *d++ = *(tmpbuf + 1);
4166 s++; /* We have just processed the 1st char */
4168 for (; s < send; s++) {
4169 d = uvchr_to_utf8(d, *s);
4172 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4176 else { /* in-place UTF-8. Just overwrite the first character */
4177 Copy(tmpbuf, d, tculen, U8);
4178 SvCUR_set(dest, need - 1);
4181 else { /* Neither source nor dest are in or need to be UTF-8 */
4183 if (IN_LOCALE_RUNTIME) {
4187 if (inplace) { /* in-place, only need to change the 1st char */
4190 else { /* Not in-place */
4192 /* Copy the case-changed character(s) from tmpbuf */
4193 Copy(tmpbuf, d, tculen, U8);
4194 d += tculen - 1; /* Code below expects d to point to final
4195 * character stored */
4198 else { /* empty source */
4199 /* See bug #39028: Don't taint if empty */
4203 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4204 * the destination to retain that flag */
4208 if (!inplace) { /* Finish the rest of the string, unchanged */
4209 /* This will copy the trailing NUL */
4210 Copy(s + 1, d + 1, slen, U8);
4211 SvCUR_set(dest, need - 1);
4218 /* There's so much setup/teardown code common between uc and lc, I wonder if
4219 it would be worth merging the two, and just having a switch outside each
4220 of the three tight loops. There is less and less commonality though */
4234 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4235 && SvTEMP(source) && !DO_UTF8(source)
4236 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4238 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4239 * make the loop tight, so we overwrite the source with the dest before
4240 * looking at it, and we need to look at the original source
4241 * afterwards. There would also need to be code added to handle
4242 * switching to not in-place in midstream if we run into characters
4243 * that change the length.
4246 s = d = (U8*)SvPV_force_nomg(source, len);
4253 /* The old implementation would copy source into TARG at this point.
4254 This had the side effect that if source was undef, TARG was now
4255 an undefined SV with PADTMP set, and they don't warn inside
4256 sv_2pv_flags(). However, we're now getting the PV direct from
4257 source, which doesn't have PADTMP set, so it would warn. Hence the
4261 s = (const U8*)SvPV_nomg_const(source, len);
4263 if (ckWARN(WARN_UNINITIALIZED))
4264 report_uninit(source);
4270 SvUPGRADE(dest, SVt_PV);
4271 d = (U8*)SvGROW(dest, min);
4272 (void)SvPOK_only(dest);
4277 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4278 to check DO_UTF8 again here. */
4280 if (DO_UTF8(source)) {
4281 const U8 *const send = s + len;
4282 U8 tmpbuf[UTF8_MAXBYTES+1];
4284 /* All occurrences of these are to be moved to follow any other marks.
4285 * This is context-dependent. We may not be passed enough context to
4286 * move the iota subscript beyond all of them, but we do the best we can
4287 * with what we're given. The result is always better than if we
4288 * hadn't done this. And, the problem would only arise if we are
4289 * passed a character without all its combining marks, which would be
4290 * the caller's mistake. The information this is based on comes from a
4291 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4292 * itself) and so can't be checked properly to see if it ever gets
4293 * revised. But the likelihood of it changing is remote */
4294 bool in_iota_subscript = FALSE;
4297 if (in_iota_subscript && ! is_utf8_mark(s)) {
4298 /* A non-mark. Time to output the iota subscript */
4299 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4300 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4302 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4303 in_iota_subscript = FALSE;
4307 /* See comments at the first instance in this file of this ifdef */
4308 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4310 /* If the UTF-8 character is invariant, then it is in the range
4311 * known by the standard macro; result is only one byte long */
4312 if (UTF8_IS_INVARIANT(*s)) {
4316 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4318 /* Likewise, if it fits in a byte, its case change is in our
4320 U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *s++);
4321 U8 upper = toUPPER_LATIN1_MOD(orig);
4322 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4330 /* Otherwise, need the general UTF-8 case. Get the changed
4331 * case value and copy it to the output buffer */
4333 const STRLEN u = UTF8SKIP(s);
4336 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4337 if (uv == GREEK_CAPITAL_LETTER_IOTA
4338 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4340 in_iota_subscript = TRUE;
4343 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4344 /* If the eventually required minimum size outgrows
4345 * the available space, we need to grow. */
4346 const UV o = d - (U8*)SvPVX_const(dest);
4348 /* If someone uppercases one million U+03B0s we
4349 * SvGROW() one million times. Or we could try
4350 * guessing how much to allocate without allocating too
4351 * much. Such is life. See corresponding comment in
4352 * lc code for another option */
4354 d = (U8*)SvPVX(dest) + o;
4356 Copy(tmpbuf, d, ulen, U8);
4362 if (in_iota_subscript) {
4363 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4367 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4369 else { /* Not UTF-8 */
4371 const U8 *const send = s + len;
4373 /* Use locale casing if in locale; regular style if not treating
4374 * latin1 as having case; otherwise the latin1 casing. Do the
4375 * whole thing in a tight loop, for speed, */
4376 if (IN_LOCALE_RUNTIME) {
4379 for (; s < send; d++, s++)
4380 *d = toUPPER_LC(*s);
4382 else if (! IN_UNI_8_BIT) {
4383 for (; s < send; d++, s++) {
4388 for (; s < send; d++, s++) {
4389 *d = toUPPER_LATIN1_MOD(*s);
4390 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4392 /* The mainstream case is the tight loop above. To avoid
4393 * extra tests in that, all three characters that require
4394 * special handling are mapped by the MOD to the one tested
4396 * Use the source to distinguish between the three cases */
4398 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4400 /* uc() of this requires 2 characters, but they are
4401 * ASCII. If not enough room, grow the string */
4402 if (SvLEN(dest) < ++min) {
4403 const UV o = d - (U8*)SvPVX_const(dest);
4405 d = (U8*)SvPVX(dest) + o;
4407 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4408 continue; /* Back to the tight loop; still in ASCII */
4411 /* The other two special handling characters have their
4412 * upper cases outside the latin1 range, hence need to be
4413 * in UTF-8, so the whole result needs to be in UTF-8. So,
4414 * here we are somewhere in the middle of processing a
4415 * non-UTF-8 string, and realize that we will have to convert
4416 * the whole thing to UTF-8. What to do? There are
4417 * several possibilities. The simplest to code is to
4418 * convert what we have so far, set a flag, and continue on
4419 * in the loop. The flag would be tested each time through
4420 * the loop, and if set, the next character would be
4421 * converted to UTF-8 and stored. But, I (khw) didn't want
4422 * to slow down the mainstream case at all for this fairly
4423 * rare case, so I didn't want to add a test that didn't
4424 * absolutely have to be there in the loop, besides the
4425 * possibility that it would get too complicated for
4426 * optimizers to deal with. Another possibility is to just
4427 * give up, convert the source to UTF-8, and restart the
4428 * function that way. Another possibility is to convert
4429 * both what has already been processed and what is yet to
4430 * come separately to UTF-8, then jump into the loop that
4431 * handles UTF-8. But the most efficient time-wise of the
4432 * ones I could think of is what follows, and turned out to
4433 * not require much extra code. */
4435 /* Convert what we have so far into UTF-8, telling the
4436 * function that we know it should be converted, and to
4437 * allow extra space for what we haven't processed yet.
4438 * Assume the worst case space requirements for converting
4439 * what we haven't processed so far: that it will require
4440 * two bytes for each remaining source character, plus the
4441 * NUL at the end. This may cause the string pointer to
4442 * move, so re-find it. */
4444 len = d - (U8*)SvPVX_const(dest);
4445 SvCUR_set(dest, len);
4446 len = sv_utf8_upgrade_flags_grow(dest,
4447 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4449 d = (U8*)SvPVX(dest) + len;
4451 /* And append the current character's upper case in UTF-8 */
4452 CAT_NON_LATIN1_UC(d, *s);
4454 /* Now process the remainder of the source, converting to
4455 * upper and UTF-8. If a resulting byte is invariant in
4456 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4457 * append it to the output. */
4460 for (; s < send; s++) {
4461 U8 upper = toUPPER_LATIN1_MOD(*s);
4462 if UTF8_IS_INVARIANT(upper) {
4466 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4470 /* Here have processed the whole source; no need to continue
4471 * with the outer loop. Each character has been converted
4472 * to upper case and converted to UTF-8 */
4475 } /* End of processing all latin1-style chars */
4476 } /* End of processing all chars */
4477 } /* End of source is not empty */
4479 if (source != dest) {
4480 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4481 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4483 } /* End of isn't utf8 */
4501 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4502 && SvTEMP(source) && !DO_UTF8(source)) {
4504 /* We can convert in place, as lowercasing anything in the latin1 range
4505 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4507 s = d = (U8*)SvPV_force_nomg(source, len);
4514 /* The old implementation would copy source into TARG at this point.
4515 This had the side effect that if source was undef, TARG was now
4516 an undefined SV with PADTMP set, and they don't warn inside
4517 sv_2pv_flags(). However, we're now getting the PV direct from
4518 source, which doesn't have PADTMP set, so it would warn. Hence the
4522 s = (const U8*)SvPV_nomg_const(source, len);
4524 if (ckWARN(WARN_UNINITIALIZED))
4525 report_uninit(source);
4531 SvUPGRADE(dest, SVt_PV);
4532 d = (U8*)SvGROW(dest, min);
4533 (void)SvPOK_only(dest);
4538 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4539 to check DO_UTF8 again here. */
4541 if (DO_UTF8(source)) {
4542 const U8 *const send = s + len;
4543 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4546 /* See comments at the first instance in this file of this ifdef */
4547 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4548 if (UTF8_IS_INVARIANT(*s)) {
4550 /* Invariant characters use the standard mappings compiled in.
4555 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4557 /* As do the ones in the Latin1 range */
4558 U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *s++));
4559 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4564 /* Here, is utf8 not in Latin-1 range, have to go out and get
4565 * the mappings from the tables. */
4567 const STRLEN u = UTF8SKIP(s);
4570 #ifndef CONTEXT_DEPENDENT_CASING
4571 toLOWER_utf8(s, tmpbuf, &ulen);
4573 /* This is ifdefd out because it needs more work and thought. It isn't clear
4574 * that we should do it.
4575 * A minor objection is that this is based on a hard-coded rule from the
4576 * Unicode standard, and may change, but this is not very likely at all.
4577 * mktables should check and warn if it does.
4578 * More importantly, if the sigma occurs at the end of the string, we don't
4579 * have enough context to know whether it is part of a larger string or going
4580 * to be or not. It may be that we are passed a subset of the context, via
4581 * a \U...\E, for example, and we could conceivably know the larger context if
4582 * code were changed to pass that in. But, if the string passed in is an
4583 * intermediate result, and the user concatenates two strings together
4584 * after we have made a final sigma, that would be wrong. If the final sigma
4585 * occurs in the middle of the string we are working on, then we know that it
4586 * should be a final sigma, but otherwise we can't be sure. */
4588 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4590 /* If the lower case is a small sigma, it may be that we need
4591 * to change it to a final sigma. This happens at the end of
4592 * a word that contains more than just this character, and only
4593 * when we started with a capital sigma. */
4594 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4595 s > send - len && /* Makes sure not the first letter */
4596 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4599 /* We use the algorithm in:
4600 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4601 * is a CAPITAL SIGMA): If C is preceded by a sequence
4602 * consisting of a cased letter and a case-ignorable
4603 * sequence, and C is not followed by a sequence consisting
4604 * of a case ignorable sequence and then a cased letter,
4605 * then when lowercasing C, C becomes a final sigma */
4607 /* To determine if this is the end of a word, need to peek
4608 * ahead. Look at the next character */
4609 const U8 *peek = s + u;
4611 /* Skip any case ignorable characters */
4612 while (peek < send && is_utf8_case_ignorable(peek)) {
4613 peek += UTF8SKIP(peek);
4616 /* If we reached the end of the string without finding any
4617 * non-case ignorable characters, or if the next such one
4618 * is not-cased, then we have met the conditions for it
4619 * being a final sigma with regards to peek ahead, and so
4620 * must do peek behind for the remaining conditions. (We
4621 * know there is stuff behind to look at since we tested
4622 * above that this isn't the first letter) */
4623 if (peek >= send || ! is_utf8_cased(peek)) {
4624 peek = utf8_hop(s, -1);
4626 /* Here are at the beginning of the first character
4627 * before the original upper case sigma. Keep backing
4628 * up, skipping any case ignorable characters */
4629 while (is_utf8_case_ignorable(peek)) {
4630 peek = utf8_hop(peek, -1);
4633 /* Here peek points to the first byte of the closest
4634 * non-case-ignorable character before the capital
4635 * sigma. If it is cased, then by the Unicode
4636 * algorithm, we should use a small final sigma instead
4637 * of what we have */
4638 if (is_utf8_cased(peek)) {
4639 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4640 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4644 else { /* Not a context sensitive mapping */
4645 #endif /* End of commented out context sensitive */
4646 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4648 /* If the eventually required minimum size outgrows
4649 * the available space, we need to grow. */
4650 const UV o = d - (U8*)SvPVX_const(dest);
4652 /* If someone lowercases one million U+0130s we
4653 * SvGROW() one million times. Or we could try
4654 * guessing how much to allocate without allocating too
4655 * much. Such is life. Another option would be to
4656 * grow an extra byte or two more each time we need to
4657 * grow, which would cut down the million to 500K, with
4660 d = (U8*)SvPVX(dest) + o;
4662 #ifdef CONTEXT_DEPENDENT_CASING
4665 /* Copy the newly lowercased letter to the output buffer we're
4667 Copy(tmpbuf, d, ulen, U8);
4670 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4673 } /* End of looping through the source string */
4676 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4677 } else { /* Not utf8 */
4679 const U8 *const send = s + len;
4681 /* Use locale casing if in locale; regular style if not treating
4682 * latin1 as having case; otherwise the latin1 casing. Do the
4683 * whole thing in a tight loop, for speed, */
4684 if (IN_LOCALE_RUNTIME) {
4687 for (; s < send; d++, s++)
4688 *d = toLOWER_LC(*s);
4690 else if (! IN_UNI_8_BIT) {
4691 for (; s < send; d++, s++) {
4696 for (; s < send; d++, s++) {
4697 *d = toLOWER_LATIN1(*s);
4701 if (source != dest) {
4703 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4713 SV * const sv = TOPs;
4715 register const char *s = SvPV_const(sv,len);
4717 SvUTF8_off(TARG); /* decontaminate */
4720 SvUPGRADE(TARG, SVt_PV);
4721 SvGROW(TARG, (len * 2) + 1);
4725 if (UTF8_IS_CONTINUED(*s)) {
4726 STRLEN ulen = UTF8SKIP(s);
4750 SvCUR_set(TARG, d - SvPVX_const(TARG));
4751 (void)SvPOK_only_UTF8(TARG);
4754 sv_setpvn(TARG, s, len);
4763 dVAR; dSP; dMARK; dORIGMARK;
4764 register AV *const av = MUTABLE_AV(POPs);
4765 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4767 if (SvTYPE(av) == SVt_PVAV) {
4768 const I32 arybase = CopARYBASE_get(PL_curcop);
4769 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4770 bool can_preserve = FALSE;
4776 can_preserve = SvCANEXISTDELETE(av);
4779 if (lval && localizing) {
4782 for (svp = MARK + 1; svp <= SP; svp++) {
4783 const I32 elem = SvIV(*svp);
4787 if (max > AvMAX(av))
4791 while (++MARK <= SP) {
4793 I32 elem = SvIV(*MARK);
4794 bool preeminent = TRUE;
4798 if (localizing && can_preserve) {
4799 /* If we can determine whether the element exist,
4800 * Try to preserve the existenceness of a tied array
4801 * element by using EXISTS and DELETE if possible.
4802 * Fallback to FETCH and STORE otherwise. */
4803 preeminent = av_exists(av, elem);
4806 svp = av_fetch(av, elem, lval);
4808 if (!svp || *svp == &PL_sv_undef)
4809 DIE(aTHX_ PL_no_aelem, elem);
4812 save_aelem(av, elem, svp);
4814 SAVEADELETE(av, elem);
4817 *MARK = svp ? *svp : &PL_sv_undef;
4820 if (GIMME != G_ARRAY) {
4822 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4828 /* Smart dereferencing for keys, values and each */
4841 /* N.B.: AMG macros return sv if no overloading is found */
4842 SV *maybe_hv = AMG_CALLunary(sv, to_hv_amg);
4843 SV *maybe_av = AMG_CALLunary(sv, to_av_amg);
4844 if ( maybe_hv != sv && maybe_av != sv ) {
4845 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4846 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4847 PL_op_desc[PL_op->op_type]
4852 else if ( maybe_av != sv ) {
4853 if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
4854 /* @{} overload, but underlying reftype is HV */
4855 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4856 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
4857 PL_op_desc[PL_op->op_type]
4863 else if ( maybe_hv != sv ) {
4864 if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
4865 /* %{} overload, but underlying reftype is AV */
4866 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4867 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4868 PL_op_desc[PL_op->op_type]
4878 if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
4879 DIE(aTHX_ "Type of argument to %s must be hashref or arrayref",
4880 PL_op_desc[PL_op->op_type] );
4883 /* Delegate to correct function for op type */
4885 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4886 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4889 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4897 AV *array = MUTABLE_AV(POPs);
4898 const I32 gimme = GIMME_V;
4899 IV *iterp = Perl_av_iter_p(aTHX_ array);
4900 const IV current = (*iterp)++;
4902 if (current > av_len(array)) {
4904 if (gimme == G_SCALAR)
4911 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4912 if (gimme == G_ARRAY) {
4913 SV **const element = av_fetch(array, current, 0);
4914 PUSHs(element ? *element : &PL_sv_undef);
4923 AV *array = MUTABLE_AV(POPs);
4924 const I32 gimme = GIMME_V;
4926 *Perl_av_iter_p(aTHX_ array) = 0;
4928 if (gimme == G_SCALAR) {
4930 PUSHi(av_len(array) + 1);
4932 else if (gimme == G_ARRAY) {
4933 IV n = Perl_av_len(aTHX_ array);
4934 IV i = CopARYBASE_get(PL_curcop);
4938 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4940 for (; i <= n; i++) {
4945 for (i = 0; i <= n; i++) {
4946 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4947 PUSHs(elem ? *elem : &PL_sv_undef);
4954 /* Associative arrays. */
4960 HV * hash = MUTABLE_HV(POPs);
4962 const I32 gimme = GIMME_V;
4965 /* might clobber stack_sp */
4966 entry = hv_iternext(hash);
4971 SV* const sv = hv_iterkeysv(entry);
4972 PUSHs(sv); /* won't clobber stack_sp */
4973 if (gimme == G_ARRAY) {
4976 /* might clobber stack_sp */
4977 val = hv_iterval(hash, entry);
4982 else if (gimme == G_SCALAR)
4989 S_do_delete_local(pTHX)
4993 const I32 gimme = GIMME_V;
4997 if (PL_op->op_private & OPpSLICE) {
4999 SV * const osv = POPs;
5000 const bool tied = SvRMAGICAL(osv)
5001 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5002 const bool can_preserve = SvCANEXISTDELETE(osv)
5003 || mg_find((const SV *)osv, PERL_MAGIC_env);
5004 const U32 type = SvTYPE(osv);
5005 if (type == SVt_PVHV) { /* hash element */
5006 HV * const hv = MUTABLE_HV(osv);
5007 while (++MARK <= SP) {
5008 SV * const keysv = *MARK;
5010 bool preeminent = TRUE;
5012 preeminent = hv_exists_ent(hv, keysv, 0);
5014 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5021 sv = hv_delete_ent(hv, keysv, 0, 0);
5022 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5025 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5027 *MARK = sv_mortalcopy(sv);
5033 SAVEHDELETE(hv, keysv);
5034 *MARK = &PL_sv_undef;
5038 else if (type == SVt_PVAV) { /* array element */
5039 if (PL_op->op_flags & OPf_SPECIAL) {
5040 AV * const av = MUTABLE_AV(osv);
5041 while (++MARK <= SP) {
5042 I32 idx = SvIV(*MARK);
5044 bool preeminent = TRUE;
5046 preeminent = av_exists(av, idx);
5048 SV **svp = av_fetch(av, idx, 1);
5055 sv = av_delete(av, idx, 0);
5056 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5059 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5061 *MARK = sv_mortalcopy(sv);
5067 SAVEADELETE(av, idx);
5068 *MARK = &PL_sv_undef;
5074 DIE(aTHX_ "Not a HASH reference");
5075 if (gimme == G_VOID)
5077 else if (gimme == G_SCALAR) {
5082 *++MARK = &PL_sv_undef;
5087 SV * const keysv = POPs;
5088 SV * const osv = POPs;
5089 const bool tied = SvRMAGICAL(osv)
5090 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5091 const bool can_preserve = SvCANEXISTDELETE(osv)
5092 || mg_find((const SV *)osv, PERL_MAGIC_env);
5093 const U32 type = SvTYPE(osv);
5095 if (type == SVt_PVHV) {
5096 HV * const hv = MUTABLE_HV(osv);
5097 bool preeminent = TRUE;
5099 preeminent = hv_exists_ent(hv, keysv, 0);
5101 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5108 sv = hv_delete_ent(hv, keysv, 0, 0);
5109 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5112 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5114 SV *nsv = sv_mortalcopy(sv);
5120 SAVEHDELETE(hv, keysv);
5122 else if (type == SVt_PVAV) {
5123 if (PL_op->op_flags & OPf_SPECIAL) {
5124 AV * const av = MUTABLE_AV(osv);
5125 I32 idx = SvIV(keysv);
5126 bool preeminent = TRUE;
5128 preeminent = av_exists(av, idx);
5130 SV **svp = av_fetch(av, idx, 1);
5137 sv = av_delete(av, idx, 0);
5138 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5141 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5143 SV *nsv = sv_mortalcopy(sv);
5149 SAVEADELETE(av, idx);
5152 DIE(aTHX_ "panic: avhv_delete no longer supported");
5155 DIE(aTHX_ "Not a HASH reference");
5158 if (gimme != G_VOID)
5172 if (PL_op->op_private & OPpLVAL_INTRO)
5173 return do_delete_local();
5176 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5178 if (PL_op->op_private & OPpSLICE) {
5180 HV * const hv = MUTABLE_HV(POPs);
5181 const U32 hvtype = SvTYPE(hv);
5182 if (hvtype == SVt_PVHV) { /* hash element */
5183 while (++MARK <= SP) {
5184 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5185 *MARK = sv ? sv : &PL_sv_undef;
5188 else if (hvtype == SVt_PVAV) { /* array element */
5189 if (PL_op->op_flags & OPf_SPECIAL) {
5190 while (++MARK <= SP) {
5191 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5192 *MARK = sv ? sv : &PL_sv_undef;
5197 DIE(aTHX_ "Not a HASH reference");
5200 else if (gimme == G_SCALAR) {
5205 *++MARK = &PL_sv_undef;
5211 HV * const hv = MUTABLE_HV(POPs);
5213 if (SvTYPE(hv) == SVt_PVHV)
5214 sv = hv_delete_ent(hv, keysv, discard, 0);
5215 else if (SvTYPE(hv) == SVt_PVAV) {
5216 if (PL_op->op_flags & OPf_SPECIAL)
5217 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5219 DIE(aTHX_ "panic: avhv_delete no longer supported");
5222 DIE(aTHX_ "Not a HASH reference");
5238 if (PL_op->op_private & OPpEXISTS_SUB) {
5240 SV * const sv = POPs;
5241 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5244 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5249 hv = MUTABLE_HV(POPs);
5250 if (SvTYPE(hv) == SVt_PVHV) {
5251 if (hv_exists_ent(hv, tmpsv, 0))
5254 else if (SvTYPE(hv) == SVt_PVAV) {
5255 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5256 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5261 DIE(aTHX_ "Not a HASH reference");
5268 dVAR; dSP; dMARK; dORIGMARK;
5269 register HV * const hv = MUTABLE_HV(POPs);
5270 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5271 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5272 bool can_preserve = FALSE;
5278 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
5279 can_preserve = TRUE;
5282 while (++MARK <= SP) {
5283 SV * const keysv = *MARK;
5286 bool preeminent = TRUE;
5288 if (localizing && can_preserve) {
5289 /* If we can determine whether the element exist,
5290 * try to preserve the existenceness of a tied hash
5291 * element by using EXISTS and DELETE if possible.
5292 * Fallback to FETCH and STORE otherwise. */
5293 preeminent = hv_exists_ent(hv, keysv, 0);
5296 he = hv_fetch_ent(hv, keysv, lval, 0);
5297 svp = he ? &HeVAL(he) : NULL;
5300 if (!svp || *svp == &PL_sv_undef) {
5301 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5304 if (HvNAME_get(hv) && isGV(*svp))
5305 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5306 else if (preeminent)
5307 save_helem_flags(hv, keysv, svp,
5308 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5310 SAVEHDELETE(hv, keysv);
5313 *MARK = svp ? *svp : &PL_sv_undef;
5315 if (GIMME != G_ARRAY) {
5317 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5323 /* List operators. */
5328 if (GIMME != G_ARRAY) {
5330 *MARK = *SP; /* unwanted list, return last item */
5332 *MARK = &PL_sv_undef;
5342 SV ** const lastrelem = PL_stack_sp;
5343 SV ** const lastlelem = PL_stack_base + POPMARK;
5344 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5345 register SV ** const firstrelem = lastlelem + 1;
5346 const I32 arybase = CopARYBASE_get(PL_curcop);
5347 I32 is_something_there = FALSE;
5349 register const I32 max = lastrelem - lastlelem;
5350 register SV **lelem;
5352 if (GIMME != G_ARRAY) {
5353 I32 ix = SvIV(*lastlelem);
5358 if (ix < 0 || ix >= max)
5359 *firstlelem = &PL_sv_undef;
5361 *firstlelem = firstrelem[ix];
5367 SP = firstlelem - 1;
5371 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5372 I32 ix = SvIV(*lelem);
5377 if (ix < 0 || ix >= max)
5378 *lelem = &PL_sv_undef;
5380 is_something_there = TRUE;
5381 if (!(*lelem = firstrelem[ix]))
5382 *lelem = &PL_sv_undef;
5385 if (is_something_there)
5388 SP = firstlelem - 1;
5394 dVAR; dSP; dMARK; dORIGMARK;
5395 const I32 items = SP - MARK;
5396 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5397 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5398 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5399 ? newRV_noinc(av) : av);
5405 dVAR; dSP; dMARK; dORIGMARK;
5406 HV* const hv = newHV();
5409 SV * const key = *++MARK;
5410 SV * const val = newSV(0);
5412 sv_setsv(val, *++MARK);
5414 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5415 (void)hv_store_ent(hv,key,val,0);
5418 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5419 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5425 dVAR; dSP; dMARK; dORIGMARK;
5426 register AV *ary = MUTABLE_AV(*++MARK);
5430 register I32 offset;
5431 register I32 length;
5435 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5438 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
5439 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5446 offset = i = SvIV(*MARK);
5448 offset += AvFILLp(ary) + 1;
5450 offset -= CopARYBASE_get(PL_curcop);
5452 DIE(aTHX_ PL_no_aelem, i);
5454 length = SvIVx(*MARK++);
5456 length += AvFILLp(ary) - offset + 1;
5462 length = AvMAX(ary) + 1; /* close enough to infinity */
5466 length = AvMAX(ary) + 1;
5468 if (offset > AvFILLp(ary) + 1) {
5469 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5470 offset = AvFILLp(ary) + 1;
5472 after = AvFILLp(ary) + 1 - (offset + length);
5473 if (after < 0) { /* not that much array */
5474 length += after; /* offset+length now in array */
5480 /* At this point, MARK .. SP-1 is our new LIST */
5483 diff = newlen - length;
5484 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5487 /* make new elements SVs now: avoid problems if they're from the array */
5488 for (dst = MARK, i = newlen; i; i--) {
5489 SV * const h = *dst;
5490 *dst++ = newSVsv(h);
5493 if (diff < 0) { /* shrinking the area */
5494 SV **tmparyval = NULL;
5496 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5497 Copy(MARK, tmparyval, newlen, SV*);
5500 MARK = ORIGMARK + 1;
5501 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5502 MEXTEND(MARK, length);
5503 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5505 EXTEND_MORTAL(length);
5506 for (i = length, dst = MARK; i; i--) {
5507 sv_2mortal(*dst); /* free them eventually */
5514 *MARK = AvARRAY(ary)[offset+length-1];
5517 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5518 SvREFCNT_dec(*dst++); /* free them now */
5521 AvFILLp(ary) += diff;
5523 /* pull up or down? */
5525 if (offset < after) { /* easier to pull up */
5526 if (offset) { /* esp. if nothing to pull */
5527 src = &AvARRAY(ary)[offset-1];
5528 dst = src - diff; /* diff is negative */
5529 for (i = offset; i > 0; i--) /* can't trust Copy */
5533 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5537 if (after) { /* anything to pull down? */
5538 src = AvARRAY(ary) + offset + length;
5539 dst = src + diff; /* diff is negative */
5540 Move(src, dst, after, SV*);
5542 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5543 /* avoid later double free */
5547 dst[--i] = &PL_sv_undef;
5550 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5551 Safefree(tmparyval);
5554 else { /* no, expanding (or same) */
5555 SV** tmparyval = NULL;
5557 Newx(tmparyval, length, SV*); /* so remember deletion */
5558 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5561 if (diff > 0) { /* expanding */
5562 /* push up or down? */
5563 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5567 Move(src, dst, offset, SV*);
5569 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5571 AvFILLp(ary) += diff;
5574 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5575 av_extend(ary, AvFILLp(ary) + diff);
5576 AvFILLp(ary) += diff;
5579 dst = AvARRAY(ary) + AvFILLp(ary);
5581 for (i = after; i; i--) {
5589 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5592 MARK = ORIGMARK + 1;
5593 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5595 Copy(tmparyval, MARK, length, SV*);
5597 EXTEND_MORTAL(length);
5598 for (i = length, dst = MARK; i; i--) {
5599 sv_2mortal(*dst); /* free them eventually */
5606 else if (length--) {
5607 *MARK = tmparyval[length];
5610 while (length-- > 0)
5611 SvREFCNT_dec(tmparyval[length]);
5615 *MARK = &PL_sv_undef;
5616 Safefree(tmparyval);
5620 mg_set(MUTABLE_SV(ary));
5628 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5629 register AV * const ary = MUTABLE_AV(*++MARK);
5630 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5633 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5636 ENTER_with_name("call_PUSH");
5637 call_method("PUSH",G_SCALAR|G_DISCARD);
5638 LEAVE_with_name("call_PUSH");
5642 PL_delaymagic = DM_DELAY;
5643 for (++MARK; MARK <= SP; MARK++) {
5644 SV * const sv = newSV(0);
5646 sv_setsv(sv, *MARK);
5647 av_store(ary, AvFILLp(ary)+1, sv);
5649 if (PL_delaymagic & DM_ARRAY_ISA)
5650 mg_set(MUTABLE_SV(ary));
5655 if (OP_GIMME(PL_op, 0) != G_VOID) {
5656 PUSHi( AvFILL(ary) + 1 );
5665 AV * const av = PL_op->op_flags & OPf_SPECIAL
5666 ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5667 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5671 (void)sv_2mortal(sv);
5678 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5679 register AV *ary = MUTABLE_AV(*++MARK);
5680 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5683 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5686 ENTER_with_name("call_UNSHIFT");
5687 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5688 LEAVE_with_name("call_UNSHIFT");
5693 av_unshift(ary, SP - MARK);
5695 SV * const sv = newSVsv(*++MARK);
5696 (void)av_store(ary, i++, sv);
5700 if (OP_GIMME(PL_op, 0) != G_VOID) {
5701 PUSHi( AvFILL(ary) + 1 );
5710 if (GIMME == G_ARRAY) {
5711 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5715 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5716 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5717 av = MUTABLE_AV((*SP));
5718 /* In-place reversing only happens in void context for the array
5719 * assignment. We don't need to push anything on the stack. */
5722 if (SvMAGICAL(av)) {
5724 register SV *tmp = sv_newmortal();
5725 /* For SvCANEXISTDELETE */
5728 bool can_preserve = SvCANEXISTDELETE(av);
5730 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5731 register SV *begin, *end;
5734 if (!av_exists(av, i)) {
5735 if (av_exists(av, j)) {
5736 register SV *sv = av_delete(av, j, 0);
5737 begin = *av_fetch(av, i, TRUE);
5738 sv_setsv_mg(begin, sv);
5742 else if (!av_exists(av, j)) {
5743 register SV *sv = av_delete(av, i, 0);
5744 end = *av_fetch(av, j, TRUE);
5745 sv_setsv_mg(end, sv);
5750 begin = *av_fetch(av, i, TRUE);
5751 end = *av_fetch(av, j, TRUE);
5752 sv_setsv(tmp, begin);
5753 sv_setsv_mg(begin, end);
5754 sv_setsv_mg(end, tmp);
5758 SV **begin = AvARRAY(av);
5761 SV **end = begin + AvFILLp(av);
5763 while (begin < end) {
5764 register SV * const tmp = *begin;
5775 register SV * const tmp = *MARK;
5779 /* safe as long as stack cannot get extended in the above */
5785 register char *down;
5790 SvUTF8_off(TARG); /* decontaminate */
5792 do_join(TARG, &PL_sv_no, MARK, SP);
5794 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5795 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5796 report_uninit(TARG);
5799 up = SvPV_force(TARG, len);
5801 if (DO_UTF8(TARG)) { /* first reverse each character */
5802 U8* s = (U8*)SvPVX(TARG);
5803 const U8* send = (U8*)(s + len);
5805 if (UTF8_IS_INVARIANT(*s)) {
5810 if (!utf8_to_uvchr(s, 0))
5814 down = (char*)(s - 1);
5815 /* reverse this character */
5819 *down-- = (char)tmp;
5825 down = SvPVX(TARG) + len - 1;
5829 *down-- = (char)tmp;
5831 (void)SvPOK_only_UTF8(TARG);
5843 register IV limit = POPi; /* note, negative is forever */
5844 SV * const sv = POPs;
5846 register const char *s = SvPV_const(sv, len);
5847 const bool do_utf8 = DO_UTF8(sv);
5848 const char *strend = s + len;
5850 register REGEXP *rx;
5852 register const char *m;
5854 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5855 I32 maxiters = slen + 10;
5856 I32 trailing_empty = 0;
5858 const I32 origlimit = limit;
5861 const I32 gimme = GIMME_V;
5863 const I32 oldsave = PL_savestack_ix;
5864 U32 make_mortal = SVs_TEMP;
5869 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5874 DIE(aTHX_ "panic: pp_split");
5877 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5878 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5880 RX_MATCH_UTF8_set(rx, do_utf8);
5883 if (pm->op_pmreplrootu.op_pmtargetoff) {
5884 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5887 if (pm->op_pmreplrootu.op_pmtargetgv) {
5888 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5893 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5899 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5901 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5908 for (i = AvFILLp(ary); i >= 0; i--)
5909 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5911 /* temporarily switch stacks */
5912 SAVESWITCHSTACK(PL_curstack, ary);
5916 base = SP - PL_stack_base;
5918 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5920 while (*s == ' ' || is_utf8_space((U8*)s))
5923 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5924 while (isSPACE_LC(*s))
5932 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5936 gimme_scalar = gimme == G_SCALAR && !ary;
5939 limit = maxiters + 2;
5940 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5943 /* this one uses 'm' and is a negative test */
5945 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5946 const int t = UTF8SKIP(m);
5947 /* is_utf8_space returns FALSE for malform utf8 */
5954 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5955 while (m < strend && !isSPACE_LC(*m))
5958 while (m < strend && !isSPACE(*m))
5971 dstr = newSVpvn_flags(s, m-s,
5972 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5976 /* skip the whitespace found last */
5978 s = m + UTF8SKIP(m);
5982 /* this one uses 's' and is a positive test */
5984 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5987 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5988 while (s < strend && isSPACE_LC(*s))
5991 while (s < strend && isSPACE(*s))
5996 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5998 for (m = s; m < strend && *m != '\n'; m++)
6011 dstr = newSVpvn_flags(s, m-s,
6012 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6018 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6020 Pre-extend the stack, either the number of bytes or
6021 characters in the string or a limited amount, triggered by:
6023 my ($x, $y) = split //, $str;
6027 if (!gimme_scalar) {
6028 const U32 items = limit - 1;
6037 /* keep track of how many bytes we skip over */
6047 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6060 dstr = newSVpvn(s, 1);
6076 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6077 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6078 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6079 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
6080 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6081 SV * const csv = CALLREG_INTUIT_STRING(rx);
6083 len = RX_MINLENRET(rx);
6084 if (len == 1 && !RX_UTF8(rx) && !tail) {
6085 const char c = *SvPV_nolen_const(csv);
6087 for (m = s; m < strend && *m != c; m++)
6098 dstr = newSVpvn_flags(s, m-s,
6099 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6102 /* The rx->minlen is in characters but we want to step
6103 * s ahead by bytes. */
6105 s = (char*)utf8_hop((U8*)m, len);
6107 s = m + len; /* Fake \n at the end */
6111 while (s < strend && --limit &&
6112 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6113 csv, multiline ? FBMrf_MULTILINE : 0)) )
6122 dstr = newSVpvn_flags(s, m-s,
6123 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6126 /* The rx->minlen is in characters but we want to step
6127 * s ahead by bytes. */
6129 s = (char*)utf8_hop((U8*)m, len);
6131 s = m + len; /* Fake \n at the end */
6136 maxiters += slen * RX_NPARENS(rx);
6137 while (s < strend && --limit)
6141 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
6144 if (rex_return == 0)
6146 TAINT_IF(RX_MATCH_TAINTED(rx));
6147 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
6150 orig = RX_SUBBEG(rx);
6152 strend = s + (strend - m);
6154 m = RX_OFFS(rx)[0].start + orig;
6163 dstr = newSVpvn_flags(s, m-s,
6164 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6167 if (RX_NPARENS(rx)) {
6169 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6170 s = RX_OFFS(rx)[i].start + orig;
6171 m = RX_OFFS(rx)[i].end + orig;
6173 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6174 parens that didn't match -- they should be set to
6175 undef, not the empty string */
6183 if (m >= orig && s >= orig) {
6184 dstr = newSVpvn_flags(s, m-s,
6185 (do_utf8 ? SVf_UTF8 : 0)
6189 dstr = &PL_sv_undef; /* undef, not "" */
6195 s = RX_OFFS(rx)[0].end + orig;
6199 if (!gimme_scalar) {
6200 iters = (SP - PL_stack_base) - base;
6202 if (iters > maxiters)
6203 DIE(aTHX_ "Split loop");
6205 /* keep field after final delim? */
6206 if (s < strend || (iters && origlimit)) {
6207 if (!gimme_scalar) {
6208 const STRLEN l = strend - s;
6209 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6214 else if (!origlimit) {
6216 iters -= trailing_empty;
6218 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6219 if (TOPs && !make_mortal)
6221 *SP-- = &PL_sv_undef;
6228 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6232 if (SvSMAGICAL(ary)) {
6234 mg_set(MUTABLE_SV(ary));
6237 if (gimme == G_ARRAY) {
6239 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6246 ENTER_with_name("call_PUSH");
6247 call_method("PUSH",G_SCALAR|G_DISCARD);
6248 LEAVE_with_name("call_PUSH");
6250 if (gimme == G_ARRAY) {
6252 /* EXTEND should not be needed - we just popped them */
6254 for (i=0; i < iters; i++) {
6255 SV **svp = av_fetch(ary, i, FALSE);
6256 PUSHs((svp) ? *svp : &PL_sv_undef);
6263 if (gimme == G_ARRAY)
6275 SV *const sv = PAD_SVl(PL_op->op_targ);
6277 if (SvPADSTALE(sv)) {
6280 RETURNOP(cLOGOP->op_other);
6282 RETURNOP(cLOGOP->op_next);
6291 assert(SvTYPE(retsv) != SVt_PVCV);
6293 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6294 retsv = refto(retsv);
6301 PP(unimplemented_op)
6304 const Optype op_type = PL_op->op_type;
6305 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6306 with out of range op numbers - it only "special" cases op_custom.
6307 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6308 if we get here for a custom op then that means that the custom op didn't
6309 have an implementation. Given that OP_NAME() looks up the custom op
6310 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6311 registers &PL_unimplemented_op as the address of their custom op.
6312 NULL doesn't generate a useful error message. "custom" does. */
6313 const char *const name = op_type >= OP_max
6314 ? "[out of range]" : PL_op_name[PL_op->op_type];
6315 if(OP_IS_SOCKET(op_type))
6316 DIE(aTHX_ PL_no_sock_func, name);
6317 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6324 HV * const hv = (HV*)POPs;
6326 if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
6328 if (SvRMAGICAL(hv)) {
6329 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6331 XPUSHs(magic_scalarpack(hv, mg));
6336 XPUSHs(boolSV(HvKEYS(hv) != 0));
6342 * c-indentation-style: bsd
6344 * indent-tabs-mode: t
6347 * ex: set ts=8 sts=4 sw=4 noet: