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";
144 /* In some cases this function inspects PL_op. If this function is called
145 for new op types, more bool parameters may need to be added in place of
148 When noinit is true, the absence of a gv will cause a retval of undef.
149 This is unrelated to the cv-to-gv assignment case.
151 Make sure to use SPAGAIN after calling this.
155 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
159 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
162 sv = amagic_deref_call(sv, to_gv_amg);
166 if (SvTYPE(sv) == SVt_PVIO) {
167 GV * const gv = MUTABLE_GV(sv_newmortal());
168 gv_init(gv, 0, "", 0, 0);
169 GvIOp(gv) = MUTABLE_IO(sv);
170 SvREFCNT_inc_void_NN(sv);
173 else if (!isGV_with_GP(sv))
174 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
177 if (!isGV_with_GP(sv)) {
179 /* If this is a 'my' scalar and flag is set then vivify
182 if (vivify_sv && sv != &PL_sv_undef) {
185 Perl_croak_no_modify(aTHX);
186 if (cUNOP->op_targ) {
188 SV * const namesv = PAD_SV(cUNOP->op_targ);
189 const char * const name = SvPV(namesv, len);
190 gv = MUTABLE_GV(newSV(0));
191 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
194 const char * const name = CopSTASHPV(PL_curcop);
197 prepare_SV_for_RV(sv);
198 SvRV_set(sv, MUTABLE_SV(gv));
203 if (PL_op->op_flags & OPf_REF || strict)
204 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
205 if (ckWARN(WARN_UNINITIALIZED))
211 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
212 sv, GV_ADDMG, SVt_PVGV
222 (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""),
225 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
226 == OPpDONT_INIT_GV) {
227 /* We are the target of a coderef assignment. Return
228 the scalar unchanged, and let pp_sasssign deal with
232 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
234 /* FAKE globs in the symbol table cause weird bugs (#77810) */
239 SV *newsv = sv_newmortal();
240 sv_setsv_flags(newsv, sv, 0);
252 sv, PL_op->op_private & OPpDEREF,
253 PL_op->op_private & HINT_STRICT_REFS,
254 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
255 || PL_op->op_type == OP_READLINE
258 if (PL_op->op_private & OPpLVAL_INTRO)
259 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
264 /* Helper function for pp_rv2sv and pp_rv2av */
266 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
267 const svtype type, SV ***spp)
272 PERL_ARGS_ASSERT_SOFTREF2XV;
274 if (PL_op->op_private & HINT_STRICT_REFS) {
276 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
278 Perl_die(aTHX_ PL_no_usym, what);
282 PL_op->op_flags & OPf_REF &&
283 PL_op->op_next->op_type != OP_BOOLKEYS
285 Perl_die(aTHX_ PL_no_usym, what);
286 if (ckWARN(WARN_UNINITIALIZED))
288 if (type != SVt_PV && GIMME_V == G_ARRAY) {
292 **spp = &PL_sv_undef;
295 if ((PL_op->op_flags & OPf_SPECIAL) &&
296 !(PL_op->op_flags & OPf_MOD))
298 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
300 **spp = &PL_sv_undef;
305 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
318 sv = amagic_deref_call(sv, to_sv_amg);
323 switch (SvTYPE(sv)) {
329 DIE(aTHX_ "Not a SCALAR reference");
336 if (!isGV_with_GP(gv)) {
337 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
343 if (PL_op->op_flags & OPf_MOD) {
344 if (PL_op->op_private & OPpLVAL_INTRO) {
345 if (cUNOP->op_first->op_type == OP_NULL)
346 sv = save_scalar(MUTABLE_GV(TOPs));
348 sv = save_scalar(gv);
350 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
352 else if (PL_op->op_private & OPpDEREF)
353 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
362 AV * const av = MUTABLE_AV(TOPs);
363 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
365 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
367 *sv = newSV_type(SVt_PVMG);
368 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
372 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
381 if (PL_op->op_flags & OPf_MOD || LVRET) {
382 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
383 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
385 LvTARG(ret) = SvREFCNT_inc_simple(sv);
386 PUSHs(ret); /* no SvSETMAGIC */
390 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
391 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
392 if (mg && mg->mg_len >= 0) {
410 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
412 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
415 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
416 /* (But not in defined().) */
418 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
421 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
422 if ((PL_op->op_private & OPpLVAL_INTRO)) {
423 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
426 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
429 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
433 cv = MUTABLE_CV(&PL_sv_undef);
434 SETs(MUTABLE_SV(cv));
444 SV *ret = &PL_sv_undef;
446 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
447 const char * s = SvPVX_const(TOPs);
448 if (strnEQ(s, "CORE::", 6)) {
449 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
450 if (!code || code == -KEY_CORE)
451 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
452 if (code < 0) { /* Overridable. */
453 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
459 cv = sv_2cv(TOPs, &stash, &gv, 0);
461 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
470 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
472 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
474 PUSHs(MUTABLE_SV(cv));
488 if (GIMME != G_ARRAY) {
492 *MARK = &PL_sv_undef;
493 *MARK = refto(*MARK);
497 EXTEND_MORTAL(SP - MARK);
499 *MARK = refto(*MARK);
504 S_refto(pTHX_ SV *sv)
509 PERL_ARGS_ASSERT_REFTO;
511 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
514 if (!(sv = LvTARG(sv)))
517 SvREFCNT_inc_void_NN(sv);
519 else if (SvTYPE(sv) == SVt_PVAV) {
520 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
521 av_reify(MUTABLE_AV(sv));
523 SvREFCNT_inc_void_NN(sv);
525 else if (SvPADTMP(sv) && !IS_PADGV(sv))
529 SvREFCNT_inc_void_NN(sv);
532 sv_upgrade(rv, SVt_IV);
542 SV * const sv = POPs;
547 if (!sv || !SvROK(sv))
550 pv = sv_reftype(SvRV(sv),TRUE);
551 PUSHp(pv, strlen(pv));
562 stash = CopSTASH(PL_curcop);
564 SV * const ssv = POPs;
568 if (!ssv) goto curstash;
569 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
570 Perl_croak(aTHX_ "Attempt to bless into a reference");
571 ptr = SvPV_const(ssv,len);
573 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
574 "Explicit blessing to '' (assuming package main)");
575 stash = gv_stashpvn(ptr, len, GV_ADD);
578 (void)sv_bless(TOPs, stash);
587 const char * const elem = SvPV_nolen_const(sv);
588 GV * const gv = MUTABLE_GV(POPs);
593 /* elem will always be NUL terminated. */
594 const char * const second_letter = elem + 1;
597 if (strEQ(second_letter, "RRAY"))
598 tmpRef = MUTABLE_SV(GvAV(gv));
601 if (strEQ(second_letter, "ODE"))
602 tmpRef = MUTABLE_SV(GvCVu(gv));
605 if (strEQ(second_letter, "ILEHANDLE")) {
606 /* finally deprecated in 5.8.0 */
607 deprecate("*glob{FILEHANDLE}");
608 tmpRef = MUTABLE_SV(GvIOp(gv));
611 if (strEQ(second_letter, "ORMAT"))
612 tmpRef = MUTABLE_SV(GvFORM(gv));
615 if (strEQ(second_letter, "LOB"))
616 tmpRef = MUTABLE_SV(gv);
619 if (strEQ(second_letter, "ASH"))
620 tmpRef = MUTABLE_SV(GvHV(gv));
623 if (*second_letter == 'O' && !elem[2])
624 tmpRef = MUTABLE_SV(GvIOp(gv));
627 if (strEQ(second_letter, "AME"))
628 sv = newSVhek(GvNAME_HEK(gv));
631 if (strEQ(second_letter, "ACKAGE")) {
632 const HV * const stash = GvSTASH(gv);
633 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
634 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
638 if (strEQ(second_letter, "CALAR"))
653 /* Pattern matching */
658 register unsigned char *s;
661 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_study) : NULL;
665 if (mg && SvSCREAM(sv))
668 s = (unsigned char*)(SvPV(sv, len));
669 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
670 /* No point in studying a zero length string, and not safe to study
671 anything that doesn't appear to be a simple scalar (and hence might
672 change between now and when the regexp engine runs without our set
673 magic ever running) such as a reference to an object with overloaded
674 stringification. Also refuse to study an FBM scalar, as this gives
675 more flexibility in SV flag usage. No real-world code would ever
676 end up studying an FBM scalar, so this isn't a real pessimisation.
677 Endemic use of I32 in Perl_screaminstr makes it hard to safely push
678 the study length limit from I32_MAX to U32_MAX - 1.
685 } else if (len < 0xFFFF) {
690 size = (256 + len) * quanta;
691 sfirst_raw = (char *)safemalloc(size);
694 DIE(aTHX_ "do_study: out of memory");
698 mg = sv_magicext(sv, NULL, PERL_MAGIC_study, &PL_vtbl_regexp, NULL, 0);
699 mg->mg_ptr = sfirst_raw;
701 mg->mg_private = quanta;
703 memset(sfirst_raw, ~0, 256 * quanta);
705 /* The assumption here is that most studied strings are fairly short, hence
706 the pain of the extra code is worth it, given the memory savings.
707 80 character string, 336 bytes as U8, down from 1344 as U32
708 800 character string, 2112 bytes as U16, down from 4224 as U32
712 U8 *const sfirst = (U8 *)sfirst_raw;
713 U8 *const snext = sfirst + 256;
715 const U8 ch = s[len];
716 snext[len] = sfirst[ch];
719 } else if (quanta == 2) {
720 U16 *const sfirst = (U16 *)sfirst_raw;
721 U16 *const snext = sfirst + 256;
723 const U8 ch = s[len];
724 snext[len] = sfirst[ch];
728 U32 *const sfirst = (U32 *)sfirst_raw;
729 U32 *const snext = sfirst + 256;
731 const U8 ch = s[len];
732 snext[len] = sfirst[ch];
745 if (PL_op->op_flags & OPf_STACKED)
747 else if (PL_op->op_private & OPpTARGET_MY)
753 TARG = sv_newmortal();
754 if(PL_op->op_type == OP_TRANSR) {
755 SV * const newsv = newSVsv(sv);
759 else PUSHi(do_trans(sv));
763 /* Lvalue operators. */
766 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
772 PERL_ARGS_ASSERT_DO_CHOMP;
774 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
776 if (SvTYPE(sv) == SVt_PVAV) {
778 AV *const av = MUTABLE_AV(sv);
779 const I32 max = AvFILL(av);
781 for (i = 0; i <= max; i++) {
782 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
783 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
784 do_chomp(retval, sv, chomping);
788 else if (SvTYPE(sv) == SVt_PVHV) {
789 HV* const hv = MUTABLE_HV(sv);
791 (void)hv_iterinit(hv);
792 while ((entry = hv_iternext(hv)))
793 do_chomp(retval, hv_iterval(hv,entry), chomping);
796 else if (SvREADONLY(sv)) {
798 /* SV is copy-on-write */
799 sv_force_normal_flags(sv, 0);
802 Perl_croak_no_modify(aTHX);
807 /* XXX, here sv is utf8-ized as a side-effect!
808 If encoding.pm is used properly, almost string-generating
809 operations, including literal strings, chr(), input data, etc.
810 should have been utf8-ized already, right?
812 sv_recode_to_utf8(sv, PL_encoding);
818 char *temp_buffer = NULL;
827 while (len && s[-1] == '\n') {
834 STRLEN rslen, rs_charlen;
835 const char *rsptr = SvPV_const(PL_rs, rslen);
837 rs_charlen = SvUTF8(PL_rs)
841 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
842 /* Assumption is that rs is shorter than the scalar. */
844 /* RS is utf8, scalar is 8 bit. */
846 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
849 /* Cannot downgrade, therefore cannot possibly match
851 assert (temp_buffer == rsptr);
857 else if (PL_encoding) {
858 /* RS is 8 bit, encoding.pm is used.
859 * Do not recode PL_rs as a side-effect. */
860 svrecode = newSVpvn(rsptr, rslen);
861 sv_recode_to_utf8(svrecode, PL_encoding);
862 rsptr = SvPV_const(svrecode, rslen);
863 rs_charlen = sv_len_utf8(svrecode);
866 /* RS is 8 bit, scalar is utf8. */
867 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
881 if (memNE(s, rsptr, rslen))
883 SvIVX(retval) += rs_charlen;
886 s = SvPV_force_nolen(sv);
894 SvREFCNT_dec(svrecode);
896 Safefree(temp_buffer);
898 if (len && !SvPOK(sv))
899 s = SvPV_force_nomg(sv, len);
902 char * const send = s + len;
903 char * const start = s;
905 while (s > start && UTF8_IS_CONTINUATION(*s))
907 if (is_utf8_string((U8*)s, send - s)) {
908 sv_setpvn(retval, s, send - s);
910 SvCUR_set(sv, s - start);
916 sv_setpvs(retval, "");
920 sv_setpvn(retval, s, 1);
927 sv_setpvs(retval, "");
935 const bool chomping = PL_op->op_type == OP_SCHOMP;
939 do_chomp(TARG, TOPs, chomping);
946 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
947 const bool chomping = PL_op->op_type == OP_CHOMP;
952 do_chomp(TARG, *++MARK, chomping);
963 if (!PL_op->op_private) {
972 SV_CHECK_THINKFIRST_COW_DROP(sv);
974 switch (SvTYPE(sv)) {
978 av_undef(MUTABLE_AV(sv));
981 hv_undef(MUTABLE_HV(sv));
984 if (cv_const_sv((const CV *)sv))
985 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
986 CvANON((const CV *)sv) ? "(anonymous)"
987 : GvENAME(CvGV((const CV *)sv)));
991 /* let user-undef'd sub keep its identity */
992 GV* const gv = CvGV((const CV *)sv);
993 cv_undef(MUTABLE_CV(sv));
994 CvGV_set(MUTABLE_CV(sv), gv);
999 SvSetMagicSV(sv, &PL_sv_undef);
1002 else if (isGV_with_GP(sv)) {
1006 /* undef *Pkg::meth_name ... */
1008 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1009 && HvENAME_get(stash);
1011 if((stash = GvHV((const GV *)sv))) {
1012 if(HvENAME_get(stash))
1013 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1017 gp_free(MUTABLE_GV(sv));
1019 GvGP_set(sv, gp_ref(gp));
1020 GvSV(sv) = newSV(0);
1021 GvLINE(sv) = CopLINE(PL_curcop);
1022 GvEGV(sv) = MUTABLE_GV(sv);
1026 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1028 /* undef *Foo::ISA */
1029 if( strEQ(GvNAME((const GV *)sv), "ISA")
1030 && (stash = GvSTASH((const GV *)sv))
1031 && (method_changed || HvENAME(stash)) )
1032 mro_isa_changed_in(stash);
1033 else if(method_changed)
1034 mro_method_changed_in(
1035 GvSTASH((const GV *)sv)
1042 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1058 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1059 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1060 Perl_croak_no_modify(aTHX);
1062 TARG = sv_newmortal();
1063 sv_setsv(TARG, TOPs);
1064 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1065 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1067 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1068 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1072 else sv_dec_nomg(TOPs);
1074 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1075 if (inc && !SvOK(TARG))
1081 /* Ordinary operators. */
1085 dVAR; dSP; dATARGET; SV *svl, *svr;
1086 #ifdef PERL_PRESERVE_IVUV
1089 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1092 #ifdef PERL_PRESERVE_IVUV
1093 /* For integer to integer power, we do the calculation by hand wherever
1094 we're sure it is safe; otherwise we call pow() and try to convert to
1095 integer afterwards. */
1097 SvIV_please_nomg(svr);
1099 SvIV_please_nomg(svl);
1108 const IV iv = SvIVX(svr);
1112 goto float_it; /* Can't do negative powers this way. */
1116 baseuok = SvUOK(svl);
1118 baseuv = SvUVX(svl);
1120 const IV iv = SvIVX(svl);
1123 baseuok = TRUE; /* effectively it's a UV now */
1125 baseuv = -iv; /* abs, baseuok == false records sign */
1128 /* now we have integer ** positive integer. */
1131 /* foo & (foo - 1) is zero only for a power of 2. */
1132 if (!(baseuv & (baseuv - 1))) {
1133 /* We are raising power-of-2 to a positive integer.
1134 The logic here will work for any base (even non-integer
1135 bases) but it can be less accurate than
1136 pow (base,power) or exp (power * log (base)) when the
1137 intermediate values start to spill out of the mantissa.
1138 With powers of 2 we know this can't happen.
1139 And powers of 2 are the favourite thing for perl
1140 programmers to notice ** not doing what they mean. */
1142 NV base = baseuok ? baseuv : -(NV)baseuv;
1147 while (power >>= 1) {
1155 SvIV_please_nomg(svr);
1158 register unsigned int highbit = 8 * sizeof(UV);
1159 register unsigned int diff = 8 * sizeof(UV);
1160 while (diff >>= 1) {
1162 if (baseuv >> highbit) {
1166 /* we now have baseuv < 2 ** highbit */
1167 if (power * highbit <= 8 * sizeof(UV)) {
1168 /* result will definitely fit in UV, so use UV math
1169 on same algorithm as above */
1170 register UV result = 1;
1171 register UV base = baseuv;
1172 const bool odd_power = cBOOL(power & 1);
1176 while (power >>= 1) {
1183 if (baseuok || !odd_power)
1184 /* answer is positive */
1186 else if (result <= (UV)IV_MAX)
1187 /* answer negative, fits in IV */
1188 SETi( -(IV)result );
1189 else if (result == (UV)IV_MIN)
1190 /* 2's complement assumption: special case IV_MIN */
1193 /* answer negative, doesn't fit */
1194 SETn( -(NV)result );
1204 NV right = SvNV_nomg(svr);
1205 NV left = SvNV_nomg(svl);
1208 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1210 We are building perl with long double support and are on an AIX OS
1211 afflicted with a powl() function that wrongly returns NaNQ for any
1212 negative base. This was reported to IBM as PMR #23047-379 on
1213 03/06/2006. The problem exists in at least the following versions
1214 of AIX and the libm fileset, and no doubt others as well:
1216 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1217 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1218 AIX 5.2.0 bos.adt.libm 5.2.0.85
1220 So, until IBM fixes powl(), we provide the following workaround to
1221 handle the problem ourselves. Our logic is as follows: for
1222 negative bases (left), we use fmod(right, 2) to check if the
1223 exponent is an odd or even integer:
1225 - if odd, powl(left, right) == -powl(-left, right)
1226 - if even, powl(left, right) == powl(-left, right)
1228 If the exponent is not an integer, the result is rightly NaNQ, so
1229 we just return that (as NV_NAN).
1233 NV mod2 = Perl_fmod( right, 2.0 );
1234 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1235 SETn( -Perl_pow( -left, right) );
1236 } else if (mod2 == 0.0) { /* even integer */
1237 SETn( Perl_pow( -left, right) );
1238 } else { /* fractional power */
1242 SETn( Perl_pow( left, right) );
1245 SETn( Perl_pow( left, right) );
1246 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1248 #ifdef PERL_PRESERVE_IVUV
1250 SvIV_please_nomg(svr);
1258 dVAR; dSP; dATARGET; SV *svl, *svr;
1259 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1262 #ifdef PERL_PRESERVE_IVUV
1263 SvIV_please_nomg(svr);
1265 /* Unless the left argument is integer in range we are going to have to
1266 use NV maths. Hence only attempt to coerce the right argument if
1267 we know the left is integer. */
1268 /* Left operand is defined, so is it IV? */
1269 SvIV_please_nomg(svl);
1271 bool auvok = SvUOK(svl);
1272 bool buvok = SvUOK(svr);
1273 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1274 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1283 const IV aiv = SvIVX(svl);
1286 auvok = TRUE; /* effectively it's a UV now */
1288 alow = -aiv; /* abs, auvok == false records sign */
1294 const IV biv = SvIVX(svr);
1297 buvok = TRUE; /* effectively it's a UV now */
1299 blow = -biv; /* abs, buvok == false records sign */
1303 /* If this does sign extension on unsigned it's time for plan B */
1304 ahigh = alow >> (4 * sizeof (UV));
1306 bhigh = blow >> (4 * sizeof (UV));
1308 if (ahigh && bhigh) {
1310 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1311 which is overflow. Drop to NVs below. */
1312 } else if (!ahigh && !bhigh) {
1313 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1314 so the unsigned multiply cannot overflow. */
1315 const UV product = alow * blow;
1316 if (auvok == buvok) {
1317 /* -ve * -ve or +ve * +ve gives a +ve result. */
1321 } else if (product <= (UV)IV_MIN) {
1322 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1323 /* -ve result, which could overflow an IV */
1325 SETi( -(IV)product );
1327 } /* else drop to NVs below. */
1329 /* One operand is large, 1 small */
1332 /* swap the operands */
1334 bhigh = blow; /* bhigh now the temp var for the swap */
1338 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1339 multiplies can't overflow. shift can, add can, -ve can. */
1340 product_middle = ahigh * blow;
1341 if (!(product_middle & topmask)) {
1342 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1344 product_middle <<= (4 * sizeof (UV));
1345 product_low = alow * blow;
1347 /* as for pp_add, UV + something mustn't get smaller.
1348 IIRC ANSI mandates this wrapping *behaviour* for
1349 unsigned whatever the actual representation*/
1350 product_low += product_middle;
1351 if (product_low >= product_middle) {
1352 /* didn't overflow */
1353 if (auvok == buvok) {
1354 /* -ve * -ve or +ve * +ve gives a +ve result. */
1356 SETu( product_low );
1358 } else if (product_low <= (UV)IV_MIN) {
1359 /* 2s complement assumption again */
1360 /* -ve result, which could overflow an IV */
1362 SETi( -(IV)product_low );
1364 } /* else drop to NVs below. */
1366 } /* product_middle too large */
1367 } /* ahigh && bhigh */
1372 NV right = SvNV_nomg(svr);
1373 NV left = SvNV_nomg(svl);
1375 SETn( left * right );
1382 dVAR; dSP; dATARGET; SV *svl, *svr;
1383 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1386 /* Only try to do UV divide first
1387 if ((SLOPPYDIVIDE is true) or
1388 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1390 The assumption is that it is better to use floating point divide
1391 whenever possible, only doing integer divide first if we can't be sure.
1392 If NV_PRESERVES_UV is true then we know at compile time that no UV
1393 can be too large to preserve, so don't need to compile the code to
1394 test the size of UVs. */
1397 # define PERL_TRY_UV_DIVIDE
1398 /* ensure that 20./5. == 4. */
1400 # ifdef PERL_PRESERVE_IVUV
1401 # ifndef NV_PRESERVES_UV
1402 # define PERL_TRY_UV_DIVIDE
1407 #ifdef PERL_TRY_UV_DIVIDE
1408 SvIV_please_nomg(svr);
1410 SvIV_please_nomg(svl);
1412 bool left_non_neg = SvUOK(svl);
1413 bool right_non_neg = SvUOK(svr);
1417 if (right_non_neg) {
1421 const IV biv = SvIVX(svr);
1424 right_non_neg = TRUE; /* effectively it's a UV now */
1430 /* historically undef()/0 gives a "Use of uninitialized value"
1431 warning before dieing, hence this test goes here.
1432 If it were immediately before the second SvIV_please, then
1433 DIE() would be invoked before left was even inspected, so
1434 no inspection would give no warning. */
1436 DIE(aTHX_ "Illegal division by zero");
1442 const IV aiv = SvIVX(svl);
1445 left_non_neg = TRUE; /* effectively it's a UV now */
1454 /* For sloppy divide we always attempt integer division. */
1456 /* Otherwise we only attempt it if either or both operands
1457 would not be preserved by an NV. If both fit in NVs
1458 we fall through to the NV divide code below. However,
1459 as left >= right to ensure integer result here, we know that
1460 we can skip the test on the right operand - right big
1461 enough not to be preserved can't get here unless left is
1464 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1467 /* Integer division can't overflow, but it can be imprecise. */
1468 const UV result = left / right;
1469 if (result * right == left) {
1470 SP--; /* result is valid */
1471 if (left_non_neg == right_non_neg) {
1472 /* signs identical, result is positive. */
1476 /* 2s complement assumption */
1477 if (result <= (UV)IV_MIN)
1478 SETi( -(IV)result );
1480 /* It's exact but too negative for IV. */
1481 SETn( -(NV)result );
1484 } /* tried integer divide but it was not an integer result */
1485 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1486 } /* left wasn't SvIOK */
1487 } /* right wasn't SvIOK */
1488 #endif /* PERL_TRY_UV_DIVIDE */
1490 NV right = SvNV_nomg(svr);
1491 NV left = SvNV_nomg(svl);
1492 (void)POPs;(void)POPs;
1493 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1494 if (! Perl_isnan(right) && right == 0.0)
1498 DIE(aTHX_ "Illegal division by zero");
1499 PUSHn( left / right );
1506 dVAR; dSP; dATARGET;
1507 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1511 bool left_neg = FALSE;
1512 bool right_neg = FALSE;
1513 bool use_double = FALSE;
1514 bool dright_valid = FALSE;
1517 SV * const svr = TOPs;
1518 SV * const svl = TOPm1s;
1519 SvIV_please_nomg(svr);
1521 right_neg = !SvUOK(svr);
1525 const IV biv = SvIVX(svr);
1528 right_neg = FALSE; /* effectively it's a UV now */
1535 dright = SvNV_nomg(svr);
1536 right_neg = dright < 0;
1539 if (dright < UV_MAX_P1) {
1540 right = U_V(dright);
1541 dright_valid = TRUE; /* In case we need to use double below. */
1547 /* At this point use_double is only true if right is out of range for
1548 a UV. In range NV has been rounded down to nearest UV and
1549 use_double false. */
1550 SvIV_please_nomg(svl);
1551 if (!use_double && SvIOK(svl)) {
1553 left_neg = !SvUOK(svl);
1557 const IV aiv = SvIVX(svl);
1560 left_neg = FALSE; /* effectively it's a UV now */
1568 dleft = SvNV_nomg(svl);
1569 left_neg = dleft < 0;
1573 /* This should be exactly the 5.6 behaviour - if left and right are
1574 both in range for UV then use U_V() rather than floor. */
1576 if (dleft < UV_MAX_P1) {
1577 /* right was in range, so is dleft, so use UVs not double.
1581 /* left is out of range for UV, right was in range, so promote
1582 right (back) to double. */
1584 /* The +0.5 is used in 5.6 even though it is not strictly
1585 consistent with the implicit +0 floor in the U_V()
1586 inside the #if 1. */
1587 dleft = Perl_floor(dleft + 0.5);
1590 dright = Perl_floor(dright + 0.5);
1601 DIE(aTHX_ "Illegal modulus zero");
1603 dans = Perl_fmod(dleft, dright);
1604 if ((left_neg != right_neg) && dans)
1605 dans = dright - dans;
1608 sv_setnv(TARG, dans);
1614 DIE(aTHX_ "Illegal modulus zero");
1617 if ((left_neg != right_neg) && ans)
1620 /* XXX may warn: unary minus operator applied to unsigned type */
1621 /* could change -foo to be (~foo)+1 instead */
1622 if (ans <= ~((UV)IV_MAX)+1)
1623 sv_setiv(TARG, ~ans+1);
1625 sv_setnv(TARG, -(NV)ans);
1628 sv_setuv(TARG, ans);
1637 dVAR; dSP; dATARGET;
1641 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1642 /* TODO: think of some way of doing list-repeat overloading ??? */
1647 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1653 const UV uv = SvUV_nomg(sv);
1655 count = IV_MAX; /* The best we can do? */
1659 const IV iv = SvIV_nomg(sv);
1666 else if (SvNOKp(sv)) {
1667 const NV nv = SvNV_nomg(sv);
1674 count = SvIV_nomg(sv);
1676 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1678 static const char oom_list_extend[] = "Out of memory during list extend";
1679 const I32 items = SP - MARK;
1680 const I32 max = items * count;
1682 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1683 /* Did the max computation overflow? */
1684 if (items > 0 && max > 0 && (max < items || max < count))
1685 Perl_croak(aTHX_ oom_list_extend);
1690 /* This code was intended to fix 20010809.028:
1693 for (($x =~ /./g) x 2) {
1694 print chop; # "abcdabcd" expected as output.
1697 * but that change (#11635) broke this code:
1699 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1701 * I can't think of a better fix that doesn't introduce
1702 * an efficiency hit by copying the SVs. The stack isn't
1703 * refcounted, and mortalisation obviously doesn't
1704 * Do The Right Thing when the stack has more than
1705 * one pointer to the same mortal value.
1709 *SP = sv_2mortal(newSVsv(*SP));
1719 repeatcpy((char*)(MARK + items), (char*)MARK,
1720 items * sizeof(const SV *), count - 1);
1723 else if (count <= 0)
1726 else { /* Note: mark already snarfed by pp_list */
1727 SV * const tmpstr = POPs;
1730 static const char oom_string_extend[] =
1731 "Out of memory during string extend";
1734 sv_setsv_nomg(TARG, tmpstr);
1735 SvPV_force_nomg(TARG, len);
1736 isutf = DO_UTF8(TARG);
1741 const STRLEN max = (UV)count * len;
1742 if (len > MEM_SIZE_MAX / count)
1743 Perl_croak(aTHX_ oom_string_extend);
1744 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1745 SvGROW(TARG, max + 1);
1746 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1747 SvCUR_set(TARG, SvCUR(TARG) * count);
1749 *SvEND(TARG) = '\0';
1752 (void)SvPOK_only_UTF8(TARG);
1754 (void)SvPOK_only(TARG);
1756 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1757 /* The parser saw this as a list repeat, and there
1758 are probably several items on the stack. But we're
1759 in scalar context, and there's no pp_list to save us
1760 now. So drop the rest of the items -- robin@kitsite.com
1772 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1773 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1776 useleft = USE_LEFT(svl);
1777 #ifdef PERL_PRESERVE_IVUV
1778 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1779 "bad things" happen if you rely on signed integers wrapping. */
1780 SvIV_please_nomg(svr);
1782 /* Unless the left argument is integer in range we are going to have to
1783 use NV maths. Hence only attempt to coerce the right argument if
1784 we know the left is integer. */
1785 register UV auv = 0;
1791 a_valid = auvok = 1;
1792 /* left operand is undef, treat as zero. */
1794 /* Left operand is defined, so is it IV? */
1795 SvIV_please_nomg(svl);
1797 if ((auvok = SvUOK(svl)))
1800 register const IV aiv = SvIVX(svl);
1803 auvok = 1; /* Now acting as a sign flag. */
1804 } else { /* 2s complement assumption for IV_MIN */
1812 bool result_good = 0;
1815 bool buvok = SvUOK(svr);
1820 register const IV biv = SvIVX(svr);
1827 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1828 else "IV" now, independent of how it came in.
1829 if a, b represents positive, A, B negative, a maps to -A etc
1834 all UV maths. negate result if A negative.
1835 subtract if signs same, add if signs differ. */
1837 if (auvok ^ buvok) {
1846 /* Must get smaller */
1851 if (result <= buv) {
1852 /* result really should be -(auv-buv). as its negation
1853 of true value, need to swap our result flag */
1865 if (result <= (UV)IV_MIN)
1866 SETi( -(IV)result );
1868 /* result valid, but out of range for IV. */
1869 SETn( -(NV)result );
1873 } /* Overflow, drop through to NVs. */
1878 NV value = SvNV_nomg(svr);
1882 /* left operand is undef, treat as zero - value */
1886 SETn( SvNV_nomg(svl) - value );
1893 dVAR; dSP; dATARGET; SV *svl, *svr;
1894 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1898 const IV shift = SvIV_nomg(svr);
1899 if (PL_op->op_private & HINT_INTEGER) {
1900 const IV i = SvIV_nomg(svl);
1904 const UV u = SvUV_nomg(svl);
1913 dVAR; dSP; dATARGET; SV *svl, *svr;
1914 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1918 const IV shift = SvIV_nomg(svr);
1919 if (PL_op->op_private & HINT_INTEGER) {
1920 const IV i = SvIV_nomg(svl);
1924 const UV u = SvUV_nomg(svl);
1936 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1940 (SvIOK_notUV(left) && SvIOK_notUV(right))
1941 ? (SvIVX(left) < SvIVX(right))
1942 : (do_ncmp(left, right) == -1)
1952 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1956 (SvIOK_notUV(left) && SvIOK_notUV(right))
1957 ? (SvIVX(left) > SvIVX(right))
1958 : (do_ncmp(left, right) == 1)
1968 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1972 (SvIOK_notUV(left) && SvIOK_notUV(right))
1973 ? (SvIVX(left) <= SvIVX(right))
1974 : (do_ncmp(left, right) <= 0)
1984 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1988 (SvIOK_notUV(left) && SvIOK_notUV(right))
1989 ? (SvIVX(left) >= SvIVX(right))
1990 : ( (do_ncmp(left, right) & 2) == 0)
2000 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2004 (SvIOK_notUV(left) && SvIOK_notUV(right))
2005 ? (SvIVX(left) != SvIVX(right))
2006 : (do_ncmp(left, right) != 0)
2011 /* compare left and right SVs. Returns:
2015 * 2: left or right was a NaN
2018 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2022 PERL_ARGS_ASSERT_DO_NCMP;
2023 #ifdef PERL_PRESERVE_IVUV
2024 SvIV_please_nomg(right);
2025 /* Fortunately it seems NaN isn't IOK */
2027 SvIV_please_nomg(left);
2030 const IV leftiv = SvIVX(left);
2031 if (!SvUOK(right)) {
2032 /* ## IV <=> IV ## */
2033 const IV rightiv = SvIVX(right);
2034 return (leftiv > rightiv) - (leftiv < rightiv);
2036 /* ## IV <=> UV ## */
2038 /* As (b) is a UV, it's >=0, so it must be < */
2041 const UV rightuv = SvUVX(right);
2042 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2047 /* ## UV <=> UV ## */
2048 const UV leftuv = SvUVX(left);
2049 const UV rightuv = SvUVX(right);
2050 return (leftuv > rightuv) - (leftuv < rightuv);
2052 /* ## UV <=> IV ## */
2054 const IV rightiv = SvIVX(right);
2056 /* As (a) is a UV, it's >=0, so it cannot be < */
2059 const UV leftuv = SvUVX(left);
2060 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2068 NV const rnv = SvNV_nomg(right);
2069 NV const lnv = SvNV_nomg(left);
2071 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2072 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2075 return (lnv > rnv) - (lnv < rnv);
2094 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2097 value = do_ncmp(left, right);
2112 int amg_type = sle_amg;
2116 switch (PL_op->op_type) {
2135 tryAMAGICbin_MG(amg_type, AMGf_set);
2138 const int cmp = (IN_LOCALE_RUNTIME
2139 ? sv_cmp_locale_flags(left, right, 0)
2140 : sv_cmp_flags(left, right, 0));
2141 SETs(boolSV(cmp * multiplier < rhs));
2149 tryAMAGICbin_MG(seq_amg, AMGf_set);
2152 SETs(boolSV(sv_eq_flags(left, right, 0)));
2160 tryAMAGICbin_MG(sne_amg, AMGf_set);
2163 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2171 tryAMAGICbin_MG(scmp_amg, 0);
2174 const int cmp = (IN_LOCALE_RUNTIME
2175 ? sv_cmp_locale_flags(left, right, 0)
2176 : sv_cmp_flags(left, right, 0));
2184 dVAR; dSP; dATARGET;
2185 tryAMAGICbin_MG(band_amg, AMGf_assign);
2188 if (SvNIOKp(left) || SvNIOKp(right)) {
2189 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2190 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2191 if (PL_op->op_private & HINT_INTEGER) {
2192 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2196 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2199 if (left_ro_nonnum) SvNIOK_off(left);
2200 if (right_ro_nonnum) SvNIOK_off(right);
2203 do_vop(PL_op->op_type, TARG, left, right);
2212 dVAR; dSP; dATARGET;
2213 const int op_type = PL_op->op_type;
2215 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2218 if (SvNIOKp(left) || SvNIOKp(right)) {
2219 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2220 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2221 if (PL_op->op_private & HINT_INTEGER) {
2222 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2223 const IV r = SvIV_nomg(right);
2224 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2228 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2229 const UV r = SvUV_nomg(right);
2230 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2233 if (left_ro_nonnum) SvNIOK_off(left);
2234 if (right_ro_nonnum) SvNIOK_off(right);
2237 do_vop(op_type, TARG, left, right);
2247 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2249 SV * const sv = TOPs;
2250 const int flags = SvFLAGS(sv);
2252 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2256 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2257 /* It's publicly an integer, or privately an integer-not-float */
2260 if (SvIVX(sv) == IV_MIN) {
2261 /* 2s complement assumption. */
2262 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2265 else if (SvUVX(sv) <= IV_MAX) {
2270 else if (SvIVX(sv) != IV_MIN) {
2274 #ifdef PERL_PRESERVE_IVUV
2282 SETn(-SvNV_nomg(sv));
2283 else if (SvPOKp(sv)) {
2285 const char * const s = SvPV_nomg_const(sv, len);
2286 if (isIDFIRST(*s)) {
2287 sv_setpvs(TARG, "-");
2290 else if (*s == '+' || *s == '-') {
2291 sv_setsv_nomg(TARG, sv);
2292 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2294 else if (DO_UTF8(sv)) {
2295 SvIV_please_nomg(sv);
2297 goto oops_its_an_int;
2299 sv_setnv(TARG, -SvNV_nomg(sv));
2301 sv_setpvs(TARG, "-");
2306 SvIV_please_nomg(sv);
2308 goto oops_its_an_int;
2309 sv_setnv(TARG, -SvNV_nomg(sv));
2314 SETn(-SvNV_nomg(sv));
2322 tryAMAGICun_MG(not_amg, AMGf_set);
2323 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2330 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2334 if (PL_op->op_private & HINT_INTEGER) {
2335 const IV i = ~SvIV_nomg(sv);
2339 const UV u = ~SvUV_nomg(sv);
2348 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2349 sv_setsv_nomg(TARG, sv);
2350 tmps = (U8*)SvPV_force_nomg(TARG, len);
2353 /* Calculate exact length, let's not estimate. */
2358 U8 * const send = tmps + len;
2359 U8 * const origtmps = tmps;
2360 const UV utf8flags = UTF8_ALLOW_ANYUV;
2362 while (tmps < send) {
2363 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2365 targlen += UNISKIP(~c);
2371 /* Now rewind strings and write them. */
2378 Newx(result, targlen + 1, U8);
2380 while (tmps < send) {
2381 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2383 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2386 sv_usepvn_flags(TARG, (char*)result, targlen,
2387 SV_HAS_TRAILING_NUL);
2394 Newx(result, nchar + 1, U8);
2396 while (tmps < send) {
2397 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2402 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2410 register long *tmpl;
2411 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2414 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2419 for ( ; anum > 0; anum--, tmps++)
2427 /* integer versions of some of the above */
2431 dVAR; dSP; dATARGET;
2432 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2435 SETi( left * right );
2443 dVAR; dSP; dATARGET;
2444 tryAMAGICbin_MG(div_amg, AMGf_assign);
2447 IV value = SvIV_nomg(right);
2449 DIE(aTHX_ "Illegal division by zero");
2450 num = SvIV_nomg(left);
2452 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2456 value = num / value;
2462 #if defined(__GLIBC__) && IVSIZE == 8
2469 /* This is the vanilla old i_modulo. */
2470 dVAR; dSP; dATARGET;
2471 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2475 DIE(aTHX_ "Illegal modulus zero");
2476 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2480 SETi( left % right );
2485 #if defined(__GLIBC__) && IVSIZE == 8
2490 /* This is the i_modulo with the workaround for the _moddi3 bug
2491 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2492 * See below for pp_i_modulo. */
2493 dVAR; dSP; dATARGET;
2494 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2498 DIE(aTHX_ "Illegal modulus zero");
2499 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2503 SETi( left % PERL_ABS(right) );
2510 dVAR; dSP; dATARGET;
2511 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2515 DIE(aTHX_ "Illegal modulus zero");
2516 /* The assumption is to use hereafter the old vanilla version... */
2518 PL_ppaddr[OP_I_MODULO] =
2520 /* .. but if we have glibc, we might have a buggy _moddi3
2521 * (at least glicb 2.2.5 is known to have this bug), in other
2522 * words our integer modulus with negative quad as the second
2523 * argument might be broken. Test for this and re-patch the
2524 * opcode dispatch table if that is the case, remembering to
2525 * also apply the workaround so that this first round works
2526 * right, too. See [perl #9402] for more information. */
2530 /* Cannot do this check with inlined IV constants since
2531 * that seems to work correctly even with the buggy glibc. */
2533 /* Yikes, we have the bug.
2534 * Patch in the workaround version. */
2536 PL_ppaddr[OP_I_MODULO] =
2537 &Perl_pp_i_modulo_1;
2538 /* Make certain we work right this time, too. */
2539 right = PERL_ABS(right);
2542 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2546 SETi( left % right );
2554 dVAR; dSP; dATARGET;
2555 tryAMAGICbin_MG(add_amg, AMGf_assign);
2557 dPOPTOPiirl_ul_nomg;
2558 SETi( left + right );
2565 dVAR; dSP; dATARGET;
2566 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2568 dPOPTOPiirl_ul_nomg;
2569 SETi( left - right );
2577 tryAMAGICbin_MG(lt_amg, AMGf_set);
2580 SETs(boolSV(left < right));
2588 tryAMAGICbin_MG(gt_amg, AMGf_set);
2591 SETs(boolSV(left > right));
2599 tryAMAGICbin_MG(le_amg, AMGf_set);
2602 SETs(boolSV(left <= right));
2610 tryAMAGICbin_MG(ge_amg, AMGf_set);
2613 SETs(boolSV(left >= right));
2621 tryAMAGICbin_MG(eq_amg, AMGf_set);
2624 SETs(boolSV(left == right));
2632 tryAMAGICbin_MG(ne_amg, AMGf_set);
2635 SETs(boolSV(left != right));
2643 tryAMAGICbin_MG(ncmp_amg, 0);
2650 else if (left < right)
2662 tryAMAGICun_MG(neg_amg, 0);
2664 SV * const sv = TOPs;
2665 IV const i = SvIV_nomg(sv);
2671 /* High falutin' math. */
2676 tryAMAGICbin_MG(atan2_amg, 0);
2679 SETn(Perl_atan2(left, right));
2687 int amg_type = sin_amg;
2688 const char *neg_report = NULL;
2689 NV (*func)(NV) = Perl_sin;
2690 const int op_type = PL_op->op_type;
2707 amg_type = sqrt_amg;
2709 neg_report = "sqrt";
2714 tryAMAGICun_MG(amg_type, 0);
2716 SV * const arg = POPs;
2717 const NV value = SvNV_nomg(arg);
2719 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2720 SET_NUMERIC_STANDARD();
2721 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2724 XPUSHn(func(value));
2729 /* Support Configure command-line overrides for rand() functions.
2730 After 5.005, perhaps we should replace this by Configure support
2731 for drand48(), random(), or rand(). For 5.005, though, maintain
2732 compatibility by calling rand() but allow the user to override it.
2733 See INSTALL for details. --Andy Dougherty 15 July 1998
2735 /* Now it's after 5.005, and Configure supports drand48() and random(),
2736 in addition to rand(). So the overrides should not be needed any more.
2737 --Jarkko Hietaniemi 27 September 1998
2740 #ifndef HAS_DRAND48_PROTO
2741 extern double drand48 (void);
2751 value = 1.0; (void)POPs;
2757 if (!PL_srand_called) {
2758 (void)seedDrand01((Rand_seed_t)seed());
2759 PL_srand_called = TRUE;
2769 const UV anum = (MAXARG < 1 || (!TOPs && !POPs)) ? seed() : POPu;
2770 (void)seedDrand01((Rand_seed_t)anum);
2771 PL_srand_called = TRUE;
2775 /* Historically srand always returned true. We can avoid breaking
2777 sv_setpvs(TARG, "0 but true");
2786 tryAMAGICun_MG(int_amg, AMGf_numeric);
2788 SV * const sv = TOPs;
2789 const IV iv = SvIV_nomg(sv);
2790 /* XXX it's arguable that compiler casting to IV might be subtly
2791 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2792 else preferring IV has introduced a subtle behaviour change bug. OTOH
2793 relying on floating point to be accurate is a bug. */
2798 else if (SvIOK(sv)) {
2800 SETu(SvUV_nomg(sv));
2805 const NV value = SvNV_nomg(sv);
2807 if (value < (NV)UV_MAX + 0.5) {
2810 SETn(Perl_floor(value));
2814 if (value > (NV)IV_MIN - 0.5) {
2817 SETn(Perl_ceil(value));
2828 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2830 SV * const sv = TOPs;
2831 /* This will cache the NV value if string isn't actually integer */
2832 const IV iv = SvIV_nomg(sv);
2837 else if (SvIOK(sv)) {
2838 /* IVX is precise */
2840 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2848 /* 2s complement assumption. Also, not really needed as
2849 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2855 const NV value = SvNV_nomg(sv);
2869 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2873 SV* const sv = POPs;
2875 tmps = (SvPV_const(sv, len));
2877 /* If Unicode, try to downgrade
2878 * If not possible, croak. */
2879 SV* const tsv = sv_2mortal(newSVsv(sv));
2882 sv_utf8_downgrade(tsv, FALSE);
2883 tmps = SvPV_const(tsv, len);
2885 if (PL_op->op_type == OP_HEX)
2888 while (*tmps && len && isSPACE(*tmps))
2892 if (*tmps == 'x' || *tmps == 'X') {
2894 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2896 else if (*tmps == 'b' || *tmps == 'B')
2897 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2899 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2901 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2915 SV * const sv = TOPs;
2917 if (SvGAMAGIC(sv)) {
2918 /* For an overloaded or magic scalar, we can't know in advance if
2919 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
2920 it likes to cache the length. Maybe that should be a documented
2925 = sv_2pv_flags(sv, &len,
2926 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
2929 if (!SvPADTMP(TARG)) {
2930 sv_setsv(TARG, &PL_sv_undef);
2935 else if (DO_UTF8(sv)) {
2936 SETi(utf8_length((U8*)p, (U8*)p + len));
2940 } else if (SvOK(sv)) {
2941 /* Neither magic nor overloaded. */
2943 SETi(sv_len_utf8(sv));
2947 if (!SvPADTMP(TARG)) {
2948 sv_setsv_nomg(TARG, &PL_sv_undef);
2970 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2973 const char *repl = NULL;
2975 int num_args = PL_op->op_private & 7;
2976 bool repl_need_utf8_upgrade = FALSE;
2977 bool repl_is_utf8 = FALSE;
2981 if((repl_sv = POPs)) {
2982 repl = SvPV_const(repl_sv, repl_len);
2983 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2987 if ((len_sv = POPs)) {
2988 len_iv = SvIV(len_sv);
2989 len_is_uv = SvIOK_UV(len_sv);
2994 pos1_iv = SvIV(pos_sv);
2995 pos1_is_uv = SvIOK_UV(pos_sv);
3001 sv_utf8_upgrade(sv);
3003 else if (DO_UTF8(sv))
3004 repl_need_utf8_upgrade = TRUE;
3006 tmps = SvPV_const(sv, curlen);
3008 utf8_curlen = sv_len_utf8(sv);
3009 if (utf8_curlen == curlen)
3012 curlen = utf8_curlen;
3017 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3018 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3021 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3025 if (!len_is_uv && len_iv < 0) {
3026 pos2_iv = curlen + len_iv;
3028 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3031 } else { /* len_iv >= 0 */
3032 if (!pos1_is_uv && pos1_iv < 0) {
3033 pos2_iv = pos1_iv + len_iv;
3034 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3036 if ((UV)len_iv > curlen-(UV)pos1_iv)
3039 pos2_iv = pos1_iv+len_iv;
3049 if (!pos2_is_uv && pos2_iv < 0) {
3050 if (!pos1_is_uv && pos1_iv < 0)
3054 else if (!pos1_is_uv && pos1_iv < 0)
3057 if ((UV)pos2_iv < (UV)pos1_iv)
3059 if ((UV)pos2_iv > curlen)
3063 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3064 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3065 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3066 STRLEN byte_len = len;
3067 STRLEN byte_pos = utf8_curlen
3068 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3070 if (lvalue && !repl) {
3073 if (!SvGMAGICAL(sv)) {
3075 SvPV_force_nolen(sv);
3076 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3077 "Attempt to use reference as lvalue in substr");
3079 if (isGV_with_GP(sv))
3080 SvPV_force_nolen(sv);
3081 else if (SvOK(sv)) /* is it defined ? */
3082 (void)SvPOK_only_UTF8(sv);
3084 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3087 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3088 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3090 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3091 LvTARGOFF(ret) = pos;
3092 LvTARGLEN(ret) = len;
3095 PUSHs(ret); /* avoid SvSETMAGIC here */
3099 SvTAINTED_off(TARG); /* decontaminate */
3100 SvUTF8_off(TARG); /* decontaminate */
3103 sv_setpvn(TARG, tmps, byte_len);
3104 #ifdef USE_LOCALE_COLLATE
3105 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3111 SV* repl_sv_copy = NULL;
3113 if (repl_need_utf8_upgrade) {
3114 repl_sv_copy = newSVsv(repl_sv);
3115 sv_utf8_upgrade(repl_sv_copy);
3116 repl = SvPV_const(repl_sv_copy, repl_len);
3117 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3121 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3124 SvREFCNT_dec(repl_sv_copy);
3134 Perl_croak(aTHX_ "substr outside of string");
3135 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3142 register const IV size = POPi;
3143 register const IV offset = POPi;
3144 register SV * const src = POPs;
3145 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3148 if (lvalue) { /* it's an lvalue! */
3149 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3150 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3152 LvTARG(ret) = SvREFCNT_inc_simple(src);
3153 LvTARGOFF(ret) = offset;
3154 LvTARGLEN(ret) = size;
3158 SvTAINTED_off(TARG); /* decontaminate */
3162 sv_setuv(ret, do_vecget(src, offset, size));
3178 const char *little_p;
3181 const bool is_index = PL_op->op_type == OP_INDEX;
3182 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3188 big_p = SvPV_const(big, biglen);
3189 little_p = SvPV_const(little, llen);
3191 big_utf8 = DO_UTF8(big);
3192 little_utf8 = DO_UTF8(little);
3193 if (big_utf8 ^ little_utf8) {
3194 /* One needs to be upgraded. */
3195 if (little_utf8 && !PL_encoding) {
3196 /* Well, maybe instead we might be able to downgrade the small
3198 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3201 /* If the large string is ISO-8859-1, and it's not possible to
3202 convert the small string to ISO-8859-1, then there is no
3203 way that it could be found anywhere by index. */
3208 /* At this point, pv is a malloc()ed string. So donate it to temp
3209 to ensure it will get free()d */
3210 little = temp = newSV(0);
3211 sv_usepvn(temp, pv, llen);
3212 little_p = SvPVX(little);
3215 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3218 sv_recode_to_utf8(temp, PL_encoding);
3220 sv_utf8_upgrade(temp);
3225 big_p = SvPV_const(big, biglen);
3228 little_p = SvPV_const(little, llen);
3232 if (SvGAMAGIC(big)) {
3233 /* Life just becomes a lot easier if I use a temporary here.
3234 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3235 will trigger magic and overloading again, as will fbm_instr()
3237 big = newSVpvn_flags(big_p, biglen,
3238 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3241 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3242 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3243 warn on undef, and we've already triggered a warning with the
3244 SvPV_const some lines above. We can't remove that, as we need to
3245 call some SvPV to trigger overloading early and find out if the
3247 This is all getting to messy. The API isn't quite clean enough,
3248 because data access has side effects.
3250 little = newSVpvn_flags(little_p, llen,
3251 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3252 little_p = SvPVX(little);
3256 offset = is_index ? 0 : biglen;
3258 if (big_utf8 && offset > 0)
3259 sv_pos_u2b(big, &offset, 0);
3265 else if (offset > (I32)biglen)
3267 if (!(little_p = is_index
3268 ? fbm_instr((unsigned char*)big_p + offset,
3269 (unsigned char*)big_p + biglen, little, 0)
3270 : rninstr(big_p, big_p + offset,
3271 little_p, little_p + llen)))
3274 retval = little_p - big_p;
3275 if (retval > 0 && big_utf8)
3276 sv_pos_b2u(big, &retval);
3286 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3287 SvTAINTED_off(TARG);
3288 do_sprintf(TARG, SP-MARK, MARK+1);
3289 TAINT_IF(SvTAINTED(TARG));
3301 const U8 *s = (U8*)SvPV_const(argsv, len);
3303 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3304 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3305 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3309 XPUSHu(DO_UTF8(argsv) ?
3310 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3322 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3324 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3326 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3328 (void) POPs; /* Ignore the argument value. */
3329 value = UNICODE_REPLACEMENT;
3335 SvUPGRADE(TARG,SVt_PV);
3337 if (value > 255 && !IN_BYTES) {
3338 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3339 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3340 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3342 (void)SvPOK_only(TARG);
3351 *tmps++ = (char)value;
3353 (void)SvPOK_only(TARG);
3355 if (PL_encoding && !IN_BYTES) {
3356 sv_recode_to_utf8(TARG, PL_encoding);
3358 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3359 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3363 *tmps++ = (char)value;
3379 const char *tmps = SvPV_const(left, len);
3381 if (DO_UTF8(left)) {
3382 /* If Unicode, try to downgrade.
3383 * If not possible, croak.
3384 * Yes, we made this up. */
3385 SV* const tsv = sv_2mortal(newSVsv(left));
3388 sv_utf8_downgrade(tsv, FALSE);
3389 tmps = SvPV_const(tsv, len);
3391 # ifdef USE_ITHREADS
3393 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3394 /* This should be threadsafe because in ithreads there is only
3395 * one thread per interpreter. If this would not be true,
3396 * we would need a mutex to protect this malloc. */
3397 PL_reentrant_buffer->_crypt_struct_buffer =
3398 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3399 #if defined(__GLIBC__) || defined(__EMX__)
3400 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3401 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3402 /* work around glibc-2.2.5 bug */
3403 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3407 # endif /* HAS_CRYPT_R */
3408 # endif /* USE_ITHREADS */
3410 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3412 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3418 "The crypt() function is unimplemented due to excessive paranoia.");
3422 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3423 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3425 /* Below are several macros that generate code */
3426 /* Generates code to store a unicode codepoint c that is known to occupy
3427 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3428 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3430 *(p) = UTF8_TWO_BYTE_HI(c); \
3431 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3434 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3435 * available byte after the two bytes */
3436 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3438 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3439 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3442 /* Generates code to store the upper case of latin1 character l which is known
3443 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3444 * are only two characters that fit this description, and this macro knows
3445 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3447 #define STORE_NON_LATIN1_UC(p, l) \
3449 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3450 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3451 } else { /* Must be the following letter */ \
3452 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3456 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3457 * after the character stored */
3458 #define CAT_NON_LATIN1_UC(p, l) \
3460 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3461 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3463 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3467 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3468 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3469 * and must require two bytes to store it. Advances p to point to the next
3470 * available position */
3471 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3473 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3474 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3475 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3476 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3477 } else {/* else is one of the other two special cases */ \
3478 CAT_NON_LATIN1_UC((p), (l)); \
3484 /* Actually is both lcfirst() and ucfirst(). Only the first character
3485 * changes. This means that possibly we can change in-place, ie., just
3486 * take the source and change that one character and store it back, but not
3487 * if read-only etc, or if the length changes */
3492 STRLEN slen; /* slen is the byte length of the whole SV. */
3495 bool inplace; /* ? Convert first char only, in-place */
3496 bool doing_utf8 = FALSE; /* ? using utf8 */
3497 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3498 const int op_type = PL_op->op_type;
3501 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3502 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3503 * stored as UTF-8 at s. */
3504 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3505 * lowercased) character stored in tmpbuf. May be either
3506 * UTF-8 or not, but in either case is the number of bytes */
3510 s = (const U8*)SvPV_nomg_const(source, slen);
3512 if (ckWARN(WARN_UNINITIALIZED))
3513 report_uninit(source);
3518 /* We may be able to get away with changing only the first character, in
3519 * place, but not if read-only, etc. Later we may discover more reasons to
3520 * not convert in-place. */
3521 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3523 /* First calculate what the changed first character should be. This affects
3524 * whether we can just swap it out, leaving the rest of the string unchanged,
3525 * or even if have to convert the dest to UTF-8 when the source isn't */
3527 if (! slen) { /* If empty */
3528 need = 1; /* still need a trailing NUL */
3530 else if (DO_UTF8(source)) { /* Is the source utf8? */
3533 if (UTF8_IS_INVARIANT(*s)) {
3535 /* An invariant source character is either ASCII or, in EBCDIC, an
3536 * ASCII equivalent or a caseless C1 control. In both these cases,
3537 * the lower and upper cases of any character are also invariants
3538 * (and title case is the same as upper case). So it is safe to
3539 * use the simple case change macros which avoid the overhead of
3540 * the general functions. Note that if perl were to be extended to
3541 * do locale handling in UTF-8 strings, this wouldn't be true in,
3542 * for example, Lithuanian or Turkic. */
3543 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3547 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3550 /* Similarly, if the source character isn't invariant but is in the
3551 * latin1 range (or EBCDIC equivalent thereof), we have the case
3552 * changes compiled into perl, and can avoid the overhead of the
3553 * general functions. In this range, the characters are stored as
3554 * two UTF-8 bytes, and it so happens that any changed-case version
3555 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3559 /* Convert the two source bytes to a single Unicode code point
3560 * value, change case and save for below */
3561 chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3562 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3563 U8 lower = toLOWER_LATIN1(chr);
3564 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3566 else { /* ucfirst */
3567 U8 upper = toUPPER_LATIN1_MOD(chr);
3569 /* Most of the latin1 range characters are well-behaved. Their
3570 * title and upper cases are the same, and are also in the
3571 * latin1 range. The macro above returns their upper (hence
3572 * title) case, and all that need be done is to save the result
3573 * for below. However, several characters are problematic, and
3574 * have to be handled specially. The MOD in the macro name
3575 * above means that these tricky characters all get mapped to
3576 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3577 * This mapping saves some tests for the majority of the
3580 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3582 /* Not tricky. Just save it. */
3583 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3585 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3587 /* This one is tricky because it is two characters long,
3588 * though the UTF-8 is still two bytes, so the stored
3589 * length doesn't change */
3590 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3591 *(tmpbuf + 1) = 's';
3595 /* The other two have their title and upper cases the same,
3596 * but are tricky because the changed-case characters
3597 * aren't in the latin1 range. They, however, do fit into
3598 * two UTF-8 bytes */
3599 STORE_NON_LATIN1_UC(tmpbuf, chr);
3605 /* Here, can't short-cut the general case */
3607 utf8_to_uvchr(s, &ulen);
3608 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3609 else toLOWER_utf8(s, tmpbuf, &tculen);
3611 /* we can't do in-place if the length changes. */
3612 if (ulen != tculen) inplace = FALSE;
3613 need = slen + 1 - ulen + tculen;
3616 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3617 * latin1 is treated as caseless. Note that a locale takes
3619 tculen = 1; /* Most characters will require one byte, but this will
3620 * need to be overridden for the tricky ones */
3623 if (op_type == OP_LCFIRST) {
3625 /* lower case the first letter: no trickiness for any character */
3626 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3627 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3630 else if (IN_LOCALE_RUNTIME) {
3631 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3632 * have upper and title case different
3635 else if (! IN_UNI_8_BIT) {
3636 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3637 * on EBCDIC machines whatever the
3638 * native function does */
3640 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3641 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3643 /* tmpbuf now has the correct title case for all latin1 characters
3644 * except for the several ones that have tricky handling. All
3645 * of these are mapped by the MOD to the letter below. */
3646 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3648 /* The length is going to change, with all three of these, so
3649 * can't replace just the first character */
3652 /* We use the original to distinguish between these tricky
3654 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3655 /* Two character title case 'Ss', but can remain non-UTF-8 */
3658 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3663 /* The other two tricky ones have their title case outside
3664 * latin1. It is the same as their upper case. */
3666 STORE_NON_LATIN1_UC(tmpbuf, *s);
3668 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3669 * and their upper cases is 2. */
3672 /* The entire result will have to be in UTF-8. Assume worst
3673 * case sizing in conversion. (all latin1 characters occupy
3674 * at most two bytes in utf8) */
3675 convert_source_to_utf8 = TRUE;
3676 need = slen * 2 + 1;
3678 } /* End of is one of the three special chars */
3679 } /* End of use Unicode (Latin1) semantics */
3680 } /* End of changing the case of the first character */
3682 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3683 * generate the result */
3686 /* We can convert in place. This means we change just the first
3687 * character without disturbing the rest; no need to grow */
3689 s = d = (U8*)SvPV_force_nomg(source, slen);
3695 /* Here, we can't convert in place; we earlier calculated how much
3696 * space we will need, so grow to accommodate that */
3697 SvUPGRADE(dest, SVt_PV);
3698 d = (U8*)SvGROW(dest, need);
3699 (void)SvPOK_only(dest);
3706 if (! convert_source_to_utf8) {
3708 /* Here both source and dest are in UTF-8, but have to create
3709 * the entire output. We initialize the result to be the
3710 * title/lower cased first character, and then append the rest
3712 sv_setpvn(dest, (char*)tmpbuf, tculen);
3714 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3718 const U8 *const send = s + slen;
3720 /* Here the dest needs to be in UTF-8, but the source isn't,
3721 * except we earlier UTF-8'd the first character of the source
3722 * into tmpbuf. First put that into dest, and then append the
3723 * rest of the source, converting it to UTF-8 as we go. */
3725 /* Assert tculen is 2 here because the only two characters that
3726 * get to this part of the code have 2-byte UTF-8 equivalents */
3728 *d++ = *(tmpbuf + 1);
3729 s++; /* We have just processed the 1st char */
3731 for (; s < send; s++) {
3732 d = uvchr_to_utf8(d, *s);
3735 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3739 else { /* in-place UTF-8. Just overwrite the first character */
3740 Copy(tmpbuf, d, tculen, U8);
3741 SvCUR_set(dest, need - 1);
3744 else { /* Neither source nor dest are in or need to be UTF-8 */
3746 if (IN_LOCALE_RUNTIME) {
3750 if (inplace) { /* in-place, only need to change the 1st char */
3753 else { /* Not in-place */
3755 /* Copy the case-changed character(s) from tmpbuf */
3756 Copy(tmpbuf, d, tculen, U8);
3757 d += tculen - 1; /* Code below expects d to point to final
3758 * character stored */
3761 else { /* empty source */
3762 /* See bug #39028: Don't taint if empty */
3766 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3767 * the destination to retain that flag */
3771 if (!inplace) { /* Finish the rest of the string, unchanged */
3772 /* This will copy the trailing NUL */
3773 Copy(s + 1, d + 1, slen, U8);
3774 SvCUR_set(dest, need - 1);
3777 if (dest != source && SvTAINTED(source))
3783 /* There's so much setup/teardown code common between uc and lc, I wonder if
3784 it would be worth merging the two, and just having a switch outside each
3785 of the three tight loops. There is less and less commonality though */
3799 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3800 && SvTEMP(source) && !DO_UTF8(source)
3801 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3803 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3804 * make the loop tight, so we overwrite the source with the dest before
3805 * looking at it, and we need to look at the original source
3806 * afterwards. There would also need to be code added to handle
3807 * switching to not in-place in midstream if we run into characters
3808 * that change the length.
3811 s = d = (U8*)SvPV_force_nomg(source, len);
3818 /* The old implementation would copy source into TARG at this point.
3819 This had the side effect that if source was undef, TARG was now
3820 an undefined SV with PADTMP set, and they don't warn inside
3821 sv_2pv_flags(). However, we're now getting the PV direct from
3822 source, which doesn't have PADTMP set, so it would warn. Hence the
3826 s = (const U8*)SvPV_nomg_const(source, len);
3828 if (ckWARN(WARN_UNINITIALIZED))
3829 report_uninit(source);
3835 SvUPGRADE(dest, SVt_PV);
3836 d = (U8*)SvGROW(dest, min);
3837 (void)SvPOK_only(dest);
3842 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3843 to check DO_UTF8 again here. */
3845 if (DO_UTF8(source)) {
3846 const U8 *const send = s + len;
3847 U8 tmpbuf[UTF8_MAXBYTES+1];
3849 /* All occurrences of these are to be moved to follow any other marks.
3850 * This is context-dependent. We may not be passed enough context to
3851 * move the iota subscript beyond all of them, but we do the best we can
3852 * with what we're given. The result is always better than if we
3853 * hadn't done this. And, the problem would only arise if we are
3854 * passed a character without all its combining marks, which would be
3855 * the caller's mistake. The information this is based on comes from a
3856 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3857 * itself) and so can't be checked properly to see if it ever gets
3858 * revised. But the likelihood of it changing is remote */
3859 bool in_iota_subscript = FALSE;
3862 if (in_iota_subscript && ! is_utf8_mark(s)) {
3863 /* A non-mark. Time to output the iota subscript */
3864 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3865 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3867 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3868 in_iota_subscript = FALSE;
3871 /* If the UTF-8 character is invariant, then it is in the range
3872 * known by the standard macro; result is only one byte long */
3873 if (UTF8_IS_INVARIANT(*s)) {
3877 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3879 /* Likewise, if it fits in a byte, its case change is in our
3881 U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3882 U8 upper = toUPPER_LATIN1_MOD(orig);
3883 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
3888 /* Otherwise, need the general UTF-8 case. Get the changed
3889 * case value and copy it to the output buffer */
3891 const STRLEN u = UTF8SKIP(s);
3894 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
3895 if (uv == GREEK_CAPITAL_LETTER_IOTA
3896 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3898 in_iota_subscript = TRUE;
3901 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3902 /* If the eventually required minimum size outgrows
3903 * the available space, we need to grow. */
3904 const UV o = d - (U8*)SvPVX_const(dest);
3906 /* If someone uppercases one million U+03B0s we
3907 * SvGROW() one million times. Or we could try
3908 * guessing how much to allocate without allocating too
3909 * much. Such is life. See corresponding comment in
3910 * lc code for another option */
3912 d = (U8*)SvPVX(dest) + o;
3914 Copy(tmpbuf, d, ulen, U8);
3920 if (in_iota_subscript) {
3921 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3925 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3927 else { /* Not UTF-8 */
3929 const U8 *const send = s + len;
3931 /* Use locale casing if in locale; regular style if not treating
3932 * latin1 as having case; otherwise the latin1 casing. Do the
3933 * whole thing in a tight loop, for speed, */
3934 if (IN_LOCALE_RUNTIME) {
3937 for (; s < send; d++, s++)
3938 *d = toUPPER_LC(*s);
3940 else if (! IN_UNI_8_BIT) {
3941 for (; s < send; d++, s++) {
3946 for (; s < send; d++, s++) {
3947 *d = toUPPER_LATIN1_MOD(*s);
3948 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
3950 /* The mainstream case is the tight loop above. To avoid
3951 * extra tests in that, all three characters that require
3952 * special handling are mapped by the MOD to the one tested
3954 * Use the source to distinguish between the three cases */
3956 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3958 /* uc() of this requires 2 characters, but they are
3959 * ASCII. If not enough room, grow the string */
3960 if (SvLEN(dest) < ++min) {
3961 const UV o = d - (U8*)SvPVX_const(dest);
3963 d = (U8*)SvPVX(dest) + o;
3965 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3966 continue; /* Back to the tight loop; still in ASCII */
3969 /* The other two special handling characters have their
3970 * upper cases outside the latin1 range, hence need to be
3971 * in UTF-8, so the whole result needs to be in UTF-8. So,
3972 * here we are somewhere in the middle of processing a
3973 * non-UTF-8 string, and realize that we will have to convert
3974 * the whole thing to UTF-8. What to do? There are
3975 * several possibilities. The simplest to code is to
3976 * convert what we have so far, set a flag, and continue on
3977 * in the loop. The flag would be tested each time through
3978 * the loop, and if set, the next character would be
3979 * converted to UTF-8 and stored. But, I (khw) didn't want
3980 * to slow down the mainstream case at all for this fairly
3981 * rare case, so I didn't want to add a test that didn't
3982 * absolutely have to be there in the loop, besides the
3983 * possibility that it would get too complicated for
3984 * optimizers to deal with. Another possibility is to just
3985 * give up, convert the source to UTF-8, and restart the
3986 * function that way. Another possibility is to convert
3987 * both what has already been processed and what is yet to
3988 * come separately to UTF-8, then jump into the loop that
3989 * handles UTF-8. But the most efficient time-wise of the
3990 * ones I could think of is what follows, and turned out to
3991 * not require much extra code. */
3993 /* Convert what we have so far into UTF-8, telling the
3994 * function that we know it should be converted, and to
3995 * allow extra space for what we haven't processed yet.
3996 * Assume the worst case space requirements for converting
3997 * what we haven't processed so far: that it will require
3998 * two bytes for each remaining source character, plus the
3999 * NUL at the end. This may cause the string pointer to
4000 * move, so re-find it. */
4002 len = d - (U8*)SvPVX_const(dest);
4003 SvCUR_set(dest, len);
4004 len = sv_utf8_upgrade_flags_grow(dest,
4005 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4007 d = (U8*)SvPVX(dest) + len;
4009 /* And append the current character's upper case in UTF-8 */
4010 CAT_NON_LATIN1_UC(d, *s);
4012 /* Now process the remainder of the source, converting to
4013 * upper and UTF-8. If a resulting byte is invariant in
4014 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4015 * append it to the output. */
4018 for (; s < send; s++) {
4019 U8 upper = toUPPER_LATIN1_MOD(*s);
4020 if UTF8_IS_INVARIANT(upper) {
4024 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4028 /* Here have processed the whole source; no need to continue
4029 * with the outer loop. Each character has been converted
4030 * to upper case and converted to UTF-8 */
4033 } /* End of processing all latin1-style chars */
4034 } /* End of processing all chars */
4035 } /* End of source is not empty */
4037 if (source != dest) {
4038 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4039 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4041 } /* End of isn't utf8 */
4042 if (dest != source && SvTAINTED(source))
4061 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4062 && SvTEMP(source) && !DO_UTF8(source)) {
4064 /* We can convert in place, as lowercasing anything in the latin1 range
4065 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4067 s = d = (U8*)SvPV_force_nomg(source, len);
4074 /* The old implementation would copy source into TARG at this point.
4075 This had the side effect that if source was undef, TARG was now
4076 an undefined SV with PADTMP set, and they don't warn inside
4077 sv_2pv_flags(). However, we're now getting the PV direct from
4078 source, which doesn't have PADTMP set, so it would warn. Hence the
4082 s = (const U8*)SvPV_nomg_const(source, len);
4084 if (ckWARN(WARN_UNINITIALIZED))
4085 report_uninit(source);
4091 SvUPGRADE(dest, SVt_PV);
4092 d = (U8*)SvGROW(dest, min);
4093 (void)SvPOK_only(dest);
4098 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4099 to check DO_UTF8 again here. */
4101 if (DO_UTF8(source)) {
4102 const U8 *const send = s + len;
4103 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4106 if (UTF8_IS_INVARIANT(*s)) {
4108 /* Invariant characters use the standard mappings compiled in.
4113 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4115 /* As do the ones in the Latin1 range */
4116 U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1)));
4117 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4121 /* Here, is utf8 not in Latin-1 range, have to go out and get
4122 * the mappings from the tables. */
4124 const STRLEN u = UTF8SKIP(s);
4127 #ifndef CONTEXT_DEPENDENT_CASING
4128 toLOWER_utf8(s, tmpbuf, &ulen);
4130 /* This is ifdefd out because it probably is the wrong thing to do. The right
4131 * thing is probably to have an I/O layer that converts final sigma to regular
4132 * on input and vice versa (under the correct circumstances) on output. In
4133 * effect, the final sigma is just a glyph variation when the regular one
4134 * occurs at the end of a word. And we don't really know what's going to be
4135 * the end of the word until it is finally output, as splitting and joining can
4136 * occur at any time and change what once was the word end to be in the middle,
4137 * and vice versa. */
4139 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4141 /* If the lower case is a small sigma, it may be that we need
4142 * to change it to a final sigma. This happens at the end of
4143 * a word that contains more than just this character, and only
4144 * when we started with a capital sigma. */
4145 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4146 s > send - len && /* Makes sure not the first letter */
4147 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4150 /* We use the algorithm in:
4151 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4152 * is a CAPITAL SIGMA): If C is preceded by a sequence
4153 * consisting of a cased letter and a case-ignorable
4154 * sequence, and C is not followed by a sequence consisting
4155 * of a case ignorable sequence and then a cased letter,
4156 * then when lowercasing C, C becomes a final sigma */
4158 /* To determine if this is the end of a word, need to peek
4159 * ahead. Look at the next character */
4160 const U8 *peek = s + u;
4162 /* Skip any case ignorable characters */
4163 while (peek < send && is_utf8_case_ignorable(peek)) {
4164 peek += UTF8SKIP(peek);
4167 /* If we reached the end of the string without finding any
4168 * non-case ignorable characters, or if the next such one
4169 * is not-cased, then we have met the conditions for it
4170 * being a final sigma with regards to peek ahead, and so
4171 * must do peek behind for the remaining conditions. (We
4172 * know there is stuff behind to look at since we tested
4173 * above that this isn't the first letter) */
4174 if (peek >= send || ! is_utf8_cased(peek)) {
4175 peek = utf8_hop(s, -1);
4177 /* Here are at the beginning of the first character
4178 * before the original upper case sigma. Keep backing
4179 * up, skipping any case ignorable characters */
4180 while (is_utf8_case_ignorable(peek)) {
4181 peek = utf8_hop(peek, -1);
4184 /* Here peek points to the first byte of the closest
4185 * non-case-ignorable character before the capital
4186 * sigma. If it is cased, then by the Unicode
4187 * algorithm, we should use a small final sigma instead
4188 * of what we have */
4189 if (is_utf8_cased(peek)) {
4190 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4191 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4195 else { /* Not a context sensitive mapping */
4196 #endif /* End of commented out context sensitive */
4197 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4199 /* If the eventually required minimum size outgrows
4200 * the available space, we need to grow. */
4201 const UV o = d - (U8*)SvPVX_const(dest);
4203 /* If someone lowercases one million U+0130s we
4204 * SvGROW() one million times. Or we could try
4205 * guessing how much to allocate without allocating too
4206 * much. Such is life. Another option would be to
4207 * grow an extra byte or two more each time we need to
4208 * grow, which would cut down the million to 500K, with
4211 d = (U8*)SvPVX(dest) + o;
4213 #ifdef CONTEXT_DEPENDENT_CASING
4216 /* Copy the newly lowercased letter to the output buffer we're
4218 Copy(tmpbuf, d, ulen, U8);
4222 } /* End of looping through the source string */
4225 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4226 } else { /* Not utf8 */
4228 const U8 *const send = s + len;
4230 /* Use locale casing if in locale; regular style if not treating
4231 * latin1 as having case; otherwise the latin1 casing. Do the
4232 * whole thing in a tight loop, for speed, */
4233 if (IN_LOCALE_RUNTIME) {
4236 for (; s < send; d++, s++)
4237 *d = toLOWER_LC(*s);
4239 else if (! IN_UNI_8_BIT) {
4240 for (; s < send; d++, s++) {
4245 for (; s < send; d++, s++) {
4246 *d = toLOWER_LATIN1(*s);
4250 if (source != dest) {
4252 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4255 if (dest != source && SvTAINTED(source))
4264 SV * const sv = TOPs;
4266 register const char *s = SvPV_const(sv,len);
4268 SvUTF8_off(TARG); /* decontaminate */
4271 SvUPGRADE(TARG, SVt_PV);
4272 SvGROW(TARG, (len * 2) + 1);
4276 if (UTF8_IS_CONTINUED(*s)) {
4277 STRLEN ulen = UTF8SKIP(s);
4301 SvCUR_set(TARG, d - SvPVX_const(TARG));
4302 (void)SvPOK_only_UTF8(TARG);
4305 sv_setpvn(TARG, s, len);
4314 dVAR; dSP; dMARK; dORIGMARK;
4315 register AV *const av = MUTABLE_AV(POPs);
4316 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4318 if (SvTYPE(av) == SVt_PVAV) {
4319 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4320 bool can_preserve = FALSE;
4326 can_preserve = SvCANEXISTDELETE(av);
4329 if (lval && localizing) {
4332 for (svp = MARK + 1; svp <= SP; svp++) {
4333 const I32 elem = SvIV(*svp);
4337 if (max > AvMAX(av))
4341 while (++MARK <= SP) {
4343 I32 elem = SvIV(*MARK);
4344 bool preeminent = TRUE;
4346 if (localizing && can_preserve) {
4347 /* If we can determine whether the element exist,
4348 * Try to preserve the existenceness of a tied array
4349 * element by using EXISTS and DELETE if possible.
4350 * Fallback to FETCH and STORE otherwise. */
4351 preeminent = av_exists(av, elem);
4354 svp = av_fetch(av, elem, lval);
4356 if (!svp || *svp == &PL_sv_undef)
4357 DIE(aTHX_ PL_no_aelem, elem);
4360 save_aelem(av, elem, svp);
4362 SAVEADELETE(av, elem);
4365 *MARK = svp ? *svp : &PL_sv_undef;
4368 if (GIMME != G_ARRAY) {
4370 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4376 /* Smart dereferencing for keys, values and each */
4388 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4393 "Type of argument to %s must be unblessed hashref or arrayref",
4394 PL_op_desc[PL_op->op_type] );
4397 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4399 "Can't modify %s in %s",
4400 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4403 /* Delegate to correct function for op type */
4405 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4406 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4409 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4417 AV *array = MUTABLE_AV(POPs);
4418 const I32 gimme = GIMME_V;
4419 IV *iterp = Perl_av_iter_p(aTHX_ array);
4420 const IV current = (*iterp)++;
4422 if (current > av_len(array)) {
4424 if (gimme == G_SCALAR)
4432 if (gimme == G_ARRAY) {
4433 SV **const element = av_fetch(array, current, 0);
4434 PUSHs(element ? *element : &PL_sv_undef);
4443 AV *array = MUTABLE_AV(POPs);
4444 const I32 gimme = GIMME_V;
4446 *Perl_av_iter_p(aTHX_ array) = 0;
4448 if (gimme == G_SCALAR) {
4450 PUSHi(av_len(array) + 1);
4452 else if (gimme == G_ARRAY) {
4453 IV n = Perl_av_len(aTHX_ array);
4458 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4459 for (i = 0; i <= n; i++) {
4464 for (i = 0; i <= n; i++) {
4465 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4466 PUSHs(elem ? *elem : &PL_sv_undef);
4473 /* Associative arrays. */
4479 HV * hash = MUTABLE_HV(POPs);
4481 const I32 gimme = GIMME_V;
4484 /* might clobber stack_sp */
4485 entry = hv_iternext(hash);
4490 SV* const sv = hv_iterkeysv(entry);
4491 PUSHs(sv); /* won't clobber stack_sp */
4492 if (gimme == G_ARRAY) {
4495 /* might clobber stack_sp */
4496 val = hv_iterval(hash, entry);
4501 else if (gimme == G_SCALAR)
4508 S_do_delete_local(pTHX)
4512 const I32 gimme = GIMME_V;
4516 if (PL_op->op_private & OPpSLICE) {
4518 SV * const osv = POPs;
4519 const bool tied = SvRMAGICAL(osv)
4520 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4521 const bool can_preserve = SvCANEXISTDELETE(osv)
4522 || mg_find((const SV *)osv, PERL_MAGIC_env);
4523 const U32 type = SvTYPE(osv);
4524 if (type == SVt_PVHV) { /* hash element */
4525 HV * const hv = MUTABLE_HV(osv);
4526 while (++MARK <= SP) {
4527 SV * const keysv = *MARK;
4529 bool preeminent = TRUE;
4531 preeminent = hv_exists_ent(hv, keysv, 0);
4533 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4540 sv = hv_delete_ent(hv, keysv, 0, 0);
4541 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4544 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4546 *MARK = sv_mortalcopy(sv);
4552 SAVEHDELETE(hv, keysv);
4553 *MARK = &PL_sv_undef;
4557 else if (type == SVt_PVAV) { /* array element */
4558 if (PL_op->op_flags & OPf_SPECIAL) {
4559 AV * const av = MUTABLE_AV(osv);
4560 while (++MARK <= SP) {
4561 I32 idx = SvIV(*MARK);
4563 bool preeminent = TRUE;
4565 preeminent = av_exists(av, idx);
4567 SV **svp = av_fetch(av, idx, 1);
4574 sv = av_delete(av, idx, 0);
4575 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4578 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4580 *MARK = sv_mortalcopy(sv);
4586 SAVEADELETE(av, idx);
4587 *MARK = &PL_sv_undef;
4593 DIE(aTHX_ "Not a HASH reference");
4594 if (gimme == G_VOID)
4596 else if (gimme == G_SCALAR) {
4601 *++MARK = &PL_sv_undef;
4606 SV * const keysv = POPs;
4607 SV * const osv = POPs;
4608 const bool tied = SvRMAGICAL(osv)
4609 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4610 const bool can_preserve = SvCANEXISTDELETE(osv)
4611 || mg_find((const SV *)osv, PERL_MAGIC_env);
4612 const U32 type = SvTYPE(osv);
4614 if (type == SVt_PVHV) {
4615 HV * const hv = MUTABLE_HV(osv);
4616 bool preeminent = TRUE;
4618 preeminent = hv_exists_ent(hv, keysv, 0);
4620 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4627 sv = hv_delete_ent(hv, keysv, 0, 0);
4628 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4631 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4633 SV *nsv = sv_mortalcopy(sv);
4639 SAVEHDELETE(hv, keysv);
4641 else if (type == SVt_PVAV) {
4642 if (PL_op->op_flags & OPf_SPECIAL) {
4643 AV * const av = MUTABLE_AV(osv);
4644 I32 idx = SvIV(keysv);
4645 bool preeminent = TRUE;
4647 preeminent = av_exists(av, idx);
4649 SV **svp = av_fetch(av, idx, 1);
4656 sv = av_delete(av, idx, 0);
4657 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4660 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4662 SV *nsv = sv_mortalcopy(sv);
4668 SAVEADELETE(av, idx);
4671 DIE(aTHX_ "panic: avhv_delete no longer supported");
4674 DIE(aTHX_ "Not a HASH reference");
4677 if (gimme != G_VOID)
4691 if (PL_op->op_private & OPpLVAL_INTRO)
4692 return do_delete_local();
4695 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4697 if (PL_op->op_private & OPpSLICE) {
4699 HV * const hv = MUTABLE_HV(POPs);
4700 const U32 hvtype = SvTYPE(hv);
4701 if (hvtype == SVt_PVHV) { /* hash element */
4702 while (++MARK <= SP) {
4703 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4704 *MARK = sv ? sv : &PL_sv_undef;
4707 else if (hvtype == SVt_PVAV) { /* array element */
4708 if (PL_op->op_flags & OPf_SPECIAL) {
4709 while (++MARK <= SP) {
4710 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4711 *MARK = sv ? sv : &PL_sv_undef;
4716 DIE(aTHX_ "Not a HASH reference");
4719 else if (gimme == G_SCALAR) {
4724 *++MARK = &PL_sv_undef;
4730 HV * const hv = MUTABLE_HV(POPs);
4732 if (SvTYPE(hv) == SVt_PVHV)
4733 sv = hv_delete_ent(hv, keysv, discard, 0);
4734 else if (SvTYPE(hv) == SVt_PVAV) {
4735 if (PL_op->op_flags & OPf_SPECIAL)
4736 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4738 DIE(aTHX_ "panic: avhv_delete no longer supported");
4741 DIE(aTHX_ "Not a HASH reference");
4757 if (PL_op->op_private & OPpEXISTS_SUB) {
4759 SV * const sv = POPs;
4760 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4763 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4768 hv = MUTABLE_HV(POPs);
4769 if (SvTYPE(hv) == SVt_PVHV) {
4770 if (hv_exists_ent(hv, tmpsv, 0))
4773 else if (SvTYPE(hv) == SVt_PVAV) {
4774 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4775 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4780 DIE(aTHX_ "Not a HASH reference");
4787 dVAR; dSP; dMARK; dORIGMARK;
4788 register HV * const hv = MUTABLE_HV(POPs);
4789 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4790 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4791 bool can_preserve = FALSE;
4797 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4798 can_preserve = TRUE;
4801 while (++MARK <= SP) {
4802 SV * const keysv = *MARK;
4805 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 hash
4810 * element by using EXISTS and DELETE if possible.
4811 * Fallback to FETCH and STORE otherwise. */
4812 preeminent = hv_exists_ent(hv, keysv, 0);
4815 he = hv_fetch_ent(hv, keysv, lval, 0);
4816 svp = he ? &HeVAL(he) : NULL;
4819 if (!svp || *svp == &PL_sv_undef) {
4820 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4823 if (HvNAME_get(hv) && isGV(*svp))
4824 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4825 else if (preeminent)
4826 save_helem_flags(hv, keysv, svp,
4827 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4829 SAVEHDELETE(hv, keysv);
4832 *MARK = svp ? *svp : &PL_sv_undef;
4834 if (GIMME != G_ARRAY) {
4836 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4842 /* List operators. */
4847 if (GIMME != G_ARRAY) {
4849 *MARK = *SP; /* unwanted list, return last item */
4851 *MARK = &PL_sv_undef;
4861 SV ** const lastrelem = PL_stack_sp;
4862 SV ** const lastlelem = PL_stack_base + POPMARK;
4863 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4864 register SV ** const firstrelem = lastlelem + 1;
4865 I32 is_something_there = FALSE;
4867 register const I32 max = lastrelem - lastlelem;
4868 register SV **lelem;
4870 if (GIMME != G_ARRAY) {
4871 I32 ix = SvIV(*lastlelem);
4874 if (ix < 0 || ix >= max)
4875 *firstlelem = &PL_sv_undef;
4877 *firstlelem = firstrelem[ix];
4883 SP = firstlelem - 1;
4887 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4888 I32 ix = SvIV(*lelem);
4891 if (ix < 0 || ix >= max)
4892 *lelem = &PL_sv_undef;
4894 is_something_there = TRUE;
4895 if (!(*lelem = firstrelem[ix]))
4896 *lelem = &PL_sv_undef;
4899 if (is_something_there)
4902 SP = firstlelem - 1;
4908 dVAR; dSP; dMARK; dORIGMARK;
4909 const I32 items = SP - MARK;
4910 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4911 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4912 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4913 ? newRV_noinc(av) : av);
4919 dVAR; dSP; dMARK; dORIGMARK;
4920 HV* const hv = newHV();
4923 SV * const key = *++MARK;
4924 SV * const val = newSV(0);
4926 sv_setsv(val, *++MARK);
4928 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4929 (void)hv_store_ent(hv,key,val,0);
4932 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4933 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4938 S_deref_plain_array(pTHX_ AV *ary)
4940 if (SvTYPE(ary) == SVt_PVAV) return ary;
4941 SvGETMAGIC((SV *)ary);
4942 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4943 Perl_die(aTHX_ "Not an ARRAY reference");
4944 else if (SvOBJECT(SvRV(ary)))
4945 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4946 return (AV *)SvRV(ary);
4949 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4950 # define DEREF_PLAIN_ARRAY(ary) \
4953 SvTYPE(aRrRay) == SVt_PVAV \
4955 : S_deref_plain_array(aTHX_ aRrRay); \
4958 # define DEREF_PLAIN_ARRAY(ary) \
4960 PL_Sv = (SV *)(ary), \
4961 SvTYPE(PL_Sv) == SVt_PVAV \
4963 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4969 dVAR; dSP; dMARK; dORIGMARK;
4970 int num_args = (SP - MARK);
4971 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4975 register I32 offset;
4976 register I32 length;
4980 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4983 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4984 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4991 offset = i = SvIV(*MARK);
4993 offset += AvFILLp(ary) + 1;
4995 DIE(aTHX_ PL_no_aelem, i);
4997 length = SvIVx(*MARK++);
4999 length += AvFILLp(ary) - offset + 1;
5005 length = AvMAX(ary) + 1; /* close enough to infinity */
5009 length = AvMAX(ary) + 1;
5011 if (offset > AvFILLp(ary) + 1) {
5013 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5014 offset = AvFILLp(ary) + 1;
5016 after = AvFILLp(ary) + 1 - (offset + length);
5017 if (after < 0) { /* not that much array */
5018 length += after; /* offset+length now in array */
5024 /* At this point, MARK .. SP-1 is our new LIST */
5027 diff = newlen - length;
5028 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5031 /* make new elements SVs now: avoid problems if they're from the array */
5032 for (dst = MARK, i = newlen; i; i--) {
5033 SV * const h = *dst;
5034 *dst++ = newSVsv(h);
5037 if (diff < 0) { /* shrinking the area */
5038 SV **tmparyval = NULL;
5040 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5041 Copy(MARK, tmparyval, newlen, SV*);
5044 MARK = ORIGMARK + 1;
5045 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5046 MEXTEND(MARK, length);
5047 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5049 EXTEND_MORTAL(length);
5050 for (i = length, dst = MARK; i; i--) {
5051 sv_2mortal(*dst); /* free them eventually */
5058 *MARK = AvARRAY(ary)[offset+length-1];
5061 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5062 SvREFCNT_dec(*dst++); /* free them now */
5065 AvFILLp(ary) += diff;
5067 /* pull up or down? */
5069 if (offset < after) { /* easier to pull up */
5070 if (offset) { /* esp. if nothing to pull */
5071 src = &AvARRAY(ary)[offset-1];
5072 dst = src - diff; /* diff is negative */
5073 for (i = offset; i > 0; i--) /* can't trust Copy */
5077 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5081 if (after) { /* anything to pull down? */
5082 src = AvARRAY(ary) + offset + length;
5083 dst = src + diff; /* diff is negative */
5084 Move(src, dst, after, SV*);
5086 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5087 /* avoid later double free */
5091 dst[--i] = &PL_sv_undef;
5094 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5095 Safefree(tmparyval);
5098 else { /* no, expanding (or same) */
5099 SV** tmparyval = NULL;
5101 Newx(tmparyval, length, SV*); /* so remember deletion */
5102 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5105 if (diff > 0) { /* expanding */
5106 /* push up or down? */
5107 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5111 Move(src, dst, offset, SV*);
5113 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5115 AvFILLp(ary) += diff;
5118 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5119 av_extend(ary, AvFILLp(ary) + diff);
5120 AvFILLp(ary) += diff;
5123 dst = AvARRAY(ary) + AvFILLp(ary);
5125 for (i = after; i; i--) {
5133 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5136 MARK = ORIGMARK + 1;
5137 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5139 Copy(tmparyval, MARK, length, SV*);
5141 EXTEND_MORTAL(length);
5142 for (i = length, dst = MARK; i; i--) {
5143 sv_2mortal(*dst); /* free them eventually */
5150 else if (length--) {
5151 *MARK = tmparyval[length];
5154 while (length-- > 0)
5155 SvREFCNT_dec(tmparyval[length]);
5159 *MARK = &PL_sv_undef;
5160 Safefree(tmparyval);
5164 mg_set(MUTABLE_SV(ary));
5172 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5173 register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5174 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5177 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5180 ENTER_with_name("call_PUSH");
5181 call_method("PUSH",G_SCALAR|G_DISCARD);
5182 LEAVE_with_name("call_PUSH");
5186 PL_delaymagic = DM_DELAY;
5187 for (++MARK; MARK <= SP; MARK++) {
5188 SV * const sv = newSV(0);
5190 sv_setsv(sv, *MARK);
5191 av_store(ary, AvFILLp(ary)+1, sv);
5193 if (PL_delaymagic & DM_ARRAY_ISA)
5194 mg_set(MUTABLE_SV(ary));
5199 if (OP_GIMME(PL_op, 0) != G_VOID) {
5200 PUSHi( AvFILL(ary) + 1 );
5209 AV * const av = PL_op->op_flags & OPf_SPECIAL
5210 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5211 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5215 (void)sv_2mortal(sv);
5222 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5223 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5224 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5227 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5230 ENTER_with_name("call_UNSHIFT");
5231 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5232 LEAVE_with_name("call_UNSHIFT");
5237 av_unshift(ary, SP - MARK);
5239 SV * const sv = newSVsv(*++MARK);
5240 (void)av_store(ary, i++, sv);
5244 if (OP_GIMME(PL_op, 0) != G_VOID) {
5245 PUSHi( AvFILL(ary) + 1 );
5254 if (GIMME == G_ARRAY) {
5255 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5259 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5260 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5261 av = MUTABLE_AV((*SP));
5262 /* In-place reversing only happens in void context for the array
5263 * assignment. We don't need to push anything on the stack. */
5266 if (SvMAGICAL(av)) {
5268 register SV *tmp = sv_newmortal();
5269 /* For SvCANEXISTDELETE */
5272 bool can_preserve = SvCANEXISTDELETE(av);
5274 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5275 register SV *begin, *end;
5278 if (!av_exists(av, i)) {
5279 if (av_exists(av, j)) {
5280 register SV *sv = av_delete(av, j, 0);
5281 begin = *av_fetch(av, i, TRUE);
5282 sv_setsv_mg(begin, sv);
5286 else if (!av_exists(av, j)) {
5287 register SV *sv = av_delete(av, i, 0);
5288 end = *av_fetch(av, j, TRUE);
5289 sv_setsv_mg(end, sv);
5294 begin = *av_fetch(av, i, TRUE);
5295 end = *av_fetch(av, j, TRUE);
5296 sv_setsv(tmp, begin);
5297 sv_setsv_mg(begin, end);
5298 sv_setsv_mg(end, tmp);
5302 SV **begin = AvARRAY(av);
5305 SV **end = begin + AvFILLp(av);
5307 while (begin < end) {
5308 register SV * const tmp = *begin;
5319 register SV * const tmp = *MARK;
5323 /* safe as long as stack cannot get extended in the above */
5329 register char *down;
5334 SvUTF8_off(TARG); /* decontaminate */
5336 do_join(TARG, &PL_sv_no, MARK, SP);
5338 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5339 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5340 report_uninit(TARG);
5343 up = SvPV_force(TARG, len);
5345 if (DO_UTF8(TARG)) { /* first reverse each character */
5346 U8* s = (U8*)SvPVX(TARG);
5347 const U8* send = (U8*)(s + len);
5349 if (UTF8_IS_INVARIANT(*s)) {
5354 if (!utf8_to_uvchr(s, 0))
5358 down = (char*)(s - 1);
5359 /* reverse this character */
5363 *down-- = (char)tmp;
5369 down = SvPVX(TARG) + len - 1;
5373 *down-- = (char)tmp;
5375 (void)SvPOK_only_UTF8(TARG);
5387 register IV limit = POPi; /* note, negative is forever */
5388 SV * const sv = POPs;
5390 register const char *s = SvPV_const(sv, len);
5391 const bool do_utf8 = DO_UTF8(sv);
5392 const char *strend = s + len;
5394 register REGEXP *rx;
5396 register const char *m;
5398 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5399 I32 maxiters = slen + 10;
5400 I32 trailing_empty = 0;
5402 const I32 origlimit = limit;
5405 const I32 gimme = GIMME_V;
5407 const I32 oldsave = PL_savestack_ix;
5408 U32 make_mortal = SVs_TEMP;
5413 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5418 DIE(aTHX_ "panic: pp_split");
5421 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5422 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5424 RX_MATCH_UTF8_set(rx, do_utf8);
5427 if (pm->op_pmreplrootu.op_pmtargetoff) {
5428 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5431 if (pm->op_pmreplrootu.op_pmtargetgv) {
5432 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5437 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5443 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5445 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5452 for (i = AvFILLp(ary); i >= 0; i--)
5453 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5455 /* temporarily switch stacks */
5456 SAVESWITCHSTACK(PL_curstack, ary);
5460 base = SP - PL_stack_base;
5462 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5464 while (*s == ' ' || is_utf8_space((U8*)s))
5467 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5468 while (isSPACE_LC(*s))
5476 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5480 gimme_scalar = gimme == G_SCALAR && !ary;
5483 limit = maxiters + 2;
5484 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5487 /* this one uses 'm' and is a negative test */
5489 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5490 const int t = UTF8SKIP(m);
5491 /* is_utf8_space returns FALSE for malform utf8 */
5498 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5499 while (m < strend && !isSPACE_LC(*m))
5502 while (m < strend && !isSPACE(*m))
5515 dstr = newSVpvn_flags(s, m-s,
5516 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5520 /* skip the whitespace found last */
5522 s = m + UTF8SKIP(m);
5526 /* this one uses 's' and is a positive test */
5528 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5531 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5532 while (s < strend && isSPACE_LC(*s))
5535 while (s < strend && isSPACE(*s))
5540 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5542 for (m = s; m < strend && *m != '\n'; m++)
5555 dstr = newSVpvn_flags(s, m-s,
5556 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5562 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5564 Pre-extend the stack, either the number of bytes or
5565 characters in the string or a limited amount, triggered by:
5567 my ($x, $y) = split //, $str;
5571 if (!gimme_scalar) {
5572 const U32 items = limit - 1;
5581 /* keep track of how many bytes we skip over */
5591 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5604 dstr = newSVpvn(s, 1);
5620 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5621 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5622 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5623 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5624 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5625 SV * const csv = CALLREG_INTUIT_STRING(rx);
5627 len = RX_MINLENRET(rx);
5628 if (len == 1 && !RX_UTF8(rx) && !tail) {
5629 const char c = *SvPV_nolen_const(csv);
5631 for (m = s; m < strend && *m != c; m++)
5642 dstr = newSVpvn_flags(s, m-s,
5643 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5646 /* The rx->minlen is in characters but we want to step
5647 * s ahead by bytes. */
5649 s = (char*)utf8_hop((U8*)m, len);
5651 s = m + len; /* Fake \n at the end */
5655 while (s < strend && --limit &&
5656 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5657 csv, multiline ? FBMrf_MULTILINE : 0)) )
5666 dstr = newSVpvn_flags(s, m-s,
5667 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5670 /* The rx->minlen is in characters but we want to step
5671 * s ahead by bytes. */
5673 s = (char*)utf8_hop((U8*)m, len);
5675 s = m + len; /* Fake \n at the end */
5680 maxiters += slen * RX_NPARENS(rx);
5681 while (s < strend && --limit)
5685 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5686 sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
5688 if (rex_return == 0)
5690 TAINT_IF(RX_MATCH_TAINTED(rx));
5691 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5694 orig = RX_SUBBEG(rx);
5696 strend = s + (strend - m);
5698 m = RX_OFFS(rx)[0].start + orig;
5707 dstr = newSVpvn_flags(s, m-s,
5708 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5711 if (RX_NPARENS(rx)) {
5713 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5714 s = RX_OFFS(rx)[i].start + orig;
5715 m = RX_OFFS(rx)[i].end + orig;
5717 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5718 parens that didn't match -- they should be set to
5719 undef, not the empty string */
5727 if (m >= orig && s >= orig) {
5728 dstr = newSVpvn_flags(s, m-s,
5729 (do_utf8 ? SVf_UTF8 : 0)
5733 dstr = &PL_sv_undef; /* undef, not "" */
5739 s = RX_OFFS(rx)[0].end + orig;
5743 if (!gimme_scalar) {
5744 iters = (SP - PL_stack_base) - base;
5746 if (iters > maxiters)
5747 DIE(aTHX_ "Split loop");
5749 /* keep field after final delim? */
5750 if (s < strend || (iters && origlimit)) {
5751 if (!gimme_scalar) {
5752 const STRLEN l = strend - s;
5753 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5758 else if (!origlimit) {
5760 iters -= trailing_empty;
5762 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5763 if (TOPs && !make_mortal)
5765 *SP-- = &PL_sv_undef;
5772 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5776 if (SvSMAGICAL(ary)) {
5778 mg_set(MUTABLE_SV(ary));
5781 if (gimme == G_ARRAY) {
5783 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5790 ENTER_with_name("call_PUSH");
5791 call_method("PUSH",G_SCALAR|G_DISCARD);
5792 LEAVE_with_name("call_PUSH");
5794 if (gimme == G_ARRAY) {
5796 /* EXTEND should not be needed - we just popped them */
5798 for (i=0; i < iters; i++) {
5799 SV **svp = av_fetch(ary, i, FALSE);
5800 PUSHs((svp) ? *svp : &PL_sv_undef);
5807 if (gimme == G_ARRAY)
5819 SV *const sv = PAD_SVl(PL_op->op_targ);
5821 if (SvPADSTALE(sv)) {
5824 RETURNOP(cLOGOP->op_other);
5826 RETURNOP(cLOGOP->op_next);
5836 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5837 || SvTYPE(retsv) == SVt_PVCV) {
5838 retsv = refto(retsv);
5845 PP(unimplemented_op)
5848 const Optype op_type = PL_op->op_type;
5849 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5850 with out of range op numbers - it only "special" cases op_custom.
5851 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5852 if we get here for a custom op then that means that the custom op didn't
5853 have an implementation. Given that OP_NAME() looks up the custom op
5854 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5855 registers &PL_unimplemented_op as the address of their custom op.
5856 NULL doesn't generate a useful error message. "custom" does. */
5857 const char *const name = op_type >= OP_max
5858 ? "[out of range]" : PL_op_name[PL_op->op_type];
5859 if(OP_IS_SOCKET(op_type))
5860 DIE(aTHX_ PL_no_sock_func, name);
5861 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5868 HV * const hv = (HV*)POPs;
5870 if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
5872 if (SvRMAGICAL(hv)) {
5873 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5875 XPUSHs(magic_scalarpack(hv, mg));
5880 XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
5884 /* For sorting out arguments passed to a &CORE:: subroutine */
5888 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5889 int defgv = PL_opargs[opnum] & OA_DEFGV, whicharg = 0;
5890 AV * const at_ = GvAV(PL_defgv);
5891 SV **svp = AvARRAY(at_);
5892 I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
5893 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5894 bool seen_question = 0;
5895 const char *err = NULL;
5896 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5898 /* Count how many args there are first, to get some idea how far to
5899 extend the stack. */
5901 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5903 if (oa & OA_OPTIONAL) seen_question = 1;
5904 if (!seen_question) minargs++;
5908 if(numargs < minargs) err = "Not enough";
5909 else if(numargs > maxargs) err = "Too many";
5911 /* diag_listed_as: Too many arguments for %s */
5913 "%s arguments for %s", err,
5914 opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
5917 /* Reset the stack pointer. Without this, we end up returning our own
5918 arguments in list context, in addition to the values we are supposed
5919 to return. nextstate usually does this on sub entry, but we need
5920 to run the next op with the caller’s hints, so we cannot have a
5922 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5924 if(!maxargs) RETURN;
5926 /* We do this here, rather than with a separate pushmark op, as it has
5927 to come in between two things this function does (stack reset and
5928 arg pushing). This seems the easiest way to do it. */
5931 (void)Perl_pp_pushmark(aTHX);
5934 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5935 PUTBACK; /* The code below can die in various places. */
5937 oa = PL_opargs[opnum] >> OASHIFT;
5938 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5942 if (!numargs && defgv && whicharg == minargs + 1) {
5943 PERL_SI * const oldsi = PL_curstackinfo;
5944 I32 const oldcxix = oldsi->si_cxix;
5946 if (oldcxix) oldsi->si_cxix--;
5947 else PL_curstackinfo = oldsi->si_prev;
5948 caller = find_runcv(NULL);
5949 PL_curstackinfo = oldsi;
5950 oldsi->si_cxix = oldcxix;
5951 PUSHs(find_rundefsv2(
5952 caller,cxstack[cxstack_ix].blk_oldcop->cop_seq
5955 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5959 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5964 if (!svp || !*svp || !SvROK(*svp)
5965 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5967 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5968 "Type of arg %d to &CORE::%s must be hash reference",
5969 whicharg, OP_DESC(PL_op->op_next)
5974 if (!numargs) PUSHs(NULL);
5975 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5976 /* no magic here, as the prototype will have added an extra
5977 refgen and we just want what was there before that */
5980 const bool constr = PL_op->op_private & whicharg;
5982 svp && *svp ? *svp : &PL_sv_undef,
5983 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5990 const bool wantscalar =
5991 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5992 if (!svp || !*svp || !SvROK(*svp)
5993 /* We have to permit globrefs even for the \$ proto, as
5994 *foo is indistinguishable from ${\*foo}, and the proto-
5995 type permits the latter. */
5996 || SvTYPE(SvRV(*svp)) > (
5997 wantscalar ? SVt_PVLV
5998 : opnum == OP_LOCK ? SVt_PVCV
6003 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6004 "Type of arg %d to &CORE::%s must be %s",
6005 whicharg, OP_DESC(PL_op->op_next),
6007 ? "scalar reference"
6009 ? "reference to one of [$@%&*]"
6010 : "reference to one of [$@%*]"
6016 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6026 * c-indentation-style: bsd
6028 * indent-tabs-mode: t
6031 * ex: set ts=8 sts=4 sw=4 noet: