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));
715 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv)) {
716 /* No point in studying a zero length string, and not safe to study
717 anything that doesn't appear to be a simple scalar (and hence might
718 change between now and when the regexp engine runs without our set
719 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 if (pos > PL_maxscream) {
732 if (PL_maxscream < 0) {
733 PL_maxscream = pos + 80;
734 Newx(PL_screamfirst, 256, I32);
735 Newx(PL_screamnext, PL_maxscream, I32);
738 PL_maxscream = pos + pos / 4;
739 Renew(PL_screamnext, PL_maxscream, I32);
743 sfirst = PL_screamfirst;
744 snext = PL_screamnext;
746 if (!sfirst || !snext)
747 DIE(aTHX_ "do_study: out of memory");
749 for (ch = 256; ch; --ch)
754 register const I32 ch = s[pos];
756 snext[pos] = sfirst[ch] - pos;
763 /* piggyback on m//g magic */
764 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
773 if (PL_op->op_flags & OPf_STACKED)
775 else if (PL_op->op_private & OPpTARGET_MY)
781 TARG = sv_newmortal();
782 if(PL_op->op_type == OP_TRANSR) {
783 SV * const newsv = newSVsv(sv);
787 else PUSHi(do_trans(sv));
791 /* Lvalue operators. */
794 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
800 PERL_ARGS_ASSERT_DO_CHOMP;
802 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
804 if (SvTYPE(sv) == SVt_PVAV) {
806 AV *const av = MUTABLE_AV(sv);
807 const I32 max = AvFILL(av);
809 for (i = 0; i <= max; i++) {
810 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
811 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
812 do_chomp(retval, sv, chomping);
816 else if (SvTYPE(sv) == SVt_PVHV) {
817 HV* const hv = MUTABLE_HV(sv);
819 (void)hv_iterinit(hv);
820 while ((entry = hv_iternext(hv)))
821 do_chomp(retval, hv_iterval(hv,entry), chomping);
824 else if (SvREADONLY(sv)) {
826 /* SV is copy-on-write */
827 sv_force_normal_flags(sv, 0);
830 Perl_croak_no_modify(aTHX);
835 /* XXX, here sv is utf8-ized as a side-effect!
836 If encoding.pm is used properly, almost string-generating
837 operations, including literal strings, chr(), input data, etc.
838 should have been utf8-ized already, right?
840 sv_recode_to_utf8(sv, PL_encoding);
846 char *temp_buffer = NULL;
855 while (len && s[-1] == '\n') {
862 STRLEN rslen, rs_charlen;
863 const char *rsptr = SvPV_const(PL_rs, rslen);
865 rs_charlen = SvUTF8(PL_rs)
869 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
870 /* Assumption is that rs is shorter than the scalar. */
872 /* RS is utf8, scalar is 8 bit. */
874 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
877 /* Cannot downgrade, therefore cannot possibly match
879 assert (temp_buffer == rsptr);
885 else if (PL_encoding) {
886 /* RS is 8 bit, encoding.pm is used.
887 * Do not recode PL_rs as a side-effect. */
888 svrecode = newSVpvn(rsptr, rslen);
889 sv_recode_to_utf8(svrecode, PL_encoding);
890 rsptr = SvPV_const(svrecode, rslen);
891 rs_charlen = sv_len_utf8(svrecode);
894 /* RS is 8 bit, scalar is utf8. */
895 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
909 if (memNE(s, rsptr, rslen))
911 SvIVX(retval) += rs_charlen;
914 s = SvPV_force_nolen(sv);
922 SvREFCNT_dec(svrecode);
924 Safefree(temp_buffer);
926 if (len && !SvPOK(sv))
927 s = SvPV_force_nomg(sv, len);
930 char * const send = s + len;
931 char * const start = s;
933 while (s > start && UTF8_IS_CONTINUATION(*s))
935 if (is_utf8_string((U8*)s, send - s)) {
936 sv_setpvn(retval, s, send - s);
938 SvCUR_set(sv, s - start);
944 sv_setpvs(retval, "");
948 sv_setpvn(retval, s, 1);
955 sv_setpvs(retval, "");
963 const bool chomping = PL_op->op_type == OP_SCHOMP;
967 do_chomp(TARG, TOPs, chomping);
974 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
975 const bool chomping = PL_op->op_type == OP_CHOMP;
980 do_chomp(TARG, *++MARK, chomping);
991 if (!PL_op->op_private) {
1000 SV_CHECK_THINKFIRST_COW_DROP(sv);
1002 switch (SvTYPE(sv)) {
1006 av_undef(MUTABLE_AV(sv));
1009 hv_undef(MUTABLE_HV(sv));
1012 if (cv_const_sv((const CV *)sv))
1013 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
1014 CvANON((const CV *)sv) ? "(anonymous)"
1015 : GvENAME(CvGV((const CV *)sv)));
1019 /* let user-undef'd sub keep its identity */
1020 GV* const gv = CvGV((const CV *)sv);
1021 cv_undef(MUTABLE_CV(sv));
1022 CvGV_set(MUTABLE_CV(sv), gv);
1027 SvSetMagicSV(sv, &PL_sv_undef);
1030 else if (isGV_with_GP(sv)) {
1034 /* undef *Pkg::meth_name ... */
1036 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1037 && HvENAME_get(stash);
1039 if((stash = GvHV((const GV *)sv))) {
1040 if(HvENAME_get(stash))
1041 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1045 gp_free(MUTABLE_GV(sv));
1047 GvGP_set(sv, gp_ref(gp));
1048 GvSV(sv) = newSV(0);
1049 GvLINE(sv) = CopLINE(PL_curcop);
1050 GvEGV(sv) = MUTABLE_GV(sv);
1054 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1056 /* undef *Foo::ISA */
1057 if( strEQ(GvNAME((const GV *)sv), "ISA")
1058 && (stash = GvSTASH((const GV *)sv))
1059 && (method_changed || HvENAME(stash)) )
1060 mro_isa_changed_in(stash);
1061 else if(method_changed)
1062 mro_method_changed_in(
1063 GvSTASH((const GV *)sv)
1070 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1085 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1086 Perl_croak_no_modify(aTHX);
1087 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1088 && SvIVX(TOPs) != IV_MIN)
1090 SvIV_set(TOPs, SvIVX(TOPs) - 1);
1091 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1102 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1103 Perl_croak_no_modify(aTHX);
1105 TARG = sv_newmortal();
1106 sv_setsv(TARG, TOPs);
1107 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1108 && SvIVX(TOPs) != IV_MAX)
1110 SvIV_set(TOPs, SvIVX(TOPs) + 1);
1111 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1116 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1126 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1127 Perl_croak_no_modify(aTHX);
1129 TARG = sv_newmortal();
1130 sv_setsv(TARG, TOPs);
1131 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1132 && SvIVX(TOPs) != IV_MIN)
1134 SvIV_set(TOPs, SvIVX(TOPs) - 1);
1135 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1144 /* Ordinary operators. */
1148 dVAR; dSP; dATARGET; SV *svl, *svr;
1149 #ifdef PERL_PRESERVE_IVUV
1152 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1155 #ifdef PERL_PRESERVE_IVUV
1156 /* For integer to integer power, we do the calculation by hand wherever
1157 we're sure it is safe; otherwise we call pow() and try to convert to
1158 integer afterwards. */
1160 SvIV_please_nomg(svr);
1162 SvIV_please_nomg(svl);
1171 const IV iv = SvIVX(svr);
1175 goto float_it; /* Can't do negative powers this way. */
1179 baseuok = SvUOK(svl);
1181 baseuv = SvUVX(svl);
1183 const IV iv = SvIVX(svl);
1186 baseuok = TRUE; /* effectively it's a UV now */
1188 baseuv = -iv; /* abs, baseuok == false records sign */
1191 /* now we have integer ** positive integer. */
1194 /* foo & (foo - 1) is zero only for a power of 2. */
1195 if (!(baseuv & (baseuv - 1))) {
1196 /* We are raising power-of-2 to a positive integer.
1197 The logic here will work for any base (even non-integer
1198 bases) but it can be less accurate than
1199 pow (base,power) or exp (power * log (base)) when the
1200 intermediate values start to spill out of the mantissa.
1201 With powers of 2 we know this can't happen.
1202 And powers of 2 are the favourite thing for perl
1203 programmers to notice ** not doing what they mean. */
1205 NV base = baseuok ? baseuv : -(NV)baseuv;
1210 while (power >>= 1) {
1218 SvIV_please_nomg(svr);
1221 register unsigned int highbit = 8 * sizeof(UV);
1222 register unsigned int diff = 8 * sizeof(UV);
1223 while (diff >>= 1) {
1225 if (baseuv >> highbit) {
1229 /* we now have baseuv < 2 ** highbit */
1230 if (power * highbit <= 8 * sizeof(UV)) {
1231 /* result will definitely fit in UV, so use UV math
1232 on same algorithm as above */
1233 register UV result = 1;
1234 register UV base = baseuv;
1235 const bool odd_power = cBOOL(power & 1);
1239 while (power >>= 1) {
1246 if (baseuok || !odd_power)
1247 /* answer is positive */
1249 else if (result <= (UV)IV_MAX)
1250 /* answer negative, fits in IV */
1251 SETi( -(IV)result );
1252 else if (result == (UV)IV_MIN)
1253 /* 2's complement assumption: special case IV_MIN */
1256 /* answer negative, doesn't fit */
1257 SETn( -(NV)result );
1267 NV right = SvNV_nomg(svr);
1268 NV left = SvNV_nomg(svl);
1271 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1273 We are building perl with long double support and are on an AIX OS
1274 afflicted with a powl() function that wrongly returns NaNQ for any
1275 negative base. This was reported to IBM as PMR #23047-379 on
1276 03/06/2006. The problem exists in at least the following versions
1277 of AIX and the libm fileset, and no doubt others as well:
1279 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1280 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1281 AIX 5.2.0 bos.adt.libm 5.2.0.85
1283 So, until IBM fixes powl(), we provide the following workaround to
1284 handle the problem ourselves. Our logic is as follows: for
1285 negative bases (left), we use fmod(right, 2) to check if the
1286 exponent is an odd or even integer:
1288 - if odd, powl(left, right) == -powl(-left, right)
1289 - if even, powl(left, right) == powl(-left, right)
1291 If the exponent is not an integer, the result is rightly NaNQ, so
1292 we just return that (as NV_NAN).
1296 NV mod2 = Perl_fmod( right, 2.0 );
1297 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1298 SETn( -Perl_pow( -left, right) );
1299 } else if (mod2 == 0.0) { /* even integer */
1300 SETn( Perl_pow( -left, right) );
1301 } else { /* fractional power */
1305 SETn( Perl_pow( left, right) );
1308 SETn( Perl_pow( left, right) );
1309 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1311 #ifdef PERL_PRESERVE_IVUV
1313 SvIV_please_nomg(svr);
1321 dVAR; dSP; dATARGET; SV *svl, *svr;
1322 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1325 #ifdef PERL_PRESERVE_IVUV
1326 SvIV_please_nomg(svr);
1328 /* Unless the left argument is integer in range we are going to have to
1329 use NV maths. Hence only attempt to coerce the right argument if
1330 we know the left is integer. */
1331 /* Left operand is defined, so is it IV? */
1332 SvIV_please_nomg(svl);
1334 bool auvok = SvUOK(svl);
1335 bool buvok = SvUOK(svr);
1336 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1337 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1346 const IV aiv = SvIVX(svl);
1349 auvok = TRUE; /* effectively it's a UV now */
1351 alow = -aiv; /* abs, auvok == false records sign */
1357 const IV biv = SvIVX(svr);
1360 buvok = TRUE; /* effectively it's a UV now */
1362 blow = -biv; /* abs, buvok == false records sign */
1366 /* If this does sign extension on unsigned it's time for plan B */
1367 ahigh = alow >> (4 * sizeof (UV));
1369 bhigh = blow >> (4 * sizeof (UV));
1371 if (ahigh && bhigh) {
1373 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1374 which is overflow. Drop to NVs below. */
1375 } else if (!ahigh && !bhigh) {
1376 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1377 so the unsigned multiply cannot overflow. */
1378 const UV product = alow * blow;
1379 if (auvok == buvok) {
1380 /* -ve * -ve or +ve * +ve gives a +ve result. */
1384 } else if (product <= (UV)IV_MIN) {
1385 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1386 /* -ve result, which could overflow an IV */
1388 SETi( -(IV)product );
1390 } /* else drop to NVs below. */
1392 /* One operand is large, 1 small */
1395 /* swap the operands */
1397 bhigh = blow; /* bhigh now the temp var for the swap */
1401 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1402 multiplies can't overflow. shift can, add can, -ve can. */
1403 product_middle = ahigh * blow;
1404 if (!(product_middle & topmask)) {
1405 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1407 product_middle <<= (4 * sizeof (UV));
1408 product_low = alow * blow;
1410 /* as for pp_add, UV + something mustn't get smaller.
1411 IIRC ANSI mandates this wrapping *behaviour* for
1412 unsigned whatever the actual representation*/
1413 product_low += product_middle;
1414 if (product_low >= product_middle) {
1415 /* didn't overflow */
1416 if (auvok == buvok) {
1417 /* -ve * -ve or +ve * +ve gives a +ve result. */
1419 SETu( product_low );
1421 } else if (product_low <= (UV)IV_MIN) {
1422 /* 2s complement assumption again */
1423 /* -ve result, which could overflow an IV */
1425 SETi( -(IV)product_low );
1427 } /* else drop to NVs below. */
1429 } /* product_middle too large */
1430 } /* ahigh && bhigh */
1435 NV right = SvNV_nomg(svr);
1436 NV left = SvNV_nomg(svl);
1438 SETn( left * right );
1445 dVAR; dSP; dATARGET; SV *svl, *svr;
1446 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1449 /* Only try to do UV divide first
1450 if ((SLOPPYDIVIDE is true) or
1451 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1453 The assumption is that it is better to use floating point divide
1454 whenever possible, only doing integer divide first if we can't be sure.
1455 If NV_PRESERVES_UV is true then we know at compile time that no UV
1456 can be too large to preserve, so don't need to compile the code to
1457 test the size of UVs. */
1460 # define PERL_TRY_UV_DIVIDE
1461 /* ensure that 20./5. == 4. */
1463 # ifdef PERL_PRESERVE_IVUV
1464 # ifndef NV_PRESERVES_UV
1465 # define PERL_TRY_UV_DIVIDE
1470 #ifdef PERL_TRY_UV_DIVIDE
1471 SvIV_please_nomg(svr);
1473 SvIV_please_nomg(svl);
1475 bool left_non_neg = SvUOK(svl);
1476 bool right_non_neg = SvUOK(svr);
1480 if (right_non_neg) {
1484 const IV biv = SvIVX(svr);
1487 right_non_neg = TRUE; /* effectively it's a UV now */
1493 /* historically undef()/0 gives a "Use of uninitialized value"
1494 warning before dieing, hence this test goes here.
1495 If it were immediately before the second SvIV_please, then
1496 DIE() would be invoked before left was even inspected, so
1497 no inspection would give no warning. */
1499 DIE(aTHX_ "Illegal division by zero");
1505 const IV aiv = SvIVX(svl);
1508 left_non_neg = TRUE; /* effectively it's a UV now */
1517 /* For sloppy divide we always attempt integer division. */
1519 /* Otherwise we only attempt it if either or both operands
1520 would not be preserved by an NV. If both fit in NVs
1521 we fall through to the NV divide code below. However,
1522 as left >= right to ensure integer result here, we know that
1523 we can skip the test on the right operand - right big
1524 enough not to be preserved can't get here unless left is
1527 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1530 /* Integer division can't overflow, but it can be imprecise. */
1531 const UV result = left / right;
1532 if (result * right == left) {
1533 SP--; /* result is valid */
1534 if (left_non_neg == right_non_neg) {
1535 /* signs identical, result is positive. */
1539 /* 2s complement assumption */
1540 if (result <= (UV)IV_MIN)
1541 SETi( -(IV)result );
1543 /* It's exact but too negative for IV. */
1544 SETn( -(NV)result );
1547 } /* tried integer divide but it was not an integer result */
1548 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1549 } /* left wasn't SvIOK */
1550 } /* right wasn't SvIOK */
1551 #endif /* PERL_TRY_UV_DIVIDE */
1553 NV right = SvNV_nomg(svr);
1554 NV left = SvNV_nomg(svl);
1555 (void)POPs;(void)POPs;
1556 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1557 if (! Perl_isnan(right) && right == 0.0)
1561 DIE(aTHX_ "Illegal division by zero");
1562 PUSHn( left / right );
1569 dVAR; dSP; dATARGET;
1570 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1574 bool left_neg = FALSE;
1575 bool right_neg = FALSE;
1576 bool use_double = FALSE;
1577 bool dright_valid = FALSE;
1580 SV * const svr = TOPs;
1581 SV * const svl = TOPm1s;
1582 SvIV_please_nomg(svr);
1584 right_neg = !SvUOK(svr);
1588 const IV biv = SvIVX(svr);
1591 right_neg = FALSE; /* effectively it's a UV now */
1598 dright = SvNV_nomg(svr);
1599 right_neg = dright < 0;
1602 if (dright < UV_MAX_P1) {
1603 right = U_V(dright);
1604 dright_valid = TRUE; /* In case we need to use double below. */
1610 /* At this point use_double is only true if right is out of range for
1611 a UV. In range NV has been rounded down to nearest UV and
1612 use_double false. */
1613 SvIV_please_nomg(svl);
1614 if (!use_double && SvIOK(svl)) {
1616 left_neg = !SvUOK(svl);
1620 const IV aiv = SvIVX(svl);
1623 left_neg = FALSE; /* effectively it's a UV now */
1631 dleft = SvNV_nomg(svl);
1632 left_neg = dleft < 0;
1636 /* This should be exactly the 5.6 behaviour - if left and right are
1637 both in range for UV then use U_V() rather than floor. */
1639 if (dleft < UV_MAX_P1) {
1640 /* right was in range, so is dleft, so use UVs not double.
1644 /* left is out of range for UV, right was in range, so promote
1645 right (back) to double. */
1647 /* The +0.5 is used in 5.6 even though it is not strictly
1648 consistent with the implicit +0 floor in the U_V()
1649 inside the #if 1. */
1650 dleft = Perl_floor(dleft + 0.5);
1653 dright = Perl_floor(dright + 0.5);
1664 DIE(aTHX_ "Illegal modulus zero");
1666 dans = Perl_fmod(dleft, dright);
1667 if ((left_neg != right_neg) && dans)
1668 dans = dright - dans;
1671 sv_setnv(TARG, dans);
1677 DIE(aTHX_ "Illegal modulus zero");
1680 if ((left_neg != right_neg) && ans)
1683 /* XXX may warn: unary minus operator applied to unsigned type */
1684 /* could change -foo to be (~foo)+1 instead */
1685 if (ans <= ~((UV)IV_MAX)+1)
1686 sv_setiv(TARG, ~ans+1);
1688 sv_setnv(TARG, -(NV)ans);
1691 sv_setuv(TARG, ans);
1700 dVAR; dSP; dATARGET;
1704 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1705 /* TODO: think of some way of doing list-repeat overloading ??? */
1710 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1716 const UV uv = SvUV_nomg(sv);
1718 count = IV_MAX; /* The best we can do? */
1722 const IV iv = SvIV_nomg(sv);
1729 else if (SvNOKp(sv)) {
1730 const NV nv = SvNV_nomg(sv);
1737 count = SvIV_nomg(sv);
1739 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1741 static const char oom_list_extend[] = "Out of memory during list extend";
1742 const I32 items = SP - MARK;
1743 const I32 max = items * count;
1745 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1746 /* Did the max computation overflow? */
1747 if (items > 0 && max > 0 && (max < items || max < count))
1748 Perl_croak(aTHX_ oom_list_extend);
1753 /* This code was intended to fix 20010809.028:
1756 for (($x =~ /./g) x 2) {
1757 print chop; # "abcdabcd" expected as output.
1760 * but that change (#11635) broke this code:
1762 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1764 * I can't think of a better fix that doesn't introduce
1765 * an efficiency hit by copying the SVs. The stack isn't
1766 * refcounted, and mortalisation obviously doesn't
1767 * Do The Right Thing when the stack has more than
1768 * one pointer to the same mortal value.
1772 *SP = sv_2mortal(newSVsv(*SP));
1782 repeatcpy((char*)(MARK + items), (char*)MARK,
1783 items * sizeof(const SV *), count - 1);
1786 else if (count <= 0)
1789 else { /* Note: mark already snarfed by pp_list */
1790 SV * const tmpstr = POPs;
1793 static const char oom_string_extend[] =
1794 "Out of memory during string extend";
1797 sv_setsv_nomg(TARG, tmpstr);
1798 SvPV_force_nomg(TARG, len);
1799 isutf = DO_UTF8(TARG);
1804 const STRLEN max = (UV)count * len;
1805 if (len > MEM_SIZE_MAX / count)
1806 Perl_croak(aTHX_ oom_string_extend);
1807 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1808 SvGROW(TARG, max + 1);
1809 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1810 SvCUR_set(TARG, SvCUR(TARG) * count);
1812 *SvEND(TARG) = '\0';
1815 (void)SvPOK_only_UTF8(TARG);
1817 (void)SvPOK_only(TARG);
1819 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1820 /* The parser saw this as a list repeat, and there
1821 are probably several items on the stack. But we're
1822 in scalar context, and there's no pp_list to save us
1823 now. So drop the rest of the items -- robin@kitsite.com
1835 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1836 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1839 useleft = USE_LEFT(svl);
1840 #ifdef PERL_PRESERVE_IVUV
1841 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1842 "bad things" happen if you rely on signed integers wrapping. */
1843 SvIV_please_nomg(svr);
1845 /* Unless the left argument is integer in range we are going to have to
1846 use NV maths. Hence only attempt to coerce the right argument if
1847 we know the left is integer. */
1848 register UV auv = 0;
1854 a_valid = auvok = 1;
1855 /* left operand is undef, treat as zero. */
1857 /* Left operand is defined, so is it IV? */
1858 SvIV_please_nomg(svl);
1860 if ((auvok = SvUOK(svl)))
1863 register const IV aiv = SvIVX(svl);
1866 auvok = 1; /* Now acting as a sign flag. */
1867 } else { /* 2s complement assumption for IV_MIN */
1875 bool result_good = 0;
1878 bool buvok = SvUOK(svr);
1883 register const IV biv = SvIVX(svr);
1890 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1891 else "IV" now, independent of how it came in.
1892 if a, b represents positive, A, B negative, a maps to -A etc
1897 all UV maths. negate result if A negative.
1898 subtract if signs same, add if signs differ. */
1900 if (auvok ^ buvok) {
1909 /* Must get smaller */
1914 if (result <= buv) {
1915 /* result really should be -(auv-buv). as its negation
1916 of true value, need to swap our result flag */
1928 if (result <= (UV)IV_MIN)
1929 SETi( -(IV)result );
1931 /* result valid, but out of range for IV. */
1932 SETn( -(NV)result );
1936 } /* Overflow, drop through to NVs. */
1941 NV value = SvNV_nomg(svr);
1945 /* left operand is undef, treat as zero - value */
1949 SETn( SvNV_nomg(svl) - value );
1956 dVAR; dSP; dATARGET; SV *svl, *svr;
1957 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1961 const IV shift = SvIV_nomg(svr);
1962 if (PL_op->op_private & HINT_INTEGER) {
1963 const IV i = SvIV_nomg(svl);
1967 const UV u = SvUV_nomg(svl);
1976 dVAR; dSP; dATARGET; SV *svl, *svr;
1977 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1981 const IV shift = SvIV_nomg(svr);
1982 if (PL_op->op_private & HINT_INTEGER) {
1983 const IV i = SvIV_nomg(svl);
1987 const UV u = SvUV_nomg(svl);
1997 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1998 #ifdef PERL_PRESERVE_IVUV
1999 SvIV_please_nomg(TOPs);
2001 SvIV_please_nomg(TOPm1s);
2002 if (SvIOK(TOPm1s)) {
2003 bool auvok = SvUOK(TOPm1s);
2004 bool buvok = SvUOK(TOPs);
2006 if (!auvok && !buvok) { /* ## IV < IV ## */
2007 const IV aiv = SvIVX(TOPm1s);
2008 const IV biv = SvIVX(TOPs);
2011 SETs(boolSV(aiv < biv));
2014 if (auvok && buvok) { /* ## UV < UV ## */
2015 const UV auv = SvUVX(TOPm1s);
2016 const UV buv = SvUVX(TOPs);
2019 SETs(boolSV(auv < buv));
2022 if (auvok) { /* ## UV < IV ## */
2024 const IV biv = SvIVX(TOPs);
2027 /* As (a) is a UV, it's >=0, so it cannot be < */
2032 SETs(boolSV(auv < (UV)biv));
2035 { /* ## IV < UV ## */
2036 const IV aiv = SvIVX(TOPm1s);
2040 /* As (b) is a UV, it's >=0, so it must be < */
2047 SETs(boolSV((UV)aiv < buv));
2053 #ifndef NV_PRESERVES_UV
2054 #ifdef PERL_PRESERVE_IVUV
2057 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2059 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
2064 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2066 if (Perl_isnan(left) || Perl_isnan(right))
2068 SETs(boolSV(left < right));
2071 SETs(boolSV(SvNV_nomg(TOPs) < value));
2080 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2081 #ifdef PERL_PRESERVE_IVUV
2082 SvIV_please_nomg(TOPs);
2084 SvIV_please_nomg(TOPm1s);
2085 if (SvIOK(TOPm1s)) {
2086 bool auvok = SvUOK(TOPm1s);
2087 bool buvok = SvUOK(TOPs);
2089 if (!auvok && !buvok) { /* ## IV > IV ## */
2090 const IV aiv = SvIVX(TOPm1s);
2091 const IV biv = SvIVX(TOPs);
2094 SETs(boolSV(aiv > biv));
2097 if (auvok && buvok) { /* ## UV > UV ## */
2098 const UV auv = SvUVX(TOPm1s);
2099 const UV buv = SvUVX(TOPs);
2102 SETs(boolSV(auv > buv));
2105 if (auvok) { /* ## UV > IV ## */
2107 const IV biv = SvIVX(TOPs);
2111 /* As (a) is a UV, it's >=0, so it must be > */
2116 SETs(boolSV(auv > (UV)biv));
2119 { /* ## IV > UV ## */
2120 const IV aiv = SvIVX(TOPm1s);
2124 /* As (b) is a UV, it's >=0, so it cannot be > */
2131 SETs(boolSV((UV)aiv > buv));
2137 #ifndef NV_PRESERVES_UV
2138 #ifdef PERL_PRESERVE_IVUV
2141 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2143 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
2148 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2150 if (Perl_isnan(left) || Perl_isnan(right))
2152 SETs(boolSV(left > right));
2155 SETs(boolSV(SvNV_nomg(TOPs) > value));
2164 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2165 #ifdef PERL_PRESERVE_IVUV
2166 SvIV_please_nomg(TOPs);
2168 SvIV_please_nomg(TOPm1s);
2169 if (SvIOK(TOPm1s)) {
2170 bool auvok = SvUOK(TOPm1s);
2171 bool buvok = SvUOK(TOPs);
2173 if (!auvok && !buvok) { /* ## IV <= IV ## */
2174 const IV aiv = SvIVX(TOPm1s);
2175 const IV biv = SvIVX(TOPs);
2178 SETs(boolSV(aiv <= biv));
2181 if (auvok && buvok) { /* ## UV <= UV ## */
2182 UV auv = SvUVX(TOPm1s);
2183 UV buv = SvUVX(TOPs);
2186 SETs(boolSV(auv <= buv));
2189 if (auvok) { /* ## UV <= IV ## */
2191 const IV biv = SvIVX(TOPs);
2195 /* As (a) is a UV, it's >=0, so a cannot be <= */
2200 SETs(boolSV(auv <= (UV)biv));
2203 { /* ## IV <= UV ## */
2204 const IV aiv = SvIVX(TOPm1s);
2208 /* As (b) is a UV, it's >=0, so a must be <= */
2215 SETs(boolSV((UV)aiv <= buv));
2221 #ifndef NV_PRESERVES_UV
2222 #ifdef PERL_PRESERVE_IVUV
2225 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2227 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2232 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2234 if (Perl_isnan(left) || Perl_isnan(right))
2236 SETs(boolSV(left <= right));
2239 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2248 tryAMAGICbin_MG(ge_amg,AMGf_set|AMGf_numeric);
2249 #ifdef PERL_PRESERVE_IVUV
2250 SvIV_please_nomg(TOPs);
2252 SvIV_please_nomg(TOPm1s);
2253 if (SvIOK(TOPm1s)) {
2254 bool auvok = SvUOK(TOPm1s);
2255 bool buvok = SvUOK(TOPs);
2257 if (!auvok && !buvok) { /* ## IV >= IV ## */
2258 const IV aiv = SvIVX(TOPm1s);
2259 const IV biv = SvIVX(TOPs);
2262 SETs(boolSV(aiv >= biv));
2265 if (auvok && buvok) { /* ## UV >= UV ## */
2266 const UV auv = SvUVX(TOPm1s);
2267 const UV buv = SvUVX(TOPs);
2270 SETs(boolSV(auv >= buv));
2273 if (auvok) { /* ## UV >= IV ## */
2275 const IV biv = SvIVX(TOPs);
2279 /* As (a) is a UV, it's >=0, so it must be >= */
2284 SETs(boolSV(auv >= (UV)biv));
2287 { /* ## IV >= UV ## */
2288 const IV aiv = SvIVX(TOPm1s);
2292 /* As (b) is a UV, it's >=0, so a cannot be >= */
2299 SETs(boolSV((UV)aiv >= buv));
2305 #ifndef NV_PRESERVES_UV
2306 #ifdef PERL_PRESERVE_IVUV
2309 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2311 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2316 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2318 if (Perl_isnan(left) || Perl_isnan(right))
2320 SETs(boolSV(left >= right));
2323 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2332 tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric);
2333 #ifndef NV_PRESERVES_UV
2334 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2336 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2340 #ifdef PERL_PRESERVE_IVUV
2341 SvIV_please_nomg(TOPs);
2343 SvIV_please_nomg(TOPm1s);
2344 if (SvIOK(TOPm1s)) {
2345 const bool auvok = SvUOK(TOPm1s);
2346 const bool buvok = SvUOK(TOPs);
2348 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2349 /* Casting IV to UV before comparison isn't going to matter
2350 on 2s complement. On 1s complement or sign&magnitude
2351 (if we have any of them) it could make negative zero
2352 differ from normal zero. As I understand it. (Need to
2353 check - is negative zero implementation defined behaviour
2355 const UV buv = SvUVX(POPs);
2356 const UV auv = SvUVX(TOPs);
2358 SETs(boolSV(auv != buv));
2361 { /* ## Mixed IV,UV ## */
2365 /* != is commutative so swap if needed (save code) */
2367 /* swap. top of stack (b) is the iv */
2371 /* As (a) is a UV, it's >0, so it cannot be == */
2380 /* As (b) is a UV, it's >0, so it cannot be == */
2384 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2386 SETs(boolSV((UV)iv != uv));
2393 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2395 if (Perl_isnan(left) || Perl_isnan(right))
2397 SETs(boolSV(left != right));
2400 SETs(boolSV(SvNV_nomg(TOPs) != value));
2409 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2410 #ifndef NV_PRESERVES_UV
2411 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2412 const UV right = PTR2UV(SvRV(POPs));
2413 const UV left = PTR2UV(SvRV(TOPs));
2414 SETi((left > right) - (left < right));
2418 #ifdef PERL_PRESERVE_IVUV
2419 /* Fortunately it seems NaN isn't IOK */
2420 SvIV_please_nomg(TOPs);
2422 SvIV_please_nomg(TOPm1s);
2423 if (SvIOK(TOPm1s)) {
2424 const bool leftuvok = SvUOK(TOPm1s);
2425 const bool rightuvok = SvUOK(TOPs);
2427 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2428 const IV leftiv = SvIVX(TOPm1s);
2429 const IV rightiv = SvIVX(TOPs);
2431 if (leftiv > rightiv)
2433 else if (leftiv < rightiv)
2437 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2438 const UV leftuv = SvUVX(TOPm1s);
2439 const UV rightuv = SvUVX(TOPs);
2441 if (leftuv > rightuv)
2443 else if (leftuv < rightuv)
2447 } else if (leftuvok) { /* ## UV <=> IV ## */
2448 const IV rightiv = SvIVX(TOPs);
2450 /* As (a) is a UV, it's >=0, so it cannot be < */
2453 const UV leftuv = SvUVX(TOPm1s);
2454 if (leftuv > (UV)rightiv) {
2456 } else if (leftuv < (UV)rightiv) {
2462 } else { /* ## IV <=> UV ## */
2463 const IV leftiv = SvIVX(TOPm1s);
2465 /* As (b) is a UV, it's >=0, so it must be < */
2468 const UV rightuv = SvUVX(TOPs);
2469 if ((UV)leftiv > rightuv) {
2471 } else if ((UV)leftiv < rightuv) {
2489 if (Perl_isnan(left) || Perl_isnan(right)) {
2493 value = (left > right) - (left < right);
2497 else if (left < right)
2499 else if (left > right)
2515 int amg_type = sle_amg;
2519 switch (PL_op->op_type) {
2538 tryAMAGICbin_MG(amg_type, AMGf_set);
2541 const int cmp = (IN_LOCALE_RUNTIME
2542 ? sv_cmp_locale_flags(left, right, 0)
2543 : sv_cmp_flags(left, right, 0));
2544 SETs(boolSV(cmp * multiplier < rhs));
2552 tryAMAGICbin_MG(seq_amg, AMGf_set);
2555 SETs(boolSV(sv_eq_flags(left, right, 0)));
2563 tryAMAGICbin_MG(sne_amg, AMGf_set);
2566 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2574 tryAMAGICbin_MG(scmp_amg, 0);
2577 const int cmp = (IN_LOCALE_RUNTIME
2578 ? sv_cmp_locale_flags(left, right, 0)
2579 : sv_cmp_flags(left, right, 0));
2587 dVAR; dSP; dATARGET;
2588 tryAMAGICbin_MG(band_amg, AMGf_assign);
2591 if (SvNIOKp(left) || SvNIOKp(right)) {
2592 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2593 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2594 if (PL_op->op_private & HINT_INTEGER) {
2595 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2599 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2602 if (left_ro_nonnum) SvNIOK_off(left);
2603 if (right_ro_nonnum) SvNIOK_off(right);
2606 do_vop(PL_op->op_type, TARG, left, right);
2615 dVAR; dSP; dATARGET;
2616 const int op_type = PL_op->op_type;
2618 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2621 if (SvNIOKp(left) || SvNIOKp(right)) {
2622 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2623 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2624 if (PL_op->op_private & HINT_INTEGER) {
2625 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2626 const IV r = SvIV_nomg(right);
2627 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2631 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2632 const UV r = SvUV_nomg(right);
2633 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2636 if (left_ro_nonnum) SvNIOK_off(left);
2637 if (right_ro_nonnum) SvNIOK_off(right);
2640 do_vop(op_type, TARG, left, right);
2650 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2652 SV * const sv = TOPs;
2653 const int flags = SvFLAGS(sv);
2655 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2659 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2660 /* It's publicly an integer, or privately an integer-not-float */
2663 if (SvIVX(sv) == IV_MIN) {
2664 /* 2s complement assumption. */
2665 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2668 else if (SvUVX(sv) <= IV_MAX) {
2673 else if (SvIVX(sv) != IV_MIN) {
2677 #ifdef PERL_PRESERVE_IVUV
2685 SETn(-SvNV_nomg(sv));
2686 else if (SvPOKp(sv)) {
2688 const char * const s = SvPV_nomg_const(sv, len);
2689 if (isIDFIRST(*s)) {
2690 sv_setpvs(TARG, "-");
2693 else if (*s == '+' || *s == '-') {
2694 sv_setsv_nomg(TARG, sv);
2695 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2697 else if (DO_UTF8(sv)) {
2698 SvIV_please_nomg(sv);
2700 goto oops_its_an_int;
2702 sv_setnv(TARG, -SvNV_nomg(sv));
2704 sv_setpvs(TARG, "-");
2709 SvIV_please_nomg(sv);
2711 goto oops_its_an_int;
2712 sv_setnv(TARG, -SvNV_nomg(sv));
2717 SETn(-SvNV_nomg(sv));
2725 tryAMAGICun_MG(not_amg, AMGf_set);
2726 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2733 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2737 if (PL_op->op_private & HINT_INTEGER) {
2738 const IV i = ~SvIV_nomg(sv);
2742 const UV u = ~SvUV_nomg(sv);
2751 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2752 sv_setsv_nomg(TARG, sv);
2753 tmps = (U8*)SvPV_force_nomg(TARG, len);
2756 /* Calculate exact length, let's not estimate. */
2761 U8 * const send = tmps + len;
2762 U8 * const origtmps = tmps;
2763 const UV utf8flags = UTF8_ALLOW_ANYUV;
2765 while (tmps < send) {
2766 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2768 targlen += UNISKIP(~c);
2774 /* Now rewind strings and write them. */
2781 Newx(result, targlen + 1, U8);
2783 while (tmps < send) {
2784 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2786 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2789 sv_usepvn_flags(TARG, (char*)result, targlen,
2790 SV_HAS_TRAILING_NUL);
2797 Newx(result, nchar + 1, U8);
2799 while (tmps < send) {
2800 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2805 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2813 register long *tmpl;
2814 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2817 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2822 for ( ; anum > 0; anum--, tmps++)
2830 /* integer versions of some of the above */
2834 dVAR; dSP; dATARGET;
2835 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2838 SETi( left * right );
2846 dVAR; dSP; dATARGET;
2847 tryAMAGICbin_MG(div_amg, AMGf_assign);
2850 IV value = SvIV_nomg(right);
2852 DIE(aTHX_ "Illegal division by zero");
2853 num = SvIV_nomg(left);
2855 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2859 value = num / value;
2865 #if defined(__GLIBC__) && IVSIZE == 8
2872 /* This is the vanilla old i_modulo. */
2873 dVAR; dSP; dATARGET;
2874 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2878 DIE(aTHX_ "Illegal modulus zero");
2879 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2883 SETi( left % right );
2888 #if defined(__GLIBC__) && IVSIZE == 8
2893 /* This is the i_modulo with the workaround for the _moddi3 bug
2894 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2895 * See below for pp_i_modulo. */
2896 dVAR; dSP; dATARGET;
2897 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2901 DIE(aTHX_ "Illegal modulus zero");
2902 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2906 SETi( left % PERL_ABS(right) );
2913 dVAR; dSP; dATARGET;
2914 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2918 DIE(aTHX_ "Illegal modulus zero");
2919 /* The assumption is to use hereafter the old vanilla version... */
2921 PL_ppaddr[OP_I_MODULO] =
2923 /* .. but if we have glibc, we might have a buggy _moddi3
2924 * (at least glicb 2.2.5 is known to have this bug), in other
2925 * words our integer modulus with negative quad as the second
2926 * argument might be broken. Test for this and re-patch the
2927 * opcode dispatch table if that is the case, remembering to
2928 * also apply the workaround so that this first round works
2929 * right, too. See [perl #9402] for more information. */
2933 /* Cannot do this check with inlined IV constants since
2934 * that seems to work correctly even with the buggy glibc. */
2936 /* Yikes, we have the bug.
2937 * Patch in the workaround version. */
2939 PL_ppaddr[OP_I_MODULO] =
2940 &Perl_pp_i_modulo_1;
2941 /* Make certain we work right this time, too. */
2942 right = PERL_ABS(right);
2945 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2949 SETi( left % right );
2957 dVAR; dSP; dATARGET;
2958 tryAMAGICbin_MG(add_amg, AMGf_assign);
2960 dPOPTOPiirl_ul_nomg;
2961 SETi( left + right );
2968 dVAR; dSP; dATARGET;
2969 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2971 dPOPTOPiirl_ul_nomg;
2972 SETi( left - right );
2980 tryAMAGICbin_MG(lt_amg, AMGf_set);
2983 SETs(boolSV(left < right));
2991 tryAMAGICbin_MG(gt_amg, AMGf_set);
2994 SETs(boolSV(left > right));
3002 tryAMAGICbin_MG(le_amg, AMGf_set);
3005 SETs(boolSV(left <= right));
3013 tryAMAGICbin_MG(ge_amg, AMGf_set);
3016 SETs(boolSV(left >= right));
3024 tryAMAGICbin_MG(eq_amg, AMGf_set);
3027 SETs(boolSV(left == right));
3035 tryAMAGICbin_MG(ne_amg, AMGf_set);
3038 SETs(boolSV(left != right));
3046 tryAMAGICbin_MG(ncmp_amg, 0);
3053 else if (left < right)
3065 tryAMAGICun_MG(neg_amg, 0);
3067 SV * const sv = TOPs;
3068 IV const i = SvIV_nomg(sv);
3074 /* High falutin' math. */
3079 tryAMAGICbin_MG(atan2_amg, 0);
3082 SETn(Perl_atan2(left, right));
3090 int amg_type = sin_amg;
3091 const char *neg_report = NULL;
3092 NV (*func)(NV) = Perl_sin;
3093 const int op_type = PL_op->op_type;
3110 amg_type = sqrt_amg;
3112 neg_report = "sqrt";
3117 tryAMAGICun_MG(amg_type, 0);
3119 SV * const arg = POPs;
3120 const NV value = SvNV_nomg(arg);
3122 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
3123 SET_NUMERIC_STANDARD();
3124 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3127 XPUSHn(func(value));
3132 /* Support Configure command-line overrides for rand() functions.
3133 After 5.005, perhaps we should replace this by Configure support
3134 for drand48(), random(), or rand(). For 5.005, though, maintain
3135 compatibility by calling rand() but allow the user to override it.
3136 See INSTALL for details. --Andy Dougherty 15 July 1998
3138 /* Now it's after 5.005, and Configure supports drand48() and random(),
3139 in addition to rand(). So the overrides should not be needed any more.
3140 --Jarkko Hietaniemi 27 September 1998
3143 #ifndef HAS_DRAND48_PROTO
3144 extern double drand48 (void);
3157 if (!PL_srand_called) {
3158 (void)seedDrand01((Rand_seed_t)seed());
3159 PL_srand_called = TRUE;
3169 const UV anum = (MAXARG < 1) ? seed() : POPu;
3170 (void)seedDrand01((Rand_seed_t)anum);
3171 PL_srand_called = TRUE;
3175 /* Historically srand always returned true. We can avoid breaking
3177 sv_setpvs(TARG, "0 but true");
3186 tryAMAGICun_MG(int_amg, AMGf_numeric);
3188 SV * const sv = TOPs;
3189 const IV iv = SvIV_nomg(sv);
3190 /* XXX it's arguable that compiler casting to IV might be subtly
3191 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3192 else preferring IV has introduced a subtle behaviour change bug. OTOH
3193 relying on floating point to be accurate is a bug. */
3198 else if (SvIOK(sv)) {
3200 SETu(SvUV_nomg(sv));
3205 const NV value = SvNV_nomg(sv);
3207 if (value < (NV)UV_MAX + 0.5) {
3210 SETn(Perl_floor(value));
3214 if (value > (NV)IV_MIN - 0.5) {
3217 SETn(Perl_ceil(value));
3228 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3230 SV * const sv = TOPs;
3231 /* This will cache the NV value if string isn't actually integer */
3232 const IV iv = SvIV_nomg(sv);
3237 else if (SvIOK(sv)) {
3238 /* IVX is precise */
3240 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3248 /* 2s complement assumption. Also, not really needed as
3249 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3255 const NV value = SvNV_nomg(sv);
3269 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3273 SV* const sv = POPs;
3275 tmps = (SvPV_const(sv, len));
3277 /* If Unicode, try to downgrade
3278 * If not possible, croak. */
3279 SV* const tsv = sv_2mortal(newSVsv(sv));
3282 sv_utf8_downgrade(tsv, FALSE);
3283 tmps = SvPV_const(tsv, len);
3285 if (PL_op->op_type == OP_HEX)
3288 while (*tmps && len && isSPACE(*tmps))
3292 if (*tmps == 'x' || *tmps == 'X') {
3294 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3296 else if (*tmps == 'b' || *tmps == 'B')
3297 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3299 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3301 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3315 SV * const sv = TOPs;
3317 if (SvGAMAGIC(sv)) {
3318 /* For an overloaded or magic scalar, we can't know in advance if
3319 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3320 it likes to cache the length. Maybe that should be a documented
3325 = sv_2pv_flags(sv, &len,
3326 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3329 if (!SvPADTMP(TARG)) {
3330 sv_setsv(TARG, &PL_sv_undef);
3335 else if (DO_UTF8(sv)) {
3336 SETi(utf8_length((U8*)p, (U8*)p + len));
3340 } else if (SvOK(sv)) {
3341 /* Neither magic nor overloaded. */
3343 SETi(sv_len_utf8(sv));
3347 if (!SvPADTMP(TARG)) {
3348 sv_setsv_nomg(TARG, &PL_sv_undef);
3370 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3372 const IV arybase = CopARYBASE_get(PL_curcop);
3374 const char *repl = NULL;
3376 const int num_args = PL_op->op_private & 7;
3377 bool repl_need_utf8_upgrade = FALSE;
3378 bool repl_is_utf8 = FALSE;
3383 repl = SvPV_const(repl_sv, repl_len);
3384 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3387 len_iv = SvIV(len_sv);
3388 len_is_uv = SvIOK_UV(len_sv);
3391 pos1_iv = SvIV(pos_sv);
3392 pos1_is_uv = SvIOK_UV(pos_sv);
3398 sv_utf8_upgrade(sv);
3400 else if (DO_UTF8(sv))
3401 repl_need_utf8_upgrade = TRUE;
3403 tmps = SvPV_const(sv, curlen);
3405 utf8_curlen = sv_len_utf8(sv);
3406 if (utf8_curlen == curlen)
3409 curlen = utf8_curlen;
3414 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3415 UV pos1_uv = pos1_iv-arybase;
3416 /* Overflow can occur when $[ < 0 */
3417 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3422 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3423 goto bound_fail; /* $[=3; substr($_,2,...) */
3425 else { /* pos < $[ */
3426 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3431 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3436 if (pos1_is_uv || pos1_iv > 0) {
3437 if ((UV)pos1_iv > curlen)
3442 if (!len_is_uv && len_iv < 0) {
3443 pos2_iv = curlen + len_iv;
3445 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3448 } else { /* len_iv >= 0 */
3449 if (!pos1_is_uv && pos1_iv < 0) {
3450 pos2_iv = pos1_iv + len_iv;
3451 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3453 if ((UV)len_iv > curlen-(UV)pos1_iv)
3456 pos2_iv = pos1_iv+len_iv;
3466 if (!pos2_is_uv && pos2_iv < 0) {
3467 if (!pos1_is_uv && pos1_iv < 0)
3471 else if (!pos1_is_uv && pos1_iv < 0)
3474 if ((UV)pos2_iv < (UV)pos1_iv)
3476 if ((UV)pos2_iv > curlen)
3480 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3481 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3482 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3483 STRLEN byte_len = len;
3484 STRLEN byte_pos = utf8_curlen
3485 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3487 if (lvalue && !repl) {
3490 if (!SvGMAGICAL(sv)) {
3492 SvPV_force_nolen(sv);
3493 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3494 "Attempt to use reference as lvalue in substr");
3496 if (isGV_with_GP(sv))
3497 SvPV_force_nolen(sv);
3498 else if (SvOK(sv)) /* is it defined ? */
3499 (void)SvPOK_only_UTF8(sv);
3501 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3504 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3505 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3507 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3508 LvTARGOFF(ret) = pos;
3509 LvTARGLEN(ret) = len;
3512 PUSHs(ret); /* avoid SvSETMAGIC here */
3516 SvTAINTED_off(TARG); /* decontaminate */
3517 SvUTF8_off(TARG); /* decontaminate */
3520 sv_setpvn(TARG, tmps, byte_len);
3521 #ifdef USE_LOCALE_COLLATE
3522 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3528 SV* repl_sv_copy = NULL;
3530 if (repl_need_utf8_upgrade) {
3531 repl_sv_copy = newSVsv(repl_sv);
3532 sv_utf8_upgrade(repl_sv_copy);
3533 repl = SvPV_const(repl_sv_copy, repl_len);
3534 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3538 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3541 SvREFCNT_dec(repl_sv_copy);
3551 Perl_croak(aTHX_ "substr outside of string");
3552 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3559 register const IV size = POPi;
3560 register const IV offset = POPi;
3561 register SV * const src = POPs;
3562 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3565 if (lvalue) { /* it's an lvalue! */
3566 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3567 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3569 LvTARG(ret) = SvREFCNT_inc_simple(src);
3570 LvTARGOFF(ret) = offset;
3571 LvTARGLEN(ret) = size;
3575 SvTAINTED_off(TARG); /* decontaminate */
3579 sv_setuv(ret, do_vecget(src, offset, size));
3595 const char *little_p;
3596 const I32 arybase = CopARYBASE_get(PL_curcop);
3599 const bool is_index = PL_op->op_type == OP_INDEX;
3602 /* arybase is in characters, like offset, so combine prior to the
3603 UTF-8 to bytes calculation. */
3604 offset = POPi - arybase;
3608 big_p = SvPV_const(big, biglen);
3609 little_p = SvPV_const(little, llen);
3611 big_utf8 = DO_UTF8(big);
3612 little_utf8 = DO_UTF8(little);
3613 if (big_utf8 ^ little_utf8) {
3614 /* One needs to be upgraded. */
3615 if (little_utf8 && !PL_encoding) {
3616 /* Well, maybe instead we might be able to downgrade the small
3618 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3621 /* If the large string is ISO-8859-1, and it's not possible to
3622 convert the small string to ISO-8859-1, then there is no
3623 way that it could be found anywhere by index. */
3628 /* At this point, pv is a malloc()ed string. So donate it to temp
3629 to ensure it will get free()d */
3630 little = temp = newSV(0);
3631 sv_usepvn(temp, pv, llen);
3632 little_p = SvPVX(little);
3635 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3638 sv_recode_to_utf8(temp, PL_encoding);
3640 sv_utf8_upgrade(temp);
3645 big_p = SvPV_const(big, biglen);
3648 little_p = SvPV_const(little, llen);
3652 if (SvGAMAGIC(big)) {
3653 /* Life just becomes a lot easier if I use a temporary here.
3654 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3655 will trigger magic and overloading again, as will fbm_instr()
3657 big = newSVpvn_flags(big_p, biglen,
3658 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3661 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3662 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3663 warn on undef, and we've already triggered a warning with the
3664 SvPV_const some lines above. We can't remove that, as we need to
3665 call some SvPV to trigger overloading early and find out if the
3667 This is all getting to messy. The API isn't quite clean enough,
3668 because data access has side effects.
3670 little = newSVpvn_flags(little_p, llen,
3671 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3672 little_p = SvPVX(little);
3676 offset = is_index ? 0 : biglen;
3678 if (big_utf8 && offset > 0)
3679 sv_pos_u2b(big, &offset, 0);
3685 else if (offset > (I32)biglen)
3687 if (!(little_p = is_index
3688 ? fbm_instr((unsigned char*)big_p + offset,
3689 (unsigned char*)big_p + biglen, little, 0)
3690 : rninstr(big_p, big_p + offset,
3691 little_p, little_p + llen)))
3694 retval = little_p - big_p;
3695 if (retval > 0 && big_utf8)
3696 sv_pos_b2u(big, &retval);
3700 PUSHi(retval + arybase);
3706 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
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 /* Below are several macros that generate code */
3846 /* Generates code to store a unicode codepoint c that is known to occupy
3847 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3848 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3850 *(p) = UTF8_TWO_BYTE_HI(c); \
3851 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3854 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3855 * available byte after the two bytes */
3856 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3858 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3859 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3862 /* Generates code to store the upper case of latin1 character l which is known
3863 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3864 * are only two characters that fit this description, and this macro knows
3865 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3867 #define STORE_NON_LATIN1_UC(p, l) \
3869 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3870 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3871 } else { /* Must be the following letter */ \
3872 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3876 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3877 * after the character stored */
3878 #define CAT_NON_LATIN1_UC(p, l) \
3880 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3881 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3883 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3887 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3888 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3889 * and must require two bytes to store it. Advances p to point to the next
3890 * available position */
3891 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3893 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3894 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3895 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3896 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3897 } else {/* else is one of the other two special cases */ \
3898 CAT_NON_LATIN1_UC((p), (l)); \
3904 /* Actually is both lcfirst() and ucfirst(). Only the first character
3905 * changes. This means that possibly we can change in-place, ie., just
3906 * take the source and change that one character and store it back, but not
3907 * if read-only etc, or if the length changes */
3912 STRLEN slen; /* slen is the byte length of the whole SV. */
3915 bool inplace; /* ? Convert first char only, in-place */
3916 bool doing_utf8 = FALSE; /* ? using utf8 */
3917 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3918 const int op_type = PL_op->op_type;
3921 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3922 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3923 * stored as UTF-8 at s. */
3924 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3925 * lowercased) character stored in tmpbuf. May be either
3926 * UTF-8 or not, but in either case is the number of bytes */
3930 s = (const U8*)SvPV_nomg_const(source, slen);
3932 if (ckWARN(WARN_UNINITIALIZED))
3933 report_uninit(source);
3938 /* We may be able to get away with changing only the first character, in
3939 * place, but not if read-only, etc. Later we may discover more reasons to
3940 * not convert in-place. */
3941 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3943 /* First calculate what the changed first character should be. This affects
3944 * whether we can just swap it out, leaving the rest of the string unchanged,
3945 * or even if have to convert the dest to UTF-8 when the source isn't */
3947 if (! slen) { /* If empty */
3948 need = 1; /* still need a trailing NUL */
3950 else if (DO_UTF8(source)) { /* Is the source utf8? */
3953 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3954 * and doesn't allow for the user to specify their own. When code is added to
3955 * detect if there is a user-defined mapping in force here, and if so to use
3956 * that, then the code below can be compiled. The detection would be a good
3957 * thing anyway, as currently the user-defined mappings only work on utf8
3958 * strings, and thus depend on the chosen internal storage method, which is a
3960 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3961 if (UTF8_IS_INVARIANT(*s)) {
3963 /* An invariant source character is either ASCII or, in EBCDIC, an
3964 * ASCII equivalent or a caseless C1 control. In both these cases,
3965 * the lower and upper cases of any character are also invariants
3966 * (and title case is the same as upper case). So it is safe to
3967 * use the simple case change macros which avoid the overhead of
3968 * the general functions. Note that if perl were to be extended to
3969 * do locale handling in UTF-8 strings, this wouldn't be true in,
3970 * for example, Lithuanian or Turkic. */
3971 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3975 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3978 /* Similarly, if the source character isn't invariant but is in the
3979 * latin1 range (or EBCDIC equivalent thereof), we have the case
3980 * changes compiled into perl, and can avoid the overhead of the
3981 * general functions. In this range, the characters are stored as
3982 * two UTF-8 bytes, and it so happens that any changed-case version
3983 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3987 /* Convert the two source bytes to a single Unicode code point
3988 * value, change case and save for below */
3989 chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3990 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3991 U8 lower = toLOWER_LATIN1(chr);
3992 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3994 else { /* ucfirst */
3995 U8 upper = toUPPER_LATIN1_MOD(chr);
3997 /* Most of the latin1 range characters are well-behaved. Their
3998 * title and upper cases are the same, and are also in the
3999 * latin1 range. The macro above returns their upper (hence
4000 * title) case, and all that need be done is to save the result
4001 * for below. However, several characters are problematic, and
4002 * have to be handled specially. The MOD in the macro name
4003 * above means that these tricky characters all get mapped to
4004 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
4005 * This mapping saves some tests for the majority of the
4008 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
4010 /* Not tricky. Just save it. */
4011 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
4013 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
4015 /* This one is tricky because it is two characters long,
4016 * though the UTF-8 is still two bytes, so the stored
4017 * length doesn't change */
4018 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
4019 *(tmpbuf + 1) = 's';
4023 /* The other two have their title and upper cases the same,
4024 * but are tricky because the changed-case characters
4025 * aren't in the latin1 range. They, however, do fit into
4026 * two UTF-8 bytes */
4027 STORE_NON_LATIN1_UC(tmpbuf, chr);
4032 #endif /* end of dont want to break user-defined casing */
4034 /* Here, can't short-cut the general case */
4036 utf8_to_uvchr(s, &ulen);
4037 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
4038 else toLOWER_utf8(s, tmpbuf, &tculen);
4040 /* we can't do in-place if the length changes. */
4041 if (ulen != tculen) inplace = FALSE;
4042 need = slen + 1 - ulen + tculen;
4043 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4047 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
4048 * latin1 is treated as caseless. Note that a locale takes
4050 tculen = 1; /* Most characters will require one byte, but this will
4051 * need to be overridden for the tricky ones */
4054 if (op_type == OP_LCFIRST) {
4056 /* lower case the first letter: no trickiness for any character */
4057 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
4058 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
4061 else if (IN_LOCALE_RUNTIME) {
4062 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
4063 * have upper and title case different
4066 else if (! IN_UNI_8_BIT) {
4067 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
4068 * on EBCDIC machines whatever the
4069 * native function does */
4071 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
4072 *tmpbuf = toUPPER_LATIN1_MOD(*s);
4074 /* tmpbuf now has the correct title case for all latin1 characters
4075 * except for the several ones that have tricky handling. All
4076 * of these are mapped by the MOD to the letter below. */
4077 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
4079 /* The length is going to change, with all three of these, so
4080 * can't replace just the first character */
4083 /* We use the original to distinguish between these tricky
4085 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4086 /* Two character title case 'Ss', but can remain non-UTF-8 */
4089 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
4094 /* The other two tricky ones have their title case outside
4095 * latin1. It is the same as their upper case. */
4097 STORE_NON_LATIN1_UC(tmpbuf, *s);
4099 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
4100 * and their upper cases is 2. */
4103 /* The entire result will have to be in UTF-8. Assume worst
4104 * case sizing in conversion. (all latin1 characters occupy
4105 * at most two bytes in utf8) */
4106 convert_source_to_utf8 = TRUE;
4107 need = slen * 2 + 1;
4109 } /* End of is one of the three special chars */
4110 } /* End of use Unicode (Latin1) semantics */
4111 } /* End of changing the case of the first character */
4113 /* Here, have the first character's changed case stored in tmpbuf. Ready to
4114 * generate the result */
4117 /* We can convert in place. This means we change just the first
4118 * character without disturbing the rest; no need to grow */
4120 s = d = (U8*)SvPV_force_nomg(source, slen);
4126 /* Here, we can't convert in place; we earlier calculated how much
4127 * space we will need, so grow to accommodate that */
4128 SvUPGRADE(dest, SVt_PV);
4129 d = (U8*)SvGROW(dest, need);
4130 (void)SvPOK_only(dest);
4137 if (! convert_source_to_utf8) {
4139 /* Here both source and dest are in UTF-8, but have to create
4140 * the entire output. We initialize the result to be the
4141 * title/lower cased first character, and then append the rest
4143 sv_setpvn(dest, (char*)tmpbuf, tculen);
4145 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4149 const U8 *const send = s + slen;
4151 /* Here the dest needs to be in UTF-8, but the source isn't,
4152 * except we earlier UTF-8'd the first character of the source
4153 * into tmpbuf. First put that into dest, and then append the
4154 * rest of the source, converting it to UTF-8 as we go. */
4156 /* Assert tculen is 2 here because the only two characters that
4157 * get to this part of the code have 2-byte UTF-8 equivalents */
4159 *d++ = *(tmpbuf + 1);
4160 s++; /* We have just processed the 1st char */
4162 for (; s < send; s++) {
4163 d = uvchr_to_utf8(d, *s);
4166 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4170 else { /* in-place UTF-8. Just overwrite the first character */
4171 Copy(tmpbuf, d, tculen, U8);
4172 SvCUR_set(dest, need - 1);
4175 else { /* Neither source nor dest are in or need to be UTF-8 */
4177 if (IN_LOCALE_RUNTIME) {
4181 if (inplace) { /* in-place, only need to change the 1st char */
4184 else { /* Not in-place */
4186 /* Copy the case-changed character(s) from tmpbuf */
4187 Copy(tmpbuf, d, tculen, U8);
4188 d += tculen - 1; /* Code below expects d to point to final
4189 * character stored */
4192 else { /* empty source */
4193 /* See bug #39028: Don't taint if empty */
4197 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4198 * the destination to retain that flag */
4202 if (!inplace) { /* Finish the rest of the string, unchanged */
4203 /* This will copy the trailing NUL */
4204 Copy(s + 1, d + 1, slen, U8);
4205 SvCUR_set(dest, need - 1);
4208 if (dest != source && SvTAINTED(source))
4214 /* There's so much setup/teardown code common between uc and lc, I wonder if
4215 it would be worth merging the two, and just having a switch outside each
4216 of the three tight loops. There is less and less commonality though */
4230 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4231 && SvTEMP(source) && !DO_UTF8(source)
4232 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4234 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4235 * make the loop tight, so we overwrite the source with the dest before
4236 * looking at it, and we need to look at the original source
4237 * afterwards. There would also need to be code added to handle
4238 * switching to not in-place in midstream if we run into characters
4239 * that change the length.
4242 s = d = (U8*)SvPV_force_nomg(source, len);
4249 /* The old implementation would copy source into TARG at this point.
4250 This had the side effect that if source was undef, TARG was now
4251 an undefined SV with PADTMP set, and they don't warn inside
4252 sv_2pv_flags(). However, we're now getting the PV direct from
4253 source, which doesn't have PADTMP set, so it would warn. Hence the
4257 s = (const U8*)SvPV_nomg_const(source, len);
4259 if (ckWARN(WARN_UNINITIALIZED))
4260 report_uninit(source);
4266 SvUPGRADE(dest, SVt_PV);
4267 d = (U8*)SvGROW(dest, min);
4268 (void)SvPOK_only(dest);
4273 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4274 to check DO_UTF8 again here. */
4276 if (DO_UTF8(source)) {
4277 const U8 *const send = s + len;
4278 U8 tmpbuf[UTF8_MAXBYTES+1];
4280 /* All occurrences of these are to be moved to follow any other marks.
4281 * This is context-dependent. We may not be passed enough context to
4282 * move the iota subscript beyond all of them, but we do the best we can
4283 * with what we're given. The result is always better than if we
4284 * hadn't done this. And, the problem would only arise if we are
4285 * passed a character without all its combining marks, which would be
4286 * the caller's mistake. The information this is based on comes from a
4287 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4288 * itself) and so can't be checked properly to see if it ever gets
4289 * revised. But the likelihood of it changing is remote */
4290 bool in_iota_subscript = FALSE;
4293 if (in_iota_subscript && ! is_utf8_mark(s)) {
4294 /* A non-mark. Time to output the iota subscript */
4295 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4296 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4298 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4299 in_iota_subscript = FALSE;
4303 /* See comments at the first instance in this file of this ifdef */
4304 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4306 /* If the UTF-8 character is invariant, then it is in the range
4307 * known by the standard macro; result is only one byte long */
4308 if (UTF8_IS_INVARIANT(*s)) {
4312 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4314 /* Likewise, if it fits in a byte, its case change is in our
4316 U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *s++);
4317 U8 upper = toUPPER_LATIN1_MOD(orig);
4318 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4326 /* Otherwise, need the general UTF-8 case. Get the changed
4327 * case value and copy it to the output buffer */
4329 const STRLEN u = UTF8SKIP(s);
4332 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4333 if (uv == GREEK_CAPITAL_LETTER_IOTA
4334 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4336 in_iota_subscript = TRUE;
4339 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4340 /* If the eventually required minimum size outgrows
4341 * the available space, we need to grow. */
4342 const UV o = d - (U8*)SvPVX_const(dest);
4344 /* If someone uppercases one million U+03B0s we
4345 * SvGROW() one million times. Or we could try
4346 * guessing how much to allocate without allocating too
4347 * much. Such is life. See corresponding comment in
4348 * lc code for another option */
4350 d = (U8*)SvPVX(dest) + o;
4352 Copy(tmpbuf, d, ulen, U8);
4358 if (in_iota_subscript) {
4359 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4363 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4365 else { /* Not UTF-8 */
4367 const U8 *const send = s + len;
4369 /* Use locale casing if in locale; regular style if not treating
4370 * latin1 as having case; otherwise the latin1 casing. Do the
4371 * whole thing in a tight loop, for speed, */
4372 if (IN_LOCALE_RUNTIME) {
4375 for (; s < send; d++, s++)
4376 *d = toUPPER_LC(*s);
4378 else if (! IN_UNI_8_BIT) {
4379 for (; s < send; d++, s++) {
4384 for (; s < send; d++, s++) {
4385 *d = toUPPER_LATIN1_MOD(*s);
4386 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4388 /* The mainstream case is the tight loop above. To avoid
4389 * extra tests in that, all three characters that require
4390 * special handling are mapped by the MOD to the one tested
4392 * Use the source to distinguish between the three cases */
4394 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4396 /* uc() of this requires 2 characters, but they are
4397 * ASCII. If not enough room, grow the string */
4398 if (SvLEN(dest) < ++min) {
4399 const UV o = d - (U8*)SvPVX_const(dest);
4401 d = (U8*)SvPVX(dest) + o;
4403 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4404 continue; /* Back to the tight loop; still in ASCII */
4407 /* The other two special handling characters have their
4408 * upper cases outside the latin1 range, hence need to be
4409 * in UTF-8, so the whole result needs to be in UTF-8. So,
4410 * here we are somewhere in the middle of processing a
4411 * non-UTF-8 string, and realize that we will have to convert
4412 * the whole thing to UTF-8. What to do? There are
4413 * several possibilities. The simplest to code is to
4414 * convert what we have so far, set a flag, and continue on
4415 * in the loop. The flag would be tested each time through
4416 * the loop, and if set, the next character would be
4417 * converted to UTF-8 and stored. But, I (khw) didn't want
4418 * to slow down the mainstream case at all for this fairly
4419 * rare case, so I didn't want to add a test that didn't
4420 * absolutely have to be there in the loop, besides the
4421 * possibility that it would get too complicated for
4422 * optimizers to deal with. Another possibility is to just
4423 * give up, convert the source to UTF-8, and restart the
4424 * function that way. Another possibility is to convert
4425 * both what has already been processed and what is yet to
4426 * come separately to UTF-8, then jump into the loop that
4427 * handles UTF-8. But the most efficient time-wise of the
4428 * ones I could think of is what follows, and turned out to
4429 * not require much extra code. */
4431 /* Convert what we have so far into UTF-8, telling the
4432 * function that we know it should be converted, and to
4433 * allow extra space for what we haven't processed yet.
4434 * Assume the worst case space requirements for converting
4435 * what we haven't processed so far: that it will require
4436 * two bytes for each remaining source character, plus the
4437 * NUL at the end. This may cause the string pointer to
4438 * move, so re-find it. */
4440 len = d - (U8*)SvPVX_const(dest);
4441 SvCUR_set(dest, len);
4442 len = sv_utf8_upgrade_flags_grow(dest,
4443 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4445 d = (U8*)SvPVX(dest) + len;
4447 /* And append the current character's upper case in UTF-8 */
4448 CAT_NON_LATIN1_UC(d, *s);
4450 /* Now process the remainder of the source, converting to
4451 * upper and UTF-8. If a resulting byte is invariant in
4452 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4453 * append it to the output. */
4456 for (; s < send; s++) {
4457 U8 upper = toUPPER_LATIN1_MOD(*s);
4458 if UTF8_IS_INVARIANT(upper) {
4462 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4466 /* Here have processed the whole source; no need to continue
4467 * with the outer loop. Each character has been converted
4468 * to upper case and converted to UTF-8 */
4471 } /* End of processing all latin1-style chars */
4472 } /* End of processing all chars */
4473 } /* End of source is not empty */
4475 if (source != dest) {
4476 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4477 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4479 } /* End of isn't utf8 */
4480 if (dest != source && SvTAINTED(source))
4499 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4500 && SvTEMP(source) && !DO_UTF8(source)) {
4502 /* We can convert in place, as lowercasing anything in the latin1 range
4503 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4505 s = d = (U8*)SvPV_force_nomg(source, len);
4512 /* The old implementation would copy source into TARG at this point.
4513 This had the side effect that if source was undef, TARG was now
4514 an undefined SV with PADTMP set, and they don't warn inside
4515 sv_2pv_flags(). However, we're now getting the PV direct from
4516 source, which doesn't have PADTMP set, so it would warn. Hence the
4520 s = (const U8*)SvPV_nomg_const(source, len);
4522 if (ckWARN(WARN_UNINITIALIZED))
4523 report_uninit(source);
4529 SvUPGRADE(dest, SVt_PV);
4530 d = (U8*)SvGROW(dest, min);
4531 (void)SvPOK_only(dest);
4536 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4537 to check DO_UTF8 again here. */
4539 if (DO_UTF8(source)) {
4540 const U8 *const send = s + len;
4541 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4544 /* See comments at the first instance in this file of this ifdef */
4545 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4546 if (UTF8_IS_INVARIANT(*s)) {
4548 /* Invariant characters use the standard mappings compiled in.
4553 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4555 /* As do the ones in the Latin1 range */
4556 U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *s++));
4557 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4562 /* Here, is utf8 not in Latin-1 range, have to go out and get
4563 * the mappings from the tables. */
4565 const STRLEN u = UTF8SKIP(s);
4568 #ifndef CONTEXT_DEPENDENT_CASING
4569 toLOWER_utf8(s, tmpbuf, &ulen);
4571 /* This is ifdefd out because it needs more work and thought. It isn't clear
4572 * that we should do it.
4573 * A minor objection is that this is based on a hard-coded rule from the
4574 * Unicode standard, and may change, but this is not very likely at all.
4575 * mktables should check and warn if it does.
4576 * More importantly, if the sigma occurs at the end of the string, we don't
4577 * have enough context to know whether it is part of a larger string or going
4578 * to be or not. It may be that we are passed a subset of the context, via
4579 * a \U...\E, for example, and we could conceivably know the larger context if
4580 * code were changed to pass that in. But, if the string passed in is an
4581 * intermediate result, and the user concatenates two strings together
4582 * after we have made a final sigma, that would be wrong. If the final sigma
4583 * occurs in the middle of the string we are working on, then we know that it
4584 * should be a final sigma, but otherwise we can't be sure. */
4586 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4588 /* If the lower case is a small sigma, it may be that we need
4589 * to change it to a final sigma. This happens at the end of
4590 * a word that contains more than just this character, and only
4591 * when we started with a capital sigma. */
4592 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4593 s > send - len && /* Makes sure not the first letter */
4594 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4597 /* We use the algorithm in:
4598 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4599 * is a CAPITAL SIGMA): If C is preceded by a sequence
4600 * consisting of a cased letter and a case-ignorable
4601 * sequence, and C is not followed by a sequence consisting
4602 * of a case ignorable sequence and then a cased letter,
4603 * then when lowercasing C, C becomes a final sigma */
4605 /* To determine if this is the end of a word, need to peek
4606 * ahead. Look at the next character */
4607 const U8 *peek = s + u;
4609 /* Skip any case ignorable characters */
4610 while (peek < send && is_utf8_case_ignorable(peek)) {
4611 peek += UTF8SKIP(peek);
4614 /* If we reached the end of the string without finding any
4615 * non-case ignorable characters, or if the next such one
4616 * is not-cased, then we have met the conditions for it
4617 * being a final sigma with regards to peek ahead, and so
4618 * must do peek behind for the remaining conditions. (We
4619 * know there is stuff behind to look at since we tested
4620 * above that this isn't the first letter) */
4621 if (peek >= send || ! is_utf8_cased(peek)) {
4622 peek = utf8_hop(s, -1);
4624 /* Here are at the beginning of the first character
4625 * before the original upper case sigma. Keep backing
4626 * up, skipping any case ignorable characters */
4627 while (is_utf8_case_ignorable(peek)) {
4628 peek = utf8_hop(peek, -1);
4631 /* Here peek points to the first byte of the closest
4632 * non-case-ignorable character before the capital
4633 * sigma. If it is cased, then by the Unicode
4634 * algorithm, we should use a small final sigma instead
4635 * of what we have */
4636 if (is_utf8_cased(peek)) {
4637 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4638 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4642 else { /* Not a context sensitive mapping */
4643 #endif /* End of commented out context sensitive */
4644 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4646 /* If the eventually required minimum size outgrows
4647 * the available space, we need to grow. */
4648 const UV o = d - (U8*)SvPVX_const(dest);
4650 /* If someone lowercases one million U+0130s we
4651 * SvGROW() one million times. Or we could try
4652 * guessing how much to allocate without allocating too
4653 * much. Such is life. Another option would be to
4654 * grow an extra byte or two more each time we need to
4655 * grow, which would cut down the million to 500K, with
4658 d = (U8*)SvPVX(dest) + o;
4660 #ifdef CONTEXT_DEPENDENT_CASING
4663 /* Copy the newly lowercased letter to the output buffer we're
4665 Copy(tmpbuf, d, ulen, U8);
4668 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4671 } /* End of looping through the source string */
4674 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4675 } else { /* Not utf8 */
4677 const U8 *const send = s + len;
4679 /* Use locale casing if in locale; regular style if not treating
4680 * latin1 as having case; otherwise the latin1 casing. Do the
4681 * whole thing in a tight loop, for speed, */
4682 if (IN_LOCALE_RUNTIME) {
4685 for (; s < send; d++, s++)
4686 *d = toLOWER_LC(*s);
4688 else if (! IN_UNI_8_BIT) {
4689 for (; s < send; d++, s++) {
4694 for (; s < send; d++, s++) {
4695 *d = toLOWER_LATIN1(*s);
4699 if (source != dest) {
4701 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4704 if (dest != source && SvTAINTED(source))
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 */
4840 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4845 "Type of argument to %s must be unblessed hashref or arrayref",
4846 PL_op_desc[PL_op->op_type] );
4849 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4851 "Can't modify %s in %s",
4852 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4855 /* Delegate to correct function for op type */
4857 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4858 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4861 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4869 AV *array = MUTABLE_AV(POPs);
4870 const I32 gimme = GIMME_V;
4871 IV *iterp = Perl_av_iter_p(aTHX_ array);
4872 const IV current = (*iterp)++;
4874 if (current > av_len(array)) {
4876 if (gimme == G_SCALAR)
4883 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4884 if (gimme == G_ARRAY) {
4885 SV **const element = av_fetch(array, current, 0);
4886 PUSHs(element ? *element : &PL_sv_undef);
4895 AV *array = MUTABLE_AV(POPs);
4896 const I32 gimme = GIMME_V;
4898 *Perl_av_iter_p(aTHX_ array) = 0;
4900 if (gimme == G_SCALAR) {
4902 PUSHi(av_len(array) + 1);
4904 else if (gimme == G_ARRAY) {
4905 IV n = Perl_av_len(aTHX_ array);
4906 IV i = CopARYBASE_get(PL_curcop);
4910 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4912 for (; i <= n; i++) {
4917 for (i = 0; i <= n; i++) {
4918 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4919 PUSHs(elem ? *elem : &PL_sv_undef);
4926 /* Associative arrays. */
4932 HV * hash = MUTABLE_HV(POPs);
4934 const I32 gimme = GIMME_V;
4937 /* might clobber stack_sp */
4938 entry = hv_iternext(hash);
4943 SV* const sv = hv_iterkeysv(entry);
4944 PUSHs(sv); /* won't clobber stack_sp */
4945 if (gimme == G_ARRAY) {
4948 /* might clobber stack_sp */
4949 val = hv_iterval(hash, entry);
4954 else if (gimme == G_SCALAR)
4961 S_do_delete_local(pTHX)
4965 const I32 gimme = GIMME_V;
4969 if (PL_op->op_private & OPpSLICE) {
4971 SV * const osv = POPs;
4972 const bool tied = SvRMAGICAL(osv)
4973 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4974 const bool can_preserve = SvCANEXISTDELETE(osv)
4975 || mg_find((const SV *)osv, PERL_MAGIC_env);
4976 const U32 type = SvTYPE(osv);
4977 if (type == SVt_PVHV) { /* hash element */
4978 HV * const hv = MUTABLE_HV(osv);
4979 while (++MARK <= SP) {
4980 SV * const keysv = *MARK;
4982 bool preeminent = TRUE;
4984 preeminent = hv_exists_ent(hv, keysv, 0);
4986 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4993 sv = hv_delete_ent(hv, keysv, 0, 0);
4994 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4997 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4999 *MARK = sv_mortalcopy(sv);
5005 SAVEHDELETE(hv, keysv);
5006 *MARK = &PL_sv_undef;
5010 else if (type == SVt_PVAV) { /* array element */
5011 if (PL_op->op_flags & OPf_SPECIAL) {
5012 AV * const av = MUTABLE_AV(osv);
5013 while (++MARK <= SP) {
5014 I32 idx = SvIV(*MARK);
5016 bool preeminent = TRUE;
5018 preeminent = av_exists(av, idx);
5020 SV **svp = av_fetch(av, idx, 1);
5027 sv = av_delete(av, idx, 0);
5028 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5031 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5033 *MARK = sv_mortalcopy(sv);
5039 SAVEADELETE(av, idx);
5040 *MARK = &PL_sv_undef;
5046 DIE(aTHX_ "Not a HASH reference");
5047 if (gimme == G_VOID)
5049 else if (gimme == G_SCALAR) {
5054 *++MARK = &PL_sv_undef;
5059 SV * const keysv = POPs;
5060 SV * const osv = POPs;
5061 const bool tied = SvRMAGICAL(osv)
5062 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5063 const bool can_preserve = SvCANEXISTDELETE(osv)
5064 || mg_find((const SV *)osv, PERL_MAGIC_env);
5065 const U32 type = SvTYPE(osv);
5067 if (type == SVt_PVHV) {
5068 HV * const hv = MUTABLE_HV(osv);
5069 bool preeminent = TRUE;
5071 preeminent = hv_exists_ent(hv, keysv, 0);
5073 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5080 sv = hv_delete_ent(hv, keysv, 0, 0);
5081 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5084 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5086 SV *nsv = sv_mortalcopy(sv);
5092 SAVEHDELETE(hv, keysv);
5094 else if (type == SVt_PVAV) {
5095 if (PL_op->op_flags & OPf_SPECIAL) {
5096 AV * const av = MUTABLE_AV(osv);
5097 I32 idx = SvIV(keysv);
5098 bool preeminent = TRUE;
5100 preeminent = av_exists(av, idx);
5102 SV **svp = av_fetch(av, idx, 1);
5109 sv = av_delete(av, idx, 0);
5110 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5113 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5115 SV *nsv = sv_mortalcopy(sv);
5121 SAVEADELETE(av, idx);
5124 DIE(aTHX_ "panic: avhv_delete no longer supported");
5127 DIE(aTHX_ "Not a HASH reference");
5130 if (gimme != G_VOID)
5144 if (PL_op->op_private & OPpLVAL_INTRO)
5145 return do_delete_local();
5148 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5150 if (PL_op->op_private & OPpSLICE) {
5152 HV * const hv = MUTABLE_HV(POPs);
5153 const U32 hvtype = SvTYPE(hv);
5154 if (hvtype == SVt_PVHV) { /* hash element */
5155 while (++MARK <= SP) {
5156 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5157 *MARK = sv ? sv : &PL_sv_undef;
5160 else if (hvtype == SVt_PVAV) { /* array element */
5161 if (PL_op->op_flags & OPf_SPECIAL) {
5162 while (++MARK <= SP) {
5163 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5164 *MARK = sv ? sv : &PL_sv_undef;
5169 DIE(aTHX_ "Not a HASH reference");
5172 else if (gimme == G_SCALAR) {
5177 *++MARK = &PL_sv_undef;
5183 HV * const hv = MUTABLE_HV(POPs);
5185 if (SvTYPE(hv) == SVt_PVHV)
5186 sv = hv_delete_ent(hv, keysv, discard, 0);
5187 else if (SvTYPE(hv) == SVt_PVAV) {
5188 if (PL_op->op_flags & OPf_SPECIAL)
5189 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5191 DIE(aTHX_ "panic: avhv_delete no longer supported");
5194 DIE(aTHX_ "Not a HASH reference");
5210 if (PL_op->op_private & OPpEXISTS_SUB) {
5212 SV * const sv = POPs;
5213 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5216 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5221 hv = MUTABLE_HV(POPs);
5222 if (SvTYPE(hv) == SVt_PVHV) {
5223 if (hv_exists_ent(hv, tmpsv, 0))
5226 else if (SvTYPE(hv) == SVt_PVAV) {
5227 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5228 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5233 DIE(aTHX_ "Not a HASH reference");
5240 dVAR; dSP; dMARK; dORIGMARK;
5241 register HV * const hv = MUTABLE_HV(POPs);
5242 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5243 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5244 bool can_preserve = FALSE;
5250 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
5251 can_preserve = TRUE;
5254 while (++MARK <= SP) {
5255 SV * const keysv = *MARK;
5258 bool preeminent = TRUE;
5260 if (localizing && can_preserve) {
5261 /* If we can determine whether the element exist,
5262 * try to preserve the existenceness of a tied hash
5263 * element by using EXISTS and DELETE if possible.
5264 * Fallback to FETCH and STORE otherwise. */
5265 preeminent = hv_exists_ent(hv, keysv, 0);
5268 he = hv_fetch_ent(hv, keysv, lval, 0);
5269 svp = he ? &HeVAL(he) : NULL;
5272 if (!svp || *svp == &PL_sv_undef) {
5273 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5276 if (HvNAME_get(hv) && isGV(*svp))
5277 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5278 else if (preeminent)
5279 save_helem_flags(hv, keysv, svp,
5280 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5282 SAVEHDELETE(hv, keysv);
5285 *MARK = svp ? *svp : &PL_sv_undef;
5287 if (GIMME != G_ARRAY) {
5289 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5295 /* List operators. */
5300 if (GIMME != G_ARRAY) {
5302 *MARK = *SP; /* unwanted list, return last item */
5304 *MARK = &PL_sv_undef;
5314 SV ** const lastrelem = PL_stack_sp;
5315 SV ** const lastlelem = PL_stack_base + POPMARK;
5316 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5317 register SV ** const firstrelem = lastlelem + 1;
5318 const I32 arybase = CopARYBASE_get(PL_curcop);
5319 I32 is_something_there = FALSE;
5321 register const I32 max = lastrelem - lastlelem;
5322 register SV **lelem;
5324 if (GIMME != G_ARRAY) {
5325 I32 ix = SvIV(*lastlelem);
5330 if (ix < 0 || ix >= max)
5331 *firstlelem = &PL_sv_undef;
5333 *firstlelem = firstrelem[ix];
5339 SP = firstlelem - 1;
5343 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5344 I32 ix = SvIV(*lelem);
5349 if (ix < 0 || ix >= max)
5350 *lelem = &PL_sv_undef;
5352 is_something_there = TRUE;
5353 if (!(*lelem = firstrelem[ix]))
5354 *lelem = &PL_sv_undef;
5357 if (is_something_there)
5360 SP = firstlelem - 1;
5366 dVAR; dSP; dMARK; dORIGMARK;
5367 const I32 items = SP - MARK;
5368 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5369 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5370 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5371 ? newRV_noinc(av) : av);
5377 dVAR; dSP; dMARK; dORIGMARK;
5378 HV* const hv = newHV();
5381 SV * const key = *++MARK;
5382 SV * const val = newSV(0);
5384 sv_setsv(val, *++MARK);
5386 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5387 (void)hv_store_ent(hv,key,val,0);
5390 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5391 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5396 S_deref_plain_array(pTHX_ AV *ary)
5398 if (SvTYPE(ary) == SVt_PVAV) return ary;
5399 SvGETMAGIC((SV *)ary);
5400 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5401 Perl_die(aTHX_ "Not an ARRAY reference");
5402 else if (SvOBJECT(SvRV(ary)))
5403 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5404 return (AV *)SvRV(ary);
5407 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5408 # define DEREF_PLAIN_ARRAY(ary) \
5411 SvTYPE(aRrRay) == SVt_PVAV \
5413 : S_deref_plain_array(aTHX_ aRrRay); \
5416 # define DEREF_PLAIN_ARRAY(ary) \
5418 PL_Sv = (SV *)(ary), \
5419 SvTYPE(PL_Sv) == SVt_PVAV \
5421 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5427 dVAR; dSP; dMARK; dORIGMARK;
5428 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5432 register I32 offset;
5433 register I32 length;
5437 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5440 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
5441 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5448 offset = i = SvIV(*MARK);
5450 offset += AvFILLp(ary) + 1;
5452 offset -= CopARYBASE_get(PL_curcop);
5454 DIE(aTHX_ PL_no_aelem, i);
5456 length = SvIVx(*MARK++);
5458 length += AvFILLp(ary) - offset + 1;
5464 length = AvMAX(ary) + 1; /* close enough to infinity */
5468 length = AvMAX(ary) + 1;
5470 if (offset > AvFILLp(ary) + 1) {
5471 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5472 offset = AvFILLp(ary) + 1;
5474 after = AvFILLp(ary) + 1 - (offset + length);
5475 if (after < 0) { /* not that much array */
5476 length += after; /* offset+length now in array */
5482 /* At this point, MARK .. SP-1 is our new LIST */
5485 diff = newlen - length;
5486 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5489 /* make new elements SVs now: avoid problems if they're from the array */
5490 for (dst = MARK, i = newlen; i; i--) {
5491 SV * const h = *dst;
5492 *dst++ = newSVsv(h);
5495 if (diff < 0) { /* shrinking the area */
5496 SV **tmparyval = NULL;
5498 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5499 Copy(MARK, tmparyval, newlen, SV*);
5502 MARK = ORIGMARK + 1;
5503 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5504 MEXTEND(MARK, length);
5505 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5507 EXTEND_MORTAL(length);
5508 for (i = length, dst = MARK; i; i--) {
5509 sv_2mortal(*dst); /* free them eventually */
5516 *MARK = AvARRAY(ary)[offset+length-1];
5519 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5520 SvREFCNT_dec(*dst++); /* free them now */
5523 AvFILLp(ary) += diff;
5525 /* pull up or down? */
5527 if (offset < after) { /* easier to pull up */
5528 if (offset) { /* esp. if nothing to pull */
5529 src = &AvARRAY(ary)[offset-1];
5530 dst = src - diff; /* diff is negative */
5531 for (i = offset; i > 0; i--) /* can't trust Copy */
5535 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5539 if (after) { /* anything to pull down? */
5540 src = AvARRAY(ary) + offset + length;
5541 dst = src + diff; /* diff is negative */
5542 Move(src, dst, after, SV*);
5544 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5545 /* avoid later double free */
5549 dst[--i] = &PL_sv_undef;
5552 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5553 Safefree(tmparyval);
5556 else { /* no, expanding (or same) */
5557 SV** tmparyval = NULL;
5559 Newx(tmparyval, length, SV*); /* so remember deletion */
5560 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5563 if (diff > 0) { /* expanding */
5564 /* push up or down? */
5565 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5569 Move(src, dst, offset, SV*);
5571 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5573 AvFILLp(ary) += diff;
5576 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5577 av_extend(ary, AvFILLp(ary) + diff);
5578 AvFILLp(ary) += diff;
5581 dst = AvARRAY(ary) + AvFILLp(ary);
5583 for (i = after; i; i--) {
5591 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5594 MARK = ORIGMARK + 1;
5595 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5597 Copy(tmparyval, MARK, length, SV*);
5599 EXTEND_MORTAL(length);
5600 for (i = length, dst = MARK; i; i--) {
5601 sv_2mortal(*dst); /* free them eventually */
5608 else if (length--) {
5609 *MARK = tmparyval[length];
5612 while (length-- > 0)
5613 SvREFCNT_dec(tmparyval[length]);
5617 *MARK = &PL_sv_undef;
5618 Safefree(tmparyval);
5622 mg_set(MUTABLE_SV(ary));
5630 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5631 register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5632 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5635 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5638 ENTER_with_name("call_PUSH");
5639 call_method("PUSH",G_SCALAR|G_DISCARD);
5640 LEAVE_with_name("call_PUSH");
5644 PL_delaymagic = DM_DELAY;
5645 for (++MARK; MARK <= SP; MARK++) {
5646 SV * const sv = newSV(0);
5648 sv_setsv(sv, *MARK);
5649 av_store(ary, AvFILLp(ary)+1, sv);
5651 if (PL_delaymagic & DM_ARRAY_ISA)
5652 mg_set(MUTABLE_SV(ary));
5657 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658 PUSHi( AvFILL(ary) + 1 );
5667 AV * const av = PL_op->op_flags & OPf_SPECIAL
5668 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5669 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5673 (void)sv_2mortal(sv);
5680 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5681 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5682 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5685 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5688 ENTER_with_name("call_UNSHIFT");
5689 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5690 LEAVE_with_name("call_UNSHIFT");
5695 av_unshift(ary, SP - MARK);
5697 SV * const sv = newSVsv(*++MARK);
5698 (void)av_store(ary, i++, sv);
5702 if (OP_GIMME(PL_op, 0) != G_VOID) {
5703 PUSHi( AvFILL(ary) + 1 );
5712 if (GIMME == G_ARRAY) {
5713 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5717 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5718 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5719 av = MUTABLE_AV((*SP));
5720 /* In-place reversing only happens in void context for the array
5721 * assignment. We don't need to push anything on the stack. */
5724 if (SvMAGICAL(av)) {
5726 register SV *tmp = sv_newmortal();
5727 /* For SvCANEXISTDELETE */
5730 bool can_preserve = SvCANEXISTDELETE(av);
5732 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5733 register SV *begin, *end;
5736 if (!av_exists(av, i)) {
5737 if (av_exists(av, j)) {
5738 register SV *sv = av_delete(av, j, 0);
5739 begin = *av_fetch(av, i, TRUE);
5740 sv_setsv_mg(begin, sv);
5744 else if (!av_exists(av, j)) {
5745 register SV *sv = av_delete(av, i, 0);
5746 end = *av_fetch(av, j, TRUE);
5747 sv_setsv_mg(end, sv);
5752 begin = *av_fetch(av, i, TRUE);
5753 end = *av_fetch(av, j, TRUE);
5754 sv_setsv(tmp, begin);
5755 sv_setsv_mg(begin, end);
5756 sv_setsv_mg(end, tmp);
5760 SV **begin = AvARRAY(av);
5763 SV **end = begin + AvFILLp(av);
5765 while (begin < end) {
5766 register SV * const tmp = *begin;
5777 register SV * const tmp = *MARK;
5781 /* safe as long as stack cannot get extended in the above */
5787 register char *down;
5792 SvUTF8_off(TARG); /* decontaminate */
5794 do_join(TARG, &PL_sv_no, MARK, SP);
5796 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5797 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5798 report_uninit(TARG);
5801 up = SvPV_force(TARG, len);
5803 if (DO_UTF8(TARG)) { /* first reverse each character */
5804 U8* s = (U8*)SvPVX(TARG);
5805 const U8* send = (U8*)(s + len);
5807 if (UTF8_IS_INVARIANT(*s)) {
5812 if (!utf8_to_uvchr(s, 0))
5816 down = (char*)(s - 1);
5817 /* reverse this character */
5821 *down-- = (char)tmp;
5827 down = SvPVX(TARG) + len - 1;
5831 *down-- = (char)tmp;
5833 (void)SvPOK_only_UTF8(TARG);
5845 register IV limit = POPi; /* note, negative is forever */
5846 SV * const sv = POPs;
5848 register const char *s = SvPV_const(sv, len);
5849 const bool do_utf8 = DO_UTF8(sv);
5850 const char *strend = s + len;
5852 register REGEXP *rx;
5854 register const char *m;
5856 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5857 I32 maxiters = slen + 10;
5858 I32 trailing_empty = 0;
5860 const I32 origlimit = limit;
5863 const I32 gimme = GIMME_V;
5865 const I32 oldsave = PL_savestack_ix;
5866 U32 make_mortal = SVs_TEMP;
5871 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5876 DIE(aTHX_ "panic: pp_split");
5879 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5880 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5882 RX_MATCH_UTF8_set(rx, do_utf8);
5885 if (pm->op_pmreplrootu.op_pmtargetoff) {
5886 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5889 if (pm->op_pmreplrootu.op_pmtargetgv) {
5890 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5895 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5901 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5903 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5910 for (i = AvFILLp(ary); i >= 0; i--)
5911 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5913 /* temporarily switch stacks */
5914 SAVESWITCHSTACK(PL_curstack, ary);
5918 base = SP - PL_stack_base;
5920 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5922 while (*s == ' ' || is_utf8_space((U8*)s))
5925 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5926 while (isSPACE_LC(*s))
5934 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5938 gimme_scalar = gimme == G_SCALAR && !ary;
5941 limit = maxiters + 2;
5942 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5945 /* this one uses 'm' and is a negative test */
5947 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5948 const int t = UTF8SKIP(m);
5949 /* is_utf8_space returns FALSE for malform utf8 */
5956 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5957 while (m < strend && !isSPACE_LC(*m))
5960 while (m < strend && !isSPACE(*m))
5973 dstr = newSVpvn_flags(s, m-s,
5974 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5978 /* skip the whitespace found last */
5980 s = m + UTF8SKIP(m);
5984 /* this one uses 's' and is a positive test */
5986 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5989 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5990 while (s < strend && isSPACE_LC(*s))
5993 while (s < strend && isSPACE(*s))
5998 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6000 for (m = s; m < strend && *m != '\n'; m++)
6013 dstr = newSVpvn_flags(s, m-s,
6014 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6020 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6022 Pre-extend the stack, either the number of bytes or
6023 characters in the string or a limited amount, triggered by:
6025 my ($x, $y) = split //, $str;
6029 if (!gimme_scalar) {
6030 const U32 items = limit - 1;
6039 /* keep track of how many bytes we skip over */
6049 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6062 dstr = newSVpvn(s, 1);
6078 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6079 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6080 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6081 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
6082 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6083 SV * const csv = CALLREG_INTUIT_STRING(rx);
6085 len = RX_MINLENRET(rx);
6086 if (len == 1 && !RX_UTF8(rx) && !tail) {
6087 const char c = *SvPV_nolen_const(csv);
6089 for (m = s; m < strend && *m != c; m++)
6100 dstr = newSVpvn_flags(s, m-s,
6101 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6104 /* The rx->minlen is in characters but we want to step
6105 * s ahead by bytes. */
6107 s = (char*)utf8_hop((U8*)m, len);
6109 s = m + len; /* Fake \n at the end */
6113 while (s < strend && --limit &&
6114 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6115 csv, multiline ? FBMrf_MULTILINE : 0)) )
6124 dstr = newSVpvn_flags(s, m-s,
6125 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6128 /* The rx->minlen is in characters but we want to step
6129 * s ahead by bytes. */
6131 s = (char*)utf8_hop((U8*)m, len);
6133 s = m + len; /* Fake \n at the end */
6138 maxiters += slen * RX_NPARENS(rx);
6139 while (s < strend && --limit)
6143 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
6146 if (rex_return == 0)
6148 TAINT_IF(RX_MATCH_TAINTED(rx));
6149 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
6152 orig = RX_SUBBEG(rx);
6154 strend = s + (strend - m);
6156 m = RX_OFFS(rx)[0].start + orig;
6165 dstr = newSVpvn_flags(s, m-s,
6166 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6169 if (RX_NPARENS(rx)) {
6171 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6172 s = RX_OFFS(rx)[i].start + orig;
6173 m = RX_OFFS(rx)[i].end + orig;
6175 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6176 parens that didn't match -- they should be set to
6177 undef, not the empty string */
6185 if (m >= orig && s >= orig) {
6186 dstr = newSVpvn_flags(s, m-s,
6187 (do_utf8 ? SVf_UTF8 : 0)
6191 dstr = &PL_sv_undef; /* undef, not "" */
6197 s = RX_OFFS(rx)[0].end + orig;
6201 if (!gimme_scalar) {
6202 iters = (SP - PL_stack_base) - base;
6204 if (iters > maxiters)
6205 DIE(aTHX_ "Split loop");
6207 /* keep field after final delim? */
6208 if (s < strend || (iters && origlimit)) {
6209 if (!gimme_scalar) {
6210 const STRLEN l = strend - s;
6211 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6216 else if (!origlimit) {
6218 iters -= trailing_empty;
6220 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6221 if (TOPs && !make_mortal)
6223 *SP-- = &PL_sv_undef;
6230 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6234 if (SvSMAGICAL(ary)) {
6236 mg_set(MUTABLE_SV(ary));
6239 if (gimme == G_ARRAY) {
6241 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6248 ENTER_with_name("call_PUSH");
6249 call_method("PUSH",G_SCALAR|G_DISCARD);
6250 LEAVE_with_name("call_PUSH");
6252 if (gimme == G_ARRAY) {
6254 /* EXTEND should not be needed - we just popped them */
6256 for (i=0; i < iters; i++) {
6257 SV **svp = av_fetch(ary, i, FALSE);
6258 PUSHs((svp) ? *svp : &PL_sv_undef);
6265 if (gimme == G_ARRAY)
6277 SV *const sv = PAD_SVl(PL_op->op_targ);
6279 if (SvPADSTALE(sv)) {
6282 RETURNOP(cLOGOP->op_other);
6284 RETURNOP(cLOGOP->op_next);
6293 assert(SvTYPE(retsv) != SVt_PVCV);
6295 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6296 retsv = refto(retsv);
6303 PP(unimplemented_op)
6306 const Optype op_type = PL_op->op_type;
6307 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6308 with out of range op numbers - it only "special" cases op_custom.
6309 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6310 if we get here for a custom op then that means that the custom op didn't
6311 have an implementation. Given that OP_NAME() looks up the custom op
6312 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6313 registers &PL_unimplemented_op as the address of their custom op.
6314 NULL doesn't generate a useful error message. "custom" does. */
6315 const char *const name = op_type >= OP_max
6316 ? "[out of range]" : PL_op_name[PL_op->op_type];
6317 if(OP_IS_SOCKET(op_type))
6318 DIE(aTHX_ PL_no_sock_func, name);
6319 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6326 HV * const hv = (HV*)POPs;
6328 if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
6330 if (SvRMAGICAL(hv)) {
6331 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6333 XPUSHs(magic_scalarpack(hv, mg));
6338 XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
6344 * c-indentation-style: bsd
6346 * indent-tabs-mode: t
6349 * ex: set ts=8 sts=4 sw=4 noet: