3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
34 it, since pid_t is an integral type.
37 #ifdef NEED_GETPID_PROTO
38 extern Pid_t getpid (void);
42 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
43 * This switches them over to IEEE.
45 #if defined(LIBM_LIB_VERSION)
46 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
49 /* variations on pp_null */
55 if (GIMME_V == G_SCALAR)
66 assert(SvTYPE(TARG) == SVt_PVAV);
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 if (!(PL_op->op_private & OPpPAD_STATE))
69 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
71 if (PL_op->op_flags & OPf_REF) {
75 if (GIMME == G_SCALAR)
76 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
81 if (gimme == G_ARRAY) {
82 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
84 if (SvMAGICAL(TARG)) {
86 for (i=0; i < (U32)maxarg; i++) {
87 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
88 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
92 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
96 else if (gimme == G_SCALAR) {
97 SV* const sv = sv_newmortal();
98 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
110 assert(SvTYPE(TARG) == SVt_PVHV);
112 if (PL_op->op_private & OPpLVAL_INTRO)
113 if (!(PL_op->op_private & OPpPAD_STATE))
114 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
115 if (PL_op->op_flags & OPf_REF)
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
123 if (gimme == G_ARRAY) {
126 else if (gimme == G_SCALAR) {
127 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
135 static const char S_no_symref_sv[] =
136 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
145 tryAMAGICunDEREF(to_gv);
148 if (SvTYPE(sv) == SVt_PVIO) {
149 GV * const gv = MUTABLE_GV(sv_newmortal());
150 gv_init(gv, 0, "", 0, 0);
151 GvIOp(gv) = MUTABLE_IO(sv);
152 SvREFCNT_inc_void_NN(sv);
155 else if (!isGV_with_GP(sv))
156 DIE(aTHX_ "Not a GLOB reference");
159 if (!isGV_with_GP(sv)) {
160 if (!SvOK(sv) && sv != &PL_sv_undef) {
161 /* If this is a 'my' scalar and flag is set then vivify
165 Perl_croak(aTHX_ "%s", PL_no_modify);
166 if (PL_op->op_private & OPpDEREF) {
168 if (cUNOP->op_targ) {
170 SV * const namesv = PAD_SV(cUNOP->op_targ);
171 const char * const name = SvPV(namesv, len);
172 gv = MUTABLE_GV(newSV(0));
173 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
176 const char * const name = CopSTASHPV(PL_curcop);
179 prepare_SV_for_RV(sv);
180 SvRV_set(sv, MUTABLE_SV(gv));
185 if (PL_op->op_flags & OPf_REF ||
186 PL_op->op_private & HINT_STRICT_REFS)
187 DIE(aTHX_ PL_no_usym, "a symbol");
188 if (ckWARN(WARN_UNINITIALIZED))
192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
195 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
197 && (!is_gv_magical_sv(sv,0)
198 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
205 if (PL_op->op_private & HINT_STRICT_REFS)
206 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
207 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
208 == OPpDONT_INIT_GV) {
209 /* We are the target of a coderef assignment. Return
210 the scalar unchanged, and let pp_sasssign deal with
214 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
218 if (PL_op->op_private & OPpLVAL_INTRO)
219 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
224 /* Helper function for pp_rv2sv and pp_rv2av */
226 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
227 const svtype type, SV ***spp)
232 PERL_ARGS_ASSERT_SOFTREF2XV;
234 if (PL_op->op_private & HINT_STRICT_REFS) {
236 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
238 Perl_die(aTHX_ PL_no_usym, what);
241 if (PL_op->op_flags & OPf_REF)
242 Perl_die(aTHX_ PL_no_usym, what);
243 if (ckWARN(WARN_UNINITIALIZED))
245 if (type != SVt_PV && GIMME_V == G_ARRAY) {
249 **spp = &PL_sv_undef;
252 if ((PL_op->op_flags & OPf_SPECIAL) &&
253 !(PL_op->op_flags & OPf_MOD))
255 gv = gv_fetchsv(sv, 0, type);
257 && (!is_gv_magical_sv(sv,0)
258 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
260 **spp = &PL_sv_undef;
265 gv = gv_fetchsv(sv, GV_ADD, type);
277 tryAMAGICunDEREF(to_sv);
280 switch (SvTYPE(sv)) {
286 DIE(aTHX_ "Not a SCALAR reference");
293 if (!isGV_with_GP(gv)) {
294 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
300 if (PL_op->op_flags & OPf_MOD) {
301 if (PL_op->op_private & OPpLVAL_INTRO) {
302 if (cUNOP->op_first->op_type == OP_NULL)
303 sv = save_scalar(MUTABLE_GV(TOPs));
305 sv = save_scalar(gv);
307 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
309 else if (PL_op->op_private & OPpDEREF)
310 vivify_ref(sv, PL_op->op_private & OPpDEREF);
319 AV * const av = MUTABLE_AV(TOPs);
320 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
322 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
324 *sv = newSV_type(SVt_PVMG);
325 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
329 SETs(sv_2mortal(newSViv(
330 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
338 dVAR; dSP; dTARGET; dPOPss;
340 if (PL_op->op_flags & OPf_MOD || LVRET) {
341 if (SvTYPE(TARG) < SVt_PVLV) {
342 sv_upgrade(TARG, SVt_PVLV);
343 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
347 if (LvTARG(TARG) != sv) {
348 SvREFCNT_dec(LvTARG(TARG));
349 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
351 PUSHs(TARG); /* no SvSETMAGIC */
355 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
356 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
357 if (mg && mg->mg_len >= 0) {
361 PUSHi(i + CopARYBASE_get(PL_curcop));
374 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
376 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
379 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
380 /* (But not in defined().) */
382 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
385 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
386 if ((PL_op->op_private & OPpLVAL_INTRO)) {
387 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
390 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
393 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
397 cv = MUTABLE_CV(&PL_sv_undef);
398 SETs(MUTABLE_SV(cv));
408 SV *ret = &PL_sv_undef;
410 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
411 const char * s = SvPVX_const(TOPs);
412 if (strnEQ(s, "CORE::", 6)) {
413 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
414 if (code < 0) { /* Overridable. */
415 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
416 int i = 0, n = 0, seen_question = 0, defgv = 0;
418 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
420 if (code == -KEY_chop || code == -KEY_chomp
421 || code == -KEY_exec || code == -KEY_system)
423 if (code == -KEY_mkdir) {
424 ret = newSVpvs_flags("_;$", SVs_TEMP);
427 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
428 ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
431 if (code == -KEY_readpipe) {
432 s = "CORE::backtick";
434 while (i < MAXO) { /* The slow way. */
435 if (strEQ(s + 6, PL_op_name[i])
436 || strEQ(s + 6, PL_op_desc[i]))
442 goto nonesuch; /* Should not happen... */
444 defgv = PL_opargs[i] & OA_DEFGV;
445 oa = PL_opargs[i] >> OASHIFT;
447 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
451 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
452 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
453 /* But globs are already references (kinda) */
454 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
458 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
461 if (defgv && str[n - 1] == '$')
464 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
466 else if (code) /* Non-Overridable */
468 else { /* None such */
470 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
474 cv = sv_2cv(TOPs, &stash, &gv, 0);
476 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
485 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
487 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
489 PUSHs(MUTABLE_SV(cv));
503 if (GIMME != G_ARRAY) {
507 *MARK = &PL_sv_undef;
508 *MARK = refto(*MARK);
512 EXTEND_MORTAL(SP - MARK);
514 *MARK = refto(*MARK);
519 S_refto(pTHX_ SV *sv)
524 PERL_ARGS_ASSERT_REFTO;
526 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
529 if (!(sv = LvTARG(sv)))
532 SvREFCNT_inc_void_NN(sv);
534 else if (SvTYPE(sv) == SVt_PVAV) {
535 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
536 av_reify(MUTABLE_AV(sv));
538 SvREFCNT_inc_void_NN(sv);
540 else if (SvPADTMP(sv) && !IS_PADGV(sv))
544 SvREFCNT_inc_void_NN(sv);
547 sv_upgrade(rv, SVt_IV);
557 SV * const sv = POPs;
562 if (!sv || !SvROK(sv))
565 pv = sv_reftype(SvRV(sv),TRUE);
566 PUSHp(pv, strlen(pv));
576 stash = CopSTASH(PL_curcop);
578 SV * const ssv = POPs;
582 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
583 Perl_croak(aTHX_ "Attempt to bless into a reference");
584 ptr = SvPV_const(ssv,len);
586 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
587 "Explicit blessing to '' (assuming package main)");
588 stash = gv_stashpvn(ptr, len, GV_ADD);
591 (void)sv_bless(TOPs, stash);
600 const char * const elem = SvPV_nolen_const(sv);
601 GV * const gv = MUTABLE_GV(POPs);
606 /* elem will always be NUL terminated. */
607 const char * const second_letter = elem + 1;
610 if (strEQ(second_letter, "RRAY"))
611 tmpRef = MUTABLE_SV(GvAV(gv));
614 if (strEQ(second_letter, "ODE"))
615 tmpRef = MUTABLE_SV(GvCVu(gv));
618 if (strEQ(second_letter, "ILEHANDLE")) {
619 /* finally deprecated in 5.8.0 */
620 deprecate("*glob{FILEHANDLE}");
621 tmpRef = MUTABLE_SV(GvIOp(gv));
624 if (strEQ(second_letter, "ORMAT"))
625 tmpRef = MUTABLE_SV(GvFORM(gv));
628 if (strEQ(second_letter, "LOB"))
629 tmpRef = MUTABLE_SV(gv);
632 if (strEQ(second_letter, "ASH"))
633 tmpRef = MUTABLE_SV(GvHV(gv));
636 if (*second_letter == 'O' && !elem[2])
637 tmpRef = MUTABLE_SV(GvIOp(gv));
640 if (strEQ(second_letter, "AME"))
641 sv = newSVhek(GvNAME_HEK(gv));
644 if (strEQ(second_letter, "ACKAGE")) {
645 const HV * const stash = GvSTASH(gv);
646 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
647 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
651 if (strEQ(second_letter, "CALAR"))
666 /* Pattern matching */
671 register unsigned char *s;
674 register I32 *sfirst;
678 if (sv == PL_lastscream) {
682 s = (unsigned char*)(SvPV(sv, len));
684 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
685 /* No point in studying a zero length string, and not safe to study
686 anything that doesn't appear to be a simple scalar (and hence might
687 change between now and when the regexp engine runs without our set
688 magic ever running) such as a reference to an object with overloaded
694 SvSCREAM_off(PL_lastscream);
695 SvREFCNT_dec(PL_lastscream);
697 PL_lastscream = SvREFCNT_inc_simple(sv);
699 s = (unsigned char*)(SvPV(sv, len));
703 if (pos > PL_maxscream) {
704 if (PL_maxscream < 0) {
705 PL_maxscream = pos + 80;
706 Newx(PL_screamfirst, 256, I32);
707 Newx(PL_screamnext, PL_maxscream, I32);
710 PL_maxscream = pos + pos / 4;
711 Renew(PL_screamnext, PL_maxscream, I32);
715 sfirst = PL_screamfirst;
716 snext = PL_screamnext;
718 if (!sfirst || !snext)
719 DIE(aTHX_ "do_study: out of memory");
721 for (ch = 256; ch; --ch)
726 register const I32 ch = s[pos];
728 snext[pos] = sfirst[ch] - pos;
735 /* piggyback on m//g magic */
736 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
745 if (PL_op->op_flags & OPf_STACKED)
747 else if (PL_op->op_private & OPpTARGET_MY)
753 TARG = sv_newmortal();
758 /* Lvalue operators. */
770 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
772 do_chop(TARG, *++MARK);
781 SETi(do_chomp(TOPs));
787 dVAR; dSP; dMARK; dTARGET;
788 register I32 count = 0;
791 count += do_chomp(POPs);
801 if (!PL_op->op_private) {
810 SV_CHECK_THINKFIRST_COW_DROP(sv);
812 switch (SvTYPE(sv)) {
816 av_undef(MUTABLE_AV(sv));
819 hv_undef(MUTABLE_HV(sv));
822 if (cv_const_sv((const CV *)sv))
823 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
824 CvANON((const CV *)sv) ? "(anonymous)"
825 : GvENAME(CvGV((const CV *)sv)));
829 /* let user-undef'd sub keep its identity */
830 GV* const gv = CvGV((const CV *)sv);
831 cv_undef(MUTABLE_CV(sv));
832 CvGV((const CV *)sv) = gv;
837 SvSetMagicSV(sv, &PL_sv_undef);
840 else if (isGV_with_GP(sv)) {
845 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
846 mro_isa_changed_in(stash);
847 /* undef *Pkg::meth_name ... */
848 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
849 && HvNAME_get(stash))
850 mro_method_changed_in(stash);
852 gp_free(MUTABLE_GV(sv));
854 GvGP(sv) = gp_ref(gp);
856 GvLINE(sv) = CopLINE(PL_curcop);
857 GvEGV(sv) = MUTABLE_GV(sv);
863 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
878 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
879 DIE(aTHX_ "%s", PL_no_modify);
880 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
881 && SvIVX(TOPs) != IV_MIN)
883 SvIV_set(TOPs, SvIVX(TOPs) - 1);
884 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
895 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
896 DIE(aTHX_ "%s", PL_no_modify);
897 sv_setsv(TARG, TOPs);
898 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
899 && SvIVX(TOPs) != IV_MAX)
901 SvIV_set(TOPs, SvIVX(TOPs) + 1);
902 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
907 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
917 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
918 DIE(aTHX_ "%s", PL_no_modify);
919 sv_setsv(TARG, TOPs);
920 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
921 && SvIVX(TOPs) != IV_MIN)
923 SvIV_set(TOPs, SvIVX(TOPs) - 1);
924 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
933 /* Ordinary operators. */
937 dVAR; dSP; dATARGET; SV *svl, *svr;
938 #ifdef PERL_PRESERVE_IVUV
941 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
944 #ifdef PERL_PRESERVE_IVUV
945 /* For integer to integer power, we do the calculation by hand wherever
946 we're sure it is safe; otherwise we call pow() and try to convert to
947 integer afterwards. */
949 SvIV_please_nomg(svr);
951 SvIV_please_nomg(svl);
960 const IV iv = SvIVX(svr);
964 goto float_it; /* Can't do negative powers this way. */
968 baseuok = SvUOK(svl);
972 const IV iv = SvIVX(svl);
975 baseuok = TRUE; /* effectively it's a UV now */
977 baseuv = -iv; /* abs, baseuok == false records sign */
980 /* now we have integer ** positive integer. */
983 /* foo & (foo - 1) is zero only for a power of 2. */
984 if (!(baseuv & (baseuv - 1))) {
985 /* We are raising power-of-2 to a positive integer.
986 The logic here will work for any base (even non-integer
987 bases) but it can be less accurate than
988 pow (base,power) or exp (power * log (base)) when the
989 intermediate values start to spill out of the mantissa.
990 With powers of 2 we know this can't happen.
991 And powers of 2 are the favourite thing for perl
992 programmers to notice ** not doing what they mean. */
994 NV base = baseuok ? baseuv : -(NV)baseuv;
999 while (power >>= 1) {
1007 SvIV_please_nomg(svr);
1010 register unsigned int highbit = 8 * sizeof(UV);
1011 register unsigned int diff = 8 * sizeof(UV);
1012 while (diff >>= 1) {
1014 if (baseuv >> highbit) {
1018 /* we now have baseuv < 2 ** highbit */
1019 if (power * highbit <= 8 * sizeof(UV)) {
1020 /* result will definitely fit in UV, so use UV math
1021 on same algorithm as above */
1022 register UV result = 1;
1023 register UV base = baseuv;
1024 const bool odd_power = cBOOL(power & 1);
1028 while (power >>= 1) {
1035 if (baseuok || !odd_power)
1036 /* answer is positive */
1038 else if (result <= (UV)IV_MAX)
1039 /* answer negative, fits in IV */
1040 SETi( -(IV)result );
1041 else if (result == (UV)IV_MIN)
1042 /* 2's complement assumption: special case IV_MIN */
1045 /* answer negative, doesn't fit */
1046 SETn( -(NV)result );
1056 NV right = SvNV_nomg(svr);
1057 NV left = SvNV_nomg(svl);
1060 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1062 We are building perl with long double support and are on an AIX OS
1063 afflicted with a powl() function that wrongly returns NaNQ for any
1064 negative base. This was reported to IBM as PMR #23047-379 on
1065 03/06/2006. The problem exists in at least the following versions
1066 of AIX and the libm fileset, and no doubt others as well:
1068 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1069 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1070 AIX 5.2.0 bos.adt.libm 5.2.0.85
1072 So, until IBM fixes powl(), we provide the following workaround to
1073 handle the problem ourselves. Our logic is as follows: for
1074 negative bases (left), we use fmod(right, 2) to check if the
1075 exponent is an odd or even integer:
1077 - if odd, powl(left, right) == -powl(-left, right)
1078 - if even, powl(left, right) == powl(-left, right)
1080 If the exponent is not an integer, the result is rightly NaNQ, so
1081 we just return that (as NV_NAN).
1085 NV mod2 = Perl_fmod( right, 2.0 );
1086 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1087 SETn( -Perl_pow( -left, right) );
1088 } else if (mod2 == 0.0) { /* even integer */
1089 SETn( Perl_pow( -left, right) );
1090 } else { /* fractional power */
1094 SETn( Perl_pow( left, right) );
1097 SETn( Perl_pow( left, right) );
1098 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1100 #ifdef PERL_PRESERVE_IVUV
1102 SvIV_please_nomg(svr);
1110 dVAR; dSP; dATARGET; SV *svl, *svr;
1111 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1114 #ifdef PERL_PRESERVE_IVUV
1115 SvIV_please_nomg(svr);
1117 /* Unless the left argument is integer in range we are going to have to
1118 use NV maths. Hence only attempt to coerce the right argument if
1119 we know the left is integer. */
1120 /* Left operand is defined, so is it IV? */
1121 SvIV_please_nomg(svl);
1123 bool auvok = SvUOK(svl);
1124 bool buvok = SvUOK(svr);
1125 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1126 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1135 const IV aiv = SvIVX(svl);
1138 auvok = TRUE; /* effectively it's a UV now */
1140 alow = -aiv; /* abs, auvok == false records sign */
1146 const IV biv = SvIVX(svr);
1149 buvok = TRUE; /* effectively it's a UV now */
1151 blow = -biv; /* abs, buvok == false records sign */
1155 /* If this does sign extension on unsigned it's time for plan B */
1156 ahigh = alow >> (4 * sizeof (UV));
1158 bhigh = blow >> (4 * sizeof (UV));
1160 if (ahigh && bhigh) {
1162 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1163 which is overflow. Drop to NVs below. */
1164 } else if (!ahigh && !bhigh) {
1165 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1166 so the unsigned multiply cannot overflow. */
1167 const UV product = alow * blow;
1168 if (auvok == buvok) {
1169 /* -ve * -ve or +ve * +ve gives a +ve result. */
1173 } else if (product <= (UV)IV_MIN) {
1174 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1175 /* -ve result, which could overflow an IV */
1177 SETi( -(IV)product );
1179 } /* else drop to NVs below. */
1181 /* One operand is large, 1 small */
1184 /* swap the operands */
1186 bhigh = blow; /* bhigh now the temp var for the swap */
1190 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1191 multiplies can't overflow. shift can, add can, -ve can. */
1192 product_middle = ahigh * blow;
1193 if (!(product_middle & topmask)) {
1194 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1196 product_middle <<= (4 * sizeof (UV));
1197 product_low = alow * blow;
1199 /* as for pp_add, UV + something mustn't get smaller.
1200 IIRC ANSI mandates this wrapping *behaviour* for
1201 unsigned whatever the actual representation*/
1202 product_low += product_middle;
1203 if (product_low >= product_middle) {
1204 /* didn't overflow */
1205 if (auvok == buvok) {
1206 /* -ve * -ve or +ve * +ve gives a +ve result. */
1208 SETu( product_low );
1210 } else if (product_low <= (UV)IV_MIN) {
1211 /* 2s complement assumption again */
1212 /* -ve result, which could overflow an IV */
1214 SETi( -(IV)product_low );
1216 } /* else drop to NVs below. */
1218 } /* product_middle too large */
1219 } /* ahigh && bhigh */
1224 NV right = SvNV_nomg(svr);
1225 NV left = SvNV_nomg(svl);
1227 SETn( left * right );
1234 dVAR; dSP; dATARGET; SV *svl, *svr;
1235 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1238 /* Only try to do UV divide first
1239 if ((SLOPPYDIVIDE is true) or
1240 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1242 The assumption is that it is better to use floating point divide
1243 whenever possible, only doing integer divide first if we can't be sure.
1244 If NV_PRESERVES_UV is true then we know at compile time that no UV
1245 can be too large to preserve, so don't need to compile the code to
1246 test the size of UVs. */
1249 # define PERL_TRY_UV_DIVIDE
1250 /* ensure that 20./5. == 4. */
1252 # ifdef PERL_PRESERVE_IVUV
1253 # ifndef NV_PRESERVES_UV
1254 # define PERL_TRY_UV_DIVIDE
1259 #ifdef PERL_TRY_UV_DIVIDE
1260 SvIV_please_nomg(svr);
1262 SvIV_please_nomg(svl);
1264 bool left_non_neg = SvUOK(svl);
1265 bool right_non_neg = SvUOK(svr);
1269 if (right_non_neg) {
1273 const IV biv = SvIVX(svr);
1276 right_non_neg = TRUE; /* effectively it's a UV now */
1282 /* historically undef()/0 gives a "Use of uninitialized value"
1283 warning before dieing, hence this test goes here.
1284 If it were immediately before the second SvIV_please, then
1285 DIE() would be invoked before left was even inspected, so
1286 no inpsection would give no warning. */
1288 DIE(aTHX_ "Illegal division by zero");
1294 const IV aiv = SvIVX(svl);
1297 left_non_neg = TRUE; /* effectively it's a UV now */
1306 /* For sloppy divide we always attempt integer division. */
1308 /* Otherwise we only attempt it if either or both operands
1309 would not be preserved by an NV. If both fit in NVs
1310 we fall through to the NV divide code below. However,
1311 as left >= right to ensure integer result here, we know that
1312 we can skip the test on the right operand - right big
1313 enough not to be preserved can't get here unless left is
1316 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1319 /* Integer division can't overflow, but it can be imprecise. */
1320 const UV result = left / right;
1321 if (result * right == left) {
1322 SP--; /* result is valid */
1323 if (left_non_neg == right_non_neg) {
1324 /* signs identical, result is positive. */
1328 /* 2s complement assumption */
1329 if (result <= (UV)IV_MIN)
1330 SETi( -(IV)result );
1332 /* It's exact but too negative for IV. */
1333 SETn( -(NV)result );
1336 } /* tried integer divide but it was not an integer result */
1337 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1338 } /* left wasn't SvIOK */
1339 } /* right wasn't SvIOK */
1340 #endif /* PERL_TRY_UV_DIVIDE */
1342 NV right = SvNV_nomg(svr);
1343 NV left = SvNV_nomg(svl);
1344 (void)POPs;(void)POPs;
1345 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1346 if (! Perl_isnan(right) && right == 0.0)
1350 DIE(aTHX_ "Illegal division by zero");
1351 PUSHn( left / right );
1358 dVAR; dSP; dATARGET;
1359 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1363 bool left_neg = FALSE;
1364 bool right_neg = FALSE;
1365 bool use_double = FALSE;
1366 bool dright_valid = FALSE;
1369 SV * const svr = TOPs;
1370 SV * const svl = TOPm1s;
1371 SvIV_please_nomg(svr);
1373 right_neg = !SvUOK(svr);
1377 const IV biv = SvIVX(svr);
1380 right_neg = FALSE; /* effectively it's a UV now */
1387 dright = SvNV_nomg(svr);
1388 right_neg = dright < 0;
1391 if (dright < UV_MAX_P1) {
1392 right = U_V(dright);
1393 dright_valid = TRUE; /* In case we need to use double below. */
1399 /* At this point use_double is only true if right is out of range for
1400 a UV. In range NV has been rounded down to nearest UV and
1401 use_double false. */
1402 SvIV_please_nomg(svl);
1403 if (!use_double && SvIOK(svl)) {
1405 left_neg = !SvUOK(svl);
1409 const IV aiv = SvIVX(svl);
1412 left_neg = FALSE; /* effectively it's a UV now */
1420 dleft = SvNV_nomg(svl);
1421 left_neg = dleft < 0;
1425 /* This should be exactly the 5.6 behaviour - if left and right are
1426 both in range for UV then use U_V() rather than floor. */
1428 if (dleft < UV_MAX_P1) {
1429 /* right was in range, so is dleft, so use UVs not double.
1433 /* left is out of range for UV, right was in range, so promote
1434 right (back) to double. */
1436 /* The +0.5 is used in 5.6 even though it is not strictly
1437 consistent with the implicit +0 floor in the U_V()
1438 inside the #if 1. */
1439 dleft = Perl_floor(dleft + 0.5);
1442 dright = Perl_floor(dright + 0.5);
1453 DIE(aTHX_ "Illegal modulus zero");
1455 dans = Perl_fmod(dleft, dright);
1456 if ((left_neg != right_neg) && dans)
1457 dans = dright - dans;
1460 sv_setnv(TARG, dans);
1466 DIE(aTHX_ "Illegal modulus zero");
1469 if ((left_neg != right_neg) && ans)
1472 /* XXX may warn: unary minus operator applied to unsigned type */
1473 /* could change -foo to be (~foo)+1 instead */
1474 if (ans <= ~((UV)IV_MAX)+1)
1475 sv_setiv(TARG, ~ans+1);
1477 sv_setnv(TARG, -(NV)ans);
1480 sv_setuv(TARG, ans);
1489 dVAR; dSP; dATARGET;
1493 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1494 /* TODO: think of some way of doing list-repeat overloading ??? */
1499 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1505 const UV uv = SvUV_nomg(sv);
1507 count = IV_MAX; /* The best we can do? */
1511 const IV iv = SvIV_nomg(sv);
1518 else if (SvNOKp(sv)) {
1519 const NV nv = SvNV_nomg(sv);
1526 count = SvIV_nomg(sv);
1528 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1530 static const char oom_list_extend[] = "Out of memory during list extend";
1531 const I32 items = SP - MARK;
1532 const I32 max = items * count;
1534 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1535 /* Did the max computation overflow? */
1536 if (items > 0 && max > 0 && (max < items || max < count))
1537 Perl_croak(aTHX_ oom_list_extend);
1542 /* This code was intended to fix 20010809.028:
1545 for (($x =~ /./g) x 2) {
1546 print chop; # "abcdabcd" expected as output.
1549 * but that change (#11635) broke this code:
1551 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1553 * I can't think of a better fix that doesn't introduce
1554 * an efficiency hit by copying the SVs. The stack isn't
1555 * refcounted, and mortalisation obviously doesn't
1556 * Do The Right Thing when the stack has more than
1557 * one pointer to the same mortal value.
1561 *SP = sv_2mortal(newSVsv(*SP));
1571 repeatcpy((char*)(MARK + items), (char*)MARK,
1572 items * sizeof(const SV *), count - 1);
1575 else if (count <= 0)
1578 else { /* Note: mark already snarfed by pp_list */
1579 SV * const tmpstr = POPs;
1582 static const char oom_string_extend[] =
1583 "Out of memory during string extend";
1586 sv_setsv_nomg(TARG, tmpstr);
1587 SvPV_force_nomg(TARG, len);
1588 isutf = DO_UTF8(TARG);
1593 const STRLEN max = (UV)count * len;
1594 if (len > MEM_SIZE_MAX / count)
1595 Perl_croak(aTHX_ oom_string_extend);
1596 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1597 SvGROW(TARG, max + 1);
1598 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1599 SvCUR_set(TARG, SvCUR(TARG) * count);
1601 *SvEND(TARG) = '\0';
1604 (void)SvPOK_only_UTF8(TARG);
1606 (void)SvPOK_only(TARG);
1608 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1609 /* The parser saw this as a list repeat, and there
1610 are probably several items on the stack. But we're
1611 in scalar context, and there's no pp_list to save us
1612 now. So drop the rest of the items -- robin@kitsite.com
1624 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1625 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1628 useleft = USE_LEFT(svl);
1629 #ifdef PERL_PRESERVE_IVUV
1630 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1631 "bad things" happen if you rely on signed integers wrapping. */
1632 SvIV_please_nomg(svr);
1634 /* Unless the left argument is integer in range we are going to have to
1635 use NV maths. Hence only attempt to coerce the right argument if
1636 we know the left is integer. */
1637 register UV auv = 0;
1643 a_valid = auvok = 1;
1644 /* left operand is undef, treat as zero. */
1646 /* Left operand is defined, so is it IV? */
1647 SvIV_please_nomg(svl);
1649 if ((auvok = SvUOK(svl)))
1652 register const IV aiv = SvIVX(svl);
1655 auvok = 1; /* Now acting as a sign flag. */
1656 } else { /* 2s complement assumption for IV_MIN */
1664 bool result_good = 0;
1667 bool buvok = SvUOK(svr);
1672 register const IV biv = SvIVX(svr);
1679 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1680 else "IV" now, independent of how it came in.
1681 if a, b represents positive, A, B negative, a maps to -A etc
1686 all UV maths. negate result if A negative.
1687 subtract if signs same, add if signs differ. */
1689 if (auvok ^ buvok) {
1698 /* Must get smaller */
1703 if (result <= buv) {
1704 /* result really should be -(auv-buv). as its negation
1705 of true value, need to swap our result flag */
1717 if (result <= (UV)IV_MIN)
1718 SETi( -(IV)result );
1720 /* result valid, but out of range for IV. */
1721 SETn( -(NV)result );
1725 } /* Overflow, drop through to NVs. */
1730 NV value = SvNV_nomg(svr);
1734 /* left operand is undef, treat as zero - value */
1738 SETn( SvNV_nomg(svl) - value );
1745 dVAR; dSP; dATARGET; SV *svl, *svr;
1746 tryAMAGICbin_MG(lshift_amg, AMGf_assign);
1750 const IV shift = SvIV_nomg(svr);
1751 if (PL_op->op_private & HINT_INTEGER) {
1752 const IV i = SvIV_nomg(svl);
1756 const UV u = SvUV_nomg(svl);
1765 dVAR; dSP; dATARGET; SV *svl, *svr;
1766 tryAMAGICbin_MG(rshift_amg, AMGf_assign);
1770 const IV shift = SvIV_nomg(svr);
1771 if (PL_op->op_private & HINT_INTEGER) {
1772 const IV i = SvIV_nomg(svl);
1776 const UV u = SvUV_nomg(svl);
1786 tryAMAGICbin_MG(lt_amg, AMGf_set);
1787 #ifdef PERL_PRESERVE_IVUV
1788 SvIV_please_nomg(TOPs);
1790 SvIV_please_nomg(TOPm1s);
1791 if (SvIOK(TOPm1s)) {
1792 bool auvok = SvUOK(TOPm1s);
1793 bool buvok = SvUOK(TOPs);
1795 if (!auvok && !buvok) { /* ## IV < IV ## */
1796 const IV aiv = SvIVX(TOPm1s);
1797 const IV biv = SvIVX(TOPs);
1800 SETs(boolSV(aiv < biv));
1803 if (auvok && buvok) { /* ## UV < UV ## */
1804 const UV auv = SvUVX(TOPm1s);
1805 const UV buv = SvUVX(TOPs);
1808 SETs(boolSV(auv < buv));
1811 if (auvok) { /* ## UV < IV ## */
1813 const IV biv = SvIVX(TOPs);
1816 /* As (a) is a UV, it's >=0, so it cannot be < */
1821 SETs(boolSV(auv < (UV)biv));
1824 { /* ## IV < UV ## */
1825 const IV aiv = SvIVX(TOPm1s);
1829 /* As (b) is a UV, it's >=0, so it must be < */
1836 SETs(boolSV((UV)aiv < buv));
1842 #ifndef NV_PRESERVES_UV
1843 #ifdef PERL_PRESERVE_IVUV
1846 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1848 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1853 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1855 if (Perl_isnan(left) || Perl_isnan(right))
1857 SETs(boolSV(left < right));
1860 SETs(boolSV(SvNV_nomg(TOPs) < value));
1869 tryAMAGICbin_MG(gt_amg, AMGf_set);
1870 #ifdef PERL_PRESERVE_IVUV
1871 SvIV_please_nomg(TOPs);
1873 SvIV_please_nomg(TOPm1s);
1874 if (SvIOK(TOPm1s)) {
1875 bool auvok = SvUOK(TOPm1s);
1876 bool buvok = SvUOK(TOPs);
1878 if (!auvok && !buvok) { /* ## IV > IV ## */
1879 const IV aiv = SvIVX(TOPm1s);
1880 const IV biv = SvIVX(TOPs);
1883 SETs(boolSV(aiv > biv));
1886 if (auvok && buvok) { /* ## UV > UV ## */
1887 const UV auv = SvUVX(TOPm1s);
1888 const UV buv = SvUVX(TOPs);
1891 SETs(boolSV(auv > buv));
1894 if (auvok) { /* ## UV > IV ## */
1896 const IV biv = SvIVX(TOPs);
1900 /* As (a) is a UV, it's >=0, so it must be > */
1905 SETs(boolSV(auv > (UV)biv));
1908 { /* ## IV > UV ## */
1909 const IV aiv = SvIVX(TOPm1s);
1913 /* As (b) is a UV, it's >=0, so it cannot be > */
1920 SETs(boolSV((UV)aiv > buv));
1926 #ifndef NV_PRESERVES_UV
1927 #ifdef PERL_PRESERVE_IVUV
1930 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1932 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1937 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1939 if (Perl_isnan(left) || Perl_isnan(right))
1941 SETs(boolSV(left > right));
1944 SETs(boolSV(SvNV_nomg(TOPs) > value));
1953 tryAMAGICbin_MG(le_amg, AMGf_set);
1954 #ifdef PERL_PRESERVE_IVUV
1955 SvIV_please_nomg(TOPs);
1957 SvIV_please_nomg(TOPm1s);
1958 if (SvIOK(TOPm1s)) {
1959 bool auvok = SvUOK(TOPm1s);
1960 bool buvok = SvUOK(TOPs);
1962 if (!auvok && !buvok) { /* ## IV <= IV ## */
1963 const IV aiv = SvIVX(TOPm1s);
1964 const IV biv = SvIVX(TOPs);
1967 SETs(boolSV(aiv <= biv));
1970 if (auvok && buvok) { /* ## UV <= UV ## */
1971 UV auv = SvUVX(TOPm1s);
1972 UV buv = SvUVX(TOPs);
1975 SETs(boolSV(auv <= buv));
1978 if (auvok) { /* ## UV <= IV ## */
1980 const IV biv = SvIVX(TOPs);
1984 /* As (a) is a UV, it's >=0, so a cannot be <= */
1989 SETs(boolSV(auv <= (UV)biv));
1992 { /* ## IV <= UV ## */
1993 const IV aiv = SvIVX(TOPm1s);
1997 /* As (b) is a UV, it's >=0, so a must be <= */
2004 SETs(boolSV((UV)aiv <= buv));
2010 #ifndef NV_PRESERVES_UV
2011 #ifdef PERL_PRESERVE_IVUV
2014 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2016 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2021 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2023 if (Perl_isnan(left) || Perl_isnan(right))
2025 SETs(boolSV(left <= right));
2028 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2037 tryAMAGICbin_MG(ge_amg,AMGf_set);
2038 #ifdef PERL_PRESERVE_IVUV
2039 SvIV_please_nomg(TOPs);
2041 SvIV_please_nomg(TOPm1s);
2042 if (SvIOK(TOPm1s)) {
2043 bool auvok = SvUOK(TOPm1s);
2044 bool buvok = SvUOK(TOPs);
2046 if (!auvok && !buvok) { /* ## IV >= IV ## */
2047 const IV aiv = SvIVX(TOPm1s);
2048 const IV biv = SvIVX(TOPs);
2051 SETs(boolSV(aiv >= biv));
2054 if (auvok && buvok) { /* ## UV >= UV ## */
2055 const UV auv = SvUVX(TOPm1s);
2056 const UV buv = SvUVX(TOPs);
2059 SETs(boolSV(auv >= buv));
2062 if (auvok) { /* ## UV >= IV ## */
2064 const IV biv = SvIVX(TOPs);
2068 /* As (a) is a UV, it's >=0, so it must be >= */
2073 SETs(boolSV(auv >= (UV)biv));
2076 { /* ## IV >= UV ## */
2077 const IV aiv = SvIVX(TOPm1s);
2081 /* As (b) is a UV, it's >=0, so a cannot be >= */
2088 SETs(boolSV((UV)aiv >= buv));
2094 #ifndef NV_PRESERVES_UV
2095 #ifdef PERL_PRESERVE_IVUV
2098 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2100 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2105 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2107 if (Perl_isnan(left) || Perl_isnan(right))
2109 SETs(boolSV(left >= right));
2112 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2121 tryAMAGICbin_MG(ne_amg,AMGf_set);
2122 #ifndef NV_PRESERVES_UV
2123 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2125 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2129 #ifdef PERL_PRESERVE_IVUV
2130 SvIV_please_nomg(TOPs);
2132 SvIV_please_nomg(TOPm1s);
2133 if (SvIOK(TOPm1s)) {
2134 const bool auvok = SvUOK(TOPm1s);
2135 const bool buvok = SvUOK(TOPs);
2137 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2138 /* Casting IV to UV before comparison isn't going to matter
2139 on 2s complement. On 1s complement or sign&magnitude
2140 (if we have any of them) it could make negative zero
2141 differ from normal zero. As I understand it. (Need to
2142 check - is negative zero implementation defined behaviour
2144 const UV buv = SvUVX(POPs);
2145 const UV auv = SvUVX(TOPs);
2147 SETs(boolSV(auv != buv));
2150 { /* ## Mixed IV,UV ## */
2154 /* != is commutative so swap if needed (save code) */
2156 /* swap. top of stack (b) is the iv */
2160 /* As (a) is a UV, it's >0, so it cannot be == */
2169 /* As (b) is a UV, it's >0, so it cannot be == */
2173 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2175 SETs(boolSV((UV)iv != uv));
2182 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2184 if (Perl_isnan(left) || Perl_isnan(right))
2186 SETs(boolSV(left != right));
2189 SETs(boolSV(SvNV_nomg(TOPs) != value));
2198 tryAMAGICbin_MG(ncmp_amg, 0);
2199 #ifndef NV_PRESERVES_UV
2200 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2201 const UV right = PTR2UV(SvRV(POPs));
2202 const UV left = PTR2UV(SvRV(TOPs));
2203 SETi((left > right) - (left < right));
2207 #ifdef PERL_PRESERVE_IVUV
2208 /* Fortunately it seems NaN isn't IOK */
2209 SvIV_please_nomg(TOPs);
2211 SvIV_please_nomg(TOPm1s);
2212 if (SvIOK(TOPm1s)) {
2213 const bool leftuvok = SvUOK(TOPm1s);
2214 const bool rightuvok = SvUOK(TOPs);
2216 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2217 const IV leftiv = SvIVX(TOPm1s);
2218 const IV rightiv = SvIVX(TOPs);
2220 if (leftiv > rightiv)
2222 else if (leftiv < rightiv)
2226 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2227 const UV leftuv = SvUVX(TOPm1s);
2228 const UV rightuv = SvUVX(TOPs);
2230 if (leftuv > rightuv)
2232 else if (leftuv < rightuv)
2236 } else if (leftuvok) { /* ## UV <=> IV ## */
2237 const IV rightiv = SvIVX(TOPs);
2239 /* As (a) is a UV, it's >=0, so it cannot be < */
2242 const UV leftuv = SvUVX(TOPm1s);
2243 if (leftuv > (UV)rightiv) {
2245 } else if (leftuv < (UV)rightiv) {
2251 } else { /* ## IV <=> UV ## */
2252 const IV leftiv = SvIVX(TOPm1s);
2254 /* As (b) is a UV, it's >=0, so it must be < */
2257 const UV rightuv = SvUVX(TOPs);
2258 if ((UV)leftiv > rightuv) {
2260 } else if ((UV)leftiv < rightuv) {
2278 if (Perl_isnan(left) || Perl_isnan(right)) {
2282 value = (left > right) - (left < right);
2286 else if (left < right)
2288 else if (left > right)
2304 int amg_type = sle_amg;
2308 switch (PL_op->op_type) {
2327 tryAMAGICbin_MG(amg_type, AMGf_set);
2330 const int cmp = (IN_LOCALE_RUNTIME
2331 ? sv_cmp_locale(left, right)
2332 : sv_cmp(left, right));
2333 SETs(boolSV(cmp * multiplier < rhs));
2341 tryAMAGICbin_MG(seq_amg, AMGf_set);
2344 SETs(boolSV(sv_eq(left, right)));
2352 tryAMAGICbin_MG(sne_amg, AMGf_set);
2355 SETs(boolSV(!sv_eq(left, right)));
2363 tryAMAGICbin_MG(scmp_amg, 0);
2366 const int cmp = (IN_LOCALE_RUNTIME
2367 ? sv_cmp_locale(left, right)
2368 : sv_cmp(left, right));
2376 dVAR; dSP; dATARGET;
2377 tryAMAGICbin_MG(band_amg, AMGf_assign);
2380 if (SvNIOKp(left) || SvNIOKp(right)) {
2381 if (PL_op->op_private & HINT_INTEGER) {
2382 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2386 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2391 do_vop(PL_op->op_type, TARG, left, right);
2400 dVAR; dSP; dATARGET;
2401 const int op_type = PL_op->op_type;
2403 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2406 if (SvNIOKp(left) || SvNIOKp(right)) {
2407 if (PL_op->op_private & HINT_INTEGER) {
2408 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2409 const IV r = SvIV_nomg(right);
2410 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2414 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2415 const UV r = SvUV_nomg(right);
2416 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2421 do_vop(op_type, TARG, left, right);
2431 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2433 SV * const sv = TOPs;
2434 const int flags = SvFLAGS(sv);
2435 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2436 /* It's publicly an integer, or privately an integer-not-float */
2439 if (SvIVX(sv) == IV_MIN) {
2440 /* 2s complement assumption. */
2441 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2444 else if (SvUVX(sv) <= IV_MAX) {
2449 else if (SvIVX(sv) != IV_MIN) {
2453 #ifdef PERL_PRESERVE_IVUV
2461 SETn(-SvNV_nomg(sv));
2462 else if (SvPOKp(sv)) {
2464 const char * const s = SvPV_nomg_const(sv, len);
2465 if (isIDFIRST(*s)) {
2466 sv_setpvs(TARG, "-");
2469 else if (*s == '+' || *s == '-') {
2470 sv_setsv_nomg(TARG, sv);
2471 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2473 else if (DO_UTF8(sv)) {
2474 SvIV_please_nomg(sv);
2476 goto oops_its_an_int;
2478 sv_setnv(TARG, -SvNV_nomg(sv));
2480 sv_setpvs(TARG, "-");
2485 SvIV_please_nomg(sv);
2487 goto oops_its_an_int;
2488 sv_setnv(TARG, -SvNV_nomg(sv));
2493 SETn(-SvNV_nomg(sv));
2501 tryAMAGICun_MG(not_amg, AMGf_set);
2502 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2509 tryAMAGICun_MG(compl_amg, 0);
2513 if (PL_op->op_private & HINT_INTEGER) {
2514 const IV i = ~SvIV_nomg(sv);
2518 const UV u = ~SvUV_nomg(sv);
2527 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2528 sv_setsv_nomg(TARG, sv);
2529 tmps = (U8*)SvPV_force_nomg(TARG, len);
2532 /* Calculate exact length, let's not estimate. */
2537 U8 * const send = tmps + len;
2538 U8 * const origtmps = tmps;
2539 const UV utf8flags = UTF8_ALLOW_ANYUV;
2541 while (tmps < send) {
2542 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2544 targlen += UNISKIP(~c);
2550 /* Now rewind strings and write them. */
2557 Newx(result, targlen + 1, U8);
2559 while (tmps < send) {
2560 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2562 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2565 sv_usepvn_flags(TARG, (char*)result, targlen,
2566 SV_HAS_TRAILING_NUL);
2573 Newx(result, nchar + 1, U8);
2575 while (tmps < send) {
2576 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2581 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2589 register long *tmpl;
2590 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2593 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2598 for ( ; anum > 0; anum--, tmps++)
2606 /* integer versions of some of the above */
2610 dVAR; dSP; dATARGET;
2611 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2614 SETi( left * right );
2622 dVAR; dSP; dATARGET;
2623 tryAMAGICbin_MG(div_amg, AMGf_assign);
2626 IV value = SvIV_nomg(right);
2628 DIE(aTHX_ "Illegal division by zero");
2629 num = SvIV_nomg(left);
2631 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2635 value = num / value;
2641 #if defined(__GLIBC__) && IVSIZE == 8
2648 /* This is the vanilla old i_modulo. */
2649 dVAR; dSP; dATARGET;
2650 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2654 DIE(aTHX_ "Illegal modulus zero");
2655 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2659 SETi( left % right );
2664 #if defined(__GLIBC__) && IVSIZE == 8
2669 /* This is the i_modulo with the workaround for the _moddi3 bug
2670 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2671 * See below for pp_i_modulo. */
2672 dVAR; dSP; dATARGET;
2673 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2677 DIE(aTHX_ "Illegal modulus zero");
2678 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2682 SETi( left % PERL_ABS(right) );
2689 dVAR; dSP; dATARGET;
2690 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2694 DIE(aTHX_ "Illegal modulus zero");
2695 /* The assumption is to use hereafter the old vanilla version... */
2697 PL_ppaddr[OP_I_MODULO] =
2699 /* .. but if we have glibc, we might have a buggy _moddi3
2700 * (at least glicb 2.2.5 is known to have this bug), in other
2701 * words our integer modulus with negative quad as the second
2702 * argument might be broken. Test for this and re-patch the
2703 * opcode dispatch table if that is the case, remembering to
2704 * also apply the workaround so that this first round works
2705 * right, too. See [perl #9402] for more information. */
2709 /* Cannot do this check with inlined IV constants since
2710 * that seems to work correctly even with the buggy glibc. */
2712 /* Yikes, we have the bug.
2713 * Patch in the workaround version. */
2715 PL_ppaddr[OP_I_MODULO] =
2716 &Perl_pp_i_modulo_1;
2717 /* Make certain we work right this time, too. */
2718 right = PERL_ABS(right);
2721 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2725 SETi( left % right );
2733 dVAR; dSP; dATARGET;
2734 tryAMAGICbin_MG(add_amg, AMGf_assign);
2736 dPOPTOPiirl_ul_nomg;
2737 SETi( left + right );
2744 dVAR; dSP; dATARGET;
2745 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2747 dPOPTOPiirl_ul_nomg;
2748 SETi( left - right );
2756 tryAMAGICbin_MG(lt_amg, AMGf_set);
2759 SETs(boolSV(left < right));
2767 tryAMAGICbin_MG(gt_amg, AMGf_set);
2770 SETs(boolSV(left > right));
2778 tryAMAGICbin_MG(le_amg, AMGf_set);
2781 SETs(boolSV(left <= right));
2789 tryAMAGICbin_MG(ge_amg, AMGf_set);
2792 SETs(boolSV(left >= right));
2800 tryAMAGICbin_MG(eq_amg, AMGf_set);
2803 SETs(boolSV(left == right));
2811 tryAMAGICbin_MG(ne_amg, AMGf_set);
2814 SETs(boolSV(left != right));
2822 tryAMAGICbin_MG(ncmp_amg, 0);
2829 else if (left < right)
2841 tryAMAGICun_MG(neg_amg, 0);
2843 SV * const sv = TOPs;
2844 IV const i = SvIV_nomg(sv);
2850 /* High falutin' math. */
2855 tryAMAGICbin_MG(atan2_amg, 0);
2858 SETn(Perl_atan2(left, right));
2866 int amg_type = sin_amg;
2867 const char *neg_report = NULL;
2868 NV (*func)(NV) = Perl_sin;
2869 const int op_type = PL_op->op_type;
2886 amg_type = sqrt_amg;
2888 neg_report = "sqrt";
2893 tryAMAGICun_MG(amg_type, 0);
2895 SV * const arg = POPs;
2896 const NV value = SvNV_nomg(arg);
2898 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2899 SET_NUMERIC_STANDARD();
2900 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2903 XPUSHn(func(value));
2908 /* Support Configure command-line overrides for rand() functions.
2909 After 5.005, perhaps we should replace this by Configure support
2910 for drand48(), random(), or rand(). For 5.005, though, maintain
2911 compatibility by calling rand() but allow the user to override it.
2912 See INSTALL for details. --Andy Dougherty 15 July 1998
2914 /* Now it's after 5.005, and Configure supports drand48() and random(),
2915 in addition to rand(). So the overrides should not be needed any more.
2916 --Jarkko Hietaniemi 27 September 1998
2919 #ifndef HAS_DRAND48_PROTO
2920 extern double drand48 (void);
2933 if (!PL_srand_called) {
2934 (void)seedDrand01((Rand_seed_t)seed());
2935 PL_srand_called = TRUE;
2945 const UV anum = (MAXARG < 1) ? seed() : POPu;
2946 (void)seedDrand01((Rand_seed_t)anum);
2947 PL_srand_called = TRUE;
2955 tryAMAGICun_MG(int_amg, AMGf_numeric);
2957 SV * const sv = TOPs;
2958 const IV iv = SvIV_nomg(sv);
2959 /* XXX it's arguable that compiler casting to IV might be subtly
2960 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2961 else preferring IV has introduced a subtle behaviour change bug. OTOH
2962 relying on floating point to be accurate is a bug. */
2967 else if (SvIOK(sv)) {
2969 SETu(SvUV_nomg(sv));
2974 const NV value = SvNV_nomg(sv);
2976 if (value < (NV)UV_MAX + 0.5) {
2979 SETn(Perl_floor(value));
2983 if (value > (NV)IV_MIN - 0.5) {
2986 SETn(Perl_ceil(value));
2997 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2999 SV * const sv = TOPs;
3000 /* This will cache the NV value if string isn't actually integer */
3001 const IV iv = SvIV_nomg(sv);
3006 else if (SvIOK(sv)) {
3007 /* IVX is precise */
3009 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3017 /* 2s complement assumption. Also, not really needed as
3018 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3024 const NV value = SvNV_nomg(sv);
3038 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3042 SV* const sv = POPs;
3044 tmps = (SvPV_const(sv, len));
3046 /* If Unicode, try to downgrade
3047 * If not possible, croak. */
3048 SV* const tsv = sv_2mortal(newSVsv(sv));
3051 sv_utf8_downgrade(tsv, FALSE);
3052 tmps = SvPV_const(tsv, len);
3054 if (PL_op->op_type == OP_HEX)
3057 while (*tmps && len && isSPACE(*tmps))
3063 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3065 else if (*tmps == 'b')
3066 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3068 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3070 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3084 SV * const sv = TOPs;
3086 if (SvGAMAGIC(sv)) {
3087 /* For an overloaded or magic scalar, we can't know in advance if
3088 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3089 it likes to cache the length. Maybe that should be a documented
3094 = sv_2pv_flags(sv, &len,
3095 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3099 else if (DO_UTF8(sv)) {
3100 SETi(utf8_length((U8*)p, (U8*)p + len));
3104 } else if (SvOK(sv)) {
3105 /* Neither magic nor overloaded. */
3107 SETi(sv_len_utf8(sv));
3130 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3132 const IV arybase = CopARYBASE_get(PL_curcop);
3134 const char *repl = NULL;
3136 const int num_args = PL_op->op_private & 7;
3137 bool repl_need_utf8_upgrade = FALSE;
3138 bool repl_is_utf8 = FALSE;
3140 SvTAINTED_off(TARG); /* decontaminate */
3141 SvUTF8_off(TARG); /* decontaminate */
3145 repl = SvPV_const(repl_sv, repl_len);
3146 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3149 len_iv = SvIV(len_sv);
3150 len_is_uv = SvIOK_UV(len_sv);
3153 pos1_iv = SvIV(pos_sv);
3154 pos1_is_uv = SvIOK_UV(pos_sv);
3160 sv_utf8_upgrade(sv);
3162 else if (DO_UTF8(sv))
3163 repl_need_utf8_upgrade = TRUE;
3165 tmps = SvPV_const(sv, curlen);
3167 utf8_curlen = sv_len_utf8(sv);
3168 if (utf8_curlen == curlen)
3171 curlen = utf8_curlen;
3176 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3177 UV pos1_uv = pos1_iv-arybase;
3178 /* Overflow can occur when $[ < 0 */
3179 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3184 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3185 goto bound_fail; /* $[=3; substr($_,2,...) */
3187 else { /* pos < $[ */
3188 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3193 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3198 if (pos1_is_uv || pos1_iv > 0) {
3199 if ((UV)pos1_iv > curlen)
3204 if (!len_is_uv && len_iv < 0) {
3205 pos2_iv = curlen + len_iv;
3207 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3210 } else { /* len_iv >= 0 */
3211 if (!pos1_is_uv && pos1_iv < 0) {
3212 pos2_iv = pos1_iv + len_iv;
3213 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3215 if ((UV)len_iv > curlen-(UV)pos1_iv)
3218 pos2_iv = pos1_iv+len_iv;
3228 if (!pos2_is_uv && pos2_iv < 0) {
3229 if (!pos1_is_uv && pos1_iv < 0)
3233 else if (!pos1_is_uv && pos1_iv < 0)
3236 if ((UV)pos2_iv < (UV)pos1_iv)
3238 if ((UV)pos2_iv > curlen)
3242 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3243 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3244 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3245 STRLEN byte_len = len;
3246 STRLEN byte_pos = utf8_curlen
3247 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3250 /* we either return a PV or an LV. If the TARG hasn't been used
3251 * before, or is of that type, reuse it; otherwise use a mortal
3252 * instead. Note that LVs can have an extended lifetime, so also
3253 * dont reuse if refcount > 1 (bug #20933) */
3254 if (SvTYPE(TARG) > SVt_NULL) {
3255 if ( (SvTYPE(TARG) == SVt_PVLV)
3256 ? (!lvalue || SvREFCNT(TARG) > 1)
3259 TARG = sv_newmortal();
3263 sv_setpvn(TARG, tmps, byte_len);
3264 #ifdef USE_LOCALE_COLLATE
3265 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3270 SV* repl_sv_copy = NULL;
3272 if (repl_need_utf8_upgrade) {
3273 repl_sv_copy = newSVsv(repl_sv);
3274 sv_utf8_upgrade(repl_sv_copy);
3275 repl = SvPV_const(repl_sv_copy, repl_len);
3276 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3280 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3283 SvREFCNT_dec(repl_sv_copy);
3285 else if (lvalue) { /* it's an lvalue! */
3286 if (!SvGMAGICAL(sv)) {
3288 SvPV_force_nolen(sv);
3289 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3290 "Attempt to use reference as lvalue in substr");
3292 if (isGV_with_GP(sv))
3293 SvPV_force_nolen(sv);
3294 else if (SvOK(sv)) /* is it defined ? */
3295 (void)SvPOK_only_UTF8(sv);
3297 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3300 if (SvTYPE(TARG) < SVt_PVLV) {
3301 sv_upgrade(TARG, SVt_PVLV);
3302 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3306 if (LvTARG(TARG) != sv) {
3307 SvREFCNT_dec(LvTARG(TARG));
3308 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3310 LvTARGOFF(TARG) = pos;
3311 LvTARGLEN(TARG) = len;
3315 PUSHs(TARG); /* avoid SvSETMAGIC here */
3320 Perl_croak(aTHX_ "substr outside of string");
3321 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3328 register const IV size = POPi;
3329 register const IV offset = POPi;
3330 register SV * const src = POPs;
3331 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3333 SvTAINTED_off(TARG); /* decontaminate */
3334 if (lvalue) { /* it's an lvalue! */
3335 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3336 TARG = sv_newmortal();
3337 if (SvTYPE(TARG) < SVt_PVLV) {
3338 sv_upgrade(TARG, SVt_PVLV);
3339 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3342 if (LvTARG(TARG) != src) {
3343 SvREFCNT_dec(LvTARG(TARG));
3344 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3346 LvTARGOFF(TARG) = offset;
3347 LvTARGLEN(TARG) = size;
3350 sv_setuv(TARG, do_vecget(src, offset, size));
3366 const char *little_p;
3367 const I32 arybase = CopARYBASE_get(PL_curcop);
3370 const bool is_index = PL_op->op_type == OP_INDEX;
3373 /* arybase is in characters, like offset, so combine prior to the
3374 UTF-8 to bytes calculation. */
3375 offset = POPi - arybase;
3379 big_p = SvPV_const(big, biglen);
3380 little_p = SvPV_const(little, llen);
3382 big_utf8 = DO_UTF8(big);
3383 little_utf8 = DO_UTF8(little);
3384 if (big_utf8 ^ little_utf8) {
3385 /* One needs to be upgraded. */
3386 if (little_utf8 && !PL_encoding) {
3387 /* Well, maybe instead we might be able to downgrade the small
3389 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3392 /* If the large string is ISO-8859-1, and it's not possible to
3393 convert the small string to ISO-8859-1, then there is no
3394 way that it could be found anywhere by index. */
3399 /* At this point, pv is a malloc()ed string. So donate it to temp
3400 to ensure it will get free()d */
3401 little = temp = newSV(0);
3402 sv_usepvn(temp, pv, llen);
3403 little_p = SvPVX(little);
3406 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3409 sv_recode_to_utf8(temp, PL_encoding);
3411 sv_utf8_upgrade(temp);
3416 big_p = SvPV_const(big, biglen);
3419 little_p = SvPV_const(little, llen);
3423 if (SvGAMAGIC(big)) {
3424 /* Life just becomes a lot easier if I use a temporary here.
3425 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3426 will trigger magic and overloading again, as will fbm_instr()
3428 big = newSVpvn_flags(big_p, biglen,
3429 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3432 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3433 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3434 warn on undef, and we've already triggered a warning with the
3435 SvPV_const some lines above. We can't remove that, as we need to
3436 call some SvPV to trigger overloading early and find out if the
3438 This is all getting to messy. The API isn't quite clean enough,
3439 because data access has side effects.
3441 little = newSVpvn_flags(little_p, llen,
3442 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3443 little_p = SvPVX(little);
3447 offset = is_index ? 0 : biglen;
3449 if (big_utf8 && offset > 0)
3450 sv_pos_u2b(big, &offset, 0);
3456 else if (offset > (I32)biglen)
3458 if (!(little_p = is_index
3459 ? fbm_instr((unsigned char*)big_p + offset,
3460 (unsigned char*)big_p + biglen, little, 0)
3461 : rninstr(big_p, big_p + offset,
3462 little_p, little_p + llen)))
3465 retval = little_p - big_p;
3466 if (retval > 0 && big_utf8)
3467 sv_pos_b2u(big, &retval);
3471 PUSHi(retval + arybase);
3477 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3478 if (SvTAINTED(MARK[1]))
3479 TAINT_PROPER("sprintf");
3480 SvTAINTED_off(TARG);
3481 do_sprintf(TARG, SP-MARK, MARK+1);
3482 TAINT_IF(SvTAINTED(TARG));
3494 const U8 *s = (U8*)SvPV_const(argsv, len);
3496 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3497 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3498 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3502 XPUSHu(DO_UTF8(argsv) ?
3503 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3515 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3517 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3519 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3521 (void) POPs; /* Ignore the argument value. */
3522 value = UNICODE_REPLACEMENT;
3528 SvUPGRADE(TARG,SVt_PV);
3530 if (value > 255 && !IN_BYTES) {
3531 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3532 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3533 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3535 (void)SvPOK_only(TARG);
3544 *tmps++ = (char)value;
3546 (void)SvPOK_only(TARG);
3548 if (PL_encoding && !IN_BYTES) {
3549 sv_recode_to_utf8(TARG, PL_encoding);
3551 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3552 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3556 *tmps++ = (char)value;
3572 const char *tmps = SvPV_const(left, len);
3574 if (DO_UTF8(left)) {
3575 /* If Unicode, try to downgrade.
3576 * If not possible, croak.
3577 * Yes, we made this up. */
3578 SV* const tsv = sv_2mortal(newSVsv(left));
3581 sv_utf8_downgrade(tsv, FALSE);
3582 tmps = SvPV_const(tsv, len);
3584 # ifdef USE_ITHREADS
3586 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3587 /* This should be threadsafe because in ithreads there is only
3588 * one thread per interpreter. If this would not be true,
3589 * we would need a mutex to protect this malloc. */
3590 PL_reentrant_buffer->_crypt_struct_buffer =
3591 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3592 #if defined(__GLIBC__) || defined(__EMX__)
3593 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3594 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3595 /* work around glibc-2.2.5 bug */
3596 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3600 # endif /* HAS_CRYPT_R */
3601 # endif /* USE_ITHREADS */
3603 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3605 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3611 "The crypt() function is unimplemented due to excessive paranoia.");
3616 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3617 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3619 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3620 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3621 * See http://www.unicode.org/unicode/reports/tr16 */
3622 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3623 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3625 /* Below are several macros that generate code */
3626 /* Generates code to store a unicode codepoint c that is known to occupy
3627 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3628 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3630 *(p) = UTF8_TWO_BYTE_HI(c); \
3631 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3634 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3635 * available byte after the two bytes */
3636 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3638 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3639 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3642 /* Generates code to store the upper case of latin1 character l which is known
3643 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3644 * are only two characters that fit this description, and this macro knows
3645 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3647 #define STORE_NON_LATIN1_UC(p, l) \
3649 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3650 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3651 } else { /* Must be the following letter */ \
3652 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3656 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3657 * after the character stored */
3658 #define CAT_NON_LATIN1_UC(p, l) \
3660 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3661 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3663 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3667 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3668 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3669 * and must require two bytes to store it. Advances p to point to the next
3670 * available position */
3671 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3673 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3674 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3675 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3676 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3677 } else {/* else is one of the other two special cases */ \
3678 CAT_NON_LATIN1_UC((p), (l)); \
3684 /* Actually is both lcfirst() and ucfirst(). Only the first character
3685 * changes. This means that possibly we can change in-place, ie., just
3686 * take the source and change that one character and store it back, but not
3687 * if read-only etc, or if the length changes */
3692 STRLEN slen; /* slen is the byte length of the whole SV. */
3695 bool inplace; /* ? Convert first char only, in-place */
3696 bool doing_utf8 = FALSE; /* ? using utf8 */
3697 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3698 const int op_type = PL_op->op_type;
3701 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3702 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3703 * stored as UTF-8 at s. */
3704 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3705 * lowercased) character stored in tmpbuf. May be either
3706 * UTF-8 or not, but in either case is the number of bytes */
3710 s = (const U8*)SvPV_nomg_const(source, slen);
3712 if (ckWARN(WARN_UNINITIALIZED))
3713 report_uninit(source);
3718 /* We may be able to get away with changing only the first character, in
3719 * place, but not if read-only, etc. Later we may discover more reasons to
3720 * not convert in-place. */
3721 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3723 /* First calculate what the changed first character should be. This affects
3724 * whether we can just swap it out, leaving the rest of the string unchanged,
3725 * or even if have to convert the dest to UTF-8 when the source isn't */
3727 if (! slen) { /* If empty */
3728 need = 1; /* still need a trailing NUL */
3730 else if (DO_UTF8(source)) { /* Is the source utf8? */
3733 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3734 * and doesn't allow for the user to specify their own. When code is added to
3735 * detect if there is a user-defined mapping in force here, and if so to use
3736 * that, then the code below can be compiled. The detection would be a good
3737 * thing anyway, as currently the user-defined mappings only work on utf8
3738 * strings, and thus depend on the chosen internal storage method, which is a
3740 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3741 if (UTF8_IS_INVARIANT(*s)) {
3743 /* An invariant source character is either ASCII or, in EBCDIC, an
3744 * ASCII equivalent or a caseless C1 control. In both these cases,
3745 * the lower and upper cases of any character are also invariants
3746 * (and title case is the same as upper case). So it is safe to
3747 * use the simple case change macros which avoid the overhead of
3748 * the general functions. Note that if perl were to be extended to
3749 * do locale handling in UTF-8 strings, this wouldn't be true in,
3750 * for example, Lithuanian or Turkic. */
3751 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3755 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3758 /* Similarly, if the source character isn't invariant but is in the
3759 * latin1 range (or EBCDIC equivalent thereof), we have the case
3760 * changes compiled into perl, and can avoid the overhead of the
3761 * general functions. In this range, the characters are stored as
3762 * two UTF-8 bytes, and it so happens that any changed-case version
3763 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3767 /* Convert the two source bytes to a single Unicode code point
3768 * value, change case and save for below */
3769 chr = UTF8_ACCUMULATE(*s, *(s+1));
3770 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3771 U8 lower = toLOWER_LATIN1(chr);
3772 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3774 else { /* ucfirst */
3775 U8 upper = toUPPER_LATIN1_MOD(chr);
3777 /* Most of the latin1 range characters are well-behaved. Their
3778 * title and upper cases are the same, and are also in the
3779 * latin1 range. The macro above returns their upper (hence
3780 * title) case, and all that need be done is to save the result
3781 * for below. However, several characters are problematic, and
3782 * have to be handled specially. The MOD in the macro name
3783 * above means that these tricky characters all get mapped to
3784 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3785 * This mapping saves some tests for the majority of the
3788 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3790 /* Not tricky. Just save it. */
3791 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3793 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3795 /* This one is tricky because it is two characters long,
3796 * though the UTF-8 is still two bytes, so the stored
3797 * length doesn't change */
3798 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3799 *(tmpbuf + 1) = 's';
3803 /* The other two have their title and upper cases the same,
3804 * but are tricky because the changed-case characters
3805 * aren't in the latin1 range. They, however, do fit into
3806 * two UTF-8 bytes */
3807 STORE_NON_LATIN1_UC(tmpbuf, chr);
3812 #endif /* end of dont want to break user-defined casing */
3814 /* Here, can't short-cut the general case */
3816 utf8_to_uvchr(s, &ulen);
3817 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3818 else toLOWER_utf8(s, tmpbuf, &tculen);
3820 /* we can't do in-place if the length changes. */
3821 if (ulen != tculen) inplace = FALSE;
3822 need = slen + 1 - ulen + tculen;
3823 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3827 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3828 * latin1 is treated as caseless. Note that a locale takes
3830 tculen = 1; /* Most characters will require one byte, but this will
3831 * need to be overridden for the tricky ones */
3834 if (op_type == OP_LCFIRST) {
3836 /* lower case the first letter: no trickiness for any character */
3837 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3838 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3841 else if (IN_LOCALE_RUNTIME) {
3842 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3843 * have upper and title case different
3846 else if (! IN_UNI_8_BIT) {
3847 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3848 * on EBCDIC machines whatever the
3849 * native function does */
3851 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3852 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3854 /* tmpbuf now has the correct title case for all latin1 characters
3855 * except for the several ones that have tricky handling. All
3856 * of these are mapped by the MOD to the letter below. */
3857 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3859 /* The length is going to change, with all three of these, so
3860 * can't replace just the first character */
3863 /* We use the original to distinguish between these tricky
3865 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3866 /* Two character title case 'Ss', but can remain non-UTF-8 */
3869 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3874 /* The other two tricky ones have their title case outside
3875 * latin1. It is the same as their upper case. */
3877 STORE_NON_LATIN1_UC(tmpbuf, *s);
3879 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3880 * and their upper cases is 2. */
3883 /* The entire result will have to be in UTF-8. Assume worst
3884 * case sizing in conversion. (all latin1 characters occupy
3885 * at most two bytes in utf8) */
3886 convert_source_to_utf8 = TRUE;
3887 need = slen * 2 + 1;
3889 } /* End of is one of the three special chars */
3890 } /* End of use Unicode (Latin1) semantics */
3891 } /* End of changing the case of the first character */
3893 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3894 * generate the result */
3897 /* We can convert in place. This means we change just the first
3898 * character without disturbing the rest; no need to grow */
3900 s = d = (U8*)SvPV_force_nomg(source, slen);
3906 /* Here, we can't convert in place; we earlier calculated how much
3907 * space we will need, so grow to accommodate that */
3908 SvUPGRADE(dest, SVt_PV);
3909 d = (U8*)SvGROW(dest, need);
3910 (void)SvPOK_only(dest);
3917 if (! convert_source_to_utf8) {
3919 /* Here both source and dest are in UTF-8, but have to create
3920 * the entire output. We initialize the result to be the
3921 * title/lower cased first character, and then append the rest
3923 sv_setpvn(dest, (char*)tmpbuf, tculen);
3925 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3929 const U8 *const send = s + slen;
3931 /* Here the dest needs to be in UTF-8, but the source isn't,
3932 * except we earlier UTF-8'd the first character of the source
3933 * into tmpbuf. First put that into dest, and then append the
3934 * rest of the source, converting it to UTF-8 as we go. */
3936 /* Assert tculen is 2 here because the only two characters that
3937 * get to this part of the code have 2-byte UTF-8 equivalents */
3939 *d++ = *(tmpbuf + 1);
3940 s++; /* We have just processed the 1st char */
3942 for (; s < send; s++) {
3943 d = uvchr_to_utf8(d, *s);
3946 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3950 else { /* in-place UTF-8. Just overwrite the first character */
3951 Copy(tmpbuf, d, tculen, U8);
3952 SvCUR_set(dest, need - 1);
3955 else { /* Neither source nor dest are in or need to be UTF-8 */
3957 if (IN_LOCALE_RUNTIME) {
3961 if (inplace) { /* in-place, only need to change the 1st char */
3964 else { /* Not in-place */
3966 /* Copy the case-changed character(s) from tmpbuf */
3967 Copy(tmpbuf, d, tculen, U8);
3968 d += tculen - 1; /* Code below expects d to point to final
3969 * character stored */
3972 else { /* empty source */
3973 /* See bug #39028: Don't taint if empty */
3977 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3978 * the destination to retain that flag */
3982 if (!inplace) { /* Finish the rest of the string, unchanged */
3983 /* This will copy the trailing NUL */
3984 Copy(s + 1, d + 1, slen, U8);
3985 SvCUR_set(dest, need - 1);
3992 /* There's so much setup/teardown code common between uc and lc, I wonder if
3993 it would be worth merging the two, and just having a switch outside each
3994 of the three tight loops. There is less and less commonality though */
4008 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4009 && SvTEMP(source) && !DO_UTF8(source)
4010 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4012 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4013 * make the loop tight, so we overwrite the source with the dest before
4014 * looking at it, and we need to look at the original source
4015 * afterwards. There would also need to be code added to handle
4016 * switching to not in-place in midstream if we run into characters
4017 * that change the length.
4020 s = d = (U8*)SvPV_force_nomg(source, len);
4027 /* The old implementation would copy source into TARG at this point.
4028 This had the side effect that if source was undef, TARG was now
4029 an undefined SV with PADTMP set, and they don't warn inside
4030 sv_2pv_flags(). However, we're now getting the PV direct from
4031 source, which doesn't have PADTMP set, so it would warn. Hence the
4035 s = (const U8*)SvPV_nomg_const(source, len);
4037 if (ckWARN(WARN_UNINITIALIZED))
4038 report_uninit(source);
4044 SvUPGRADE(dest, SVt_PV);
4045 d = (U8*)SvGROW(dest, min);
4046 (void)SvPOK_only(dest);
4051 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4052 to check DO_UTF8 again here. */
4054 if (DO_UTF8(source)) {
4055 const U8 *const send = s + len;
4056 U8 tmpbuf[UTF8_MAXBYTES+1];
4058 /* This is ifdefd out because it needs more work and thought. It isn't clear
4059 * that we should do it. These are hard-coded rules from the Unicode standard,
4060 * and may change. 5.2 gives new guidance on the iota subscript, for example,
4061 * which has not been checked against this; and secondly it may be that we are
4062 * passed a subset of the context, via a \U...\E, for example, and its not
4063 * clear what the best approach is to that */
4064 #ifdef CONTEXT_DEPENDENT_CASING
4065 bool in_iota_subscript = FALSE;
4069 #ifdef CONTEXT_DEPENDENT_CASING
4070 if (in_iota_subscript && ! is_utf8_mark(s)) {
4071 /* A non-mark. Time to output the iota subscript */
4072 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4073 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4075 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4076 in_iota_subscript = FALSE;
4081 /* See comments at the first instance in this file of this ifdef */
4082 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4084 /* If the UTF-8 character is invariant, then it is in the range
4085 * known by the standard macro; result is only one byte long */
4086 if (UTF8_IS_INVARIANT(*s)) {
4090 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4092 /* Likewise, if it fits in a byte, its case change is in our
4094 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4095 U8 upper = toUPPER_LATIN1_MOD(orig);
4096 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4104 /* Otherwise, need the general UTF-8 case. Get the changed
4105 * case value and copy it to the output buffer */
4107 const STRLEN u = UTF8SKIP(s);
4110 #ifndef CONTEXT_DEPENDENT_CASING
4111 toUPPER_utf8(s, tmpbuf, &ulen);
4113 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4114 if (uv == GREEK_CAPITAL_LETTER_IOTA && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI) {
4115 in_iota_subscript = TRUE;
4119 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4120 /* If the eventually required minimum size outgrows
4121 * the available space, we need to grow. */
4122 const UV o = d - (U8*)SvPVX_const(dest);
4124 /* If someone uppercases one million U+03B0s we
4125 * SvGROW() one million times. Or we could try
4126 * guessing how much to allocate without allocating too
4127 * much. Such is life. See corresponding comment in lc code
4128 * for another option */
4130 d = (U8*)SvPVX(dest) + o;
4132 Copy(tmpbuf, d, ulen, U8);
4134 #ifdef CONTEXT_DEPENDENT_CASING
4140 #ifdef CONTEXT_DEPENDENT_CASING
4141 if (in_iota_subscript) CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4145 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4146 } else { /* Not UTF-8 */
4148 const U8 *const send = s + len;
4150 /* Use locale casing if in locale; regular style if not treating
4151 * latin1 as having case; otherwise the latin1 casing. Do the
4152 * whole thing in a tight loop, for speed, */
4153 if (IN_LOCALE_RUNTIME) {
4156 for (; s < send; d++, s++)
4157 *d = toUPPER_LC(*s);
4159 else if (! IN_UNI_8_BIT) {
4160 for (; s < send; d++, s++) {
4165 for (; s < send; d++, s++) {
4166 *d = toUPPER_LATIN1_MOD(*s);
4167 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4169 /* The mainstream case is the tight loop above. To avoid
4170 * extra tests in that, all three characters that require
4171 * special handling are mapped by the MOD to the one tested
4173 * Use the source to distinguish between the three cases */
4175 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4177 /* uc() of this requires 2 characters, but they are
4178 * ASCII. If not enough room, grow the string */
4179 if (SvLEN(dest) < ++min) {
4180 const UV o = d - (U8*)SvPVX_const(dest);
4182 d = (U8*)SvPVX(dest) + o;
4184 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4185 continue; /* Back to the tight loop; still in ASCII */
4188 /* The other two special handling characters have their
4189 * upper cases outside the latin1 range, hence need to be
4190 * in UTF-8, so the whole result needs to be in UTF-8. So,
4191 * here we are somewhere in the middle of processing a
4192 * non-UTF-8 string, and realize that we will have to convert
4193 * the whole thing to UTF-8. What to do? There are
4194 * several possibilities. The simplest to code is to
4195 * convert what we have so far, set a flag, and continue on
4196 * in the loop. The flag would be tested each time through
4197 * the loop, and if set, the next character would be
4198 * converted to UTF-8 and stored. But, I (khw) didn't want
4199 * to slow down the mainstream case at all for this fairly
4200 * rare case, so I didn't want to add a test that didn't
4201 * absolutely have to be there in the loop, besides the
4202 * possibility that it would get too complicated for
4203 * optimizers to deal with. Another possibility is to just
4204 * give up, convert the source to UTF-8, and restart the
4205 * function that way. Another possibility is to convert
4206 * both what has already been processed and what is yet to
4207 * come separately to UTF-8, then jump into the loop that
4208 * handles UTF-8. But the most efficient time-wise of the
4209 * ones I could think of is what follows, and turned out to
4210 * not require much extra code. */
4212 /* Convert what we have so far into UTF-8, telling the
4213 * function that we know it should be converted, and to
4214 * allow extra space for what we haven't processed yet.
4215 * Assume the worst case space requirements for converting
4216 * what we haven't processed so far: that it will require
4217 * two bytes for each remaining source character, plus the
4218 * NUL at the end. This may cause the string pointer to
4219 * move, so re-find it. */
4221 len = d - (U8*)SvPVX_const(dest);
4222 SvCUR_set(dest, len);
4223 len = sv_utf8_upgrade_flags_grow(dest,
4224 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4226 d = (U8*)SvPVX(dest) + len;
4228 /* And append the current character's upper case in UTF-8 */
4229 CAT_NON_LATIN1_UC(d, *s);
4231 /* Now process the remainder of the source, converting to
4232 * upper and UTF-8. If a resulting byte is invariant in
4233 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4234 * append it to the output. */
4237 for (; s < send; s++) {
4238 U8 upper = toUPPER_LATIN1_MOD(*s);
4239 if UTF8_IS_INVARIANT(upper) {
4243 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4247 /* Here have processed the whole source; no need to continue
4248 * with the outer loop. Each character has been converted
4249 * to upper case and converted to UTF-8 */
4252 } /* End of processing all latin1-style chars */
4253 } /* End of processing all chars */
4254 } /* End of source is not empty */
4256 if (source != dest) {
4257 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4258 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4260 } /* End of isn't utf8 */
4278 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4279 && SvTEMP(source) && !DO_UTF8(source)) {
4281 /* We can convert in place, as lowercasing anything in the latin1 range
4282 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4284 s = d = (U8*)SvPV_force_nomg(source, len);
4291 /* The old implementation would copy source into TARG at this point.
4292 This had the side effect that if source was undef, TARG was now
4293 an undefined SV with PADTMP set, and they don't warn inside
4294 sv_2pv_flags(). However, we're now getting the PV direct from
4295 source, which doesn't have PADTMP set, so it would warn. Hence the
4299 s = (const U8*)SvPV_nomg_const(source, len);
4301 if (ckWARN(WARN_UNINITIALIZED))
4302 report_uninit(source);
4308 SvUPGRADE(dest, SVt_PV);
4309 d = (U8*)SvGROW(dest, min);
4310 (void)SvPOK_only(dest);
4315 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4316 to check DO_UTF8 again here. */
4318 if (DO_UTF8(source)) {
4319 const U8 *const send = s + len;
4320 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4323 /* See comments at the first instance in this file of this ifdef */
4324 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4325 if (UTF8_IS_INVARIANT(*s)) {
4327 /* Invariant characters use the standard mappings compiled in.
4332 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4334 /* As do the ones in the Latin1 range */
4335 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4336 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4341 /* Here, is utf8 not in Latin-1 range, have to go out and get
4342 * the mappings from the tables. */
4344 const STRLEN u = UTF8SKIP(s);
4347 /* See comments at the first instance in this file of this ifdef */
4348 #ifndef CONTEXT_DEPENDENT_CASING
4349 toLOWER_utf8(s, tmpbuf, &ulen);
4351 /* Here is context dependent casing, not compiled in currently;
4352 * needs more thought and work */
4354 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4356 /* If the lower case is a small sigma, it may be that we need
4357 * to change it to a final sigma. This happens at the end of
4358 * a word that contains more than just this character, and only
4359 * when we started with a capital sigma. */
4360 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4361 s > send - len && /* Makes sure not the first letter */
4362 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4365 /* We use the algorithm in:
4366 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4367 * is a CAPITAL SIGMA): If C is preceded by a sequence
4368 * consisting of a cased letter and a case-ignorable
4369 * sequence, and C is not followed by a sequence consisting
4370 * of a case ignorable sequence and then a cased letter,
4371 * then when lowercasing C, C becomes a final sigma */
4373 /* To determine if this is the end of a word, need to peek
4374 * ahead. Look at the next character */
4375 const U8 *peek = s + u;
4377 /* Skip any case ignorable characters */
4378 while (peek < send && is_utf8_case_ignorable(peek)) {
4379 peek += UTF8SKIP(peek);
4382 /* If we reached the end of the string without finding any
4383 * non-case ignorable characters, or if the next such one
4384 * is not-cased, then we have met the conditions for it
4385 * being a final sigma with regards to peek ahead, and so
4386 * must do peek behind for the remaining conditions. (We
4387 * know there is stuff behind to look at since we tested
4388 * above that this isn't the first letter) */
4389 if (peek >= send || ! is_utf8_cased(peek)) {
4390 peek = utf8_hop(s, -1);
4392 /* Here are at the beginning of the first character
4393 * before the original upper case sigma. Keep backing
4394 * up, skipping any case ignorable characters */
4395 while (is_utf8_case_ignorable(peek)) {
4396 peek = utf8_hop(peek, -1);
4399 /* Here peek points to the first byte of the closest
4400 * non-case-ignorable character before the capital
4401 * sigma. If it is cased, then by the Unicode
4402 * algorithm, we should use a small final sigma instead
4403 * of what we have */
4404 if (is_utf8_cased(peek)) {
4405 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4406 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4410 else { /* Not a context sensitive mapping */
4411 #endif /* End of commented out context sensitive */
4412 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4414 /* If the eventually required minimum size outgrows
4415 * the available space, we need to grow. */
4416 const UV o = d - (U8*)SvPVX_const(dest);
4418 /* If someone lowercases one million U+0130s we
4419 * SvGROW() one million times. Or we could try
4420 * guessing how much to allocate without allocating too
4421 * much. Such is life. Another option would be to
4422 * grow an extra byte or two more each time we need to
4423 * grow, which would cut down the million to 500K, with
4426 d = (U8*)SvPVX(dest) + o;
4428 #ifdef CONTEXT_DEPENDENT_CASING
4431 /* Copy the newly lowercased letter to the output buffer we're
4433 Copy(tmpbuf, d, ulen, U8);
4436 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4439 } /* End of looping through the source string */
4442 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4443 } else { /* Not utf8 */
4445 const U8 *const send = s + len;
4447 /* Use locale casing if in locale; regular style if not treating
4448 * latin1 as having case; otherwise the latin1 casing. Do the
4449 * whole thing in a tight loop, for speed, */
4450 if (IN_LOCALE_RUNTIME) {
4453 for (; s < send; d++, s++)
4454 *d = toLOWER_LC(*s);
4456 else if (! IN_UNI_8_BIT) {
4457 for (; s < send; d++, s++) {
4462 for (; s < send; d++, s++) {
4463 *d = toLOWER_LATIN1(*s);
4467 if (source != dest) {
4469 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4479 SV * const sv = TOPs;
4481 register const char *s = SvPV_const(sv,len);
4483 SvUTF8_off(TARG); /* decontaminate */
4486 SvUPGRADE(TARG, SVt_PV);
4487 SvGROW(TARG, (len * 2) + 1);
4491 if (UTF8_IS_CONTINUED(*s)) {
4492 STRLEN ulen = UTF8SKIP(s);
4516 SvCUR_set(TARG, d - SvPVX_const(TARG));
4517 (void)SvPOK_only_UTF8(TARG);
4520 sv_setpvn(TARG, s, len);
4529 dVAR; dSP; dMARK; dORIGMARK;
4530 register AV *const av = MUTABLE_AV(POPs);
4531 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4533 if (SvTYPE(av) == SVt_PVAV) {
4534 const I32 arybase = CopARYBASE_get(PL_curcop);
4535 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4536 bool can_preserve = FALSE;
4542 can_preserve = SvCANEXISTDELETE(av);
4545 if (lval && localizing) {
4548 for (svp = MARK + 1; svp <= SP; svp++) {
4549 const I32 elem = SvIV(*svp);
4553 if (max > AvMAX(av))
4557 while (++MARK <= SP) {
4559 I32 elem = SvIV(*MARK);
4560 bool preeminent = TRUE;
4564 if (localizing && can_preserve) {
4565 /* If we can determine whether the element exist,
4566 * Try to preserve the existenceness of a tied array
4567 * element by using EXISTS and DELETE if possible.
4568 * Fallback to FETCH and STORE otherwise. */
4569 preeminent = av_exists(av, elem);
4572 svp = av_fetch(av, elem, lval);
4574 if (!svp || *svp == &PL_sv_undef)
4575 DIE(aTHX_ PL_no_aelem, elem);
4578 save_aelem(av, elem, svp);
4580 SAVEADELETE(av, elem);
4583 *MARK = svp ? *svp : &PL_sv_undef;
4586 if (GIMME != G_ARRAY) {
4588 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4598 AV *array = MUTABLE_AV(POPs);
4599 const I32 gimme = GIMME_V;
4600 IV *iterp = Perl_av_iter_p(aTHX_ array);
4601 const IV current = (*iterp)++;
4603 if (current > av_len(array)) {
4605 if (gimme == G_SCALAR)
4612 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4613 if (gimme == G_ARRAY) {
4614 SV **const element = av_fetch(array, current, 0);
4615 PUSHs(element ? *element : &PL_sv_undef);
4624 AV *array = MUTABLE_AV(POPs);
4625 const I32 gimme = GIMME_V;
4627 *Perl_av_iter_p(aTHX_ array) = 0;
4629 if (gimme == G_SCALAR) {
4631 PUSHi(av_len(array) + 1);
4633 else if (gimme == G_ARRAY) {
4634 IV n = Perl_av_len(aTHX_ array);
4635 IV i = CopARYBASE_get(PL_curcop);
4639 if (PL_op->op_type == OP_AKEYS) {
4641 for (; i <= n; i++) {
4646 for (i = 0; i <= n; i++) {
4647 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4648 PUSHs(elem ? *elem : &PL_sv_undef);
4655 /* Associative arrays. */
4661 HV * hash = MUTABLE_HV(POPs);
4663 const I32 gimme = GIMME_V;
4666 /* might clobber stack_sp */
4667 entry = hv_iternext(hash);
4672 SV* const sv = hv_iterkeysv(entry);
4673 PUSHs(sv); /* won't clobber stack_sp */
4674 if (gimme == G_ARRAY) {
4677 /* might clobber stack_sp */
4678 val = hv_iterval(hash, entry);
4683 else if (gimme == G_SCALAR)
4690 S_do_delete_local(pTHX)
4694 const I32 gimme = GIMME_V;
4698 if (PL_op->op_private & OPpSLICE) {
4700 SV * const osv = POPs;
4701 const bool tied = SvRMAGICAL(osv)
4702 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4703 const bool can_preserve = SvCANEXISTDELETE(osv)
4704 || mg_find((const SV *)osv, PERL_MAGIC_env);
4705 const U32 type = SvTYPE(osv);
4706 if (type == SVt_PVHV) { /* hash element */
4707 HV * const hv = MUTABLE_HV(osv);
4708 while (++MARK <= SP) {
4709 SV * const keysv = *MARK;
4711 bool preeminent = TRUE;
4713 preeminent = hv_exists_ent(hv, keysv, 0);
4715 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4722 sv = hv_delete_ent(hv, keysv, 0, 0);
4723 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4726 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4728 *MARK = sv_mortalcopy(sv);
4734 SAVEHDELETE(hv, keysv);
4735 *MARK = &PL_sv_undef;
4739 else if (type == SVt_PVAV) { /* array element */
4740 if (PL_op->op_flags & OPf_SPECIAL) {
4741 AV * const av = MUTABLE_AV(osv);
4742 while (++MARK <= SP) {
4743 I32 idx = SvIV(*MARK);
4745 bool preeminent = TRUE;
4747 preeminent = av_exists(av, idx);
4749 SV **svp = av_fetch(av, idx, 1);
4756 sv = av_delete(av, idx, 0);
4757 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4760 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4762 *MARK = sv_mortalcopy(sv);
4768 SAVEADELETE(av, idx);
4769 *MARK = &PL_sv_undef;
4775 DIE(aTHX_ "Not a HASH reference");
4776 if (gimme == G_VOID)
4778 else if (gimme == G_SCALAR) {
4783 *++MARK = &PL_sv_undef;
4788 SV * const keysv = POPs;
4789 SV * const osv = POPs;
4790 const bool tied = SvRMAGICAL(osv)
4791 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4792 const bool can_preserve = SvCANEXISTDELETE(osv)
4793 || mg_find((const SV *)osv, PERL_MAGIC_env);
4794 const U32 type = SvTYPE(osv);
4796 if (type == SVt_PVHV) {
4797 HV * const hv = MUTABLE_HV(osv);
4798 bool preeminent = TRUE;
4800 preeminent = hv_exists_ent(hv, keysv, 0);
4802 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4809 sv = hv_delete_ent(hv, keysv, 0, 0);
4810 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4813 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4815 SV *nsv = sv_mortalcopy(sv);
4821 SAVEHDELETE(hv, keysv);
4823 else if (type == SVt_PVAV) {
4824 if (PL_op->op_flags & OPf_SPECIAL) {
4825 AV * const av = MUTABLE_AV(osv);
4826 I32 idx = SvIV(keysv);
4827 bool preeminent = TRUE;
4829 preeminent = av_exists(av, idx);
4831 SV **svp = av_fetch(av, idx, 1);
4838 sv = av_delete(av, idx, 0);
4839 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4842 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4844 SV *nsv = sv_mortalcopy(sv);
4850 SAVEADELETE(av, idx);
4853 DIE(aTHX_ "panic: avhv_delete no longer supported");
4856 DIE(aTHX_ "Not a HASH reference");
4859 if (gimme != G_VOID)
4873 if (PL_op->op_private & OPpLVAL_INTRO)
4874 return do_delete_local();
4877 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4879 if (PL_op->op_private & OPpSLICE) {
4881 HV * const hv = MUTABLE_HV(POPs);
4882 const U32 hvtype = SvTYPE(hv);
4883 if (hvtype == SVt_PVHV) { /* hash element */
4884 while (++MARK <= SP) {
4885 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4886 *MARK = sv ? sv : &PL_sv_undef;
4889 else if (hvtype == SVt_PVAV) { /* array element */
4890 if (PL_op->op_flags & OPf_SPECIAL) {
4891 while (++MARK <= SP) {
4892 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4893 *MARK = sv ? sv : &PL_sv_undef;
4898 DIE(aTHX_ "Not a HASH reference");
4901 else if (gimme == G_SCALAR) {
4906 *++MARK = &PL_sv_undef;
4912 HV * const hv = MUTABLE_HV(POPs);
4914 if (SvTYPE(hv) == SVt_PVHV)
4915 sv = hv_delete_ent(hv, keysv, discard, 0);
4916 else if (SvTYPE(hv) == SVt_PVAV) {
4917 if (PL_op->op_flags & OPf_SPECIAL)
4918 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4920 DIE(aTHX_ "panic: avhv_delete no longer supported");
4923 DIE(aTHX_ "Not a HASH reference");
4939 if (PL_op->op_private & OPpEXISTS_SUB) {
4941 SV * const sv = POPs;
4942 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4945 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4950 hv = MUTABLE_HV(POPs);
4951 if (SvTYPE(hv) == SVt_PVHV) {
4952 if (hv_exists_ent(hv, tmpsv, 0))
4955 else if (SvTYPE(hv) == SVt_PVAV) {
4956 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4957 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4962 DIE(aTHX_ "Not a HASH reference");
4969 dVAR; dSP; dMARK; dORIGMARK;
4970 register HV * const hv = MUTABLE_HV(POPs);
4971 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4972 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4973 bool can_preserve = FALSE;
4979 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4980 can_preserve = TRUE;
4983 while (++MARK <= SP) {
4984 SV * const keysv = *MARK;
4987 bool preeminent = TRUE;
4989 if (localizing && can_preserve) {
4990 /* If we can determine whether the element exist,
4991 * try to preserve the existenceness of a tied hash
4992 * element by using EXISTS and DELETE if possible.
4993 * Fallback to FETCH and STORE otherwise. */
4994 preeminent = hv_exists_ent(hv, keysv, 0);
4997 he = hv_fetch_ent(hv, keysv, lval, 0);
4998 svp = he ? &HeVAL(he) : NULL;
5001 if (!svp || *svp == &PL_sv_undef) {
5002 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5005 if (HvNAME_get(hv) && isGV(*svp))
5006 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5007 else if (preeminent)
5008 save_helem_flags(hv, keysv, svp,
5009 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5011 SAVEHDELETE(hv, keysv);
5014 *MARK = svp ? *svp : &PL_sv_undef;
5016 if (GIMME != G_ARRAY) {
5018 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5024 /* List operators. */
5029 if (GIMME != G_ARRAY) {
5031 *MARK = *SP; /* unwanted list, return last item */
5033 *MARK = &PL_sv_undef;
5043 SV ** const lastrelem = PL_stack_sp;
5044 SV ** const lastlelem = PL_stack_base + POPMARK;
5045 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5046 register SV ** const firstrelem = lastlelem + 1;
5047 const I32 arybase = CopARYBASE_get(PL_curcop);
5048 I32 is_something_there = FALSE;
5050 register const I32 max = lastrelem - lastlelem;
5051 register SV **lelem;
5053 if (GIMME != G_ARRAY) {
5054 I32 ix = SvIV(*lastlelem);
5059 if (ix < 0 || ix >= max)
5060 *firstlelem = &PL_sv_undef;
5062 *firstlelem = firstrelem[ix];
5068 SP = firstlelem - 1;
5072 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5073 I32 ix = SvIV(*lelem);
5078 if (ix < 0 || ix >= max)
5079 *lelem = &PL_sv_undef;
5081 is_something_there = TRUE;
5082 if (!(*lelem = firstrelem[ix]))
5083 *lelem = &PL_sv_undef;
5086 if (is_something_there)
5089 SP = firstlelem - 1;
5095 dVAR; dSP; dMARK; dORIGMARK;
5096 const I32 items = SP - MARK;
5097 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5098 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5099 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5100 ? newRV_noinc(av) : av);
5106 dVAR; dSP; dMARK; dORIGMARK;
5107 HV* const hv = newHV();
5110 SV * const key = *++MARK;
5111 SV * const val = newSV(0);
5113 sv_setsv(val, *++MARK);
5115 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5116 (void)hv_store_ent(hv,key,val,0);
5119 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5120 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5126 dVAR; dSP; dMARK; dORIGMARK;
5127 register AV *ary = MUTABLE_AV(*++MARK);
5131 register I32 offset;
5132 register I32 length;
5136 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5139 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5142 ENTER_with_name("call_SPLICE");
5143 call_method("SPLICE",GIMME_V);
5144 LEAVE_with_name("call_SPLICE");
5152 offset = i = SvIV(*MARK);
5154 offset += AvFILLp(ary) + 1;
5156 offset -= CopARYBASE_get(PL_curcop);
5158 DIE(aTHX_ PL_no_aelem, i);
5160 length = SvIVx(*MARK++);
5162 length += AvFILLp(ary) - offset + 1;
5168 length = AvMAX(ary) + 1; /* close enough to infinity */
5172 length = AvMAX(ary) + 1;
5174 if (offset > AvFILLp(ary) + 1) {
5175 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5176 offset = AvFILLp(ary) + 1;
5178 after = AvFILLp(ary) + 1 - (offset + length);
5179 if (after < 0) { /* not that much array */
5180 length += after; /* offset+length now in array */
5186 /* At this point, MARK .. SP-1 is our new LIST */
5189 diff = newlen - length;
5190 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5193 /* make new elements SVs now: avoid problems if they're from the array */
5194 for (dst = MARK, i = newlen; i; i--) {
5195 SV * const h = *dst;
5196 *dst++ = newSVsv(h);
5199 if (diff < 0) { /* shrinking the area */
5200 SV **tmparyval = NULL;
5202 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5203 Copy(MARK, tmparyval, newlen, SV*);
5206 MARK = ORIGMARK + 1;
5207 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5208 MEXTEND(MARK, length);
5209 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5211 EXTEND_MORTAL(length);
5212 for (i = length, dst = MARK; i; i--) {
5213 sv_2mortal(*dst); /* free them eventualy */
5220 *MARK = AvARRAY(ary)[offset+length-1];
5223 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5224 SvREFCNT_dec(*dst++); /* free them now */
5227 AvFILLp(ary) += diff;
5229 /* pull up or down? */
5231 if (offset < after) { /* easier to pull up */
5232 if (offset) { /* esp. if nothing to pull */
5233 src = &AvARRAY(ary)[offset-1];
5234 dst = src - diff; /* diff is negative */
5235 for (i = offset; i > 0; i--) /* can't trust Copy */
5239 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5243 if (after) { /* anything to pull down? */
5244 src = AvARRAY(ary) + offset + length;
5245 dst = src + diff; /* diff is negative */
5246 Move(src, dst, after, SV*);
5248 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5249 /* avoid later double free */
5253 dst[--i] = &PL_sv_undef;
5256 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5257 Safefree(tmparyval);
5260 else { /* no, expanding (or same) */
5261 SV** tmparyval = NULL;
5263 Newx(tmparyval, length, SV*); /* so remember deletion */
5264 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5267 if (diff > 0) { /* expanding */
5268 /* push up or down? */
5269 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5273 Move(src, dst, offset, SV*);
5275 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5277 AvFILLp(ary) += diff;
5280 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5281 av_extend(ary, AvFILLp(ary) + diff);
5282 AvFILLp(ary) += diff;
5285 dst = AvARRAY(ary) + AvFILLp(ary);
5287 for (i = after; i; i--) {
5295 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5298 MARK = ORIGMARK + 1;
5299 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5301 Copy(tmparyval, MARK, length, SV*);
5303 EXTEND_MORTAL(length);
5304 for (i = length, dst = MARK; i; i--) {
5305 sv_2mortal(*dst); /* free them eventualy */
5312 else if (length--) {
5313 *MARK = tmparyval[length];
5316 while (length-- > 0)
5317 SvREFCNT_dec(tmparyval[length]);
5321 *MARK = &PL_sv_undef;
5322 Safefree(tmparyval);
5330 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5331 register AV * const ary = MUTABLE_AV(*++MARK);
5332 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5335 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5338 ENTER_with_name("call_PUSH");
5339 call_method("PUSH",G_SCALAR|G_DISCARD);
5340 LEAVE_with_name("call_PUSH");
5344 PL_delaymagic = DM_DELAY;
5345 for (++MARK; MARK <= SP; MARK++) {
5346 SV * const sv = newSV(0);
5348 sv_setsv(sv, *MARK);
5349 av_store(ary, AvFILLp(ary)+1, sv);
5351 if (PL_delaymagic & DM_ARRAY)
5352 mg_set(MUTABLE_SV(ary));
5357 if (OP_GIMME(PL_op, 0) != G_VOID) {
5358 PUSHi( AvFILL(ary) + 1 );
5367 AV * const av = PL_op->op_flags & OPf_SPECIAL
5368 ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5369 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5373 (void)sv_2mortal(sv);
5380 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5381 register AV *ary = MUTABLE_AV(*++MARK);
5382 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5385 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5388 ENTER_with_name("call_UNSHIFT");
5389 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5390 LEAVE_with_name("call_UNSHIFT");
5395 av_unshift(ary, SP - MARK);
5397 SV * const sv = newSVsv(*++MARK);
5398 (void)av_store(ary, i++, sv);
5402 if (OP_GIMME(PL_op, 0) != G_VOID) {
5403 PUSHi( AvFILL(ary) + 1 );
5412 if (GIMME == G_ARRAY) {
5413 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5417 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5418 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5419 av = MUTABLE_AV((*SP));
5420 /* In-place reversing only happens in void context for the array
5421 * assignment. We don't need to push anything on the stack. */
5424 if (SvMAGICAL(av)) {
5426 register SV *tmp = sv_newmortal();
5427 /* For SvCANEXISTDELETE */
5430 bool can_preserve = SvCANEXISTDELETE(av);
5432 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5433 register SV *begin, *end;
5436 if (!av_exists(av, i)) {
5437 if (av_exists(av, j)) {
5438 register SV *sv = av_delete(av, j, 0);
5439 begin = *av_fetch(av, i, TRUE);
5440 sv_setsv_mg(begin, sv);
5444 else if (!av_exists(av, j)) {
5445 register SV *sv = av_delete(av, i, 0);
5446 end = *av_fetch(av, j, TRUE);
5447 sv_setsv_mg(end, sv);
5452 begin = *av_fetch(av, i, TRUE);
5453 end = *av_fetch(av, j, TRUE);
5454 sv_setsv(tmp, begin);
5455 sv_setsv_mg(begin, end);
5456 sv_setsv_mg(end, tmp);
5460 SV **begin = AvARRAY(av);
5463 SV **end = begin + AvFILLp(av);
5465 while (begin < end) {
5466 register SV * const tmp = *begin;
5477 register SV * const tmp = *MARK;
5481 /* safe as long as stack cannot get extended in the above */
5487 register char *down;
5491 PADOFFSET padoff_du;
5493 SvUTF8_off(TARG); /* decontaminate */
5495 do_join(TARG, &PL_sv_no, MARK, SP);
5497 sv_setsv(TARG, (SP > MARK)
5499 : (padoff_du = find_rundefsvoffset(),
5500 (padoff_du == NOT_IN_PAD
5501 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
5502 ? DEFSV : PAD_SVl(padoff_du)));
5504 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5505 report_uninit(TARG);
5508 up = SvPV_force(TARG, len);
5510 if (DO_UTF8(TARG)) { /* first reverse each character */
5511 U8* s = (U8*)SvPVX(TARG);
5512 const U8* send = (U8*)(s + len);
5514 if (UTF8_IS_INVARIANT(*s)) {
5519 if (!utf8_to_uvchr(s, 0))
5523 down = (char*)(s - 1);
5524 /* reverse this character */
5528 *down-- = (char)tmp;
5534 down = SvPVX(TARG) + len - 1;
5538 *down-- = (char)tmp;
5540 (void)SvPOK_only_UTF8(TARG);
5552 register IV limit = POPi; /* note, negative is forever */
5553 SV * const sv = POPs;
5555 register const char *s = SvPV_const(sv, len);
5556 const bool do_utf8 = DO_UTF8(sv);
5557 const char *strend = s + len;
5559 register REGEXP *rx;
5561 register const char *m;
5563 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5564 I32 maxiters = slen + 10;
5565 I32 trailing_empty = 0;
5567 const I32 origlimit = limit;
5570 const I32 gimme = GIMME_V;
5572 const I32 oldsave = PL_savestack_ix;
5573 U32 make_mortal = SVs_TEMP;
5578 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5583 DIE(aTHX_ "panic: pp_split");
5586 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5587 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5589 RX_MATCH_UTF8_set(rx, do_utf8);
5592 if (pm->op_pmreplrootu.op_pmtargetoff) {
5593 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5596 if (pm->op_pmreplrootu.op_pmtargetgv) {
5597 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5602 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5608 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5610 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5617 for (i = AvFILLp(ary); i >= 0; i--)
5618 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5620 /* temporarily switch stacks */
5621 SAVESWITCHSTACK(PL_curstack, ary);
5625 base = SP - PL_stack_base;
5627 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5629 while (*s == ' ' || is_utf8_space((U8*)s))
5632 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5633 while (isSPACE_LC(*s))
5641 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5645 gimme_scalar = gimme == G_SCALAR && !ary;
5648 limit = maxiters + 2;
5649 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5652 /* this one uses 'm' and is a negative test */
5654 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5655 const int t = UTF8SKIP(m);
5656 /* is_utf8_space returns FALSE for malform utf8 */
5662 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5663 while (m < strend && !isSPACE_LC(*m))
5666 while (m < strend && !isSPACE(*m))
5679 dstr = newSVpvn_flags(s, m-s,
5680 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5684 /* skip the whitespace found last */
5686 s = m + UTF8SKIP(m);
5690 /* this one uses 's' and is a positive test */
5692 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5694 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5695 while (s < strend && isSPACE_LC(*s))
5698 while (s < strend && isSPACE(*s))
5703 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5705 for (m = s; m < strend && *m != '\n'; m++)
5718 dstr = newSVpvn_flags(s, m-s,
5719 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5725 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5727 Pre-extend the stack, either the number of bytes or
5728 characters in the string or a limited amount, triggered by:
5730 my ($x, $y) = split //, $str;
5734 if (!gimme_scalar) {
5735 const U32 items = limit - 1;
5744 /* keep track of how many bytes we skip over */
5754 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5767 dstr = newSVpvn(s, 1);
5783 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5784 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5785 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5786 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5787 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5788 SV * const csv = CALLREG_INTUIT_STRING(rx);
5790 len = RX_MINLENRET(rx);
5791 if (len == 1 && !RX_UTF8(rx) && !tail) {
5792 const char c = *SvPV_nolen_const(csv);
5794 for (m = s; m < strend && *m != c; m++)
5805 dstr = newSVpvn_flags(s, m-s,
5806 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5809 /* The rx->minlen is in characters but we want to step
5810 * s ahead by bytes. */
5812 s = (char*)utf8_hop((U8*)m, len);
5814 s = m + len; /* Fake \n at the end */
5818 while (s < strend && --limit &&
5819 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5820 csv, multiline ? FBMrf_MULTILINE : 0)) )
5829 dstr = newSVpvn_flags(s, m-s,
5830 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5833 /* The rx->minlen is in characters but we want to step
5834 * s ahead by bytes. */
5836 s = (char*)utf8_hop((U8*)m, len);
5838 s = m + len; /* Fake \n at the end */
5843 maxiters += slen * RX_NPARENS(rx);
5844 while (s < strend && --limit)
5848 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5851 if (rex_return == 0)
5853 TAINT_IF(RX_MATCH_TAINTED(rx));
5854 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5857 orig = RX_SUBBEG(rx);
5859 strend = s + (strend - m);
5861 m = RX_OFFS(rx)[0].start + orig;
5870 dstr = newSVpvn_flags(s, m-s,
5871 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5874 if (RX_NPARENS(rx)) {
5876 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5877 s = RX_OFFS(rx)[i].start + orig;
5878 m = RX_OFFS(rx)[i].end + orig;
5880 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5881 parens that didn't match -- they should be set to
5882 undef, not the empty string */
5890 if (m >= orig && s >= orig) {
5891 dstr = newSVpvn_flags(s, m-s,
5892 (do_utf8 ? SVf_UTF8 : 0)
5896 dstr = &PL_sv_undef; /* undef, not "" */
5902 s = RX_OFFS(rx)[0].end + orig;
5906 if (!gimme_scalar) {
5907 iters = (SP - PL_stack_base) - base;
5909 if (iters > maxiters)
5910 DIE(aTHX_ "Split loop");
5912 /* keep field after final delim? */
5913 if (s < strend || (iters && origlimit)) {
5914 if (!gimme_scalar) {
5915 const STRLEN l = strend - s;
5916 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5921 else if (!origlimit) {
5923 iters -= trailing_empty;
5925 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5926 if (TOPs && !make_mortal)
5928 *SP-- = &PL_sv_undef;
5935 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5939 if (SvSMAGICAL(ary)) {
5941 mg_set(MUTABLE_SV(ary));
5944 if (gimme == G_ARRAY) {
5946 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5953 ENTER_with_name("call_PUSH");
5954 call_method("PUSH",G_SCALAR|G_DISCARD);
5955 LEAVE_with_name("call_PUSH");
5957 if (gimme == G_ARRAY) {
5959 /* EXTEND should not be needed - we just popped them */
5961 for (i=0; i < iters; i++) {
5962 SV **svp = av_fetch(ary, i, FALSE);
5963 PUSHs((svp) ? *svp : &PL_sv_undef);
5970 if (gimme == G_ARRAY)
5982 SV *const sv = PAD_SVl(PL_op->op_targ);
5984 if (SvPADSTALE(sv)) {
5987 RETURNOP(cLOGOP->op_other);
5989 RETURNOP(cLOGOP->op_next);
5998 assert(SvTYPE(retsv) != SVt_PVCV);
6000 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6001 retsv = refto(retsv);
6008 PP(unimplemented_op)
6011 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6020 HV * const hv = (HV*)POPs;
6022 if (SvRMAGICAL(hv)) {
6023 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6025 XPUSHs(magic_scalarpack(hv, mg));
6030 XPUSHs(boolSV(HvKEYS(hv) != 0));
6036 * c-indentation-style: bsd
6038 * indent-tabs-mode: t
6041 * ex: set ts=8 sts=4 sw=4 noet: