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) {
74 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
75 const I32 flags = is_lvalue_sub();
76 if (flags && !(flags & OPpENTERSUB_INARGS)) {
77 if (GIMME == G_SCALAR)
78 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84 if (gimme == G_ARRAY) {
85 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
87 if (SvMAGICAL(TARG)) {
89 for (i=0; i < (U32)maxarg; i++) {
90 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
91 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
95 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
99 else if (gimme == G_SCALAR) {
100 SV* const sv = sv_newmortal();
101 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
102 sv_setiv(sv, maxarg);
113 assert(SvTYPE(TARG) == SVt_PVHV);
115 if (PL_op->op_private & OPpLVAL_INTRO)
116 if (!(PL_op->op_private & OPpPAD_STATE))
117 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
118 if (PL_op->op_flags & OPf_REF)
120 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
121 const I32 flags = is_lvalue_sub();
122 if (flags && !(flags & OPpENTERSUB_INARGS)) {
123 if (GIMME == G_SCALAR)
124 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
129 if (gimme == G_ARRAY) {
130 RETURNOP(Perl_do_kv(aTHX));
132 else if (gimme == G_SCALAR) {
133 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
141 static const char S_no_symref_sv[] =
142 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
148 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
152 sv = amagic_deref_call(sv, to_gv_amg);
156 if (SvTYPE(sv) == SVt_PVIO) {
157 GV * const gv = MUTABLE_GV(sv_newmortal());
158 gv_init(gv, 0, "", 0, 0);
159 GvIOp(gv) = MUTABLE_IO(sv);
160 SvREFCNT_inc_void_NN(sv);
163 else if (!isGV_with_GP(sv))
164 DIE(aTHX_ "Not a GLOB reference");
167 if (!isGV_with_GP(sv)) {
168 if (!SvOK(sv) && sv != &PL_sv_undef) {
169 /* If this is a 'my' scalar and flag is set then vivify
173 Perl_croak_no_modify(aTHX);
174 if (PL_op->op_private & OPpDEREF) {
176 if (cUNOP->op_targ) {
178 SV * const namesv = PAD_SV(cUNOP->op_targ);
179 const char * const name = SvPV(namesv, len);
180 gv = MUTABLE_GV(newSV(0));
181 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
184 const char * const name = CopSTASHPV(PL_curcop);
187 prepare_SV_for_RV(sv);
188 SvRV_set(sv, MUTABLE_SV(gv));
193 if (PL_op->op_flags & OPf_REF ||
194 PL_op->op_private & HINT_STRICT_REFS)
195 DIE(aTHX_ PL_no_usym, "a symbol");
196 if (ckWARN(WARN_UNINITIALIZED))
200 if ((PL_op->op_flags & OPf_SPECIAL) &&
201 !(PL_op->op_flags & OPf_MOD))
203 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
205 && (!is_gv_magical_sv(sv,0)
206 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
213 if (PL_op->op_private & HINT_STRICT_REFS)
214 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
215 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
216 == OPpDONT_INIT_GV) {
217 /* We are the target of a coderef assignment. Return
218 the scalar unchanged, and let pp_sasssign deal with
222 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
224 /* FAKE globs in the symbol table cause weird bugs (#77810) */
225 if (sv) SvFAKE_off(sv);
228 if (sv && SvFAKE(sv)) {
229 SV *newsv = sv_newmortal();
230 sv_setsv_flags(newsv, sv, 0);
234 if (PL_op->op_private & OPpLVAL_INTRO)
235 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
240 /* Helper function for pp_rv2sv and pp_rv2av */
242 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
243 const svtype type, SV ***spp)
248 PERL_ARGS_ASSERT_SOFTREF2XV;
250 if (PL_op->op_private & HINT_STRICT_REFS) {
252 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
254 Perl_die(aTHX_ PL_no_usym, what);
258 PL_op->op_flags & OPf_REF &&
259 PL_op->op_next->op_type != OP_BOOLKEYS
261 Perl_die(aTHX_ PL_no_usym, what);
262 if (ckWARN(WARN_UNINITIALIZED))
264 if (type != SVt_PV && GIMME_V == G_ARRAY) {
268 **spp = &PL_sv_undef;
271 if ((PL_op->op_flags & OPf_SPECIAL) &&
272 !(PL_op->op_flags & OPf_MOD))
274 gv = gv_fetchsv(sv, 0, type);
276 && (!is_gv_magical_sv(sv,0)
277 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
279 **spp = &PL_sv_undef;
284 gv = gv_fetchsv(sv, GV_ADD, type);
294 if (!(PL_op->op_private & OPpDEREFed))
298 sv = amagic_deref_call(sv, to_sv_amg);
303 switch (SvTYPE(sv)) {
309 DIE(aTHX_ "Not a SCALAR reference");
316 if (!isGV_with_GP(gv)) {
317 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
323 if (PL_op->op_flags & OPf_MOD) {
324 if (PL_op->op_private & OPpLVAL_INTRO) {
325 if (cUNOP->op_first->op_type == OP_NULL)
326 sv = save_scalar(MUTABLE_GV(TOPs));
328 sv = save_scalar(gv);
330 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
332 else if (PL_op->op_private & OPpDEREF)
333 vivify_ref(sv, PL_op->op_private & OPpDEREF);
342 AV * const av = MUTABLE_AV(TOPs);
343 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
345 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
347 *sv = newSV_type(SVt_PVMG);
348 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
352 SETs(sv_2mortal(newSViv(
353 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
363 if (PL_op->op_flags & OPf_MOD || LVRET) {
364 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
365 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
367 LvTARG(ret) = SvREFCNT_inc_simple(sv);
368 PUSHs(ret); /* no SvSETMAGIC */
372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
373 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
374 if (mg && mg->mg_len >= 0) {
379 PUSHi(i + CopARYBASE_get(PL_curcop));
392 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
394 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
397 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
398 /* (But not in defined().) */
400 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
403 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
404 if ((PL_op->op_private & OPpLVAL_INTRO)) {
405 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
408 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
411 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
415 cv = MUTABLE_CV(&PL_sv_undef);
416 SETs(MUTABLE_SV(cv));
426 SV *ret = &PL_sv_undef;
428 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
429 const char * s = SvPVX_const(TOPs);
430 if (strnEQ(s, "CORE::", 6)) {
431 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
432 if (code < 0) { /* Overridable. */
433 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
434 int i = 0, n = 0, seen_question = 0, defgv = 0;
436 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
438 if (code == -KEY_chop || code == -KEY_chomp
439 || code == -KEY_exec || code == -KEY_system)
441 if (code == -KEY_mkdir) {
442 ret = newSVpvs_flags("_;$", SVs_TEMP);
445 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
446 ret = newSVpvs_flags("+", SVs_TEMP);
449 if (code == -KEY_push || code == -KEY_unshift) {
450 ret = newSVpvs_flags("+@", SVs_TEMP);
453 if (code == -KEY_pop || code == -KEY_shift) {
454 ret = newSVpvs_flags(";+", SVs_TEMP);
457 if (code == -KEY_splice) {
458 ret = newSVpvs_flags("+;$$@", SVs_TEMP);
461 if (code == -KEY_tied || code == -KEY_untie) {
462 ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
465 if (code == -KEY_tie) {
466 ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
469 if (code == -KEY_readpipe) {
470 s = "CORE::backtick";
472 while (i < MAXO) { /* The slow way. */
473 if (strEQ(s + 6, PL_op_name[i])
474 || strEQ(s + 6, PL_op_desc[i]))
480 goto nonesuch; /* Should not happen... */
482 defgv = PL_opargs[i] & OA_DEFGV;
483 oa = PL_opargs[i] >> OASHIFT;
485 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
489 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
490 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
491 /* But globs are already references (kinda) */
492 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
496 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
499 if (defgv && str[n - 1] == '$')
502 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
504 else if (code) /* Non-Overridable */
506 else { /* None such */
508 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
512 cv = sv_2cv(TOPs, &stash, &gv, 0);
514 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
523 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
525 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
527 PUSHs(MUTABLE_SV(cv));
541 if (GIMME != G_ARRAY) {
545 *MARK = &PL_sv_undef;
546 *MARK = refto(*MARK);
550 EXTEND_MORTAL(SP - MARK);
552 *MARK = refto(*MARK);
557 S_refto(pTHX_ SV *sv)
562 PERL_ARGS_ASSERT_REFTO;
564 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
567 if (!(sv = LvTARG(sv)))
570 SvREFCNT_inc_void_NN(sv);
572 else if (SvTYPE(sv) == SVt_PVAV) {
573 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
574 av_reify(MUTABLE_AV(sv));
576 SvREFCNT_inc_void_NN(sv);
578 else if (SvPADTMP(sv) && !IS_PADGV(sv))
582 SvREFCNT_inc_void_NN(sv);
585 sv_upgrade(rv, SVt_IV);
595 SV * const sv = POPs;
600 if (!sv || !SvROK(sv))
603 pv = sv_reftype(SvRV(sv),TRUE);
604 PUSHp(pv, strlen(pv));
614 stash = CopSTASH(PL_curcop);
616 SV * const ssv = POPs;
620 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
621 Perl_croak(aTHX_ "Attempt to bless into a reference");
622 ptr = SvPV_const(ssv,len);
624 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
625 "Explicit blessing to '' (assuming package main)");
626 stash = gv_stashpvn(ptr, len, GV_ADD);
629 (void)sv_bless(TOPs, stash);
638 const char * const elem = SvPV_nolen_const(sv);
639 GV * const gv = MUTABLE_GV(POPs);
644 /* elem will always be NUL terminated. */
645 const char * const second_letter = elem + 1;
648 if (strEQ(second_letter, "RRAY"))
649 tmpRef = MUTABLE_SV(GvAV(gv));
652 if (strEQ(second_letter, "ODE"))
653 tmpRef = MUTABLE_SV(GvCVu(gv));
656 if (strEQ(second_letter, "ILEHANDLE")) {
657 /* finally deprecated in 5.8.0 */
658 deprecate("*glob{FILEHANDLE}");
659 tmpRef = MUTABLE_SV(GvIOp(gv));
662 if (strEQ(second_letter, "ORMAT"))
663 tmpRef = MUTABLE_SV(GvFORM(gv));
666 if (strEQ(second_letter, "LOB"))
667 tmpRef = MUTABLE_SV(gv);
670 if (strEQ(second_letter, "ASH"))
671 tmpRef = MUTABLE_SV(GvHV(gv));
674 if (*second_letter == 'O' && !elem[2])
675 tmpRef = MUTABLE_SV(GvIOp(gv));
678 if (strEQ(second_letter, "AME"))
679 sv = newSVhek(GvNAME_HEK(gv));
682 if (strEQ(second_letter, "ACKAGE")) {
683 const HV * const stash = GvSTASH(gv);
684 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
685 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
689 if (strEQ(second_letter, "CALAR"))
704 /* Pattern matching */
709 register unsigned char *s;
712 register I32 *sfirst;
716 if (sv == PL_lastscream) {
720 s = (unsigned char*)(SvPV(sv, len));
721 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
722 /* No point in studying a zero length string, and not safe to study
723 anything that doesn't appear to be a simple scalar (and hence might
724 change between now and when the regexp engine runs without our set
725 magic ever running) such as a reference to an object with overloaded
726 stringification. Also refuse to study an FBM scalar, as this gives
727 more flexibility in SV flag usage. No real-world code would ever
728 end up studying an FBM scalar, so this isn't a real pessimisation.
735 SvSCREAM_off(PL_lastscream);
736 SvREFCNT_dec(PL_lastscream);
738 PL_lastscream = SvREFCNT_inc_simple(sv);
740 if (pos > PL_maxscream) {
741 if (PL_maxscream < 0) {
742 PL_maxscream = pos + 80;
743 Newx(PL_screamfirst, 256, I32);
744 Newx(PL_screamnext, PL_maxscream, I32);
747 PL_maxscream = pos + pos / 4;
748 Renew(PL_screamnext, PL_maxscream, I32);
752 sfirst = PL_screamfirst;
753 snext = PL_screamnext;
755 if (!sfirst || !snext)
756 DIE(aTHX_ "do_study: out of memory");
758 for (ch = 256; ch; --ch)
763 register const I32 ch = s[pos];
765 snext[pos] = sfirst[ch] - pos;
772 /* piggyback on m//g magic */
773 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
782 if (PL_op->op_flags & OPf_STACKED)
784 else if (PL_op->op_private & OPpTARGET_MY)
790 TARG = sv_newmortal();
791 if(PL_op->op_type == OP_TRANSR) {
792 SV * const newsv = newSVsv(sv);
796 else PUSHi(do_trans(sv));
800 /* Lvalue operators. */
803 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
809 PERL_ARGS_ASSERT_DO_CHOMP;
811 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
813 if (SvTYPE(sv) == SVt_PVAV) {
815 AV *const av = MUTABLE_AV(sv);
816 const I32 max = AvFILL(av);
818 for (i = 0; i <= max; i++) {
819 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
820 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
821 do_chomp(retval, sv, chomping);
825 else if (SvTYPE(sv) == SVt_PVHV) {
826 HV* const hv = MUTABLE_HV(sv);
828 (void)hv_iterinit(hv);
829 while ((entry = hv_iternext(hv)))
830 do_chomp(retval, hv_iterval(hv,entry), chomping);
833 else if (SvREADONLY(sv)) {
835 /* SV is copy-on-write */
836 sv_force_normal_flags(sv, 0);
839 Perl_croak_no_modify(aTHX);
844 /* XXX, here sv is utf8-ized as a side-effect!
845 If encoding.pm is used properly, almost string-generating
846 operations, including literal strings, chr(), input data, etc.
847 should have been utf8-ized already, right?
849 sv_recode_to_utf8(sv, PL_encoding);
855 char *temp_buffer = NULL;
864 while (len && s[-1] == '\n') {
871 STRLEN rslen, rs_charlen;
872 const char *rsptr = SvPV_const(PL_rs, rslen);
874 rs_charlen = SvUTF8(PL_rs)
878 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
879 /* Assumption is that rs is shorter than the scalar. */
881 /* RS is utf8, scalar is 8 bit. */
883 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
886 /* Cannot downgrade, therefore cannot possibly match
888 assert (temp_buffer == rsptr);
894 else if (PL_encoding) {
895 /* RS is 8 bit, encoding.pm is used.
896 * Do not recode PL_rs as a side-effect. */
897 svrecode = newSVpvn(rsptr, rslen);
898 sv_recode_to_utf8(svrecode, PL_encoding);
899 rsptr = SvPV_const(svrecode, rslen);
900 rs_charlen = sv_len_utf8(svrecode);
903 /* RS is 8 bit, scalar is utf8. */
904 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
918 if (memNE(s, rsptr, rslen))
920 SvIVX(retval) += rs_charlen;
923 s = SvPV_force_nolen(sv);
931 SvREFCNT_dec(svrecode);
933 Safefree(temp_buffer);
935 if (len && !SvPOK(sv))
936 s = SvPV_force_nomg(sv, len);
939 char * const send = s + len;
940 char * const start = s;
942 while (s > start && UTF8_IS_CONTINUATION(*s))
944 if (is_utf8_string((U8*)s, send - s)) {
945 sv_setpvn(retval, s, send - s);
947 SvCUR_set(sv, s - start);
953 sv_setpvs(retval, "");
957 sv_setpvn(retval, s, 1);
964 sv_setpvs(retval, "");
972 const bool chomping = PL_op->op_type == OP_SCHOMP;
976 do_chomp(TARG, TOPs, chomping);
983 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
984 const bool chomping = PL_op->op_type == OP_CHOMP;
989 do_chomp(TARG, *++MARK, chomping);
1000 if (!PL_op->op_private) {
1009 SV_CHECK_THINKFIRST_COW_DROP(sv);
1011 switch (SvTYPE(sv)) {
1015 av_undef(MUTABLE_AV(sv));
1018 hv_undef(MUTABLE_HV(sv));
1021 if (cv_const_sv((const CV *)sv))
1022 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
1023 CvANON((const CV *)sv) ? "(anonymous)"
1024 : GvENAME(CvGV((const CV *)sv)));
1028 /* let user-undef'd sub keep its identity */
1029 GV* const gv = CvGV((const CV *)sv);
1030 cv_undef(MUTABLE_CV(sv));
1031 CvGV_set(MUTABLE_CV(sv), gv);
1036 SvSetMagicSV(sv, &PL_sv_undef);
1039 else if (isGV_with_GP(sv)) {
1043 /* undef *Pkg::meth_name ... */
1045 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1046 && HvENAME_get(stash);
1048 if((stash = GvHV((const GV *)sv))) {
1049 if(HvENAME_get(stash))
1050 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1054 gp_free(MUTABLE_GV(sv));
1056 GvGP_set(sv, gp_ref(gp));
1057 GvSV(sv) = newSV(0);
1058 GvLINE(sv) = CopLINE(PL_curcop);
1059 GvEGV(sv) = MUTABLE_GV(sv);
1063 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1065 /* undef *Foo::ISA */
1066 if( strEQ(GvNAME((const GV *)sv), "ISA")
1067 && (stash = GvSTASH((const GV *)sv))
1068 && (method_changed || HvENAME(stash)) )
1069 mro_isa_changed_in(stash);
1070 else if(method_changed)
1071 mro_method_changed_in(
1072 GvSTASH((const GV *)sv)
1079 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1094 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1095 Perl_croak_no_modify(aTHX);
1096 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1097 && SvIVX(TOPs) != IV_MIN)
1099 SvIV_set(TOPs, SvIVX(TOPs) - 1);
1100 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1111 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1112 Perl_croak_no_modify(aTHX);
1114 TARG = sv_newmortal();
1115 sv_setsv(TARG, TOPs);
1116 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1117 && SvIVX(TOPs) != IV_MAX)
1119 SvIV_set(TOPs, SvIVX(TOPs) + 1);
1120 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1125 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1135 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
1136 Perl_croak_no_modify(aTHX);
1138 TARG = sv_newmortal();
1139 sv_setsv(TARG, TOPs);
1140 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1141 && SvIVX(TOPs) != IV_MIN)
1143 SvIV_set(TOPs, SvIVX(TOPs) - 1);
1144 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1153 /* Ordinary operators. */
1157 dVAR; dSP; dATARGET; SV *svl, *svr;
1158 #ifdef PERL_PRESERVE_IVUV
1161 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1164 #ifdef PERL_PRESERVE_IVUV
1165 /* For integer to integer power, we do the calculation by hand wherever
1166 we're sure it is safe; otherwise we call pow() and try to convert to
1167 integer afterwards. */
1169 SvIV_please_nomg(svr);
1171 SvIV_please_nomg(svl);
1180 const IV iv = SvIVX(svr);
1184 goto float_it; /* Can't do negative powers this way. */
1188 baseuok = SvUOK(svl);
1190 baseuv = SvUVX(svl);
1192 const IV iv = SvIVX(svl);
1195 baseuok = TRUE; /* effectively it's a UV now */
1197 baseuv = -iv; /* abs, baseuok == false records sign */
1200 /* now we have integer ** positive integer. */
1203 /* foo & (foo - 1) is zero only for a power of 2. */
1204 if (!(baseuv & (baseuv - 1))) {
1205 /* We are raising power-of-2 to a positive integer.
1206 The logic here will work for any base (even non-integer
1207 bases) but it can be less accurate than
1208 pow (base,power) or exp (power * log (base)) when the
1209 intermediate values start to spill out of the mantissa.
1210 With powers of 2 we know this can't happen.
1211 And powers of 2 are the favourite thing for perl
1212 programmers to notice ** not doing what they mean. */
1214 NV base = baseuok ? baseuv : -(NV)baseuv;
1219 while (power >>= 1) {
1227 SvIV_please_nomg(svr);
1230 register unsigned int highbit = 8 * sizeof(UV);
1231 register unsigned int diff = 8 * sizeof(UV);
1232 while (diff >>= 1) {
1234 if (baseuv >> highbit) {
1238 /* we now have baseuv < 2 ** highbit */
1239 if (power * highbit <= 8 * sizeof(UV)) {
1240 /* result will definitely fit in UV, so use UV math
1241 on same algorithm as above */
1242 register UV result = 1;
1243 register UV base = baseuv;
1244 const bool odd_power = cBOOL(power & 1);
1248 while (power >>= 1) {
1255 if (baseuok || !odd_power)
1256 /* answer is positive */
1258 else if (result <= (UV)IV_MAX)
1259 /* answer negative, fits in IV */
1260 SETi( -(IV)result );
1261 else if (result == (UV)IV_MIN)
1262 /* 2's complement assumption: special case IV_MIN */
1265 /* answer negative, doesn't fit */
1266 SETn( -(NV)result );
1276 NV right = SvNV_nomg(svr);
1277 NV left = SvNV_nomg(svl);
1280 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1282 We are building perl with long double support and are on an AIX OS
1283 afflicted with a powl() function that wrongly returns NaNQ for any
1284 negative base. This was reported to IBM as PMR #23047-379 on
1285 03/06/2006. The problem exists in at least the following versions
1286 of AIX and the libm fileset, and no doubt others as well:
1288 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1289 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1290 AIX 5.2.0 bos.adt.libm 5.2.0.85
1292 So, until IBM fixes powl(), we provide the following workaround to
1293 handle the problem ourselves. Our logic is as follows: for
1294 negative bases (left), we use fmod(right, 2) to check if the
1295 exponent is an odd or even integer:
1297 - if odd, powl(left, right) == -powl(-left, right)
1298 - if even, powl(left, right) == powl(-left, right)
1300 If the exponent is not an integer, the result is rightly NaNQ, so
1301 we just return that (as NV_NAN).
1305 NV mod2 = Perl_fmod( right, 2.0 );
1306 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1307 SETn( -Perl_pow( -left, right) );
1308 } else if (mod2 == 0.0) { /* even integer */
1309 SETn( Perl_pow( -left, right) );
1310 } else { /* fractional power */
1314 SETn( Perl_pow( left, right) );
1317 SETn( Perl_pow( left, right) );
1318 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1320 #ifdef PERL_PRESERVE_IVUV
1322 SvIV_please_nomg(svr);
1330 dVAR; dSP; dATARGET; SV *svl, *svr;
1331 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1334 #ifdef PERL_PRESERVE_IVUV
1335 SvIV_please_nomg(svr);
1337 /* Unless the left argument is integer in range we are going to have to
1338 use NV maths. Hence only attempt to coerce the right argument if
1339 we know the left is integer. */
1340 /* Left operand is defined, so is it IV? */
1341 SvIV_please_nomg(svl);
1343 bool auvok = SvUOK(svl);
1344 bool buvok = SvUOK(svr);
1345 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1346 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1355 const IV aiv = SvIVX(svl);
1358 auvok = TRUE; /* effectively it's a UV now */
1360 alow = -aiv; /* abs, auvok == false records sign */
1366 const IV biv = SvIVX(svr);
1369 buvok = TRUE; /* effectively it's a UV now */
1371 blow = -biv; /* abs, buvok == false records sign */
1375 /* If this does sign extension on unsigned it's time for plan B */
1376 ahigh = alow >> (4 * sizeof (UV));
1378 bhigh = blow >> (4 * sizeof (UV));
1380 if (ahigh && bhigh) {
1382 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1383 which is overflow. Drop to NVs below. */
1384 } else if (!ahigh && !bhigh) {
1385 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1386 so the unsigned multiply cannot overflow. */
1387 const UV product = alow * blow;
1388 if (auvok == buvok) {
1389 /* -ve * -ve or +ve * +ve gives a +ve result. */
1393 } else if (product <= (UV)IV_MIN) {
1394 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1395 /* -ve result, which could overflow an IV */
1397 SETi( -(IV)product );
1399 } /* else drop to NVs below. */
1401 /* One operand is large, 1 small */
1404 /* swap the operands */
1406 bhigh = blow; /* bhigh now the temp var for the swap */
1410 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1411 multiplies can't overflow. shift can, add can, -ve can. */
1412 product_middle = ahigh * blow;
1413 if (!(product_middle & topmask)) {
1414 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1416 product_middle <<= (4 * sizeof (UV));
1417 product_low = alow * blow;
1419 /* as for pp_add, UV + something mustn't get smaller.
1420 IIRC ANSI mandates this wrapping *behaviour* for
1421 unsigned whatever the actual representation*/
1422 product_low += product_middle;
1423 if (product_low >= product_middle) {
1424 /* didn't overflow */
1425 if (auvok == buvok) {
1426 /* -ve * -ve or +ve * +ve gives a +ve result. */
1428 SETu( product_low );
1430 } else if (product_low <= (UV)IV_MIN) {
1431 /* 2s complement assumption again */
1432 /* -ve result, which could overflow an IV */
1434 SETi( -(IV)product_low );
1436 } /* else drop to NVs below. */
1438 } /* product_middle too large */
1439 } /* ahigh && bhigh */
1444 NV right = SvNV_nomg(svr);
1445 NV left = SvNV_nomg(svl);
1447 SETn( left * right );
1454 dVAR; dSP; dATARGET; SV *svl, *svr;
1455 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1458 /* Only try to do UV divide first
1459 if ((SLOPPYDIVIDE is true) or
1460 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1462 The assumption is that it is better to use floating point divide
1463 whenever possible, only doing integer divide first if we can't be sure.
1464 If NV_PRESERVES_UV is true then we know at compile time that no UV
1465 can be too large to preserve, so don't need to compile the code to
1466 test the size of UVs. */
1469 # define PERL_TRY_UV_DIVIDE
1470 /* ensure that 20./5. == 4. */
1472 # ifdef PERL_PRESERVE_IVUV
1473 # ifndef NV_PRESERVES_UV
1474 # define PERL_TRY_UV_DIVIDE
1479 #ifdef PERL_TRY_UV_DIVIDE
1480 SvIV_please_nomg(svr);
1482 SvIV_please_nomg(svl);
1484 bool left_non_neg = SvUOK(svl);
1485 bool right_non_neg = SvUOK(svr);
1489 if (right_non_neg) {
1493 const IV biv = SvIVX(svr);
1496 right_non_neg = TRUE; /* effectively it's a UV now */
1502 /* historically undef()/0 gives a "Use of uninitialized value"
1503 warning before dieing, hence this test goes here.
1504 If it were immediately before the second SvIV_please, then
1505 DIE() would be invoked before left was even inspected, so
1506 no inspection would give no warning. */
1508 DIE(aTHX_ "Illegal division by zero");
1514 const IV aiv = SvIVX(svl);
1517 left_non_neg = TRUE; /* effectively it's a UV now */
1526 /* For sloppy divide we always attempt integer division. */
1528 /* Otherwise we only attempt it if either or both operands
1529 would not be preserved by an NV. If both fit in NVs
1530 we fall through to the NV divide code below. However,
1531 as left >= right to ensure integer result here, we know that
1532 we can skip the test on the right operand - right big
1533 enough not to be preserved can't get here unless left is
1536 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1539 /* Integer division can't overflow, but it can be imprecise. */
1540 const UV result = left / right;
1541 if (result * right == left) {
1542 SP--; /* result is valid */
1543 if (left_non_neg == right_non_neg) {
1544 /* signs identical, result is positive. */
1548 /* 2s complement assumption */
1549 if (result <= (UV)IV_MIN)
1550 SETi( -(IV)result );
1552 /* It's exact but too negative for IV. */
1553 SETn( -(NV)result );
1556 } /* tried integer divide but it was not an integer result */
1557 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1558 } /* left wasn't SvIOK */
1559 } /* right wasn't SvIOK */
1560 #endif /* PERL_TRY_UV_DIVIDE */
1562 NV right = SvNV_nomg(svr);
1563 NV left = SvNV_nomg(svl);
1564 (void)POPs;(void)POPs;
1565 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1566 if (! Perl_isnan(right) && right == 0.0)
1570 DIE(aTHX_ "Illegal division by zero");
1571 PUSHn( left / right );
1578 dVAR; dSP; dATARGET;
1579 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1583 bool left_neg = FALSE;
1584 bool right_neg = FALSE;
1585 bool use_double = FALSE;
1586 bool dright_valid = FALSE;
1589 SV * const svr = TOPs;
1590 SV * const svl = TOPm1s;
1591 SvIV_please_nomg(svr);
1593 right_neg = !SvUOK(svr);
1597 const IV biv = SvIVX(svr);
1600 right_neg = FALSE; /* effectively it's a UV now */
1607 dright = SvNV_nomg(svr);
1608 right_neg = dright < 0;
1611 if (dright < UV_MAX_P1) {
1612 right = U_V(dright);
1613 dright_valid = TRUE; /* In case we need to use double below. */
1619 /* At this point use_double is only true if right is out of range for
1620 a UV. In range NV has been rounded down to nearest UV and
1621 use_double false. */
1622 SvIV_please_nomg(svl);
1623 if (!use_double && SvIOK(svl)) {
1625 left_neg = !SvUOK(svl);
1629 const IV aiv = SvIVX(svl);
1632 left_neg = FALSE; /* effectively it's a UV now */
1640 dleft = SvNV_nomg(svl);
1641 left_neg = dleft < 0;
1645 /* This should be exactly the 5.6 behaviour - if left and right are
1646 both in range for UV then use U_V() rather than floor. */
1648 if (dleft < UV_MAX_P1) {
1649 /* right was in range, so is dleft, so use UVs not double.
1653 /* left is out of range for UV, right was in range, so promote
1654 right (back) to double. */
1656 /* The +0.5 is used in 5.6 even though it is not strictly
1657 consistent with the implicit +0 floor in the U_V()
1658 inside the #if 1. */
1659 dleft = Perl_floor(dleft + 0.5);
1662 dright = Perl_floor(dright + 0.5);
1673 DIE(aTHX_ "Illegal modulus zero");
1675 dans = Perl_fmod(dleft, dright);
1676 if ((left_neg != right_neg) && dans)
1677 dans = dright - dans;
1680 sv_setnv(TARG, dans);
1686 DIE(aTHX_ "Illegal modulus zero");
1689 if ((left_neg != right_neg) && ans)
1692 /* XXX may warn: unary minus operator applied to unsigned type */
1693 /* could change -foo to be (~foo)+1 instead */
1694 if (ans <= ~((UV)IV_MAX)+1)
1695 sv_setiv(TARG, ~ans+1);
1697 sv_setnv(TARG, -(NV)ans);
1700 sv_setuv(TARG, ans);
1709 dVAR; dSP; dATARGET;
1713 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1714 /* TODO: think of some way of doing list-repeat overloading ??? */
1719 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1725 const UV uv = SvUV_nomg(sv);
1727 count = IV_MAX; /* The best we can do? */
1731 const IV iv = SvIV_nomg(sv);
1738 else if (SvNOKp(sv)) {
1739 const NV nv = SvNV_nomg(sv);
1746 count = SvIV_nomg(sv);
1748 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1750 static const char oom_list_extend[] = "Out of memory during list extend";
1751 const I32 items = SP - MARK;
1752 const I32 max = items * count;
1754 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1755 /* Did the max computation overflow? */
1756 if (items > 0 && max > 0 && (max < items || max < count))
1757 Perl_croak(aTHX_ oom_list_extend);
1762 /* This code was intended to fix 20010809.028:
1765 for (($x =~ /./g) x 2) {
1766 print chop; # "abcdabcd" expected as output.
1769 * but that change (#11635) broke this code:
1771 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1773 * I can't think of a better fix that doesn't introduce
1774 * an efficiency hit by copying the SVs. The stack isn't
1775 * refcounted, and mortalisation obviously doesn't
1776 * Do The Right Thing when the stack has more than
1777 * one pointer to the same mortal value.
1781 *SP = sv_2mortal(newSVsv(*SP));
1791 repeatcpy((char*)(MARK + items), (char*)MARK,
1792 items * sizeof(const SV *), count - 1);
1795 else if (count <= 0)
1798 else { /* Note: mark already snarfed by pp_list */
1799 SV * const tmpstr = POPs;
1802 static const char oom_string_extend[] =
1803 "Out of memory during string extend";
1806 sv_setsv_nomg(TARG, tmpstr);
1807 SvPV_force_nomg(TARG, len);
1808 isutf = DO_UTF8(TARG);
1813 const STRLEN max = (UV)count * len;
1814 if (len > MEM_SIZE_MAX / count)
1815 Perl_croak(aTHX_ oom_string_extend);
1816 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1817 SvGROW(TARG, max + 1);
1818 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1819 SvCUR_set(TARG, SvCUR(TARG) * count);
1821 *SvEND(TARG) = '\0';
1824 (void)SvPOK_only_UTF8(TARG);
1826 (void)SvPOK_only(TARG);
1828 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1829 /* The parser saw this as a list repeat, and there
1830 are probably several items on the stack. But we're
1831 in scalar context, and there's no pp_list to save us
1832 now. So drop the rest of the items -- robin@kitsite.com
1844 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1845 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1848 useleft = USE_LEFT(svl);
1849 #ifdef PERL_PRESERVE_IVUV
1850 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1851 "bad things" happen if you rely on signed integers wrapping. */
1852 SvIV_please_nomg(svr);
1854 /* Unless the left argument is integer in range we are going to have to
1855 use NV maths. Hence only attempt to coerce the right argument if
1856 we know the left is integer. */
1857 register UV auv = 0;
1863 a_valid = auvok = 1;
1864 /* left operand is undef, treat as zero. */
1866 /* Left operand is defined, so is it IV? */
1867 SvIV_please_nomg(svl);
1869 if ((auvok = SvUOK(svl)))
1872 register const IV aiv = SvIVX(svl);
1875 auvok = 1; /* Now acting as a sign flag. */
1876 } else { /* 2s complement assumption for IV_MIN */
1884 bool result_good = 0;
1887 bool buvok = SvUOK(svr);
1892 register const IV biv = SvIVX(svr);
1899 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1900 else "IV" now, independent of how it came in.
1901 if a, b represents positive, A, B negative, a maps to -A etc
1906 all UV maths. negate result if A negative.
1907 subtract if signs same, add if signs differ. */
1909 if (auvok ^ buvok) {
1918 /* Must get smaller */
1923 if (result <= buv) {
1924 /* result really should be -(auv-buv). as its negation
1925 of true value, need to swap our result flag */
1937 if (result <= (UV)IV_MIN)
1938 SETi( -(IV)result );
1940 /* result valid, but out of range for IV. */
1941 SETn( -(NV)result );
1945 } /* Overflow, drop through to NVs. */
1950 NV value = SvNV_nomg(svr);
1954 /* left operand is undef, treat as zero - value */
1958 SETn( SvNV_nomg(svl) - value );
1965 dVAR; dSP; dATARGET; SV *svl, *svr;
1966 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1970 const IV shift = SvIV_nomg(svr);
1971 if (PL_op->op_private & HINT_INTEGER) {
1972 const IV i = SvIV_nomg(svl);
1976 const UV u = SvUV_nomg(svl);
1985 dVAR; dSP; dATARGET; SV *svl, *svr;
1986 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1990 const IV shift = SvIV_nomg(svr);
1991 if (PL_op->op_private & HINT_INTEGER) {
1992 const IV i = SvIV_nomg(svl);
1996 const UV u = SvUV_nomg(svl);
2006 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2007 #ifdef PERL_PRESERVE_IVUV
2008 SvIV_please_nomg(TOPs);
2010 SvIV_please_nomg(TOPm1s);
2011 if (SvIOK(TOPm1s)) {
2012 bool auvok = SvUOK(TOPm1s);
2013 bool buvok = SvUOK(TOPs);
2015 if (!auvok && !buvok) { /* ## IV < IV ## */
2016 const IV aiv = SvIVX(TOPm1s);
2017 const IV biv = SvIVX(TOPs);
2020 SETs(boolSV(aiv < biv));
2023 if (auvok && buvok) { /* ## UV < UV ## */
2024 const UV auv = SvUVX(TOPm1s);
2025 const UV buv = SvUVX(TOPs);
2028 SETs(boolSV(auv < buv));
2031 if (auvok) { /* ## UV < IV ## */
2033 const IV biv = SvIVX(TOPs);
2036 /* As (a) is a UV, it's >=0, so it cannot be < */
2041 SETs(boolSV(auv < (UV)biv));
2044 { /* ## IV < UV ## */
2045 const IV aiv = SvIVX(TOPm1s);
2049 /* As (b) is a UV, it's >=0, so it must be < */
2056 SETs(boolSV((UV)aiv < buv));
2062 #ifndef NV_PRESERVES_UV
2063 #ifdef PERL_PRESERVE_IVUV
2066 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2068 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
2073 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2075 if (Perl_isnan(left) || Perl_isnan(right))
2077 SETs(boolSV(left < right));
2080 SETs(boolSV(SvNV_nomg(TOPs) < value));
2089 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2090 #ifdef PERL_PRESERVE_IVUV
2091 SvIV_please_nomg(TOPs);
2093 SvIV_please_nomg(TOPm1s);
2094 if (SvIOK(TOPm1s)) {
2095 bool auvok = SvUOK(TOPm1s);
2096 bool buvok = SvUOK(TOPs);
2098 if (!auvok && !buvok) { /* ## IV > IV ## */
2099 const IV aiv = SvIVX(TOPm1s);
2100 const IV biv = SvIVX(TOPs);
2103 SETs(boolSV(aiv > biv));
2106 if (auvok && buvok) { /* ## UV > UV ## */
2107 const UV auv = SvUVX(TOPm1s);
2108 const UV buv = SvUVX(TOPs);
2111 SETs(boolSV(auv > buv));
2114 if (auvok) { /* ## UV > IV ## */
2116 const IV biv = SvIVX(TOPs);
2120 /* As (a) is a UV, it's >=0, so it must be > */
2125 SETs(boolSV(auv > (UV)biv));
2128 { /* ## IV > UV ## */
2129 const IV aiv = SvIVX(TOPm1s);
2133 /* As (b) is a UV, it's >=0, so it cannot be > */
2140 SETs(boolSV((UV)aiv > buv));
2146 #ifndef NV_PRESERVES_UV
2147 #ifdef PERL_PRESERVE_IVUV
2150 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2152 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
2157 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2159 if (Perl_isnan(left) || Perl_isnan(right))
2161 SETs(boolSV(left > right));
2164 SETs(boolSV(SvNV_nomg(TOPs) > value));
2173 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2174 #ifdef PERL_PRESERVE_IVUV
2175 SvIV_please_nomg(TOPs);
2177 SvIV_please_nomg(TOPm1s);
2178 if (SvIOK(TOPm1s)) {
2179 bool auvok = SvUOK(TOPm1s);
2180 bool buvok = SvUOK(TOPs);
2182 if (!auvok && !buvok) { /* ## IV <= IV ## */
2183 const IV aiv = SvIVX(TOPm1s);
2184 const IV biv = SvIVX(TOPs);
2187 SETs(boolSV(aiv <= biv));
2190 if (auvok && buvok) { /* ## UV <= UV ## */
2191 UV auv = SvUVX(TOPm1s);
2192 UV buv = SvUVX(TOPs);
2195 SETs(boolSV(auv <= buv));
2198 if (auvok) { /* ## UV <= IV ## */
2200 const IV biv = SvIVX(TOPs);
2204 /* As (a) is a UV, it's >=0, so a cannot be <= */
2209 SETs(boolSV(auv <= (UV)biv));
2212 { /* ## IV <= UV ## */
2213 const IV aiv = SvIVX(TOPm1s);
2217 /* As (b) is a UV, it's >=0, so a must be <= */
2224 SETs(boolSV((UV)aiv <= buv));
2230 #ifndef NV_PRESERVES_UV
2231 #ifdef PERL_PRESERVE_IVUV
2234 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2236 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2241 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2243 if (Perl_isnan(left) || Perl_isnan(right))
2245 SETs(boolSV(left <= right));
2248 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2257 tryAMAGICbin_MG(ge_amg,AMGf_set|AMGf_numeric);
2258 #ifdef PERL_PRESERVE_IVUV
2259 SvIV_please_nomg(TOPs);
2261 SvIV_please_nomg(TOPm1s);
2262 if (SvIOK(TOPm1s)) {
2263 bool auvok = SvUOK(TOPm1s);
2264 bool buvok = SvUOK(TOPs);
2266 if (!auvok && !buvok) { /* ## IV >= IV ## */
2267 const IV aiv = SvIVX(TOPm1s);
2268 const IV biv = SvIVX(TOPs);
2271 SETs(boolSV(aiv >= biv));
2274 if (auvok && buvok) { /* ## UV >= UV ## */
2275 const UV auv = SvUVX(TOPm1s);
2276 const UV buv = SvUVX(TOPs);
2279 SETs(boolSV(auv >= buv));
2282 if (auvok) { /* ## UV >= IV ## */
2284 const IV biv = SvIVX(TOPs);
2288 /* As (a) is a UV, it's >=0, so it must be >= */
2293 SETs(boolSV(auv >= (UV)biv));
2296 { /* ## IV >= UV ## */
2297 const IV aiv = SvIVX(TOPm1s);
2301 /* As (b) is a UV, it's >=0, so a cannot be >= */
2308 SETs(boolSV((UV)aiv >= buv));
2314 #ifndef NV_PRESERVES_UV
2315 #ifdef PERL_PRESERVE_IVUV
2318 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2320 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2325 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2327 if (Perl_isnan(left) || Perl_isnan(right))
2329 SETs(boolSV(left >= right));
2332 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2341 tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric);
2342 #ifndef NV_PRESERVES_UV
2343 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2345 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2349 #ifdef PERL_PRESERVE_IVUV
2350 SvIV_please_nomg(TOPs);
2352 SvIV_please_nomg(TOPm1s);
2353 if (SvIOK(TOPm1s)) {
2354 const bool auvok = SvUOK(TOPm1s);
2355 const bool buvok = SvUOK(TOPs);
2357 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2358 /* Casting IV to UV before comparison isn't going to matter
2359 on 2s complement. On 1s complement or sign&magnitude
2360 (if we have any of them) it could make negative zero
2361 differ from normal zero. As I understand it. (Need to
2362 check - is negative zero implementation defined behaviour
2364 const UV buv = SvUVX(POPs);
2365 const UV auv = SvUVX(TOPs);
2367 SETs(boolSV(auv != buv));
2370 { /* ## Mixed IV,UV ## */
2374 /* != is commutative so swap if needed (save code) */
2376 /* swap. top of stack (b) is the iv */
2380 /* As (a) is a UV, it's >0, so it cannot be == */
2389 /* As (b) is a UV, it's >0, so it cannot be == */
2393 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2395 SETs(boolSV((UV)iv != uv));
2402 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2404 if (Perl_isnan(left) || Perl_isnan(right))
2406 SETs(boolSV(left != right));
2409 SETs(boolSV(SvNV_nomg(TOPs) != value));
2418 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2419 #ifndef NV_PRESERVES_UV
2420 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2421 const UV right = PTR2UV(SvRV(POPs));
2422 const UV left = PTR2UV(SvRV(TOPs));
2423 SETi((left > right) - (left < right));
2427 #ifdef PERL_PRESERVE_IVUV
2428 /* Fortunately it seems NaN isn't IOK */
2429 SvIV_please_nomg(TOPs);
2431 SvIV_please_nomg(TOPm1s);
2432 if (SvIOK(TOPm1s)) {
2433 const bool leftuvok = SvUOK(TOPm1s);
2434 const bool rightuvok = SvUOK(TOPs);
2436 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2437 const IV leftiv = SvIVX(TOPm1s);
2438 const IV rightiv = SvIVX(TOPs);
2440 if (leftiv > rightiv)
2442 else if (leftiv < rightiv)
2446 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2447 const UV leftuv = SvUVX(TOPm1s);
2448 const UV rightuv = SvUVX(TOPs);
2450 if (leftuv > rightuv)
2452 else if (leftuv < rightuv)
2456 } else if (leftuvok) { /* ## UV <=> IV ## */
2457 const IV rightiv = SvIVX(TOPs);
2459 /* As (a) is a UV, it's >=0, so it cannot be < */
2462 const UV leftuv = SvUVX(TOPm1s);
2463 if (leftuv > (UV)rightiv) {
2465 } else if (leftuv < (UV)rightiv) {
2471 } else { /* ## IV <=> UV ## */
2472 const IV leftiv = SvIVX(TOPm1s);
2474 /* As (b) is a UV, it's >=0, so it must be < */
2477 const UV rightuv = SvUVX(TOPs);
2478 if ((UV)leftiv > rightuv) {
2480 } else if ((UV)leftiv < rightuv) {
2498 if (Perl_isnan(left) || Perl_isnan(right)) {
2502 value = (left > right) - (left < right);
2506 else if (left < right)
2508 else if (left > right)
2524 int amg_type = sle_amg;
2528 switch (PL_op->op_type) {
2547 tryAMAGICbin_MG(amg_type, AMGf_set);
2550 const int cmp = (IN_LOCALE_RUNTIME
2551 ? sv_cmp_locale_flags(left, right, 0)
2552 : sv_cmp_flags(left, right, 0));
2553 SETs(boolSV(cmp * multiplier < rhs));
2561 tryAMAGICbin_MG(seq_amg, AMGf_set);
2564 SETs(boolSV(sv_eq_flags(left, right, 0)));
2572 tryAMAGICbin_MG(sne_amg, AMGf_set);
2575 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2583 tryAMAGICbin_MG(scmp_amg, 0);
2586 const int cmp = (IN_LOCALE_RUNTIME
2587 ? sv_cmp_locale_flags(left, right, 0)
2588 : sv_cmp_flags(left, right, 0));
2596 dVAR; dSP; dATARGET;
2597 tryAMAGICbin_MG(band_amg, AMGf_assign);
2600 if (SvNIOKp(left) || SvNIOKp(right)) {
2601 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2602 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2603 if (PL_op->op_private & HINT_INTEGER) {
2604 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2608 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2611 if (left_ro_nonnum) SvNIOK_off(left);
2612 if (right_ro_nonnum) SvNIOK_off(right);
2615 do_vop(PL_op->op_type, TARG, left, right);
2624 dVAR; dSP; dATARGET;
2625 const int op_type = PL_op->op_type;
2627 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2630 if (SvNIOKp(left) || SvNIOKp(right)) {
2631 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2632 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2633 if (PL_op->op_private & HINT_INTEGER) {
2634 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2635 const IV r = SvIV_nomg(right);
2636 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2640 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2641 const UV r = SvUV_nomg(right);
2642 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2645 if (left_ro_nonnum) SvNIOK_off(left);
2646 if (right_ro_nonnum) SvNIOK_off(right);
2649 do_vop(op_type, TARG, left, right);
2659 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2661 SV * const sv = TOPs;
2662 const int flags = SvFLAGS(sv);
2664 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2668 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2669 /* It's publicly an integer, or privately an integer-not-float */
2672 if (SvIVX(sv) == IV_MIN) {
2673 /* 2s complement assumption. */
2674 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2677 else if (SvUVX(sv) <= IV_MAX) {
2682 else if (SvIVX(sv) != IV_MIN) {
2686 #ifdef PERL_PRESERVE_IVUV
2694 SETn(-SvNV_nomg(sv));
2695 else if (SvPOKp(sv)) {
2697 const char * const s = SvPV_nomg_const(sv, len);
2698 if (isIDFIRST(*s)) {
2699 sv_setpvs(TARG, "-");
2702 else if (*s == '+' || *s == '-') {
2703 sv_setsv_nomg(TARG, sv);
2704 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2706 else if (DO_UTF8(sv)) {
2707 SvIV_please_nomg(sv);
2709 goto oops_its_an_int;
2711 sv_setnv(TARG, -SvNV_nomg(sv));
2713 sv_setpvs(TARG, "-");
2718 SvIV_please_nomg(sv);
2720 goto oops_its_an_int;
2721 sv_setnv(TARG, -SvNV_nomg(sv));
2726 SETn(-SvNV_nomg(sv));
2734 tryAMAGICun_MG(not_amg, AMGf_set);
2735 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2742 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2746 if (PL_op->op_private & HINT_INTEGER) {
2747 const IV i = ~SvIV_nomg(sv);
2751 const UV u = ~SvUV_nomg(sv);
2760 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2761 sv_setsv_nomg(TARG, sv);
2762 tmps = (U8*)SvPV_force_nomg(TARG, len);
2765 /* Calculate exact length, let's not estimate. */
2770 U8 * const send = tmps + len;
2771 U8 * const origtmps = tmps;
2772 const UV utf8flags = UTF8_ALLOW_ANYUV;
2774 while (tmps < send) {
2775 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2777 targlen += UNISKIP(~c);
2783 /* Now rewind strings and write them. */
2790 Newx(result, targlen + 1, U8);
2792 while (tmps < send) {
2793 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2795 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2798 sv_usepvn_flags(TARG, (char*)result, targlen,
2799 SV_HAS_TRAILING_NUL);
2806 Newx(result, nchar + 1, U8);
2808 while (tmps < send) {
2809 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2814 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2822 register long *tmpl;
2823 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2826 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2831 for ( ; anum > 0; anum--, tmps++)
2839 /* integer versions of some of the above */
2843 dVAR; dSP; dATARGET;
2844 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2847 SETi( left * right );
2855 dVAR; dSP; dATARGET;
2856 tryAMAGICbin_MG(div_amg, AMGf_assign);
2859 IV value = SvIV_nomg(right);
2861 DIE(aTHX_ "Illegal division by zero");
2862 num = SvIV_nomg(left);
2864 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2868 value = num / value;
2874 #if defined(__GLIBC__) && IVSIZE == 8
2881 /* This is the vanilla old i_modulo. */
2882 dVAR; dSP; dATARGET;
2883 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2887 DIE(aTHX_ "Illegal modulus zero");
2888 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2892 SETi( left % right );
2897 #if defined(__GLIBC__) && IVSIZE == 8
2902 /* This is the i_modulo with the workaround for the _moddi3 bug
2903 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2904 * See below for pp_i_modulo. */
2905 dVAR; dSP; dATARGET;
2906 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2910 DIE(aTHX_ "Illegal modulus zero");
2911 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2915 SETi( left % PERL_ABS(right) );
2922 dVAR; dSP; dATARGET;
2923 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2927 DIE(aTHX_ "Illegal modulus zero");
2928 /* The assumption is to use hereafter the old vanilla version... */
2930 PL_ppaddr[OP_I_MODULO] =
2932 /* .. but if we have glibc, we might have a buggy _moddi3
2933 * (at least glicb 2.2.5 is known to have this bug), in other
2934 * words our integer modulus with negative quad as the second
2935 * argument might be broken. Test for this and re-patch the
2936 * opcode dispatch table if that is the case, remembering to
2937 * also apply the workaround so that this first round works
2938 * right, too. See [perl #9402] for more information. */
2942 /* Cannot do this check with inlined IV constants since
2943 * that seems to work correctly even with the buggy glibc. */
2945 /* Yikes, we have the bug.
2946 * Patch in the workaround version. */
2948 PL_ppaddr[OP_I_MODULO] =
2949 &Perl_pp_i_modulo_1;
2950 /* Make certain we work right this time, too. */
2951 right = PERL_ABS(right);
2954 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2958 SETi( left % right );
2966 dVAR; dSP; dATARGET;
2967 tryAMAGICbin_MG(add_amg, AMGf_assign);
2969 dPOPTOPiirl_ul_nomg;
2970 SETi( left + right );
2977 dVAR; dSP; dATARGET;
2978 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2980 dPOPTOPiirl_ul_nomg;
2981 SETi( left - right );
2989 tryAMAGICbin_MG(lt_amg, AMGf_set);
2992 SETs(boolSV(left < right));
3000 tryAMAGICbin_MG(gt_amg, AMGf_set);
3003 SETs(boolSV(left > right));
3011 tryAMAGICbin_MG(le_amg, AMGf_set);
3014 SETs(boolSV(left <= right));
3022 tryAMAGICbin_MG(ge_amg, AMGf_set);
3025 SETs(boolSV(left >= right));
3033 tryAMAGICbin_MG(eq_amg, AMGf_set);
3036 SETs(boolSV(left == right));
3044 tryAMAGICbin_MG(ne_amg, AMGf_set);
3047 SETs(boolSV(left != right));
3055 tryAMAGICbin_MG(ncmp_amg, 0);
3062 else if (left < right)
3074 tryAMAGICun_MG(neg_amg, 0);
3076 SV * const sv = TOPs;
3077 IV const i = SvIV_nomg(sv);
3083 /* High falutin' math. */
3088 tryAMAGICbin_MG(atan2_amg, 0);
3091 SETn(Perl_atan2(left, right));
3099 int amg_type = sin_amg;
3100 const char *neg_report = NULL;
3101 NV (*func)(NV) = Perl_sin;
3102 const int op_type = PL_op->op_type;
3119 amg_type = sqrt_amg;
3121 neg_report = "sqrt";
3126 tryAMAGICun_MG(amg_type, 0);
3128 SV * const arg = POPs;
3129 const NV value = SvNV_nomg(arg);
3131 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
3132 SET_NUMERIC_STANDARD();
3133 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3136 XPUSHn(func(value));
3141 /* Support Configure command-line overrides for rand() functions.
3142 After 5.005, perhaps we should replace this by Configure support
3143 for drand48(), random(), or rand(). For 5.005, though, maintain
3144 compatibility by calling rand() but allow the user to override it.
3145 See INSTALL for details. --Andy Dougherty 15 July 1998
3147 /* Now it's after 5.005, and Configure supports drand48() and random(),
3148 in addition to rand(). So the overrides should not be needed any more.
3149 --Jarkko Hietaniemi 27 September 1998
3152 #ifndef HAS_DRAND48_PROTO
3153 extern double drand48 (void);
3166 if (!PL_srand_called) {
3167 (void)seedDrand01((Rand_seed_t)seed());
3168 PL_srand_called = TRUE;
3178 const UV anum = (MAXARG < 1) ? seed() : POPu;
3179 (void)seedDrand01((Rand_seed_t)anum);
3180 PL_srand_called = TRUE;
3184 /* Historically srand always returned true. We can avoid breaking
3186 sv_setpvs(TARG, "0 but true");
3195 tryAMAGICun_MG(int_amg, AMGf_numeric);
3197 SV * const sv = TOPs;
3198 const IV iv = SvIV_nomg(sv);
3199 /* XXX it's arguable that compiler casting to IV might be subtly
3200 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3201 else preferring IV has introduced a subtle behaviour change bug. OTOH
3202 relying on floating point to be accurate is a bug. */
3207 else if (SvIOK(sv)) {
3209 SETu(SvUV_nomg(sv));
3214 const NV value = SvNV_nomg(sv);
3216 if (value < (NV)UV_MAX + 0.5) {
3219 SETn(Perl_floor(value));
3223 if (value > (NV)IV_MIN - 0.5) {
3226 SETn(Perl_ceil(value));
3237 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3239 SV * const sv = TOPs;
3240 /* This will cache the NV value if string isn't actually integer */
3241 const IV iv = SvIV_nomg(sv);
3246 else if (SvIOK(sv)) {
3247 /* IVX is precise */
3249 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3257 /* 2s complement assumption. Also, not really needed as
3258 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3264 const NV value = SvNV_nomg(sv);
3278 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3282 SV* const sv = POPs;
3284 tmps = (SvPV_const(sv, len));
3286 /* If Unicode, try to downgrade
3287 * If not possible, croak. */
3288 SV* const tsv = sv_2mortal(newSVsv(sv));
3291 sv_utf8_downgrade(tsv, FALSE);
3292 tmps = SvPV_const(tsv, len);
3294 if (PL_op->op_type == OP_HEX)
3297 while (*tmps && len && isSPACE(*tmps))
3301 if (*tmps == 'x' || *tmps == 'X') {
3303 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3305 else if (*tmps == 'b' || *tmps == 'B')
3306 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3308 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3310 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3324 SV * const sv = TOPs;
3326 if (SvGAMAGIC(sv)) {
3327 /* For an overloaded or magic scalar, we can't know in advance if
3328 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3329 it likes to cache the length. Maybe that should be a documented
3334 = sv_2pv_flags(sv, &len,
3335 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3338 if (!SvPADTMP(TARG)) {
3339 sv_setsv(TARG, &PL_sv_undef);
3344 else if (DO_UTF8(sv)) {
3345 SETi(utf8_length((U8*)p, (U8*)p + len));
3349 } else if (SvOK(sv)) {
3350 /* Neither magic nor overloaded. */
3352 SETi(sv_len_utf8(sv));
3356 if (!SvPADTMP(TARG)) {
3357 sv_setsv_nomg(TARG, &PL_sv_undef);
3379 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3381 const IV arybase = CopARYBASE_get(PL_curcop);
3383 const char *repl = NULL;
3385 const int num_args = PL_op->op_private & 7;
3386 bool repl_need_utf8_upgrade = FALSE;
3387 bool repl_is_utf8 = FALSE;
3392 repl = SvPV_const(repl_sv, repl_len);
3393 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3396 len_iv = SvIV(len_sv);
3397 len_is_uv = SvIOK_UV(len_sv);
3400 pos1_iv = SvIV(pos_sv);
3401 pos1_is_uv = SvIOK_UV(pos_sv);
3407 sv_utf8_upgrade(sv);
3409 else if (DO_UTF8(sv))
3410 repl_need_utf8_upgrade = TRUE;
3412 tmps = SvPV_const(sv, curlen);
3414 utf8_curlen = sv_len_utf8(sv);
3415 if (utf8_curlen == curlen)
3418 curlen = utf8_curlen;
3423 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3424 UV pos1_uv = pos1_iv-arybase;
3425 /* Overflow can occur when $[ < 0 */
3426 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3431 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3432 goto bound_fail; /* $[=3; substr($_,2,...) */
3434 else { /* pos < $[ */
3435 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3440 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3445 if (pos1_is_uv || pos1_iv > 0) {
3446 if ((UV)pos1_iv > curlen)
3451 if (!len_is_uv && len_iv < 0) {
3452 pos2_iv = curlen + len_iv;
3454 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3457 } else { /* len_iv >= 0 */
3458 if (!pos1_is_uv && pos1_iv < 0) {
3459 pos2_iv = pos1_iv + len_iv;
3460 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3462 if ((UV)len_iv > curlen-(UV)pos1_iv)
3465 pos2_iv = pos1_iv+len_iv;
3475 if (!pos2_is_uv && pos2_iv < 0) {
3476 if (!pos1_is_uv && pos1_iv < 0)
3480 else if (!pos1_is_uv && pos1_iv < 0)
3483 if ((UV)pos2_iv < (UV)pos1_iv)
3485 if ((UV)pos2_iv > curlen)
3489 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3490 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3491 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3492 STRLEN byte_len = len;
3493 STRLEN byte_pos = utf8_curlen
3494 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3496 if (lvalue && !repl) {
3499 if (!SvGMAGICAL(sv)) {
3501 SvPV_force_nolen(sv);
3502 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3503 "Attempt to use reference as lvalue in substr");
3505 if (isGV_with_GP(sv))
3506 SvPV_force_nolen(sv);
3507 else if (SvOK(sv)) /* is it defined ? */
3508 (void)SvPOK_only_UTF8(sv);
3510 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3513 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3514 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3516 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3517 LvTARGOFF(ret) = pos;
3518 LvTARGLEN(ret) = len;
3521 PUSHs(ret); /* avoid SvSETMAGIC here */
3525 SvTAINTED_off(TARG); /* decontaminate */
3526 SvUTF8_off(TARG); /* decontaminate */
3529 sv_setpvn(TARG, tmps, byte_len);
3530 #ifdef USE_LOCALE_COLLATE
3531 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3537 SV* repl_sv_copy = NULL;
3539 if (repl_need_utf8_upgrade) {
3540 repl_sv_copy = newSVsv(repl_sv);
3541 sv_utf8_upgrade(repl_sv_copy);
3542 repl = SvPV_const(repl_sv_copy, repl_len);
3543 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3547 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3550 SvREFCNT_dec(repl_sv_copy);
3560 Perl_croak(aTHX_ "substr outside of string");
3561 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3568 register const IV size = POPi;
3569 register const IV offset = POPi;
3570 register SV * const src = POPs;
3571 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3574 if (lvalue) { /* it's an lvalue! */
3575 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3576 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3578 LvTARG(ret) = SvREFCNT_inc_simple(src);
3579 LvTARGOFF(ret) = offset;
3580 LvTARGLEN(ret) = size;
3584 SvTAINTED_off(TARG); /* decontaminate */
3588 sv_setuv(ret, do_vecget(src, offset, size));
3604 const char *little_p;
3605 const I32 arybase = CopARYBASE_get(PL_curcop);
3608 const bool is_index = PL_op->op_type == OP_INDEX;
3611 /* arybase is in characters, like offset, so combine prior to the
3612 UTF-8 to bytes calculation. */
3613 offset = POPi - arybase;
3617 big_p = SvPV_const(big, biglen);
3618 little_p = SvPV_const(little, llen);
3620 big_utf8 = DO_UTF8(big);
3621 little_utf8 = DO_UTF8(little);
3622 if (big_utf8 ^ little_utf8) {
3623 /* One needs to be upgraded. */
3624 if (little_utf8 && !PL_encoding) {
3625 /* Well, maybe instead we might be able to downgrade the small
3627 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3630 /* If the large string is ISO-8859-1, and it's not possible to
3631 convert the small string to ISO-8859-1, then there is no
3632 way that it could be found anywhere by index. */
3637 /* At this point, pv is a malloc()ed string. So donate it to temp
3638 to ensure it will get free()d */
3639 little = temp = newSV(0);
3640 sv_usepvn(temp, pv, llen);
3641 little_p = SvPVX(little);
3644 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3647 sv_recode_to_utf8(temp, PL_encoding);
3649 sv_utf8_upgrade(temp);
3654 big_p = SvPV_const(big, biglen);
3657 little_p = SvPV_const(little, llen);
3661 if (SvGAMAGIC(big)) {
3662 /* Life just becomes a lot easier if I use a temporary here.
3663 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3664 will trigger magic and overloading again, as will fbm_instr()
3666 big = newSVpvn_flags(big_p, biglen,
3667 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3670 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3671 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3672 warn on undef, and we've already triggered a warning with the
3673 SvPV_const some lines above. We can't remove that, as we need to
3674 call some SvPV to trigger overloading early and find out if the
3676 This is all getting to messy. The API isn't quite clean enough,
3677 because data access has side effects.
3679 little = newSVpvn_flags(little_p, llen,
3680 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3681 little_p = SvPVX(little);
3685 offset = is_index ? 0 : biglen;
3687 if (big_utf8 && offset > 0)
3688 sv_pos_u2b(big, &offset, 0);
3694 else if (offset > (I32)biglen)
3696 if (!(little_p = is_index
3697 ? fbm_instr((unsigned char*)big_p + offset,
3698 (unsigned char*)big_p + biglen, little, 0)
3699 : rninstr(big_p, big_p + offset,
3700 little_p, little_p + llen)))
3703 retval = little_p - big_p;
3704 if (retval > 0 && big_utf8)
3705 sv_pos_b2u(big, &retval);
3709 PUSHi(retval + arybase);
3715 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3716 SvTAINTED_off(TARG);
3717 do_sprintf(TARG, SP-MARK, MARK+1);
3718 TAINT_IF(SvTAINTED(TARG));
3730 const U8 *s = (U8*)SvPV_const(argsv, len);
3732 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3733 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3734 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3738 XPUSHu(DO_UTF8(argsv) ?
3739 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3751 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3753 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3755 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3757 (void) POPs; /* Ignore the argument value. */
3758 value = UNICODE_REPLACEMENT;
3764 SvUPGRADE(TARG,SVt_PV);
3766 if (value > 255 && !IN_BYTES) {
3767 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3768 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3769 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3771 (void)SvPOK_only(TARG);
3780 *tmps++ = (char)value;
3782 (void)SvPOK_only(TARG);
3784 if (PL_encoding && !IN_BYTES) {
3785 sv_recode_to_utf8(TARG, PL_encoding);
3787 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3788 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3792 *tmps++ = (char)value;
3808 const char *tmps = SvPV_const(left, len);
3810 if (DO_UTF8(left)) {
3811 /* If Unicode, try to downgrade.
3812 * If not possible, croak.
3813 * Yes, we made this up. */
3814 SV* const tsv = sv_2mortal(newSVsv(left));
3817 sv_utf8_downgrade(tsv, FALSE);
3818 tmps = SvPV_const(tsv, len);
3820 # ifdef USE_ITHREADS
3822 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3823 /* This should be threadsafe because in ithreads there is only
3824 * one thread per interpreter. If this would not be true,
3825 * we would need a mutex to protect this malloc. */
3826 PL_reentrant_buffer->_crypt_struct_buffer =
3827 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3828 #if defined(__GLIBC__) || defined(__EMX__)
3829 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3830 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3831 /* work around glibc-2.2.5 bug */
3832 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3836 # endif /* HAS_CRYPT_R */
3837 # endif /* USE_ITHREADS */
3839 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3841 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3847 "The crypt() function is unimplemented due to excessive paranoia.");
3851 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3852 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3854 /* Below are several macros that generate code */
3855 /* Generates code to store a unicode codepoint c that is known to occupy
3856 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3857 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3859 *(p) = UTF8_TWO_BYTE_HI(c); \
3860 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3863 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3864 * available byte after the two bytes */
3865 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3867 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3868 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3871 /* Generates code to store the upper case of latin1 character l which is known
3872 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3873 * are only two characters that fit this description, and this macro knows
3874 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3876 #define STORE_NON_LATIN1_UC(p, l) \
3878 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3879 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3880 } else { /* Must be the following letter */ \
3881 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3885 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3886 * after the character stored */
3887 #define CAT_NON_LATIN1_UC(p, l) \
3889 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3890 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3892 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3896 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3897 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3898 * and must require two bytes to store it. Advances p to point to the next
3899 * available position */
3900 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3902 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3903 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3904 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3905 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3906 } else {/* else is one of the other two special cases */ \
3907 CAT_NON_LATIN1_UC((p), (l)); \
3913 /* Actually is both lcfirst() and ucfirst(). Only the first character
3914 * changes. This means that possibly we can change in-place, ie., just
3915 * take the source and change that one character and store it back, but not
3916 * if read-only etc, or if the length changes */
3921 STRLEN slen; /* slen is the byte length of the whole SV. */
3924 bool inplace; /* ? Convert first char only, in-place */
3925 bool doing_utf8 = FALSE; /* ? using utf8 */
3926 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3927 const int op_type = PL_op->op_type;
3930 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3931 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3932 * stored as UTF-8 at s. */
3933 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3934 * lowercased) character stored in tmpbuf. May be either
3935 * UTF-8 or not, but in either case is the number of bytes */
3939 s = (const U8*)SvPV_nomg_const(source, slen);
3941 if (ckWARN(WARN_UNINITIALIZED))
3942 report_uninit(source);
3947 /* We may be able to get away with changing only the first character, in
3948 * place, but not if read-only, etc. Later we may discover more reasons to
3949 * not convert in-place. */
3950 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3952 /* First calculate what the changed first character should be. This affects
3953 * whether we can just swap it out, leaving the rest of the string unchanged,
3954 * or even if have to convert the dest to UTF-8 when the source isn't */
3956 if (! slen) { /* If empty */
3957 need = 1; /* still need a trailing NUL */
3959 else if (DO_UTF8(source)) { /* Is the source utf8? */
3962 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3963 * and doesn't allow for the user to specify their own. When code is added to
3964 * detect if there is a user-defined mapping in force here, and if so to use
3965 * that, then the code below can be compiled. The detection would be a good
3966 * thing anyway, as currently the user-defined mappings only work on utf8
3967 * strings, and thus depend on the chosen internal storage method, which is a
3969 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3970 if (UTF8_IS_INVARIANT(*s)) {
3972 /* An invariant source character is either ASCII or, in EBCDIC, an
3973 * ASCII equivalent or a caseless C1 control. In both these cases,
3974 * the lower and upper cases of any character are also invariants
3975 * (and title case is the same as upper case). So it is safe to
3976 * use the simple case change macros which avoid the overhead of
3977 * the general functions. Note that if perl were to be extended to
3978 * do locale handling in UTF-8 strings, this wouldn't be true in,
3979 * for example, Lithuanian or Turkic. */
3980 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3984 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3987 /* Similarly, if the source character isn't invariant but is in the
3988 * latin1 range (or EBCDIC equivalent thereof), we have the case
3989 * changes compiled into perl, and can avoid the overhead of the
3990 * general functions. In this range, the characters are stored as
3991 * two UTF-8 bytes, and it so happens that any changed-case version
3992 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3996 /* Convert the two source bytes to a single Unicode code point
3997 * value, change case and save for below */
3998 chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3999 if (op_type == OP_LCFIRST) { /* lower casing is easy */
4000 U8 lower = toLOWER_LATIN1(chr);
4001 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
4003 else { /* ucfirst */
4004 U8 upper = toUPPER_LATIN1_MOD(chr);
4006 /* Most of the latin1 range characters are well-behaved. Their
4007 * title and upper cases are the same, and are also in the
4008 * latin1 range. The macro above returns their upper (hence
4009 * title) case, and all that need be done is to save the result
4010 * for below. However, several characters are problematic, and
4011 * have to be handled specially. The MOD in the macro name
4012 * above means that these tricky characters all get mapped to
4013 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
4014 * This mapping saves some tests for the majority of the
4017 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
4019 /* Not tricky. Just save it. */
4020 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
4022 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
4024 /* This one is tricky because it is two characters long,
4025 * though the UTF-8 is still two bytes, so the stored
4026 * length doesn't change */
4027 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
4028 *(tmpbuf + 1) = 's';
4032 /* The other two have their title and upper cases the same,
4033 * but are tricky because the changed-case characters
4034 * aren't in the latin1 range. They, however, do fit into
4035 * two UTF-8 bytes */
4036 STORE_NON_LATIN1_UC(tmpbuf, chr);
4041 #endif /* end of dont want to break user-defined casing */
4043 /* Here, can't short-cut the general case */
4045 utf8_to_uvchr(s, &ulen);
4046 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
4047 else toLOWER_utf8(s, tmpbuf, &tculen);
4049 /* we can't do in-place if the length changes. */
4050 if (ulen != tculen) inplace = FALSE;
4051 need = slen + 1 - ulen + tculen;
4052 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4056 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
4057 * latin1 is treated as caseless. Note that a locale takes
4059 tculen = 1; /* Most characters will require one byte, but this will
4060 * need to be overridden for the tricky ones */
4063 if (op_type == OP_LCFIRST) {
4065 /* lower case the first letter: no trickiness for any character */
4066 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
4067 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
4070 else if (IN_LOCALE_RUNTIME) {
4071 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
4072 * have upper and title case different
4075 else if (! IN_UNI_8_BIT) {
4076 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
4077 * on EBCDIC machines whatever the
4078 * native function does */
4080 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
4081 *tmpbuf = toUPPER_LATIN1_MOD(*s);
4083 /* tmpbuf now has the correct title case for all latin1 characters
4084 * except for the several ones that have tricky handling. All
4085 * of these are mapped by the MOD to the letter below. */
4086 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
4088 /* The length is going to change, with all three of these, so
4089 * can't replace just the first character */
4092 /* We use the original to distinguish between these tricky
4094 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4095 /* Two character title case 'Ss', but can remain non-UTF-8 */
4098 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
4103 /* The other two tricky ones have their title case outside
4104 * latin1. It is the same as their upper case. */
4106 STORE_NON_LATIN1_UC(tmpbuf, *s);
4108 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
4109 * and their upper cases is 2. */
4112 /* The entire result will have to be in UTF-8. Assume worst
4113 * case sizing in conversion. (all latin1 characters occupy
4114 * at most two bytes in utf8) */
4115 convert_source_to_utf8 = TRUE;
4116 need = slen * 2 + 1;
4118 } /* End of is one of the three special chars */
4119 } /* End of use Unicode (Latin1) semantics */
4120 } /* End of changing the case of the first character */
4122 /* Here, have the first character's changed case stored in tmpbuf. Ready to
4123 * generate the result */
4126 /* We can convert in place. This means we change just the first
4127 * character without disturbing the rest; no need to grow */
4129 s = d = (U8*)SvPV_force_nomg(source, slen);
4135 /* Here, we can't convert in place; we earlier calculated how much
4136 * space we will need, so grow to accommodate that */
4137 SvUPGRADE(dest, SVt_PV);
4138 d = (U8*)SvGROW(dest, need);
4139 (void)SvPOK_only(dest);
4146 if (! convert_source_to_utf8) {
4148 /* Here both source and dest are in UTF-8, but have to create
4149 * the entire output. We initialize the result to be the
4150 * title/lower cased first character, and then append the rest
4152 sv_setpvn(dest, (char*)tmpbuf, tculen);
4154 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
4158 const U8 *const send = s + slen;
4160 /* Here the dest needs to be in UTF-8, but the source isn't,
4161 * except we earlier UTF-8'd the first character of the source
4162 * into tmpbuf. First put that into dest, and then append the
4163 * rest of the source, converting it to UTF-8 as we go. */
4165 /* Assert tculen is 2 here because the only two characters that
4166 * get to this part of the code have 2-byte UTF-8 equivalents */
4168 *d++ = *(tmpbuf + 1);
4169 s++; /* We have just processed the 1st char */
4171 for (; s < send; s++) {
4172 d = uvchr_to_utf8(d, *s);
4175 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4179 else { /* in-place UTF-8. Just overwrite the first character */
4180 Copy(tmpbuf, d, tculen, U8);
4181 SvCUR_set(dest, need - 1);
4184 else { /* Neither source nor dest are in or need to be UTF-8 */
4186 if (IN_LOCALE_RUNTIME) {
4190 if (inplace) { /* in-place, only need to change the 1st char */
4193 else { /* Not in-place */
4195 /* Copy the case-changed character(s) from tmpbuf */
4196 Copy(tmpbuf, d, tculen, U8);
4197 d += tculen - 1; /* Code below expects d to point to final
4198 * character stored */
4201 else { /* empty source */
4202 /* See bug #39028: Don't taint if empty */
4206 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4207 * the destination to retain that flag */
4211 if (!inplace) { /* Finish the rest of the string, unchanged */
4212 /* This will copy the trailing NUL */
4213 Copy(s + 1, d + 1, slen, U8);
4214 SvCUR_set(dest, need - 1);
4217 if (dest != source && SvTAINTED(source))
4223 /* There's so much setup/teardown code common between uc and lc, I wonder if
4224 it would be worth merging the two, and just having a switch outside each
4225 of the three tight loops. There is less and less commonality though */
4239 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4240 && SvTEMP(source) && !DO_UTF8(source)
4241 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4243 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4244 * make the loop tight, so we overwrite the source with the dest before
4245 * looking at it, and we need to look at the original source
4246 * afterwards. There would also need to be code added to handle
4247 * switching to not in-place in midstream if we run into characters
4248 * that change the length.
4251 s = d = (U8*)SvPV_force_nomg(source, len);
4258 /* The old implementation would copy source into TARG at this point.
4259 This had the side effect that if source was undef, TARG was now
4260 an undefined SV with PADTMP set, and they don't warn inside
4261 sv_2pv_flags(). However, we're now getting the PV direct from
4262 source, which doesn't have PADTMP set, so it would warn. Hence the
4266 s = (const U8*)SvPV_nomg_const(source, len);
4268 if (ckWARN(WARN_UNINITIALIZED))
4269 report_uninit(source);
4275 SvUPGRADE(dest, SVt_PV);
4276 d = (U8*)SvGROW(dest, min);
4277 (void)SvPOK_only(dest);
4282 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4283 to check DO_UTF8 again here. */
4285 if (DO_UTF8(source)) {
4286 const U8 *const send = s + len;
4287 U8 tmpbuf[UTF8_MAXBYTES+1];
4289 /* All occurrences of these are to be moved to follow any other marks.
4290 * This is context-dependent. We may not be passed enough context to
4291 * move the iota subscript beyond all of them, but we do the best we can
4292 * with what we're given. The result is always better than if we
4293 * hadn't done this. And, the problem would only arise if we are
4294 * passed a character without all its combining marks, which would be
4295 * the caller's mistake. The information this is based on comes from a
4296 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4297 * itself) and so can't be checked properly to see if it ever gets
4298 * revised. But the likelihood of it changing is remote */
4299 bool in_iota_subscript = FALSE;
4302 if (in_iota_subscript && ! is_utf8_mark(s)) {
4303 /* A non-mark. Time to output the iota subscript */
4304 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4305 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4307 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4308 in_iota_subscript = FALSE;
4312 /* See comments at the first instance in this file of this ifdef */
4313 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4315 /* If the UTF-8 character is invariant, then it is in the range
4316 * known by the standard macro; result is only one byte long */
4317 if (UTF8_IS_INVARIANT(*s)) {
4321 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4323 /* Likewise, if it fits in a byte, its case change is in our
4325 U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *s++);
4326 U8 upper = toUPPER_LATIN1_MOD(orig);
4327 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4335 /* Otherwise, need the general UTF-8 case. Get the changed
4336 * case value and copy it to the output buffer */
4338 const STRLEN u = UTF8SKIP(s);
4341 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4342 if (uv == GREEK_CAPITAL_LETTER_IOTA
4343 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4345 in_iota_subscript = TRUE;
4348 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4349 /* If the eventually required minimum size outgrows
4350 * the available space, we need to grow. */
4351 const UV o = d - (U8*)SvPVX_const(dest);
4353 /* If someone uppercases one million U+03B0s we
4354 * SvGROW() one million times. Or we could try
4355 * guessing how much to allocate without allocating too
4356 * much. Such is life. See corresponding comment in
4357 * lc code for another option */
4359 d = (U8*)SvPVX(dest) + o;
4361 Copy(tmpbuf, d, ulen, U8);
4367 if (in_iota_subscript) {
4368 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4372 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4374 else { /* Not UTF-8 */
4376 const U8 *const send = s + len;
4378 /* Use locale casing if in locale; regular style if not treating
4379 * latin1 as having case; otherwise the latin1 casing. Do the
4380 * whole thing in a tight loop, for speed, */
4381 if (IN_LOCALE_RUNTIME) {
4384 for (; s < send; d++, s++)
4385 *d = toUPPER_LC(*s);
4387 else if (! IN_UNI_8_BIT) {
4388 for (; s < send; d++, s++) {
4393 for (; s < send; d++, s++) {
4394 *d = toUPPER_LATIN1_MOD(*s);
4395 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4397 /* The mainstream case is the tight loop above. To avoid
4398 * extra tests in that, all three characters that require
4399 * special handling are mapped by the MOD to the one tested
4401 * Use the source to distinguish between the three cases */
4403 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4405 /* uc() of this requires 2 characters, but they are
4406 * ASCII. If not enough room, grow the string */
4407 if (SvLEN(dest) < ++min) {
4408 const UV o = d - (U8*)SvPVX_const(dest);
4410 d = (U8*)SvPVX(dest) + o;
4412 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4413 continue; /* Back to the tight loop; still in ASCII */
4416 /* The other two special handling characters have their
4417 * upper cases outside the latin1 range, hence need to be
4418 * in UTF-8, so the whole result needs to be in UTF-8. So,
4419 * here we are somewhere in the middle of processing a
4420 * non-UTF-8 string, and realize that we will have to convert
4421 * the whole thing to UTF-8. What to do? There are
4422 * several possibilities. The simplest to code is to
4423 * convert what we have so far, set a flag, and continue on
4424 * in the loop. The flag would be tested each time through
4425 * the loop, and if set, the next character would be
4426 * converted to UTF-8 and stored. But, I (khw) didn't want
4427 * to slow down the mainstream case at all for this fairly
4428 * rare case, so I didn't want to add a test that didn't
4429 * absolutely have to be there in the loop, besides the
4430 * possibility that it would get too complicated for
4431 * optimizers to deal with. Another possibility is to just
4432 * give up, convert the source to UTF-8, and restart the
4433 * function that way. Another possibility is to convert
4434 * both what has already been processed and what is yet to
4435 * come separately to UTF-8, then jump into the loop that
4436 * handles UTF-8. But the most efficient time-wise of the
4437 * ones I could think of is what follows, and turned out to
4438 * not require much extra code. */
4440 /* Convert what we have so far into UTF-8, telling the
4441 * function that we know it should be converted, and to
4442 * allow extra space for what we haven't processed yet.
4443 * Assume the worst case space requirements for converting
4444 * what we haven't processed so far: that it will require
4445 * two bytes for each remaining source character, plus the
4446 * NUL at the end. This may cause the string pointer to
4447 * move, so re-find it. */
4449 len = d - (U8*)SvPVX_const(dest);
4450 SvCUR_set(dest, len);
4451 len = sv_utf8_upgrade_flags_grow(dest,
4452 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4454 d = (U8*)SvPVX(dest) + len;
4456 /* And append the current character's upper case in UTF-8 */
4457 CAT_NON_LATIN1_UC(d, *s);
4459 /* Now process the remainder of the source, converting to
4460 * upper and UTF-8. If a resulting byte is invariant in
4461 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4462 * append it to the output. */
4465 for (; s < send; s++) {
4466 U8 upper = toUPPER_LATIN1_MOD(*s);
4467 if UTF8_IS_INVARIANT(upper) {
4471 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4475 /* Here have processed the whole source; no need to continue
4476 * with the outer loop. Each character has been converted
4477 * to upper case and converted to UTF-8 */
4480 } /* End of processing all latin1-style chars */
4481 } /* End of processing all chars */
4482 } /* End of source is not empty */
4484 if (source != dest) {
4485 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4486 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4488 } /* End of isn't utf8 */
4489 if (dest != source && SvTAINTED(source))
4508 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4509 && SvTEMP(source) && !DO_UTF8(source)) {
4511 /* We can convert in place, as lowercasing anything in the latin1 range
4512 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4514 s = d = (U8*)SvPV_force_nomg(source, len);
4521 /* The old implementation would copy source into TARG at this point.
4522 This had the side effect that if source was undef, TARG was now
4523 an undefined SV with PADTMP set, and they don't warn inside
4524 sv_2pv_flags(). However, we're now getting the PV direct from
4525 source, which doesn't have PADTMP set, so it would warn. Hence the
4529 s = (const U8*)SvPV_nomg_const(source, len);
4531 if (ckWARN(WARN_UNINITIALIZED))
4532 report_uninit(source);
4538 SvUPGRADE(dest, SVt_PV);
4539 d = (U8*)SvGROW(dest, min);
4540 (void)SvPOK_only(dest);
4545 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4546 to check DO_UTF8 again here. */
4548 if (DO_UTF8(source)) {
4549 const U8 *const send = s + len;
4550 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4553 /* See comments at the first instance in this file of this ifdef */
4554 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4555 if (UTF8_IS_INVARIANT(*s)) {
4557 /* Invariant characters use the standard mappings compiled in.
4562 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4564 /* As do the ones in the Latin1 range */
4565 U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *s++));
4566 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4571 /* Here, is utf8 not in Latin-1 range, have to go out and get
4572 * the mappings from the tables. */
4574 const STRLEN u = UTF8SKIP(s);
4577 #ifndef CONTEXT_DEPENDENT_CASING
4578 toLOWER_utf8(s, tmpbuf, &ulen);
4580 /* This is ifdefd out because it needs more work and thought. It isn't clear
4581 * that we should do it.
4582 * A minor objection is that this is based on a hard-coded rule from the
4583 * Unicode standard, and may change, but this is not very likely at all.
4584 * mktables should check and warn if it does.
4585 * More importantly, if the sigma occurs at the end of the string, we don't
4586 * have enough context to know whether it is part of a larger string or going
4587 * to be or not. It may be that we are passed a subset of the context, via
4588 * a \U...\E, for example, and we could conceivably know the larger context if
4589 * code were changed to pass that in. But, if the string passed in is an
4590 * intermediate result, and the user concatenates two strings together
4591 * after we have made a final sigma, that would be wrong. If the final sigma
4592 * occurs in the middle of the string we are working on, then we know that it
4593 * should be a final sigma, but otherwise we can't be sure. */
4595 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4597 /* If the lower case is a small sigma, it may be that we need
4598 * to change it to a final sigma. This happens at the end of
4599 * a word that contains more than just this character, and only
4600 * when we started with a capital sigma. */
4601 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4602 s > send - len && /* Makes sure not the first letter */
4603 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4606 /* We use the algorithm in:
4607 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4608 * is a CAPITAL SIGMA): If C is preceded by a sequence
4609 * consisting of a cased letter and a case-ignorable
4610 * sequence, and C is not followed by a sequence consisting
4611 * of a case ignorable sequence and then a cased letter,
4612 * then when lowercasing C, C becomes a final sigma */
4614 /* To determine if this is the end of a word, need to peek
4615 * ahead. Look at the next character */
4616 const U8 *peek = s + u;
4618 /* Skip any case ignorable characters */
4619 while (peek < send && is_utf8_case_ignorable(peek)) {
4620 peek += UTF8SKIP(peek);
4623 /* If we reached the end of the string without finding any
4624 * non-case ignorable characters, or if the next such one
4625 * is not-cased, then we have met the conditions for it
4626 * being a final sigma with regards to peek ahead, and so
4627 * must do peek behind for the remaining conditions. (We
4628 * know there is stuff behind to look at since we tested
4629 * above that this isn't the first letter) */
4630 if (peek >= send || ! is_utf8_cased(peek)) {
4631 peek = utf8_hop(s, -1);
4633 /* Here are at the beginning of the first character
4634 * before the original upper case sigma. Keep backing
4635 * up, skipping any case ignorable characters */
4636 while (is_utf8_case_ignorable(peek)) {
4637 peek = utf8_hop(peek, -1);
4640 /* Here peek points to the first byte of the closest
4641 * non-case-ignorable character before the capital
4642 * sigma. If it is cased, then by the Unicode
4643 * algorithm, we should use a small final sigma instead
4644 * of what we have */
4645 if (is_utf8_cased(peek)) {
4646 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4647 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4651 else { /* Not a context sensitive mapping */
4652 #endif /* End of commented out context sensitive */
4653 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4655 /* If the eventually required minimum size outgrows
4656 * the available space, we need to grow. */
4657 const UV o = d - (U8*)SvPVX_const(dest);
4659 /* If someone lowercases one million U+0130s we
4660 * SvGROW() one million times. Or we could try
4661 * guessing how much to allocate without allocating too
4662 * much. Such is life. Another option would be to
4663 * grow an extra byte or two more each time we need to
4664 * grow, which would cut down the million to 500K, with
4667 d = (U8*)SvPVX(dest) + o;
4669 #ifdef CONTEXT_DEPENDENT_CASING
4672 /* Copy the newly lowercased letter to the output buffer we're
4674 Copy(tmpbuf, d, ulen, U8);
4677 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4680 } /* End of looping through the source string */
4683 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4684 } else { /* Not utf8 */
4686 const U8 *const send = s + len;
4688 /* Use locale casing if in locale; regular style if not treating
4689 * latin1 as having case; otherwise the latin1 casing. Do the
4690 * whole thing in a tight loop, for speed, */
4691 if (IN_LOCALE_RUNTIME) {
4694 for (; s < send; d++, s++)
4695 *d = toLOWER_LC(*s);
4697 else if (! IN_UNI_8_BIT) {
4698 for (; s < send; d++, s++) {
4703 for (; s < send; d++, s++) {
4704 *d = toLOWER_LATIN1(*s);
4708 if (source != dest) {
4710 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4713 if (dest != source && SvTAINTED(source))
4722 SV * const sv = TOPs;
4724 register const char *s = SvPV_const(sv,len);
4726 SvUTF8_off(TARG); /* decontaminate */
4729 SvUPGRADE(TARG, SVt_PV);
4730 SvGROW(TARG, (len * 2) + 1);
4734 if (UTF8_IS_CONTINUED(*s)) {
4735 STRLEN ulen = UTF8SKIP(s);
4759 SvCUR_set(TARG, d - SvPVX_const(TARG));
4760 (void)SvPOK_only_UTF8(TARG);
4763 sv_setpvn(TARG, s, len);
4772 dVAR; dSP; dMARK; dORIGMARK;
4773 register AV *const av = MUTABLE_AV(POPs);
4774 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4776 if (SvTYPE(av) == SVt_PVAV) {
4777 const I32 arybase = CopARYBASE_get(PL_curcop);
4778 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4779 bool can_preserve = FALSE;
4785 can_preserve = SvCANEXISTDELETE(av);
4788 if (lval && localizing) {
4791 for (svp = MARK + 1; svp <= SP; svp++) {
4792 const I32 elem = SvIV(*svp);
4796 if (max > AvMAX(av))
4800 while (++MARK <= SP) {
4802 I32 elem = SvIV(*MARK);
4803 bool preeminent = TRUE;
4807 if (localizing && can_preserve) {
4808 /* If we can determine whether the element exist,
4809 * Try to preserve the existenceness of a tied array
4810 * element by using EXISTS and DELETE if possible.
4811 * Fallback to FETCH and STORE otherwise. */
4812 preeminent = av_exists(av, elem);
4815 svp = av_fetch(av, elem, lval);
4817 if (!svp || *svp == &PL_sv_undef)
4818 DIE(aTHX_ PL_no_aelem, elem);
4821 save_aelem(av, elem, svp);
4823 SAVEADELETE(av, elem);
4826 *MARK = svp ? *svp : &PL_sv_undef;
4829 if (GIMME != G_ARRAY) {
4831 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4837 /* Smart dereferencing for keys, values and each */
4849 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4854 "Type of argument to %s must be unblessed hashref or arrayref",
4855 PL_op_desc[PL_op->op_type] );
4858 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4860 "Can't modify %s in %s",
4861 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4864 /* Delegate to correct function for op type */
4866 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4867 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4870 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4878 AV *array = MUTABLE_AV(POPs);
4879 const I32 gimme = GIMME_V;
4880 IV *iterp = Perl_av_iter_p(aTHX_ array);
4881 const IV current = (*iterp)++;
4883 if (current > av_len(array)) {
4885 if (gimme == G_SCALAR)
4892 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4893 if (gimme == G_ARRAY) {
4894 SV **const element = av_fetch(array, current, 0);
4895 PUSHs(element ? *element : &PL_sv_undef);
4904 AV *array = MUTABLE_AV(POPs);
4905 const I32 gimme = GIMME_V;
4907 *Perl_av_iter_p(aTHX_ array) = 0;
4909 if (gimme == G_SCALAR) {
4911 PUSHi(av_len(array) + 1);
4913 else if (gimme == G_ARRAY) {
4914 IV n = Perl_av_len(aTHX_ array);
4915 IV i = CopARYBASE_get(PL_curcop);
4919 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4921 for (; i <= n; i++) {
4926 for (i = 0; i <= n; i++) {
4927 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4928 PUSHs(elem ? *elem : &PL_sv_undef);
4935 /* Associative arrays. */
4941 HV * hash = MUTABLE_HV(POPs);
4943 const I32 gimme = GIMME_V;
4946 /* might clobber stack_sp */
4947 entry = hv_iternext(hash);
4952 SV* const sv = hv_iterkeysv(entry);
4953 PUSHs(sv); /* won't clobber stack_sp */
4954 if (gimme == G_ARRAY) {
4957 /* might clobber stack_sp */
4958 val = hv_iterval(hash, entry);
4963 else if (gimme == G_SCALAR)
4970 S_do_delete_local(pTHX)
4974 const I32 gimme = GIMME_V;
4978 if (PL_op->op_private & OPpSLICE) {
4980 SV * const osv = POPs;
4981 const bool tied = SvRMAGICAL(osv)
4982 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4983 const bool can_preserve = SvCANEXISTDELETE(osv)
4984 || mg_find((const SV *)osv, PERL_MAGIC_env);
4985 const U32 type = SvTYPE(osv);
4986 if (type == SVt_PVHV) { /* hash element */
4987 HV * const hv = MUTABLE_HV(osv);
4988 while (++MARK <= SP) {
4989 SV * const keysv = *MARK;
4991 bool preeminent = TRUE;
4993 preeminent = hv_exists_ent(hv, keysv, 0);
4995 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5002 sv = hv_delete_ent(hv, keysv, 0, 0);
5003 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5006 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5008 *MARK = sv_mortalcopy(sv);
5014 SAVEHDELETE(hv, keysv);
5015 *MARK = &PL_sv_undef;
5019 else if (type == SVt_PVAV) { /* array element */
5020 if (PL_op->op_flags & OPf_SPECIAL) {
5021 AV * const av = MUTABLE_AV(osv);
5022 while (++MARK <= SP) {
5023 I32 idx = SvIV(*MARK);
5025 bool preeminent = TRUE;
5027 preeminent = av_exists(av, idx);
5029 SV **svp = av_fetch(av, idx, 1);
5036 sv = av_delete(av, idx, 0);
5037 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5040 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5042 *MARK = sv_mortalcopy(sv);
5048 SAVEADELETE(av, idx);
5049 *MARK = &PL_sv_undef;
5055 DIE(aTHX_ "Not a HASH reference");
5056 if (gimme == G_VOID)
5058 else if (gimme == G_SCALAR) {
5063 *++MARK = &PL_sv_undef;
5068 SV * const keysv = POPs;
5069 SV * const osv = POPs;
5070 const bool tied = SvRMAGICAL(osv)
5071 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5072 const bool can_preserve = SvCANEXISTDELETE(osv)
5073 || mg_find((const SV *)osv, PERL_MAGIC_env);
5074 const U32 type = SvTYPE(osv);
5076 if (type == SVt_PVHV) {
5077 HV * const hv = MUTABLE_HV(osv);
5078 bool preeminent = TRUE;
5080 preeminent = hv_exists_ent(hv, keysv, 0);
5082 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5089 sv = hv_delete_ent(hv, keysv, 0, 0);
5090 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5093 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5095 SV *nsv = sv_mortalcopy(sv);
5101 SAVEHDELETE(hv, keysv);
5103 else if (type == SVt_PVAV) {
5104 if (PL_op->op_flags & OPf_SPECIAL) {
5105 AV * const av = MUTABLE_AV(osv);
5106 I32 idx = SvIV(keysv);
5107 bool preeminent = TRUE;
5109 preeminent = av_exists(av, idx);
5111 SV **svp = av_fetch(av, idx, 1);
5118 sv = av_delete(av, idx, 0);
5119 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5122 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5124 SV *nsv = sv_mortalcopy(sv);
5130 SAVEADELETE(av, idx);
5133 DIE(aTHX_ "panic: avhv_delete no longer supported");
5136 DIE(aTHX_ "Not a HASH reference");
5139 if (gimme != G_VOID)
5153 if (PL_op->op_private & OPpLVAL_INTRO)
5154 return do_delete_local();
5157 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5159 if (PL_op->op_private & OPpSLICE) {
5161 HV * const hv = MUTABLE_HV(POPs);
5162 const U32 hvtype = SvTYPE(hv);
5163 if (hvtype == SVt_PVHV) { /* hash element */
5164 while (++MARK <= SP) {
5165 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5166 *MARK = sv ? sv : &PL_sv_undef;
5169 else if (hvtype == SVt_PVAV) { /* array element */
5170 if (PL_op->op_flags & OPf_SPECIAL) {
5171 while (++MARK <= SP) {
5172 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5173 *MARK = sv ? sv : &PL_sv_undef;
5178 DIE(aTHX_ "Not a HASH reference");
5181 else if (gimme == G_SCALAR) {
5186 *++MARK = &PL_sv_undef;
5192 HV * const hv = MUTABLE_HV(POPs);
5194 if (SvTYPE(hv) == SVt_PVHV)
5195 sv = hv_delete_ent(hv, keysv, discard, 0);
5196 else if (SvTYPE(hv) == SVt_PVAV) {
5197 if (PL_op->op_flags & OPf_SPECIAL)
5198 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5200 DIE(aTHX_ "panic: avhv_delete no longer supported");
5203 DIE(aTHX_ "Not a HASH reference");
5219 if (PL_op->op_private & OPpEXISTS_SUB) {
5221 SV * const sv = POPs;
5222 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5225 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5230 hv = MUTABLE_HV(POPs);
5231 if (SvTYPE(hv) == SVt_PVHV) {
5232 if (hv_exists_ent(hv, tmpsv, 0))
5235 else if (SvTYPE(hv) == SVt_PVAV) {
5236 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5237 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5242 DIE(aTHX_ "Not a HASH reference");
5249 dVAR; dSP; dMARK; dORIGMARK;
5250 register HV * const hv = MUTABLE_HV(POPs);
5251 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5252 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5253 bool can_preserve = FALSE;
5259 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
5260 can_preserve = TRUE;
5263 while (++MARK <= SP) {
5264 SV * const keysv = *MARK;
5267 bool preeminent = TRUE;
5269 if (localizing && can_preserve) {
5270 /* If we can determine whether the element exist,
5271 * try to preserve the existenceness of a tied hash
5272 * element by using EXISTS and DELETE if possible.
5273 * Fallback to FETCH and STORE otherwise. */
5274 preeminent = hv_exists_ent(hv, keysv, 0);
5277 he = hv_fetch_ent(hv, keysv, lval, 0);
5278 svp = he ? &HeVAL(he) : NULL;
5281 if (!svp || *svp == &PL_sv_undef) {
5282 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5285 if (HvNAME_get(hv) && isGV(*svp))
5286 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5287 else if (preeminent)
5288 save_helem_flags(hv, keysv, svp,
5289 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5291 SAVEHDELETE(hv, keysv);
5294 *MARK = svp ? *svp : &PL_sv_undef;
5296 if (GIMME != G_ARRAY) {
5298 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5304 /* List operators. */
5309 if (GIMME != G_ARRAY) {
5311 *MARK = *SP; /* unwanted list, return last item */
5313 *MARK = &PL_sv_undef;
5323 SV ** const lastrelem = PL_stack_sp;
5324 SV ** const lastlelem = PL_stack_base + POPMARK;
5325 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5326 register SV ** const firstrelem = lastlelem + 1;
5327 const I32 arybase = CopARYBASE_get(PL_curcop);
5328 I32 is_something_there = FALSE;
5330 register const I32 max = lastrelem - lastlelem;
5331 register SV **lelem;
5333 if (GIMME != G_ARRAY) {
5334 I32 ix = SvIV(*lastlelem);
5339 if (ix < 0 || ix >= max)
5340 *firstlelem = &PL_sv_undef;
5342 *firstlelem = firstrelem[ix];
5348 SP = firstlelem - 1;
5352 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5353 I32 ix = SvIV(*lelem);
5358 if (ix < 0 || ix >= max)
5359 *lelem = &PL_sv_undef;
5361 is_something_there = TRUE;
5362 if (!(*lelem = firstrelem[ix]))
5363 *lelem = &PL_sv_undef;
5366 if (is_something_there)
5369 SP = firstlelem - 1;
5375 dVAR; dSP; dMARK; dORIGMARK;
5376 const I32 items = SP - MARK;
5377 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5378 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5379 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5380 ? newRV_noinc(av) : av);
5386 dVAR; dSP; dMARK; dORIGMARK;
5387 HV* const hv = newHV();
5390 SV * const key = *++MARK;
5391 SV * const val = newSV(0);
5393 sv_setsv(val, *++MARK);
5395 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5396 (void)hv_store_ent(hv,key,val,0);
5399 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5400 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5405 S_deref_plain_array(pTHX_ AV *ary)
5407 if (SvTYPE(ary) == SVt_PVAV) return ary;
5408 SvGETMAGIC((SV *)ary);
5409 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5410 Perl_die(aTHX_ "Not an ARRAY reference");
5411 else if (SvOBJECT(SvRV(ary)))
5412 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5413 return (AV *)SvRV(ary);
5416 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5417 # define DEREF_PLAIN_ARRAY(ary) \
5420 SvTYPE(aRrRay) == SVt_PVAV \
5422 : S_deref_plain_array(aTHX_ aRrRay); \
5425 # define DEREF_PLAIN_ARRAY(ary) \
5427 PL_Sv = (SV *)(ary), \
5428 SvTYPE(PL_Sv) == SVt_PVAV \
5430 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5436 dVAR; dSP; dMARK; dORIGMARK;
5437 int num_args = (SP - MARK);
5438 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5442 register I32 offset;
5443 register I32 length;
5447 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5450 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
5451 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5458 offset = i = SvIV(*MARK);
5460 offset += AvFILLp(ary) + 1;
5462 offset -= CopARYBASE_get(PL_curcop);
5464 DIE(aTHX_ PL_no_aelem, i);
5466 length = SvIVx(*MARK++);
5468 length += AvFILLp(ary) - offset + 1;
5474 length = AvMAX(ary) + 1; /* close enough to infinity */
5478 length = AvMAX(ary) + 1;
5480 if (offset > AvFILLp(ary) + 1) {
5482 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5483 offset = AvFILLp(ary) + 1;
5485 after = AvFILLp(ary) + 1 - (offset + length);
5486 if (after < 0) { /* not that much array */
5487 length += after; /* offset+length now in array */
5493 /* At this point, MARK .. SP-1 is our new LIST */
5496 diff = newlen - length;
5497 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5500 /* make new elements SVs now: avoid problems if they're from the array */
5501 for (dst = MARK, i = newlen; i; i--) {
5502 SV * const h = *dst;
5503 *dst++ = newSVsv(h);
5506 if (diff < 0) { /* shrinking the area */
5507 SV **tmparyval = NULL;
5509 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5510 Copy(MARK, tmparyval, newlen, SV*);
5513 MARK = ORIGMARK + 1;
5514 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5515 MEXTEND(MARK, length);
5516 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5518 EXTEND_MORTAL(length);
5519 for (i = length, dst = MARK; i; i--) {
5520 sv_2mortal(*dst); /* free them eventually */
5527 *MARK = AvARRAY(ary)[offset+length-1];
5530 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5531 SvREFCNT_dec(*dst++); /* free them now */
5534 AvFILLp(ary) += diff;
5536 /* pull up or down? */
5538 if (offset < after) { /* easier to pull up */
5539 if (offset) { /* esp. if nothing to pull */
5540 src = &AvARRAY(ary)[offset-1];
5541 dst = src - diff; /* diff is negative */
5542 for (i = offset; i > 0; i--) /* can't trust Copy */
5546 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5550 if (after) { /* anything to pull down? */
5551 src = AvARRAY(ary) + offset + length;
5552 dst = src + diff; /* diff is negative */
5553 Move(src, dst, after, SV*);
5555 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5556 /* avoid later double free */
5560 dst[--i] = &PL_sv_undef;
5563 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5564 Safefree(tmparyval);
5567 else { /* no, expanding (or same) */
5568 SV** tmparyval = NULL;
5570 Newx(tmparyval, length, SV*); /* so remember deletion */
5571 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5574 if (diff > 0) { /* expanding */
5575 /* push up or down? */
5576 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5580 Move(src, dst, offset, SV*);
5582 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5584 AvFILLp(ary) += diff;
5587 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5588 av_extend(ary, AvFILLp(ary) + diff);
5589 AvFILLp(ary) += diff;
5592 dst = AvARRAY(ary) + AvFILLp(ary);
5594 for (i = after; i; i--) {
5602 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5605 MARK = ORIGMARK + 1;
5606 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5608 Copy(tmparyval, MARK, length, SV*);
5610 EXTEND_MORTAL(length);
5611 for (i = length, dst = MARK; i; i--) {
5612 sv_2mortal(*dst); /* free them eventually */
5619 else if (length--) {
5620 *MARK = tmparyval[length];
5623 while (length-- > 0)
5624 SvREFCNT_dec(tmparyval[length]);
5628 *MARK = &PL_sv_undef;
5629 Safefree(tmparyval);
5633 mg_set(MUTABLE_SV(ary));
5641 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5642 register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5643 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5646 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5649 ENTER_with_name("call_PUSH");
5650 call_method("PUSH",G_SCALAR|G_DISCARD);
5651 LEAVE_with_name("call_PUSH");
5655 PL_delaymagic = DM_DELAY;
5656 for (++MARK; MARK <= SP; MARK++) {
5657 SV * const sv = newSV(0);
5659 sv_setsv(sv, *MARK);
5660 av_store(ary, AvFILLp(ary)+1, sv);
5662 if (PL_delaymagic & DM_ARRAY_ISA)
5663 mg_set(MUTABLE_SV(ary));
5668 if (OP_GIMME(PL_op, 0) != G_VOID) {
5669 PUSHi( AvFILL(ary) + 1 );
5678 AV * const av = PL_op->op_flags & OPf_SPECIAL
5679 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5680 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5684 (void)sv_2mortal(sv);
5691 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5692 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5693 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5696 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5699 ENTER_with_name("call_UNSHIFT");
5700 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5701 LEAVE_with_name("call_UNSHIFT");
5706 av_unshift(ary, SP - MARK);
5708 SV * const sv = newSVsv(*++MARK);
5709 (void)av_store(ary, i++, sv);
5713 if (OP_GIMME(PL_op, 0) != G_VOID) {
5714 PUSHi( AvFILL(ary) + 1 );
5723 if (GIMME == G_ARRAY) {
5724 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5728 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5729 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5730 av = MUTABLE_AV((*SP));
5731 /* In-place reversing only happens in void context for the array
5732 * assignment. We don't need to push anything on the stack. */
5735 if (SvMAGICAL(av)) {
5737 register SV *tmp = sv_newmortal();
5738 /* For SvCANEXISTDELETE */
5741 bool can_preserve = SvCANEXISTDELETE(av);
5743 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5744 register SV *begin, *end;
5747 if (!av_exists(av, i)) {
5748 if (av_exists(av, j)) {
5749 register SV *sv = av_delete(av, j, 0);
5750 begin = *av_fetch(av, i, TRUE);
5751 sv_setsv_mg(begin, sv);
5755 else if (!av_exists(av, j)) {
5756 register SV *sv = av_delete(av, i, 0);
5757 end = *av_fetch(av, j, TRUE);
5758 sv_setsv_mg(end, sv);
5763 begin = *av_fetch(av, i, TRUE);
5764 end = *av_fetch(av, j, TRUE);
5765 sv_setsv(tmp, begin);
5766 sv_setsv_mg(begin, end);
5767 sv_setsv_mg(end, tmp);
5771 SV **begin = AvARRAY(av);
5774 SV **end = begin + AvFILLp(av);
5776 while (begin < end) {
5777 register SV * const tmp = *begin;
5788 register SV * const tmp = *MARK;
5792 /* safe as long as stack cannot get extended in the above */
5798 register char *down;
5803 SvUTF8_off(TARG); /* decontaminate */
5805 do_join(TARG, &PL_sv_no, MARK, SP);
5807 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5808 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5809 report_uninit(TARG);
5812 up = SvPV_force(TARG, len);
5814 if (DO_UTF8(TARG)) { /* first reverse each character */
5815 U8* s = (U8*)SvPVX(TARG);
5816 const U8* send = (U8*)(s + len);
5818 if (UTF8_IS_INVARIANT(*s)) {
5823 if (!utf8_to_uvchr(s, 0))
5827 down = (char*)(s - 1);
5828 /* reverse this character */
5832 *down-- = (char)tmp;
5838 down = SvPVX(TARG) + len - 1;
5842 *down-- = (char)tmp;
5844 (void)SvPOK_only_UTF8(TARG);
5856 register IV limit = POPi; /* note, negative is forever */
5857 SV * const sv = POPs;
5859 register const char *s = SvPV_const(sv, len);
5860 const bool do_utf8 = DO_UTF8(sv);
5861 const char *strend = s + len;
5863 register REGEXP *rx;
5865 register const char *m;
5867 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5868 I32 maxiters = slen + 10;
5869 I32 trailing_empty = 0;
5871 const I32 origlimit = limit;
5874 const I32 gimme = GIMME_V;
5876 const I32 oldsave = PL_savestack_ix;
5877 U32 make_mortal = SVs_TEMP;
5882 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5887 DIE(aTHX_ "panic: pp_split");
5890 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5891 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5893 RX_MATCH_UTF8_set(rx, do_utf8);
5896 if (pm->op_pmreplrootu.op_pmtargetoff) {
5897 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5900 if (pm->op_pmreplrootu.op_pmtargetgv) {
5901 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5906 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5912 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5914 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5921 for (i = AvFILLp(ary); i >= 0; i--)
5922 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5924 /* temporarily switch stacks */
5925 SAVESWITCHSTACK(PL_curstack, ary);
5929 base = SP - PL_stack_base;
5931 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5933 while (*s == ' ' || is_utf8_space((U8*)s))
5936 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5937 while (isSPACE_LC(*s))
5945 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5949 gimme_scalar = gimme == G_SCALAR && !ary;
5952 limit = maxiters + 2;
5953 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5956 /* this one uses 'm' and is a negative test */
5958 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5959 const int t = UTF8SKIP(m);
5960 /* is_utf8_space returns FALSE for malform utf8 */
5967 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5968 while (m < strend && !isSPACE_LC(*m))
5971 while (m < strend && !isSPACE(*m))
5984 dstr = newSVpvn_flags(s, m-s,
5985 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5989 /* skip the whitespace found last */
5991 s = m + UTF8SKIP(m);
5995 /* this one uses 's' and is a positive test */
5997 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
6000 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6001 while (s < strend && isSPACE_LC(*s))
6004 while (s < strend && isSPACE(*s))
6009 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6011 for (m = s; m < strend && *m != '\n'; m++)
6024 dstr = newSVpvn_flags(s, m-s,
6025 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6031 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6033 Pre-extend the stack, either the number of bytes or
6034 characters in the string or a limited amount, triggered by:
6036 my ($x, $y) = split //, $str;
6040 if (!gimme_scalar) {
6041 const U32 items = limit - 1;
6050 /* keep track of how many bytes we skip over */
6060 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6073 dstr = newSVpvn(s, 1);
6089 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6090 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6091 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6092 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
6093 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6094 SV * const csv = CALLREG_INTUIT_STRING(rx);
6096 len = RX_MINLENRET(rx);
6097 if (len == 1 && !RX_UTF8(rx) && !tail) {
6098 const char c = *SvPV_nolen_const(csv);
6100 for (m = s; m < strend && *m != c; m++)
6111 dstr = newSVpvn_flags(s, m-s,
6112 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6115 /* The rx->minlen is in characters but we want to step
6116 * s ahead by bytes. */
6118 s = (char*)utf8_hop((U8*)m, len);
6120 s = m + len; /* Fake \n at the end */
6124 while (s < strend && --limit &&
6125 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6126 csv, multiline ? FBMrf_MULTILINE : 0)) )
6135 dstr = newSVpvn_flags(s, m-s,
6136 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6139 /* The rx->minlen is in characters but we want to step
6140 * s ahead by bytes. */
6142 s = (char*)utf8_hop((U8*)m, len);
6144 s = m + len; /* Fake \n at the end */
6149 maxiters += slen * RX_NPARENS(rx);
6150 while (s < strend && --limit)
6154 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
6155 sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
6157 if (rex_return == 0)
6159 TAINT_IF(RX_MATCH_TAINTED(rx));
6160 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
6163 orig = RX_SUBBEG(rx);
6165 strend = s + (strend - m);
6167 m = RX_OFFS(rx)[0].start + orig;
6176 dstr = newSVpvn_flags(s, m-s,
6177 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6180 if (RX_NPARENS(rx)) {
6182 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6183 s = RX_OFFS(rx)[i].start + orig;
6184 m = RX_OFFS(rx)[i].end + orig;
6186 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6187 parens that didn't match -- they should be set to
6188 undef, not the empty string */
6196 if (m >= orig && s >= orig) {
6197 dstr = newSVpvn_flags(s, m-s,
6198 (do_utf8 ? SVf_UTF8 : 0)
6202 dstr = &PL_sv_undef; /* undef, not "" */
6208 s = RX_OFFS(rx)[0].end + orig;
6212 if (!gimme_scalar) {
6213 iters = (SP - PL_stack_base) - base;
6215 if (iters > maxiters)
6216 DIE(aTHX_ "Split loop");
6218 /* keep field after final delim? */
6219 if (s < strend || (iters && origlimit)) {
6220 if (!gimme_scalar) {
6221 const STRLEN l = strend - s;
6222 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6227 else if (!origlimit) {
6229 iters -= trailing_empty;
6231 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6232 if (TOPs && !make_mortal)
6234 *SP-- = &PL_sv_undef;
6241 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6245 if (SvSMAGICAL(ary)) {
6247 mg_set(MUTABLE_SV(ary));
6250 if (gimme == G_ARRAY) {
6252 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6259 ENTER_with_name("call_PUSH");
6260 call_method("PUSH",G_SCALAR|G_DISCARD);
6261 LEAVE_with_name("call_PUSH");
6263 if (gimme == G_ARRAY) {
6265 /* EXTEND should not be needed - we just popped them */
6267 for (i=0; i < iters; i++) {
6268 SV **svp = av_fetch(ary, i, FALSE);
6269 PUSHs((svp) ? *svp : &PL_sv_undef);
6276 if (gimme == G_ARRAY)
6288 SV *const sv = PAD_SVl(PL_op->op_targ);
6290 if (SvPADSTALE(sv)) {
6293 RETURNOP(cLOGOP->op_other);
6295 RETURNOP(cLOGOP->op_next);
6304 assert(SvTYPE(retsv) != SVt_PVCV);
6306 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6307 retsv = refto(retsv);
6314 PP(unimplemented_op)
6317 const Optype op_type = PL_op->op_type;
6318 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6319 with out of range op numbers - it only "special" cases op_custom.
6320 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6321 if we get here for a custom op then that means that the custom op didn't
6322 have an implementation. Given that OP_NAME() looks up the custom op
6323 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6324 registers &PL_unimplemented_op as the address of their custom op.
6325 NULL doesn't generate a useful error message. "custom" does. */
6326 const char *const name = op_type >= OP_max
6327 ? "[out of range]" : PL_op_name[PL_op->op_type];
6328 if(OP_IS_SOCKET(op_type))
6329 DIE(aTHX_ PL_no_sock_func, name);
6330 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6337 HV * const hv = (HV*)POPs;
6339 if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
6341 if (SvRMAGICAL(hv)) {
6342 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6344 XPUSHs(magic_scalarpack(hv, mg));
6349 XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
6355 * c-indentation-style: bsd
6357 * indent-tabs-mode: t
6360 * ex: set ts=8 sts=4 sw=4 noet: