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_no_modify(aTHX);
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);
275 if (!(PL_op->op_private & OPpDEREFed))
278 tryAMAGICunDEREF(to_sv);
281 switch (SvTYPE(sv)) {
287 DIE(aTHX_ "Not a SCALAR reference");
294 if (!isGV_with_GP(gv)) {
295 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
301 if (PL_op->op_flags & OPf_MOD) {
302 if (PL_op->op_private & OPpLVAL_INTRO) {
303 if (cUNOP->op_first->op_type == OP_NULL)
304 sv = save_scalar(MUTABLE_GV(TOPs));
306 sv = save_scalar(gv);
308 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
310 else if (PL_op->op_private & OPpDEREF)
311 vivify_ref(sv, PL_op->op_private & OPpDEREF);
320 AV * const av = MUTABLE_AV(TOPs);
321 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
323 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
325 *sv = newSV_type(SVt_PVMG);
326 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
330 SETs(sv_2mortal(newSViv(
331 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
341 if (PL_op->op_flags & OPf_MOD || LVRET) {
342 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
343 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
345 LvTARG(ret) = SvREFCNT_inc_simple(sv);
346 PUSHs(ret); /* no SvSETMAGIC */
350 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
351 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
352 if (mg && mg->mg_len >= 0) {
357 PUSHi(i + CopARYBASE_get(PL_curcop));
370 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
372 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
375 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
376 /* (But not in defined().) */
378 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
381 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
382 if ((PL_op->op_private & OPpLVAL_INTRO)) {
383 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
386 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
389 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
393 cv = MUTABLE_CV(&PL_sv_undef);
394 SETs(MUTABLE_SV(cv));
404 SV *ret = &PL_sv_undef;
406 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
407 const char * s = SvPVX_const(TOPs);
408 if (strnEQ(s, "CORE::", 6)) {
409 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
410 if (code < 0) { /* Overridable. */
411 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
412 int i = 0, n = 0, seen_question = 0, defgv = 0;
414 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
416 if (code == -KEY_chop || code == -KEY_chomp
417 || code == -KEY_exec || code == -KEY_system)
419 if (code == -KEY_mkdir) {
420 ret = newSVpvs_flags("_;$", SVs_TEMP);
423 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
424 ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
427 if (code == -KEY_tied || code == -KEY_untie) {
428 ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
431 if (code == -KEY_tie) {
432 ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
435 if (code == -KEY_readpipe) {
436 s = "CORE::backtick";
438 while (i < MAXO) { /* The slow way. */
439 if (strEQ(s + 6, PL_op_name[i])
440 || strEQ(s + 6, PL_op_desc[i]))
446 goto nonesuch; /* Should not happen... */
448 defgv = PL_opargs[i] & OA_DEFGV;
449 oa = PL_opargs[i] >> OASHIFT;
451 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
455 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
456 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
457 /* But globs are already references (kinda) */
458 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
462 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
465 if (defgv && str[n - 1] == '$')
468 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
470 else if (code) /* Non-Overridable */
472 else { /* None such */
474 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
478 cv = sv_2cv(TOPs, &stash, &gv, 0);
480 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
489 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
491 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
493 PUSHs(MUTABLE_SV(cv));
507 if (GIMME != G_ARRAY) {
511 *MARK = &PL_sv_undef;
512 *MARK = refto(*MARK);
516 EXTEND_MORTAL(SP - MARK);
518 *MARK = refto(*MARK);
523 S_refto(pTHX_ SV *sv)
528 PERL_ARGS_ASSERT_REFTO;
530 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
533 if (!(sv = LvTARG(sv)))
536 SvREFCNT_inc_void_NN(sv);
538 else if (SvTYPE(sv) == SVt_PVAV) {
539 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
540 av_reify(MUTABLE_AV(sv));
542 SvREFCNT_inc_void_NN(sv);
544 else if (SvPADTMP(sv) && !IS_PADGV(sv))
548 SvREFCNT_inc_void_NN(sv);
551 sv_upgrade(rv, SVt_IV);
561 SV * const sv = POPs;
566 if (!sv || !SvROK(sv))
569 pv = sv_reftype(SvRV(sv),TRUE);
570 PUSHp(pv, strlen(pv));
580 stash = CopSTASH(PL_curcop);
582 SV * const ssv = POPs;
586 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
587 Perl_croak(aTHX_ "Attempt to bless into a reference");
588 ptr = SvPV_const(ssv,len);
590 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
591 "Explicit blessing to '' (assuming package main)");
592 stash = gv_stashpvn(ptr, len, GV_ADD);
595 (void)sv_bless(TOPs, stash);
604 const char * const elem = SvPV_nolen_const(sv);
605 GV * const gv = MUTABLE_GV(POPs);
610 /* elem will always be NUL terminated. */
611 const char * const second_letter = elem + 1;
614 if (strEQ(second_letter, "RRAY"))
615 tmpRef = MUTABLE_SV(GvAV(gv));
618 if (strEQ(second_letter, "ODE"))
619 tmpRef = MUTABLE_SV(GvCVu(gv));
622 if (strEQ(second_letter, "ILEHANDLE")) {
623 /* finally deprecated in 5.8.0 */
624 deprecate("*glob{FILEHANDLE}");
625 tmpRef = MUTABLE_SV(GvIOp(gv));
628 if (strEQ(second_letter, "ORMAT"))
629 tmpRef = MUTABLE_SV(GvFORM(gv));
632 if (strEQ(second_letter, "LOB"))
633 tmpRef = MUTABLE_SV(gv);
636 if (strEQ(second_letter, "ASH"))
637 tmpRef = MUTABLE_SV(GvHV(gv));
640 if (*second_letter == 'O' && !elem[2])
641 tmpRef = MUTABLE_SV(GvIOp(gv));
644 if (strEQ(second_letter, "AME"))
645 sv = newSVhek(GvNAME_HEK(gv));
648 if (strEQ(second_letter, "ACKAGE")) {
649 const HV * const stash = GvSTASH(gv);
650 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
651 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
655 if (strEQ(second_letter, "CALAR"))
670 /* Pattern matching */
675 register unsigned char *s;
678 register I32 *sfirst;
682 if (sv == PL_lastscream) {
686 s = (unsigned char*)(SvPV(sv, len));
688 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
689 /* No point in studying a zero length string, and not safe to study
690 anything that doesn't appear to be a simple scalar (and hence might
691 change between now and when the regexp engine runs without our set
692 magic ever running) such as a reference to an object with overloaded
698 SvSCREAM_off(PL_lastscream);
699 SvREFCNT_dec(PL_lastscream);
701 PL_lastscream = SvREFCNT_inc_simple(sv);
703 s = (unsigned char*)(SvPV(sv, len));
707 if (pos > PL_maxscream) {
708 if (PL_maxscream < 0) {
709 PL_maxscream = pos + 80;
710 Newx(PL_screamfirst, 256, I32);
711 Newx(PL_screamnext, PL_maxscream, I32);
714 PL_maxscream = pos + pos / 4;
715 Renew(PL_screamnext, PL_maxscream, I32);
719 sfirst = PL_screamfirst;
720 snext = PL_screamnext;
722 if (!sfirst || !snext)
723 DIE(aTHX_ "do_study: out of memory");
725 for (ch = 256; ch; --ch)
730 register const I32 ch = s[pos];
732 snext[pos] = sfirst[ch] - pos;
739 /* piggyback on m//g magic */
740 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
749 if (PL_op->op_flags & OPf_STACKED)
751 else if (PL_op->op_private & OPpTARGET_MY)
757 TARG = sv_newmortal();
762 /* Lvalue operators. */
774 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
776 do_chop(TARG, *++MARK);
785 SETi(do_chomp(TOPs));
791 dVAR; dSP; dMARK; dTARGET;
792 register I32 count = 0;
795 count += do_chomp(POPs);
805 if (!PL_op->op_private) {
814 SV_CHECK_THINKFIRST_COW_DROP(sv);
816 switch (SvTYPE(sv)) {
820 av_undef(MUTABLE_AV(sv));
823 hv_undef(MUTABLE_HV(sv));
826 if (cv_const_sv((const CV *)sv))
827 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
828 CvANON((const CV *)sv) ? "(anonymous)"
829 : GvENAME(CvGV((const CV *)sv)));
833 /* let user-undef'd sub keep its identity */
834 GV* const gv = CvGV((const CV *)sv);
835 cv_undef(MUTABLE_CV(sv));
836 CvGV_set(MUTABLE_CV(sv), gv);
841 SvSetMagicSV(sv, &PL_sv_undef);
844 else if (isGV_with_GP(sv)) {
849 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
850 mro_isa_changed_in(stash);
851 /* undef *Pkg::meth_name ... */
852 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
853 && HvNAME_get(stash))
854 mro_method_changed_in(stash);
856 gp_free(MUTABLE_GV(sv));
858 GvGP(sv) = gp_ref(gp);
860 GvLINE(sv) = CopLINE(PL_curcop);
861 GvEGV(sv) = MUTABLE_GV(sv);
867 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
882 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
883 Perl_croak_no_modify(aTHX);
884 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
885 && SvIVX(TOPs) != IV_MIN)
887 SvIV_set(TOPs, SvIVX(TOPs) - 1);
888 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
899 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
900 Perl_croak_no_modify(aTHX);
902 TARG = sv_newmortal();
903 sv_setsv(TARG, TOPs);
904 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
905 && SvIVX(TOPs) != IV_MAX)
907 SvIV_set(TOPs, SvIVX(TOPs) + 1);
908 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
913 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
923 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
924 Perl_croak_no_modify(aTHX);
926 TARG = sv_newmortal();
927 sv_setsv(TARG, TOPs);
928 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
929 && SvIVX(TOPs) != IV_MIN)
931 SvIV_set(TOPs, SvIVX(TOPs) - 1);
932 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
941 /* Ordinary operators. */
945 dVAR; dSP; dATARGET; SV *svl, *svr;
946 #ifdef PERL_PRESERVE_IVUV
949 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
952 #ifdef PERL_PRESERVE_IVUV
953 /* For integer to integer power, we do the calculation by hand wherever
954 we're sure it is safe; otherwise we call pow() and try to convert to
955 integer afterwards. */
957 SvIV_please_nomg(svr);
959 SvIV_please_nomg(svl);
968 const IV iv = SvIVX(svr);
972 goto float_it; /* Can't do negative powers this way. */
976 baseuok = SvUOK(svl);
980 const IV iv = SvIVX(svl);
983 baseuok = TRUE; /* effectively it's a UV now */
985 baseuv = -iv; /* abs, baseuok == false records sign */
988 /* now we have integer ** positive integer. */
991 /* foo & (foo - 1) is zero only for a power of 2. */
992 if (!(baseuv & (baseuv - 1))) {
993 /* We are raising power-of-2 to a positive integer.
994 The logic here will work for any base (even non-integer
995 bases) but it can be less accurate than
996 pow (base,power) or exp (power * log (base)) when the
997 intermediate values start to spill out of the mantissa.
998 With powers of 2 we know this can't happen.
999 And powers of 2 are the favourite thing for perl
1000 programmers to notice ** not doing what they mean. */
1002 NV base = baseuok ? baseuv : -(NV)baseuv;
1007 while (power >>= 1) {
1015 SvIV_please_nomg(svr);
1018 register unsigned int highbit = 8 * sizeof(UV);
1019 register unsigned int diff = 8 * sizeof(UV);
1020 while (diff >>= 1) {
1022 if (baseuv >> highbit) {
1026 /* we now have baseuv < 2 ** highbit */
1027 if (power * highbit <= 8 * sizeof(UV)) {
1028 /* result will definitely fit in UV, so use UV math
1029 on same algorithm as above */
1030 register UV result = 1;
1031 register UV base = baseuv;
1032 const bool odd_power = cBOOL(power & 1);
1036 while (power >>= 1) {
1043 if (baseuok || !odd_power)
1044 /* answer is positive */
1046 else if (result <= (UV)IV_MAX)
1047 /* answer negative, fits in IV */
1048 SETi( -(IV)result );
1049 else if (result == (UV)IV_MIN)
1050 /* 2's complement assumption: special case IV_MIN */
1053 /* answer negative, doesn't fit */
1054 SETn( -(NV)result );
1064 NV right = SvNV_nomg(svr);
1065 NV left = SvNV_nomg(svl);
1068 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1070 We are building perl with long double support and are on an AIX OS
1071 afflicted with a powl() function that wrongly returns NaNQ for any
1072 negative base. This was reported to IBM as PMR #23047-379 on
1073 03/06/2006. The problem exists in at least the following versions
1074 of AIX and the libm fileset, and no doubt others as well:
1076 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1077 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1078 AIX 5.2.0 bos.adt.libm 5.2.0.85
1080 So, until IBM fixes powl(), we provide the following workaround to
1081 handle the problem ourselves. Our logic is as follows: for
1082 negative bases (left), we use fmod(right, 2) to check if the
1083 exponent is an odd or even integer:
1085 - if odd, powl(left, right) == -powl(-left, right)
1086 - if even, powl(left, right) == powl(-left, right)
1088 If the exponent is not an integer, the result is rightly NaNQ, so
1089 we just return that (as NV_NAN).
1093 NV mod2 = Perl_fmod( right, 2.0 );
1094 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1095 SETn( -Perl_pow( -left, right) );
1096 } else if (mod2 == 0.0) { /* even integer */
1097 SETn( Perl_pow( -left, right) );
1098 } else { /* fractional power */
1102 SETn( Perl_pow( left, right) );
1105 SETn( Perl_pow( left, right) );
1106 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1108 #ifdef PERL_PRESERVE_IVUV
1110 SvIV_please_nomg(svr);
1118 dVAR; dSP; dATARGET; SV *svl, *svr;
1119 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1122 #ifdef PERL_PRESERVE_IVUV
1123 SvIV_please_nomg(svr);
1125 /* Unless the left argument is integer in range we are going to have to
1126 use NV maths. Hence only attempt to coerce the right argument if
1127 we know the left is integer. */
1128 /* Left operand is defined, so is it IV? */
1129 SvIV_please_nomg(svl);
1131 bool auvok = SvUOK(svl);
1132 bool buvok = SvUOK(svr);
1133 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1134 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1143 const IV aiv = SvIVX(svl);
1146 auvok = TRUE; /* effectively it's a UV now */
1148 alow = -aiv; /* abs, auvok == false records sign */
1154 const IV biv = SvIVX(svr);
1157 buvok = TRUE; /* effectively it's a UV now */
1159 blow = -biv; /* abs, buvok == false records sign */
1163 /* If this does sign extension on unsigned it's time for plan B */
1164 ahigh = alow >> (4 * sizeof (UV));
1166 bhigh = blow >> (4 * sizeof (UV));
1168 if (ahigh && bhigh) {
1170 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1171 which is overflow. Drop to NVs below. */
1172 } else if (!ahigh && !bhigh) {
1173 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1174 so the unsigned multiply cannot overflow. */
1175 const UV product = alow * blow;
1176 if (auvok == buvok) {
1177 /* -ve * -ve or +ve * +ve gives a +ve result. */
1181 } else if (product <= (UV)IV_MIN) {
1182 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1183 /* -ve result, which could overflow an IV */
1185 SETi( -(IV)product );
1187 } /* else drop to NVs below. */
1189 /* One operand is large, 1 small */
1192 /* swap the operands */
1194 bhigh = blow; /* bhigh now the temp var for the swap */
1198 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1199 multiplies can't overflow. shift can, add can, -ve can. */
1200 product_middle = ahigh * blow;
1201 if (!(product_middle & topmask)) {
1202 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1204 product_middle <<= (4 * sizeof (UV));
1205 product_low = alow * blow;
1207 /* as for pp_add, UV + something mustn't get smaller.
1208 IIRC ANSI mandates this wrapping *behaviour* for
1209 unsigned whatever the actual representation*/
1210 product_low += product_middle;
1211 if (product_low >= product_middle) {
1212 /* didn't overflow */
1213 if (auvok == buvok) {
1214 /* -ve * -ve or +ve * +ve gives a +ve result. */
1216 SETu( product_low );
1218 } else if (product_low <= (UV)IV_MIN) {
1219 /* 2s complement assumption again */
1220 /* -ve result, which could overflow an IV */
1222 SETi( -(IV)product_low );
1224 } /* else drop to NVs below. */
1226 } /* product_middle too large */
1227 } /* ahigh && bhigh */
1232 NV right = SvNV_nomg(svr);
1233 NV left = SvNV_nomg(svl);
1235 SETn( left * right );
1242 dVAR; dSP; dATARGET; SV *svl, *svr;
1243 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1246 /* Only try to do UV divide first
1247 if ((SLOPPYDIVIDE is true) or
1248 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1250 The assumption is that it is better to use floating point divide
1251 whenever possible, only doing integer divide first if we can't be sure.
1252 If NV_PRESERVES_UV is true then we know at compile time that no UV
1253 can be too large to preserve, so don't need to compile the code to
1254 test the size of UVs. */
1257 # define PERL_TRY_UV_DIVIDE
1258 /* ensure that 20./5. == 4. */
1260 # ifdef PERL_PRESERVE_IVUV
1261 # ifndef NV_PRESERVES_UV
1262 # define PERL_TRY_UV_DIVIDE
1267 #ifdef PERL_TRY_UV_DIVIDE
1268 SvIV_please_nomg(svr);
1270 SvIV_please_nomg(svl);
1272 bool left_non_neg = SvUOK(svl);
1273 bool right_non_neg = SvUOK(svr);
1277 if (right_non_neg) {
1281 const IV biv = SvIVX(svr);
1284 right_non_neg = TRUE; /* effectively it's a UV now */
1290 /* historically undef()/0 gives a "Use of uninitialized value"
1291 warning before dieing, hence this test goes here.
1292 If it were immediately before the second SvIV_please, then
1293 DIE() would be invoked before left was even inspected, so
1294 no inpsection would give no warning. */
1296 DIE(aTHX_ "Illegal division by zero");
1302 const IV aiv = SvIVX(svl);
1305 left_non_neg = TRUE; /* effectively it's a UV now */
1314 /* For sloppy divide we always attempt integer division. */
1316 /* Otherwise we only attempt it if either or both operands
1317 would not be preserved by an NV. If both fit in NVs
1318 we fall through to the NV divide code below. However,
1319 as left >= right to ensure integer result here, we know that
1320 we can skip the test on the right operand - right big
1321 enough not to be preserved can't get here unless left is
1324 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1327 /* Integer division can't overflow, but it can be imprecise. */
1328 const UV result = left / right;
1329 if (result * right == left) {
1330 SP--; /* result is valid */
1331 if (left_non_neg == right_non_neg) {
1332 /* signs identical, result is positive. */
1336 /* 2s complement assumption */
1337 if (result <= (UV)IV_MIN)
1338 SETi( -(IV)result );
1340 /* It's exact but too negative for IV. */
1341 SETn( -(NV)result );
1344 } /* tried integer divide but it was not an integer result */
1345 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1346 } /* left wasn't SvIOK */
1347 } /* right wasn't SvIOK */
1348 #endif /* PERL_TRY_UV_DIVIDE */
1350 NV right = SvNV_nomg(svr);
1351 NV left = SvNV_nomg(svl);
1352 (void)POPs;(void)POPs;
1353 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1354 if (! Perl_isnan(right) && right == 0.0)
1358 DIE(aTHX_ "Illegal division by zero");
1359 PUSHn( left / right );
1366 dVAR; dSP; dATARGET;
1367 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1371 bool left_neg = FALSE;
1372 bool right_neg = FALSE;
1373 bool use_double = FALSE;
1374 bool dright_valid = FALSE;
1377 SV * const svr = TOPs;
1378 SV * const svl = TOPm1s;
1379 SvIV_please_nomg(svr);
1381 right_neg = !SvUOK(svr);
1385 const IV biv = SvIVX(svr);
1388 right_neg = FALSE; /* effectively it's a UV now */
1395 dright = SvNV_nomg(svr);
1396 right_neg = dright < 0;
1399 if (dright < UV_MAX_P1) {
1400 right = U_V(dright);
1401 dright_valid = TRUE; /* In case we need to use double below. */
1407 /* At this point use_double is only true if right is out of range for
1408 a UV. In range NV has been rounded down to nearest UV and
1409 use_double false. */
1410 SvIV_please_nomg(svl);
1411 if (!use_double && SvIOK(svl)) {
1413 left_neg = !SvUOK(svl);
1417 const IV aiv = SvIVX(svl);
1420 left_neg = FALSE; /* effectively it's a UV now */
1428 dleft = SvNV_nomg(svl);
1429 left_neg = dleft < 0;
1433 /* This should be exactly the 5.6 behaviour - if left and right are
1434 both in range for UV then use U_V() rather than floor. */
1436 if (dleft < UV_MAX_P1) {
1437 /* right was in range, so is dleft, so use UVs not double.
1441 /* left is out of range for UV, right was in range, so promote
1442 right (back) to double. */
1444 /* The +0.5 is used in 5.6 even though it is not strictly
1445 consistent with the implicit +0 floor in the U_V()
1446 inside the #if 1. */
1447 dleft = Perl_floor(dleft + 0.5);
1450 dright = Perl_floor(dright + 0.5);
1461 DIE(aTHX_ "Illegal modulus zero");
1463 dans = Perl_fmod(dleft, dright);
1464 if ((left_neg != right_neg) && dans)
1465 dans = dright - dans;
1468 sv_setnv(TARG, dans);
1474 DIE(aTHX_ "Illegal modulus zero");
1477 if ((left_neg != right_neg) && ans)
1480 /* XXX may warn: unary minus operator applied to unsigned type */
1481 /* could change -foo to be (~foo)+1 instead */
1482 if (ans <= ~((UV)IV_MAX)+1)
1483 sv_setiv(TARG, ~ans+1);
1485 sv_setnv(TARG, -(NV)ans);
1488 sv_setuv(TARG, ans);
1497 dVAR; dSP; dATARGET;
1501 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1502 /* TODO: think of some way of doing list-repeat overloading ??? */
1507 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1513 const UV uv = SvUV_nomg(sv);
1515 count = IV_MAX; /* The best we can do? */
1519 const IV iv = SvIV_nomg(sv);
1526 else if (SvNOKp(sv)) {
1527 const NV nv = SvNV_nomg(sv);
1534 count = SvIV_nomg(sv);
1536 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1538 static const char oom_list_extend[] = "Out of memory during list extend";
1539 const I32 items = SP - MARK;
1540 const I32 max = items * count;
1542 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1543 /* Did the max computation overflow? */
1544 if (items > 0 && max > 0 && (max < items || max < count))
1545 Perl_croak(aTHX_ oom_list_extend);
1550 /* This code was intended to fix 20010809.028:
1553 for (($x =~ /./g) x 2) {
1554 print chop; # "abcdabcd" expected as output.
1557 * but that change (#11635) broke this code:
1559 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1561 * I can't think of a better fix that doesn't introduce
1562 * an efficiency hit by copying the SVs. The stack isn't
1563 * refcounted, and mortalisation obviously doesn't
1564 * Do The Right Thing when the stack has more than
1565 * one pointer to the same mortal value.
1569 *SP = sv_2mortal(newSVsv(*SP));
1579 repeatcpy((char*)(MARK + items), (char*)MARK,
1580 items * sizeof(const SV *), count - 1);
1583 else if (count <= 0)
1586 else { /* Note: mark already snarfed by pp_list */
1587 SV * const tmpstr = POPs;
1590 static const char oom_string_extend[] =
1591 "Out of memory during string extend";
1594 sv_setsv_nomg(TARG, tmpstr);
1595 SvPV_force_nomg(TARG, len);
1596 isutf = DO_UTF8(TARG);
1601 const STRLEN max = (UV)count * len;
1602 if (len > MEM_SIZE_MAX / count)
1603 Perl_croak(aTHX_ oom_string_extend);
1604 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1605 SvGROW(TARG, max + 1);
1606 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1607 SvCUR_set(TARG, SvCUR(TARG) * count);
1609 *SvEND(TARG) = '\0';
1612 (void)SvPOK_only_UTF8(TARG);
1614 (void)SvPOK_only(TARG);
1616 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1617 /* The parser saw this as a list repeat, and there
1618 are probably several items on the stack. But we're
1619 in scalar context, and there's no pp_list to save us
1620 now. So drop the rest of the items -- robin@kitsite.com
1632 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1633 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1636 useleft = USE_LEFT(svl);
1637 #ifdef PERL_PRESERVE_IVUV
1638 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1639 "bad things" happen if you rely on signed integers wrapping. */
1640 SvIV_please_nomg(svr);
1642 /* Unless the left argument is integer in range we are going to have to
1643 use NV maths. Hence only attempt to coerce the right argument if
1644 we know the left is integer. */
1645 register UV auv = 0;
1651 a_valid = auvok = 1;
1652 /* left operand is undef, treat as zero. */
1654 /* Left operand is defined, so is it IV? */
1655 SvIV_please_nomg(svl);
1657 if ((auvok = SvUOK(svl)))
1660 register const IV aiv = SvIVX(svl);
1663 auvok = 1; /* Now acting as a sign flag. */
1664 } else { /* 2s complement assumption for IV_MIN */
1672 bool result_good = 0;
1675 bool buvok = SvUOK(svr);
1680 register const IV biv = SvIVX(svr);
1687 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1688 else "IV" now, independent of how it came in.
1689 if a, b represents positive, A, B negative, a maps to -A etc
1694 all UV maths. negate result if A negative.
1695 subtract if signs same, add if signs differ. */
1697 if (auvok ^ buvok) {
1706 /* Must get smaller */
1711 if (result <= buv) {
1712 /* result really should be -(auv-buv). as its negation
1713 of true value, need to swap our result flag */
1725 if (result <= (UV)IV_MIN)
1726 SETi( -(IV)result );
1728 /* result valid, but out of range for IV. */
1729 SETn( -(NV)result );
1733 } /* Overflow, drop through to NVs. */
1738 NV value = SvNV_nomg(svr);
1742 /* left operand is undef, treat as zero - value */
1746 SETn( SvNV_nomg(svl) - value );
1753 dVAR; dSP; dATARGET; SV *svl, *svr;
1754 tryAMAGICbin_MG(lshift_amg, AMGf_assign);
1758 const IV shift = SvIV_nomg(svr);
1759 if (PL_op->op_private & HINT_INTEGER) {
1760 const IV i = SvIV_nomg(svl);
1764 const UV u = SvUV_nomg(svl);
1773 dVAR; dSP; dATARGET; SV *svl, *svr;
1774 tryAMAGICbin_MG(rshift_amg, AMGf_assign);
1778 const IV shift = SvIV_nomg(svr);
1779 if (PL_op->op_private & HINT_INTEGER) {
1780 const IV i = SvIV_nomg(svl);
1784 const UV u = SvUV_nomg(svl);
1794 tryAMAGICbin_MG(lt_amg, AMGf_set);
1795 #ifdef PERL_PRESERVE_IVUV
1796 SvIV_please_nomg(TOPs);
1798 SvIV_please_nomg(TOPm1s);
1799 if (SvIOK(TOPm1s)) {
1800 bool auvok = SvUOK(TOPm1s);
1801 bool buvok = SvUOK(TOPs);
1803 if (!auvok && !buvok) { /* ## IV < IV ## */
1804 const IV aiv = SvIVX(TOPm1s);
1805 const IV biv = SvIVX(TOPs);
1808 SETs(boolSV(aiv < biv));
1811 if (auvok && buvok) { /* ## UV < UV ## */
1812 const UV auv = SvUVX(TOPm1s);
1813 const UV buv = SvUVX(TOPs);
1816 SETs(boolSV(auv < buv));
1819 if (auvok) { /* ## UV < IV ## */
1821 const IV biv = SvIVX(TOPs);
1824 /* As (a) is a UV, it's >=0, so it cannot be < */
1829 SETs(boolSV(auv < (UV)biv));
1832 { /* ## IV < UV ## */
1833 const IV aiv = SvIVX(TOPm1s);
1837 /* As (b) is a UV, it's >=0, so it must be < */
1844 SETs(boolSV((UV)aiv < buv));
1850 #ifndef NV_PRESERVES_UV
1851 #ifdef PERL_PRESERVE_IVUV
1854 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1856 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1861 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1863 if (Perl_isnan(left) || Perl_isnan(right))
1865 SETs(boolSV(left < right));
1868 SETs(boolSV(SvNV_nomg(TOPs) < value));
1877 tryAMAGICbin_MG(gt_amg, AMGf_set);
1878 #ifdef PERL_PRESERVE_IVUV
1879 SvIV_please_nomg(TOPs);
1881 SvIV_please_nomg(TOPm1s);
1882 if (SvIOK(TOPm1s)) {
1883 bool auvok = SvUOK(TOPm1s);
1884 bool buvok = SvUOK(TOPs);
1886 if (!auvok && !buvok) { /* ## IV > IV ## */
1887 const IV aiv = SvIVX(TOPm1s);
1888 const IV biv = SvIVX(TOPs);
1891 SETs(boolSV(aiv > biv));
1894 if (auvok && buvok) { /* ## UV > UV ## */
1895 const UV auv = SvUVX(TOPm1s);
1896 const UV buv = SvUVX(TOPs);
1899 SETs(boolSV(auv > buv));
1902 if (auvok) { /* ## UV > IV ## */
1904 const IV biv = SvIVX(TOPs);
1908 /* As (a) is a UV, it's >=0, so it must be > */
1913 SETs(boolSV(auv > (UV)biv));
1916 { /* ## IV > UV ## */
1917 const IV aiv = SvIVX(TOPm1s);
1921 /* As (b) is a UV, it's >=0, so it cannot be > */
1928 SETs(boolSV((UV)aiv > buv));
1934 #ifndef NV_PRESERVES_UV
1935 #ifdef PERL_PRESERVE_IVUV
1938 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1940 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1945 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1947 if (Perl_isnan(left) || Perl_isnan(right))
1949 SETs(boolSV(left > right));
1952 SETs(boolSV(SvNV_nomg(TOPs) > value));
1961 tryAMAGICbin_MG(le_amg, AMGf_set);
1962 #ifdef PERL_PRESERVE_IVUV
1963 SvIV_please_nomg(TOPs);
1965 SvIV_please_nomg(TOPm1s);
1966 if (SvIOK(TOPm1s)) {
1967 bool auvok = SvUOK(TOPm1s);
1968 bool buvok = SvUOK(TOPs);
1970 if (!auvok && !buvok) { /* ## IV <= IV ## */
1971 const IV aiv = SvIVX(TOPm1s);
1972 const IV biv = SvIVX(TOPs);
1975 SETs(boolSV(aiv <= biv));
1978 if (auvok && buvok) { /* ## UV <= UV ## */
1979 UV auv = SvUVX(TOPm1s);
1980 UV buv = SvUVX(TOPs);
1983 SETs(boolSV(auv <= buv));
1986 if (auvok) { /* ## UV <= IV ## */
1988 const IV biv = SvIVX(TOPs);
1992 /* As (a) is a UV, it's >=0, so a cannot be <= */
1997 SETs(boolSV(auv <= (UV)biv));
2000 { /* ## IV <= UV ## */
2001 const IV aiv = SvIVX(TOPm1s);
2005 /* As (b) is a UV, it's >=0, so a must be <= */
2012 SETs(boolSV((UV)aiv <= buv));
2018 #ifndef NV_PRESERVES_UV
2019 #ifdef PERL_PRESERVE_IVUV
2022 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2024 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2029 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2031 if (Perl_isnan(left) || Perl_isnan(right))
2033 SETs(boolSV(left <= right));
2036 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2045 tryAMAGICbin_MG(ge_amg,AMGf_set);
2046 #ifdef PERL_PRESERVE_IVUV
2047 SvIV_please_nomg(TOPs);
2049 SvIV_please_nomg(TOPm1s);
2050 if (SvIOK(TOPm1s)) {
2051 bool auvok = SvUOK(TOPm1s);
2052 bool buvok = SvUOK(TOPs);
2054 if (!auvok && !buvok) { /* ## IV >= IV ## */
2055 const IV aiv = SvIVX(TOPm1s);
2056 const IV biv = SvIVX(TOPs);
2059 SETs(boolSV(aiv >= biv));
2062 if (auvok && buvok) { /* ## UV >= UV ## */
2063 const UV auv = SvUVX(TOPm1s);
2064 const UV buv = SvUVX(TOPs);
2067 SETs(boolSV(auv >= buv));
2070 if (auvok) { /* ## UV >= IV ## */
2072 const IV biv = SvIVX(TOPs);
2076 /* As (a) is a UV, it's >=0, so it must be >= */
2081 SETs(boolSV(auv >= (UV)biv));
2084 { /* ## IV >= UV ## */
2085 const IV aiv = SvIVX(TOPm1s);
2089 /* As (b) is a UV, it's >=0, so a cannot be >= */
2096 SETs(boolSV((UV)aiv >= buv));
2102 #ifndef NV_PRESERVES_UV
2103 #ifdef PERL_PRESERVE_IVUV
2106 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2108 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2113 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2115 if (Perl_isnan(left) || Perl_isnan(right))
2117 SETs(boolSV(left >= right));
2120 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2129 tryAMAGICbin_MG(ne_amg,AMGf_set);
2130 #ifndef NV_PRESERVES_UV
2131 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2133 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2137 #ifdef PERL_PRESERVE_IVUV
2138 SvIV_please_nomg(TOPs);
2140 SvIV_please_nomg(TOPm1s);
2141 if (SvIOK(TOPm1s)) {
2142 const bool auvok = SvUOK(TOPm1s);
2143 const bool buvok = SvUOK(TOPs);
2145 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2146 /* Casting IV to UV before comparison isn't going to matter
2147 on 2s complement. On 1s complement or sign&magnitude
2148 (if we have any of them) it could make negative zero
2149 differ from normal zero. As I understand it. (Need to
2150 check - is negative zero implementation defined behaviour
2152 const UV buv = SvUVX(POPs);
2153 const UV auv = SvUVX(TOPs);
2155 SETs(boolSV(auv != buv));
2158 { /* ## Mixed IV,UV ## */
2162 /* != is commutative so swap if needed (save code) */
2164 /* swap. top of stack (b) is the iv */
2168 /* As (a) is a UV, it's >0, so it cannot be == */
2177 /* As (b) is a UV, it's >0, so it cannot be == */
2181 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2183 SETs(boolSV((UV)iv != uv));
2190 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2192 if (Perl_isnan(left) || Perl_isnan(right))
2194 SETs(boolSV(left != right));
2197 SETs(boolSV(SvNV_nomg(TOPs) != value));
2206 tryAMAGICbin_MG(ncmp_amg, 0);
2207 #ifndef NV_PRESERVES_UV
2208 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2209 const UV right = PTR2UV(SvRV(POPs));
2210 const UV left = PTR2UV(SvRV(TOPs));
2211 SETi((left > right) - (left < right));
2215 #ifdef PERL_PRESERVE_IVUV
2216 /* Fortunately it seems NaN isn't IOK */
2217 SvIV_please_nomg(TOPs);
2219 SvIV_please_nomg(TOPm1s);
2220 if (SvIOK(TOPm1s)) {
2221 const bool leftuvok = SvUOK(TOPm1s);
2222 const bool rightuvok = SvUOK(TOPs);
2224 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2225 const IV leftiv = SvIVX(TOPm1s);
2226 const IV rightiv = SvIVX(TOPs);
2228 if (leftiv > rightiv)
2230 else if (leftiv < rightiv)
2234 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2235 const UV leftuv = SvUVX(TOPm1s);
2236 const UV rightuv = SvUVX(TOPs);
2238 if (leftuv > rightuv)
2240 else if (leftuv < rightuv)
2244 } else if (leftuvok) { /* ## UV <=> IV ## */
2245 const IV rightiv = SvIVX(TOPs);
2247 /* As (a) is a UV, it's >=0, so it cannot be < */
2250 const UV leftuv = SvUVX(TOPm1s);
2251 if (leftuv > (UV)rightiv) {
2253 } else if (leftuv < (UV)rightiv) {
2259 } else { /* ## IV <=> UV ## */
2260 const IV leftiv = SvIVX(TOPm1s);
2262 /* As (b) is a UV, it's >=0, so it must be < */
2265 const UV rightuv = SvUVX(TOPs);
2266 if ((UV)leftiv > rightuv) {
2268 } else if ((UV)leftiv < rightuv) {
2286 if (Perl_isnan(left) || Perl_isnan(right)) {
2290 value = (left > right) - (left < right);
2294 else if (left < right)
2296 else if (left > right)
2312 int amg_type = sle_amg;
2316 switch (PL_op->op_type) {
2335 tryAMAGICbin_MG(amg_type, AMGf_set);
2338 const int cmp = (IN_LOCALE_RUNTIME
2339 ? sv_cmp_locale_flags(left, right, 0)
2340 : sv_cmp_flags(left, right, 0));
2341 SETs(boolSV(cmp * multiplier < rhs));
2349 tryAMAGICbin_MG(seq_amg, AMGf_set);
2352 SETs(boolSV(sv_eq_flags(left, right, 0)));
2360 tryAMAGICbin_MG(sne_amg, AMGf_set);
2363 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2371 tryAMAGICbin_MG(scmp_amg, 0);
2374 const int cmp = (IN_LOCALE_RUNTIME
2375 ? sv_cmp_locale_flags(left, right, 0)
2376 : sv_cmp_flags(left, right, 0));
2384 dVAR; dSP; dATARGET;
2385 tryAMAGICbin_MG(band_amg, AMGf_assign);
2388 if (SvNIOKp(left) || SvNIOKp(right)) {
2389 if (PL_op->op_private & HINT_INTEGER) {
2390 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2394 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2399 do_vop(PL_op->op_type, TARG, left, right);
2408 dVAR; dSP; dATARGET;
2409 const int op_type = PL_op->op_type;
2411 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2414 if (SvNIOKp(left) || SvNIOKp(right)) {
2415 if (PL_op->op_private & HINT_INTEGER) {
2416 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2417 const IV r = SvIV_nomg(right);
2418 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2422 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2423 const UV r = SvUV_nomg(right);
2424 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2429 do_vop(op_type, TARG, left, right);
2439 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2441 SV * const sv = TOPs;
2442 const int flags = SvFLAGS(sv);
2443 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2444 /* It's publicly an integer, or privately an integer-not-float */
2447 if (SvIVX(sv) == IV_MIN) {
2448 /* 2s complement assumption. */
2449 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2452 else if (SvUVX(sv) <= IV_MAX) {
2457 else if (SvIVX(sv) != IV_MIN) {
2461 #ifdef PERL_PRESERVE_IVUV
2469 SETn(-SvNV_nomg(sv));
2470 else if (SvPOKp(sv)) {
2472 const char * const s = SvPV_nomg_const(sv, len);
2473 if (isIDFIRST(*s)) {
2474 sv_setpvs(TARG, "-");
2477 else if (*s == '+' || *s == '-') {
2478 sv_setsv_nomg(TARG, sv);
2479 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2481 else if (DO_UTF8(sv)) {
2482 SvIV_please_nomg(sv);
2484 goto oops_its_an_int;
2486 sv_setnv(TARG, -SvNV_nomg(sv));
2488 sv_setpvs(TARG, "-");
2493 SvIV_please_nomg(sv);
2495 goto oops_its_an_int;
2496 sv_setnv(TARG, -SvNV_nomg(sv));
2501 SETn(-SvNV_nomg(sv));
2509 tryAMAGICun_MG(not_amg, AMGf_set);
2510 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2517 tryAMAGICun_MG(compl_amg, 0);
2521 if (PL_op->op_private & HINT_INTEGER) {
2522 const IV i = ~SvIV_nomg(sv);
2526 const UV u = ~SvUV_nomg(sv);
2535 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2536 sv_setsv_nomg(TARG, sv);
2537 tmps = (U8*)SvPV_force_nomg(TARG, len);
2540 /* Calculate exact length, let's not estimate. */
2545 U8 * const send = tmps + len;
2546 U8 * const origtmps = tmps;
2547 const UV utf8flags = UTF8_ALLOW_ANYUV;
2549 while (tmps < send) {
2550 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2552 targlen += UNISKIP(~c);
2558 /* Now rewind strings and write them. */
2565 Newx(result, targlen + 1, U8);
2567 while (tmps < send) {
2568 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2570 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2573 sv_usepvn_flags(TARG, (char*)result, targlen,
2574 SV_HAS_TRAILING_NUL);
2581 Newx(result, nchar + 1, U8);
2583 while (tmps < send) {
2584 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2589 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2597 register long *tmpl;
2598 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2601 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2606 for ( ; anum > 0; anum--, tmps++)
2614 /* integer versions of some of the above */
2618 dVAR; dSP; dATARGET;
2619 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2622 SETi( left * right );
2630 dVAR; dSP; dATARGET;
2631 tryAMAGICbin_MG(div_amg, AMGf_assign);
2634 IV value = SvIV_nomg(right);
2636 DIE(aTHX_ "Illegal division by zero");
2637 num = SvIV_nomg(left);
2639 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2643 value = num / value;
2649 #if defined(__GLIBC__) && IVSIZE == 8
2656 /* This is the vanilla old i_modulo. */
2657 dVAR; dSP; dATARGET;
2658 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2662 DIE(aTHX_ "Illegal modulus zero");
2663 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2667 SETi( left % right );
2672 #if defined(__GLIBC__) && IVSIZE == 8
2677 /* This is the i_modulo with the workaround for the _moddi3 bug
2678 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2679 * See below for pp_i_modulo. */
2680 dVAR; dSP; dATARGET;
2681 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2685 DIE(aTHX_ "Illegal modulus zero");
2686 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2690 SETi( left % PERL_ABS(right) );
2697 dVAR; dSP; dATARGET;
2698 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2702 DIE(aTHX_ "Illegal modulus zero");
2703 /* The assumption is to use hereafter the old vanilla version... */
2705 PL_ppaddr[OP_I_MODULO] =
2707 /* .. but if we have glibc, we might have a buggy _moddi3
2708 * (at least glicb 2.2.5 is known to have this bug), in other
2709 * words our integer modulus with negative quad as the second
2710 * argument might be broken. Test for this and re-patch the
2711 * opcode dispatch table if that is the case, remembering to
2712 * also apply the workaround so that this first round works
2713 * right, too. See [perl #9402] for more information. */
2717 /* Cannot do this check with inlined IV constants since
2718 * that seems to work correctly even with the buggy glibc. */
2720 /* Yikes, we have the bug.
2721 * Patch in the workaround version. */
2723 PL_ppaddr[OP_I_MODULO] =
2724 &Perl_pp_i_modulo_1;
2725 /* Make certain we work right this time, too. */
2726 right = PERL_ABS(right);
2729 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2733 SETi( left % right );
2741 dVAR; dSP; dATARGET;
2742 tryAMAGICbin_MG(add_amg, AMGf_assign);
2744 dPOPTOPiirl_ul_nomg;
2745 SETi( left + right );
2752 dVAR; dSP; dATARGET;
2753 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2755 dPOPTOPiirl_ul_nomg;
2756 SETi( left - right );
2764 tryAMAGICbin_MG(lt_amg, AMGf_set);
2767 SETs(boolSV(left < right));
2775 tryAMAGICbin_MG(gt_amg, AMGf_set);
2778 SETs(boolSV(left > right));
2786 tryAMAGICbin_MG(le_amg, AMGf_set);
2789 SETs(boolSV(left <= right));
2797 tryAMAGICbin_MG(ge_amg, AMGf_set);
2800 SETs(boolSV(left >= right));
2808 tryAMAGICbin_MG(eq_amg, AMGf_set);
2811 SETs(boolSV(left == right));
2819 tryAMAGICbin_MG(ne_amg, AMGf_set);
2822 SETs(boolSV(left != right));
2830 tryAMAGICbin_MG(ncmp_amg, 0);
2837 else if (left < right)
2849 tryAMAGICun_MG(neg_amg, 0);
2851 SV * const sv = TOPs;
2852 IV const i = SvIV_nomg(sv);
2858 /* High falutin' math. */
2863 tryAMAGICbin_MG(atan2_amg, 0);
2866 SETn(Perl_atan2(left, right));
2874 int amg_type = sin_amg;
2875 const char *neg_report = NULL;
2876 NV (*func)(NV) = Perl_sin;
2877 const int op_type = PL_op->op_type;
2894 amg_type = sqrt_amg;
2896 neg_report = "sqrt";
2901 tryAMAGICun_MG(amg_type, 0);
2903 SV * const arg = POPs;
2904 const NV value = SvNV_nomg(arg);
2906 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2907 SET_NUMERIC_STANDARD();
2908 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2911 XPUSHn(func(value));
2916 /* Support Configure command-line overrides for rand() functions.
2917 After 5.005, perhaps we should replace this by Configure support
2918 for drand48(), random(), or rand(). For 5.005, though, maintain
2919 compatibility by calling rand() but allow the user to override it.
2920 See INSTALL for details. --Andy Dougherty 15 July 1998
2922 /* Now it's after 5.005, and Configure supports drand48() and random(),
2923 in addition to rand(). So the overrides should not be needed any more.
2924 --Jarkko Hietaniemi 27 September 1998
2927 #ifndef HAS_DRAND48_PROTO
2928 extern double drand48 (void);
2941 if (!PL_srand_called) {
2942 (void)seedDrand01((Rand_seed_t)seed());
2943 PL_srand_called = TRUE;
2953 const UV anum = (MAXARG < 1) ? seed() : POPu;
2954 (void)seedDrand01((Rand_seed_t)anum);
2955 PL_srand_called = TRUE;
2959 /* Historically srand always returned true. We can avoid breaking
2961 sv_setpvs(TARG, "0 but true");
2970 tryAMAGICun_MG(int_amg, AMGf_numeric);
2972 SV * const sv = TOPs;
2973 const IV iv = SvIV_nomg(sv);
2974 /* XXX it's arguable that compiler casting to IV might be subtly
2975 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2976 else preferring IV has introduced a subtle behaviour change bug. OTOH
2977 relying on floating point to be accurate is a bug. */
2982 else if (SvIOK(sv)) {
2984 SETu(SvUV_nomg(sv));
2989 const NV value = SvNV_nomg(sv);
2991 if (value < (NV)UV_MAX + 0.5) {
2994 SETn(Perl_floor(value));
2998 if (value > (NV)IV_MIN - 0.5) {
3001 SETn(Perl_ceil(value));
3012 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3014 SV * const sv = TOPs;
3015 /* This will cache the NV value if string isn't actually integer */
3016 const IV iv = SvIV_nomg(sv);
3021 else if (SvIOK(sv)) {
3022 /* IVX is precise */
3024 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3032 /* 2s complement assumption. Also, not really needed as
3033 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3039 const NV value = SvNV_nomg(sv);
3053 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3057 SV* const sv = POPs;
3059 tmps = (SvPV_const(sv, len));
3061 /* If Unicode, try to downgrade
3062 * If not possible, croak. */
3063 SV* const tsv = sv_2mortal(newSVsv(sv));
3066 sv_utf8_downgrade(tsv, FALSE);
3067 tmps = SvPV_const(tsv, len);
3069 if (PL_op->op_type == OP_HEX)
3072 while (*tmps && len && isSPACE(*tmps))
3076 if (*tmps == 'x' || *tmps == 'X') {
3078 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3080 else if (*tmps == 'b' || *tmps == 'B')
3081 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3083 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3085 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3099 SV * const sv = TOPs;
3101 if (SvGAMAGIC(sv)) {
3102 /* For an overloaded or magic scalar, we can't know in advance if
3103 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3104 it likes to cache the length. Maybe that should be a documented
3109 = sv_2pv_flags(sv, &len,
3110 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3113 sv_setsv(TARG, &PL_sv_undef);
3116 else if (DO_UTF8(sv)) {
3117 SETi(utf8_length((U8*)p, (U8*)p + len));
3121 } else if (SvOK(sv)) {
3122 /* Neither magic nor overloaded. */
3124 SETi(sv_len_utf8(sv));
3128 sv_setsv_nomg(TARG, &PL_sv_undef);
3148 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3150 const IV arybase = CopARYBASE_get(PL_curcop);
3152 const char *repl = NULL;
3154 const int num_args = PL_op->op_private & 7;
3155 bool repl_need_utf8_upgrade = FALSE;
3156 bool repl_is_utf8 = FALSE;
3161 repl = SvPV_const(repl_sv, repl_len);
3162 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3165 len_iv = SvIV(len_sv);
3166 len_is_uv = SvIOK_UV(len_sv);
3169 pos1_iv = SvIV(pos_sv);
3170 pos1_is_uv = SvIOK_UV(pos_sv);
3176 sv_utf8_upgrade(sv);
3178 else if (DO_UTF8(sv))
3179 repl_need_utf8_upgrade = TRUE;
3181 tmps = SvPV_const(sv, curlen);
3183 utf8_curlen = sv_len_utf8(sv);
3184 if (utf8_curlen == curlen)
3187 curlen = utf8_curlen;
3192 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3193 UV pos1_uv = pos1_iv-arybase;
3194 /* Overflow can occur when $[ < 0 */
3195 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3200 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3201 goto bound_fail; /* $[=3; substr($_,2,...) */
3203 else { /* pos < $[ */
3204 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3209 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3214 if (pos1_is_uv || pos1_iv > 0) {
3215 if ((UV)pos1_iv > curlen)
3220 if (!len_is_uv && len_iv < 0) {
3221 pos2_iv = curlen + len_iv;
3223 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3226 } else { /* len_iv >= 0 */
3227 if (!pos1_is_uv && pos1_iv < 0) {
3228 pos2_iv = pos1_iv + len_iv;
3229 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3231 if ((UV)len_iv > curlen-(UV)pos1_iv)
3234 pos2_iv = pos1_iv+len_iv;
3244 if (!pos2_is_uv && pos2_iv < 0) {
3245 if (!pos1_is_uv && pos1_iv < 0)
3249 else if (!pos1_is_uv && pos1_iv < 0)
3252 if ((UV)pos2_iv < (UV)pos1_iv)
3254 if ((UV)pos2_iv > curlen)
3258 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3259 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3260 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3261 STRLEN byte_len = len;
3262 STRLEN byte_pos = utf8_curlen
3263 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3265 if (lvalue && !repl) {
3268 if (!SvGMAGICAL(sv)) {
3270 SvPV_force_nolen(sv);
3271 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3272 "Attempt to use reference as lvalue in substr");
3274 if (isGV_with_GP(sv))
3275 SvPV_force_nolen(sv);
3276 else if (SvOK(sv)) /* is it defined ? */
3277 (void)SvPOK_only_UTF8(sv);
3279 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3282 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3283 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3285 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3286 LvTARGOFF(ret) = pos;
3287 LvTARGLEN(ret) = len;
3290 PUSHs(ret); /* avoid SvSETMAGIC here */
3294 SvTAINTED_off(TARG); /* decontaminate */
3295 SvUTF8_off(TARG); /* decontaminate */
3298 sv_setpvn(TARG, tmps, byte_len);
3299 #ifdef USE_LOCALE_COLLATE
3300 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3306 SV* repl_sv_copy = NULL;
3308 if (repl_need_utf8_upgrade) {
3309 repl_sv_copy = newSVsv(repl_sv);
3310 sv_utf8_upgrade(repl_sv_copy);
3311 repl = SvPV_const(repl_sv_copy, repl_len);
3312 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3316 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3319 SvREFCNT_dec(repl_sv_copy);
3323 PUSHs(TARG); /* avoid SvSETMAGIC here */
3328 Perl_croak(aTHX_ "substr outside of string");
3329 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3336 register const IV size = POPi;
3337 register const IV offset = POPi;
3338 register SV * const src = POPs;
3339 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3342 if (lvalue) { /* it's an lvalue! */
3343 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3344 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3346 LvTARG(ret) = SvREFCNT_inc_simple(src);
3347 LvTARGOFF(ret) = offset;
3348 LvTARGLEN(ret) = size;
3352 SvTAINTED_off(TARG); /* decontaminate */
3356 sv_setuv(ret, do_vecget(src, offset, size));
3372 const char *little_p;
3373 const I32 arybase = CopARYBASE_get(PL_curcop);
3376 const bool is_index = PL_op->op_type == OP_INDEX;
3379 /* arybase is in characters, like offset, so combine prior to the
3380 UTF-8 to bytes calculation. */
3381 offset = POPi - arybase;
3385 big_p = SvPV_const(big, biglen);
3386 little_p = SvPV_const(little, llen);
3388 big_utf8 = DO_UTF8(big);
3389 little_utf8 = DO_UTF8(little);
3390 if (big_utf8 ^ little_utf8) {
3391 /* One needs to be upgraded. */
3392 if (little_utf8 && !PL_encoding) {
3393 /* Well, maybe instead we might be able to downgrade the small
3395 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3398 /* If the large string is ISO-8859-1, and it's not possible to
3399 convert the small string to ISO-8859-1, then there is no
3400 way that it could be found anywhere by index. */
3405 /* At this point, pv is a malloc()ed string. So donate it to temp
3406 to ensure it will get free()d */
3407 little = temp = newSV(0);
3408 sv_usepvn(temp, pv, llen);
3409 little_p = SvPVX(little);
3412 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3415 sv_recode_to_utf8(temp, PL_encoding);
3417 sv_utf8_upgrade(temp);
3422 big_p = SvPV_const(big, biglen);
3425 little_p = SvPV_const(little, llen);
3429 if (SvGAMAGIC(big)) {
3430 /* Life just becomes a lot easier if I use a temporary here.
3431 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3432 will trigger magic and overloading again, as will fbm_instr()
3434 big = newSVpvn_flags(big_p, biglen,
3435 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3438 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3439 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3440 warn on undef, and we've already triggered a warning with the
3441 SvPV_const some lines above. We can't remove that, as we need to
3442 call some SvPV to trigger overloading early and find out if the
3444 This is all getting to messy. The API isn't quite clean enough,
3445 because data access has side effects.
3447 little = newSVpvn_flags(little_p, llen,
3448 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3449 little_p = SvPVX(little);
3453 offset = is_index ? 0 : biglen;
3455 if (big_utf8 && offset > 0)
3456 sv_pos_u2b(big, &offset, 0);
3462 else if (offset > (I32)biglen)
3464 if (!(little_p = is_index
3465 ? fbm_instr((unsigned char*)big_p + offset,
3466 (unsigned char*)big_p + biglen, little, 0)
3467 : rninstr(big_p, big_p + offset,
3468 little_p, little_p + llen)))
3471 retval = little_p - big_p;
3472 if (retval > 0 && big_utf8)
3473 sv_pos_b2u(big, &retval);
3477 PUSHi(retval + arybase);
3483 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3484 if (SvTAINTED(MARK[1]))
3485 TAINT_PROPER("sprintf");
3486 SvTAINTED_off(TARG);
3487 do_sprintf(TARG, SP-MARK, MARK+1);
3488 TAINT_IF(SvTAINTED(TARG));
3500 const U8 *s = (U8*)SvPV_const(argsv, len);
3502 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3503 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3504 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3508 XPUSHu(DO_UTF8(argsv) ?
3509 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3521 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3523 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3525 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3527 (void) POPs; /* Ignore the argument value. */
3528 value = UNICODE_REPLACEMENT;
3534 SvUPGRADE(TARG,SVt_PV);
3536 if (value > 255 && !IN_BYTES) {
3537 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3538 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3539 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3541 (void)SvPOK_only(TARG);
3550 *tmps++ = (char)value;
3552 (void)SvPOK_only(TARG);
3554 if (PL_encoding && !IN_BYTES) {
3555 sv_recode_to_utf8(TARG, PL_encoding);
3557 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3558 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3562 *tmps++ = (char)value;
3578 const char *tmps = SvPV_const(left, len);
3580 if (DO_UTF8(left)) {
3581 /* If Unicode, try to downgrade.
3582 * If not possible, croak.
3583 * Yes, we made this up. */
3584 SV* const tsv = sv_2mortal(newSVsv(left));
3587 sv_utf8_downgrade(tsv, FALSE);
3588 tmps = SvPV_const(tsv, len);
3590 # ifdef USE_ITHREADS
3592 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3593 /* This should be threadsafe because in ithreads there is only
3594 * one thread per interpreter. If this would not be true,
3595 * we would need a mutex to protect this malloc. */
3596 PL_reentrant_buffer->_crypt_struct_buffer =
3597 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3598 #if defined(__GLIBC__) || defined(__EMX__)
3599 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3600 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3601 /* work around glibc-2.2.5 bug */
3602 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3606 # endif /* HAS_CRYPT_R */
3607 # endif /* USE_ITHREADS */
3609 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3611 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3617 "The crypt() function is unimplemented due to excessive paranoia.");
3621 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3622 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3624 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3625 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3626 * See http://www.unicode.org/unicode/reports/tr16 */
3627 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3628 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3630 /* Below are several macros that generate code */
3631 /* Generates code to store a unicode codepoint c that is known to occupy
3632 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3633 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3635 *(p) = UTF8_TWO_BYTE_HI(c); \
3636 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3639 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3640 * available byte after the two bytes */
3641 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3643 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3644 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3647 /* Generates code to store the upper case of latin1 character l which is known
3648 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3649 * are only two characters that fit this description, and this macro knows
3650 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3652 #define STORE_NON_LATIN1_UC(p, l) \
3654 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3655 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3656 } else { /* Must be the following letter */ \
3657 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3661 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3662 * after the character stored */
3663 #define CAT_NON_LATIN1_UC(p, l) \
3665 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3666 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3668 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3672 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3673 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3674 * and must require two bytes to store it. Advances p to point to the next
3675 * available position */
3676 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3678 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3679 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3680 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3681 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3682 } else {/* else is one of the other two special cases */ \
3683 CAT_NON_LATIN1_UC((p), (l)); \
3689 /* Actually is both lcfirst() and ucfirst(). Only the first character
3690 * changes. This means that possibly we can change in-place, ie., just
3691 * take the source and change that one character and store it back, but not
3692 * if read-only etc, or if the length changes */
3697 STRLEN slen; /* slen is the byte length of the whole SV. */
3700 bool inplace; /* ? Convert first char only, in-place */
3701 bool doing_utf8 = FALSE; /* ? using utf8 */
3702 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3703 const int op_type = PL_op->op_type;
3706 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3707 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3708 * stored as UTF-8 at s. */
3709 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3710 * lowercased) character stored in tmpbuf. May be either
3711 * UTF-8 or not, but in either case is the number of bytes */
3715 s = (const U8*)SvPV_nomg_const(source, slen);
3717 if (ckWARN(WARN_UNINITIALIZED))
3718 report_uninit(source);
3723 /* We may be able to get away with changing only the first character, in
3724 * place, but not if read-only, etc. Later we may discover more reasons to
3725 * not convert in-place. */
3726 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3728 /* First calculate what the changed first character should be. This affects
3729 * whether we can just swap it out, leaving the rest of the string unchanged,
3730 * or even if have to convert the dest to UTF-8 when the source isn't */
3732 if (! slen) { /* If empty */
3733 need = 1; /* still need a trailing NUL */
3735 else if (DO_UTF8(source)) { /* Is the source utf8? */
3738 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3739 * and doesn't allow for the user to specify their own. When code is added to
3740 * detect if there is a user-defined mapping in force here, and if so to use
3741 * that, then the code below can be compiled. The detection would be a good
3742 * thing anyway, as currently the user-defined mappings only work on utf8
3743 * strings, and thus depend on the chosen internal storage method, which is a
3745 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3746 if (UTF8_IS_INVARIANT(*s)) {
3748 /* An invariant source character is either ASCII or, in EBCDIC, an
3749 * ASCII equivalent or a caseless C1 control. In both these cases,
3750 * the lower and upper cases of any character are also invariants
3751 * (and title case is the same as upper case). So it is safe to
3752 * use the simple case change macros which avoid the overhead of
3753 * the general functions. Note that if perl were to be extended to
3754 * do locale handling in UTF-8 strings, this wouldn't be true in,
3755 * for example, Lithuanian or Turkic. */
3756 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3760 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3763 /* Similarly, if the source character isn't invariant but is in the
3764 * latin1 range (or EBCDIC equivalent thereof), we have the case
3765 * changes compiled into perl, and can avoid the overhead of the
3766 * general functions. In this range, the characters are stored as
3767 * two UTF-8 bytes, and it so happens that any changed-case version
3768 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3772 /* Convert the two source bytes to a single Unicode code point
3773 * value, change case and save for below */
3774 chr = UTF8_ACCUMULATE(*s, *(s+1));
3775 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3776 U8 lower = toLOWER_LATIN1(chr);
3777 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3779 else { /* ucfirst */
3780 U8 upper = toUPPER_LATIN1_MOD(chr);
3782 /* Most of the latin1 range characters are well-behaved. Their
3783 * title and upper cases are the same, and are also in the
3784 * latin1 range. The macro above returns their upper (hence
3785 * title) case, and all that need be done is to save the result
3786 * for below. However, several characters are problematic, and
3787 * have to be handled specially. The MOD in the macro name
3788 * above means that these tricky characters all get mapped to
3789 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3790 * This mapping saves some tests for the majority of the
3793 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3795 /* Not tricky. Just save it. */
3796 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3798 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3800 /* This one is tricky because it is two characters long,
3801 * though the UTF-8 is still two bytes, so the stored
3802 * length doesn't change */
3803 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3804 *(tmpbuf + 1) = 's';
3808 /* The other two have their title and upper cases the same,
3809 * but are tricky because the changed-case characters
3810 * aren't in the latin1 range. They, however, do fit into
3811 * two UTF-8 bytes */
3812 STORE_NON_LATIN1_UC(tmpbuf, chr);
3817 #endif /* end of dont want to break user-defined casing */
3819 /* Here, can't short-cut the general case */
3821 utf8_to_uvchr(s, &ulen);
3822 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3823 else toLOWER_utf8(s, tmpbuf, &tculen);
3825 /* we can't do in-place if the length changes. */
3826 if (ulen != tculen) inplace = FALSE;
3827 need = slen + 1 - ulen + tculen;
3828 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3832 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3833 * latin1 is treated as caseless. Note that a locale takes
3835 tculen = 1; /* Most characters will require one byte, but this will
3836 * need to be overridden for the tricky ones */
3839 if (op_type == OP_LCFIRST) {
3841 /* lower case the first letter: no trickiness for any character */
3842 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3843 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3846 else if (IN_LOCALE_RUNTIME) {
3847 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3848 * have upper and title case different
3851 else if (! IN_UNI_8_BIT) {
3852 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3853 * on EBCDIC machines whatever the
3854 * native function does */
3856 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3857 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3859 /* tmpbuf now has the correct title case for all latin1 characters
3860 * except for the several ones that have tricky handling. All
3861 * of these are mapped by the MOD to the letter below. */
3862 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3864 /* The length is going to change, with all three of these, so
3865 * can't replace just the first character */
3868 /* We use the original to distinguish between these tricky
3870 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3871 /* Two character title case 'Ss', but can remain non-UTF-8 */
3874 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3879 /* The other two tricky ones have their title case outside
3880 * latin1. It is the same as their upper case. */
3882 STORE_NON_LATIN1_UC(tmpbuf, *s);
3884 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3885 * and their upper cases is 2. */
3888 /* The entire result will have to be in UTF-8. Assume worst
3889 * case sizing in conversion. (all latin1 characters occupy
3890 * at most two bytes in utf8) */
3891 convert_source_to_utf8 = TRUE;
3892 need = slen * 2 + 1;
3894 } /* End of is one of the three special chars */
3895 } /* End of use Unicode (Latin1) semantics */
3896 } /* End of changing the case of the first character */
3898 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3899 * generate the result */
3902 /* We can convert in place. This means we change just the first
3903 * character without disturbing the rest; no need to grow */
3905 s = d = (U8*)SvPV_force_nomg(source, slen);
3911 /* Here, we can't convert in place; we earlier calculated how much
3912 * space we will need, so grow to accommodate that */
3913 SvUPGRADE(dest, SVt_PV);
3914 d = (U8*)SvGROW(dest, need);
3915 (void)SvPOK_only(dest);
3922 if (! convert_source_to_utf8) {
3924 /* Here both source and dest are in UTF-8, but have to create
3925 * the entire output. We initialize the result to be the
3926 * title/lower cased first character, and then append the rest
3928 sv_setpvn(dest, (char*)tmpbuf, tculen);
3930 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3934 const U8 *const send = s + slen;
3936 /* Here the dest needs to be in UTF-8, but the source isn't,
3937 * except we earlier UTF-8'd the first character of the source
3938 * into tmpbuf. First put that into dest, and then append the
3939 * rest of the source, converting it to UTF-8 as we go. */
3941 /* Assert tculen is 2 here because the only two characters that
3942 * get to this part of the code have 2-byte UTF-8 equivalents */
3944 *d++ = *(tmpbuf + 1);
3945 s++; /* We have just processed the 1st char */
3947 for (; s < send; s++) {
3948 d = uvchr_to_utf8(d, *s);
3951 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3955 else { /* in-place UTF-8. Just overwrite the first character */
3956 Copy(tmpbuf, d, tculen, U8);
3957 SvCUR_set(dest, need - 1);
3960 else { /* Neither source nor dest are in or need to be UTF-8 */
3962 if (IN_LOCALE_RUNTIME) {
3966 if (inplace) { /* in-place, only need to change the 1st char */
3969 else { /* Not in-place */
3971 /* Copy the case-changed character(s) from tmpbuf */
3972 Copy(tmpbuf, d, tculen, U8);
3973 d += tculen - 1; /* Code below expects d to point to final
3974 * character stored */
3977 else { /* empty source */
3978 /* See bug #39028: Don't taint if empty */
3982 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3983 * the destination to retain that flag */
3987 if (!inplace) { /* Finish the rest of the string, unchanged */
3988 /* This will copy the trailing NUL */
3989 Copy(s + 1, d + 1, slen, U8);
3990 SvCUR_set(dest, need - 1);
3997 /* There's so much setup/teardown code common between uc and lc, I wonder if
3998 it would be worth merging the two, and just having a switch outside each
3999 of the three tight loops. There is less and less commonality though */
4013 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4014 && SvTEMP(source) && !DO_UTF8(source)
4015 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4017 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4018 * make the loop tight, so we overwrite the source with the dest before
4019 * looking at it, and we need to look at the original source
4020 * afterwards. There would also need to be code added to handle
4021 * switching to not in-place in midstream if we run into characters
4022 * that change the length.
4025 s = d = (U8*)SvPV_force_nomg(source, len);
4032 /* The old implementation would copy source into TARG at this point.
4033 This had the side effect that if source was undef, TARG was now
4034 an undefined SV with PADTMP set, and they don't warn inside
4035 sv_2pv_flags(). However, we're now getting the PV direct from
4036 source, which doesn't have PADTMP set, so it would warn. Hence the
4040 s = (const U8*)SvPV_nomg_const(source, len);
4042 if (ckWARN(WARN_UNINITIALIZED))
4043 report_uninit(source);
4049 SvUPGRADE(dest, SVt_PV);
4050 d = (U8*)SvGROW(dest, min);
4051 (void)SvPOK_only(dest);
4056 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4057 to check DO_UTF8 again here. */
4059 if (DO_UTF8(source)) {
4060 const U8 *const send = s + len;
4061 U8 tmpbuf[UTF8_MAXBYTES+1];
4063 /* All occurrences of these are to be moved to follow any other marks.
4064 * This is context-dependent. We may not be passed enough context to
4065 * move the iota subscript beyond all of them, but we do the best we can
4066 * with what we're given. The result is always better than if we
4067 * hadn't done this. And, the problem would only arise if we are
4068 * passed a character without all its combining marks, which would be
4069 * the caller's mistake. The information this is based on comes from a
4070 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4071 * itself) and so can't be checked properly to see if it ever gets
4072 * revised. But the likelihood of it changing is remote */
4073 bool in_iota_subscript = FALSE;
4076 if (in_iota_subscript && ! is_utf8_mark(s)) {
4077 /* A non-mark. Time to output the iota subscript */
4078 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4079 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4081 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4082 in_iota_subscript = FALSE;
4086 /* See comments at the first instance in this file of this ifdef */
4087 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4089 /* If the UTF-8 character is invariant, then it is in the range
4090 * known by the standard macro; result is only one byte long */
4091 if (UTF8_IS_INVARIANT(*s)) {
4095 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4097 /* Likewise, if it fits in a byte, its case change is in our
4099 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4100 U8 upper = toUPPER_LATIN1_MOD(orig);
4101 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4109 /* Otherwise, need the general UTF-8 case. Get the changed
4110 * case value and copy it to the output buffer */
4112 const STRLEN u = UTF8SKIP(s);
4115 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4116 if (uv == GREEK_CAPITAL_LETTER_IOTA
4117 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4119 in_iota_subscript = TRUE;
4122 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4123 /* If the eventually required minimum size outgrows
4124 * the available space, we need to grow. */
4125 const UV o = d - (U8*)SvPVX_const(dest);
4127 /* If someone uppercases one million U+03B0s we
4128 * SvGROW() one million times. Or we could try
4129 * guessing how much to allocate without allocating too
4130 * much. Such is life. See corresponding comment in
4131 * lc code for another option */
4133 d = (U8*)SvPVX(dest) + o;
4135 Copy(tmpbuf, d, ulen, U8);
4141 if (in_iota_subscript) {
4142 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4146 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4148 else { /* Not UTF-8 */
4150 const U8 *const send = s + len;
4152 /* Use locale casing if in locale; regular style if not treating
4153 * latin1 as having case; otherwise the latin1 casing. Do the
4154 * whole thing in a tight loop, for speed, */
4155 if (IN_LOCALE_RUNTIME) {
4158 for (; s < send; d++, s++)
4159 *d = toUPPER_LC(*s);
4161 else if (! IN_UNI_8_BIT) {
4162 for (; s < send; d++, s++) {
4167 for (; s < send; d++, s++) {
4168 *d = toUPPER_LATIN1_MOD(*s);
4169 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4171 /* The mainstream case is the tight loop above. To avoid
4172 * extra tests in that, all three characters that require
4173 * special handling are mapped by the MOD to the one tested
4175 * Use the source to distinguish between the three cases */
4177 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4179 /* uc() of this requires 2 characters, but they are
4180 * ASCII. If not enough room, grow the string */
4181 if (SvLEN(dest) < ++min) {
4182 const UV o = d - (U8*)SvPVX_const(dest);
4184 d = (U8*)SvPVX(dest) + o;
4186 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4187 continue; /* Back to the tight loop; still in ASCII */
4190 /* The other two special handling characters have their
4191 * upper cases outside the latin1 range, hence need to be
4192 * in UTF-8, so the whole result needs to be in UTF-8. So,
4193 * here we are somewhere in the middle of processing a
4194 * non-UTF-8 string, and realize that we will have to convert
4195 * the whole thing to UTF-8. What to do? There are
4196 * several possibilities. The simplest to code is to
4197 * convert what we have so far, set a flag, and continue on
4198 * in the loop. The flag would be tested each time through
4199 * the loop, and if set, the next character would be
4200 * converted to UTF-8 and stored. But, I (khw) didn't want
4201 * to slow down the mainstream case at all for this fairly
4202 * rare case, so I didn't want to add a test that didn't
4203 * absolutely have to be there in the loop, besides the
4204 * possibility that it would get too complicated for
4205 * optimizers to deal with. Another possibility is to just
4206 * give up, convert the source to UTF-8, and restart the
4207 * function that way. Another possibility is to convert
4208 * both what has already been processed and what is yet to
4209 * come separately to UTF-8, then jump into the loop that
4210 * handles UTF-8. But the most efficient time-wise of the
4211 * ones I could think of is what follows, and turned out to
4212 * not require much extra code. */
4214 /* Convert what we have so far into UTF-8, telling the
4215 * function that we know it should be converted, and to
4216 * allow extra space for what we haven't processed yet.
4217 * Assume the worst case space requirements for converting
4218 * what we haven't processed so far: that it will require
4219 * two bytes for each remaining source character, plus the
4220 * NUL at the end. This may cause the string pointer to
4221 * move, so re-find it. */
4223 len = d - (U8*)SvPVX_const(dest);
4224 SvCUR_set(dest, len);
4225 len = sv_utf8_upgrade_flags_grow(dest,
4226 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4228 d = (U8*)SvPVX(dest) + len;
4230 /* And append the current character's upper case in UTF-8 */
4231 CAT_NON_LATIN1_UC(d, *s);
4233 /* Now process the remainder of the source, converting to
4234 * upper and UTF-8. If a resulting byte is invariant in
4235 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4236 * append it to the output. */
4239 for (; s < send; s++) {
4240 U8 upper = toUPPER_LATIN1_MOD(*s);
4241 if UTF8_IS_INVARIANT(upper) {
4245 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4249 /* Here have processed the whole source; no need to continue
4250 * with the outer loop. Each character has been converted
4251 * to upper case and converted to UTF-8 */
4254 } /* End of processing all latin1-style chars */
4255 } /* End of processing all chars */
4256 } /* End of source is not empty */
4258 if (source != dest) {
4259 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4260 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4262 } /* End of isn't utf8 */
4280 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4281 && SvTEMP(source) && !DO_UTF8(source)) {
4283 /* We can convert in place, as lowercasing anything in the latin1 range
4284 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4286 s = d = (U8*)SvPV_force_nomg(source, len);
4293 /* The old implementation would copy source into TARG at this point.
4294 This had the side effect that if source was undef, TARG was now
4295 an undefined SV with PADTMP set, and they don't warn inside
4296 sv_2pv_flags(). However, we're now getting the PV direct from
4297 source, which doesn't have PADTMP set, so it would warn. Hence the
4301 s = (const U8*)SvPV_nomg_const(source, len);
4303 if (ckWARN(WARN_UNINITIALIZED))
4304 report_uninit(source);
4310 SvUPGRADE(dest, SVt_PV);
4311 d = (U8*)SvGROW(dest, min);
4312 (void)SvPOK_only(dest);
4317 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4318 to check DO_UTF8 again here. */
4320 if (DO_UTF8(source)) {
4321 const U8 *const send = s + len;
4322 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4325 /* See comments at the first instance in this file of this ifdef */
4326 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4327 if (UTF8_IS_INVARIANT(*s)) {
4329 /* Invariant characters use the standard mappings compiled in.
4334 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4336 /* As do the ones in the Latin1 range */
4337 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4338 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4343 /* Here, is utf8 not in Latin-1 range, have to go out and get
4344 * the mappings from the tables. */
4346 const STRLEN u = UTF8SKIP(s);
4349 #ifndef CONTEXT_DEPENDENT_CASING
4350 toLOWER_utf8(s, tmpbuf, &ulen);
4352 /* This is ifdefd out because it needs more work and thought. It isn't clear
4353 * that we should do it.
4354 * A minor objection is that this is based on a hard-coded rule from the
4355 * Unicode standard, and may change, but this is not very likely at all.
4356 * mktables should check and warn if it does.
4357 * More importantly, if the sigma occurs at the end of the string, we don't
4358 * have enough context to know whether it is part of a larger string or going
4359 * to be or not. It may be that we are passed a subset of the context, via
4360 * a \U...\E, for example, and we could conceivably know the larger context if
4361 * code were changed to pass that in. But, if the string passed in is an
4362 * intermediate result, and the user concatenates two strings together
4363 * after we have made a final sigma, that would be wrong. If the final sigma
4364 * occurs in the middle of the string we are working on, then we know that it
4365 * should be a final sigma, but otherwise we can't be sure. */
4367 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4369 /* If the lower case is a small sigma, it may be that we need
4370 * to change it to a final sigma. This happens at the end of
4371 * a word that contains more than just this character, and only
4372 * when we started with a capital sigma. */
4373 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4374 s > send - len && /* Makes sure not the first letter */
4375 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4378 /* We use the algorithm in:
4379 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4380 * is a CAPITAL SIGMA): If C is preceded by a sequence
4381 * consisting of a cased letter and a case-ignorable
4382 * sequence, and C is not followed by a sequence consisting
4383 * of a case ignorable sequence and then a cased letter,
4384 * then when lowercasing C, C becomes a final sigma */
4386 /* To determine if this is the end of a word, need to peek
4387 * ahead. Look at the next character */
4388 const U8 *peek = s + u;
4390 /* Skip any case ignorable characters */
4391 while (peek < send && is_utf8_case_ignorable(peek)) {
4392 peek += UTF8SKIP(peek);
4395 /* If we reached the end of the string without finding any
4396 * non-case ignorable characters, or if the next such one
4397 * is not-cased, then we have met the conditions for it
4398 * being a final sigma with regards to peek ahead, and so
4399 * must do peek behind for the remaining conditions. (We
4400 * know there is stuff behind to look at since we tested
4401 * above that this isn't the first letter) */
4402 if (peek >= send || ! is_utf8_cased(peek)) {
4403 peek = utf8_hop(s, -1);
4405 /* Here are at the beginning of the first character
4406 * before the original upper case sigma. Keep backing
4407 * up, skipping any case ignorable characters */
4408 while (is_utf8_case_ignorable(peek)) {
4409 peek = utf8_hop(peek, -1);
4412 /* Here peek points to the first byte of the closest
4413 * non-case-ignorable character before the capital
4414 * sigma. If it is cased, then by the Unicode
4415 * algorithm, we should use a small final sigma instead
4416 * of what we have */
4417 if (is_utf8_cased(peek)) {
4418 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4419 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4423 else { /* Not a context sensitive mapping */
4424 #endif /* End of commented out context sensitive */
4425 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4427 /* If the eventually required minimum size outgrows
4428 * the available space, we need to grow. */
4429 const UV o = d - (U8*)SvPVX_const(dest);
4431 /* If someone lowercases one million U+0130s we
4432 * SvGROW() one million times. Or we could try
4433 * guessing how much to allocate without allocating too
4434 * much. Such is life. Another option would be to
4435 * grow an extra byte or two more each time we need to
4436 * grow, which would cut down the million to 500K, with
4439 d = (U8*)SvPVX(dest) + o;
4441 #ifdef CONTEXT_DEPENDENT_CASING
4444 /* Copy the newly lowercased letter to the output buffer we're
4446 Copy(tmpbuf, d, ulen, U8);
4449 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4452 } /* End of looping through the source string */
4455 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4456 } else { /* Not utf8 */
4458 const U8 *const send = s + len;
4460 /* Use locale casing if in locale; regular style if not treating
4461 * latin1 as having case; otherwise the latin1 casing. Do the
4462 * whole thing in a tight loop, for speed, */
4463 if (IN_LOCALE_RUNTIME) {
4466 for (; s < send; d++, s++)
4467 *d = toLOWER_LC(*s);
4469 else if (! IN_UNI_8_BIT) {
4470 for (; s < send; d++, s++) {
4475 for (; s < send; d++, s++) {
4476 *d = toLOWER_LATIN1(*s);
4480 if (source != dest) {
4482 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4492 SV * const sv = TOPs;
4494 register const char *s = SvPV_const(sv,len);
4496 SvUTF8_off(TARG); /* decontaminate */
4499 SvUPGRADE(TARG, SVt_PV);
4500 SvGROW(TARG, (len * 2) + 1);
4504 if (UTF8_IS_CONTINUED(*s)) {
4505 STRLEN ulen = UTF8SKIP(s);
4529 SvCUR_set(TARG, d - SvPVX_const(TARG));
4530 (void)SvPOK_only_UTF8(TARG);
4533 sv_setpvn(TARG, s, len);
4542 dVAR; dSP; dMARK; dORIGMARK;
4543 register AV *const av = MUTABLE_AV(POPs);
4544 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4546 if (SvTYPE(av) == SVt_PVAV) {
4547 const I32 arybase = CopARYBASE_get(PL_curcop);
4548 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4549 bool can_preserve = FALSE;
4555 can_preserve = SvCANEXISTDELETE(av);
4558 if (lval && localizing) {
4561 for (svp = MARK + 1; svp <= SP; svp++) {
4562 const I32 elem = SvIV(*svp);
4566 if (max > AvMAX(av))
4570 while (++MARK <= SP) {
4572 I32 elem = SvIV(*MARK);
4573 bool preeminent = TRUE;
4577 if (localizing && can_preserve) {
4578 /* If we can determine whether the element exist,
4579 * Try to preserve the existenceness of a tied array
4580 * element by using EXISTS and DELETE if possible.
4581 * Fallback to FETCH and STORE otherwise. */
4582 preeminent = av_exists(av, elem);
4585 svp = av_fetch(av, elem, lval);
4587 if (!svp || *svp == &PL_sv_undef)
4588 DIE(aTHX_ PL_no_aelem, elem);
4591 save_aelem(av, elem, svp);
4593 SAVEADELETE(av, elem);
4596 *MARK = svp ? *svp : &PL_sv_undef;
4599 if (GIMME != G_ARRAY) {
4601 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4611 AV *array = MUTABLE_AV(POPs);
4612 const I32 gimme = GIMME_V;
4613 IV *iterp = Perl_av_iter_p(aTHX_ array);
4614 const IV current = (*iterp)++;
4616 if (current > av_len(array)) {
4618 if (gimme == G_SCALAR)
4625 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4626 if (gimme == G_ARRAY) {
4627 SV **const element = av_fetch(array, current, 0);
4628 PUSHs(element ? *element : &PL_sv_undef);
4637 AV *array = MUTABLE_AV(POPs);
4638 const I32 gimme = GIMME_V;
4640 *Perl_av_iter_p(aTHX_ array) = 0;
4642 if (gimme == G_SCALAR) {
4644 PUSHi(av_len(array) + 1);
4646 else if (gimme == G_ARRAY) {
4647 IV n = Perl_av_len(aTHX_ array);
4648 IV i = CopARYBASE_get(PL_curcop);
4652 if (PL_op->op_type == OP_AKEYS) {
4654 for (; i <= n; i++) {
4659 for (i = 0; i <= n; i++) {
4660 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4661 PUSHs(elem ? *elem : &PL_sv_undef);
4668 /* Associative arrays. */
4674 HV * hash = MUTABLE_HV(POPs);
4676 const I32 gimme = GIMME_V;
4679 /* might clobber stack_sp */
4680 entry = hv_iternext(hash);
4685 SV* const sv = hv_iterkeysv(entry);
4686 PUSHs(sv); /* won't clobber stack_sp */
4687 if (gimme == G_ARRAY) {
4690 /* might clobber stack_sp */
4691 val = hv_iterval(hash, entry);
4696 else if (gimme == G_SCALAR)
4703 S_do_delete_local(pTHX)
4707 const I32 gimme = GIMME_V;
4711 if (PL_op->op_private & OPpSLICE) {
4713 SV * const osv = POPs;
4714 const bool tied = SvRMAGICAL(osv)
4715 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4716 const bool can_preserve = SvCANEXISTDELETE(osv)
4717 || mg_find((const SV *)osv, PERL_MAGIC_env);
4718 const U32 type = SvTYPE(osv);
4719 if (type == SVt_PVHV) { /* hash element */
4720 HV * const hv = MUTABLE_HV(osv);
4721 while (++MARK <= SP) {
4722 SV * const keysv = *MARK;
4724 bool preeminent = TRUE;
4726 preeminent = hv_exists_ent(hv, keysv, 0);
4728 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4735 sv = hv_delete_ent(hv, keysv, 0, 0);
4736 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4739 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4741 *MARK = sv_mortalcopy(sv);
4747 SAVEHDELETE(hv, keysv);
4748 *MARK = &PL_sv_undef;
4752 else if (type == SVt_PVAV) { /* array element */
4753 if (PL_op->op_flags & OPf_SPECIAL) {
4754 AV * const av = MUTABLE_AV(osv);
4755 while (++MARK <= SP) {
4756 I32 idx = SvIV(*MARK);
4758 bool preeminent = TRUE;
4760 preeminent = av_exists(av, idx);
4762 SV **svp = av_fetch(av, idx, 1);
4769 sv = av_delete(av, idx, 0);
4770 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4773 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4775 *MARK = sv_mortalcopy(sv);
4781 SAVEADELETE(av, idx);
4782 *MARK = &PL_sv_undef;
4788 DIE(aTHX_ "Not a HASH reference");
4789 if (gimme == G_VOID)
4791 else if (gimme == G_SCALAR) {
4796 *++MARK = &PL_sv_undef;
4801 SV * const keysv = POPs;
4802 SV * const osv = POPs;
4803 const bool tied = SvRMAGICAL(osv)
4804 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4805 const bool can_preserve = SvCANEXISTDELETE(osv)
4806 || mg_find((const SV *)osv, PERL_MAGIC_env);
4807 const U32 type = SvTYPE(osv);
4809 if (type == SVt_PVHV) {
4810 HV * const hv = MUTABLE_HV(osv);
4811 bool preeminent = TRUE;
4813 preeminent = hv_exists_ent(hv, keysv, 0);
4815 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4822 sv = hv_delete_ent(hv, keysv, 0, 0);
4823 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4826 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4828 SV *nsv = sv_mortalcopy(sv);
4834 SAVEHDELETE(hv, keysv);
4836 else if (type == SVt_PVAV) {
4837 if (PL_op->op_flags & OPf_SPECIAL) {
4838 AV * const av = MUTABLE_AV(osv);
4839 I32 idx = SvIV(keysv);
4840 bool preeminent = TRUE;
4842 preeminent = av_exists(av, idx);
4844 SV **svp = av_fetch(av, idx, 1);
4851 sv = av_delete(av, idx, 0);
4852 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4855 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4857 SV *nsv = sv_mortalcopy(sv);
4863 SAVEADELETE(av, idx);
4866 DIE(aTHX_ "panic: avhv_delete no longer supported");
4869 DIE(aTHX_ "Not a HASH reference");
4872 if (gimme != G_VOID)
4886 if (PL_op->op_private & OPpLVAL_INTRO)
4887 return do_delete_local();
4890 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4892 if (PL_op->op_private & OPpSLICE) {
4894 HV * const hv = MUTABLE_HV(POPs);
4895 const U32 hvtype = SvTYPE(hv);
4896 if (hvtype == SVt_PVHV) { /* hash element */
4897 while (++MARK <= SP) {
4898 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4899 *MARK = sv ? sv : &PL_sv_undef;
4902 else if (hvtype == SVt_PVAV) { /* array element */
4903 if (PL_op->op_flags & OPf_SPECIAL) {
4904 while (++MARK <= SP) {
4905 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4906 *MARK = sv ? sv : &PL_sv_undef;
4911 DIE(aTHX_ "Not a HASH reference");
4914 else if (gimme == G_SCALAR) {
4919 *++MARK = &PL_sv_undef;
4925 HV * const hv = MUTABLE_HV(POPs);
4927 if (SvTYPE(hv) == SVt_PVHV)
4928 sv = hv_delete_ent(hv, keysv, discard, 0);
4929 else if (SvTYPE(hv) == SVt_PVAV) {
4930 if (PL_op->op_flags & OPf_SPECIAL)
4931 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4933 DIE(aTHX_ "panic: avhv_delete no longer supported");
4936 DIE(aTHX_ "Not a HASH reference");
4952 if (PL_op->op_private & OPpEXISTS_SUB) {
4954 SV * const sv = POPs;
4955 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4958 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4963 hv = MUTABLE_HV(POPs);
4964 if (SvTYPE(hv) == SVt_PVHV) {
4965 if (hv_exists_ent(hv, tmpsv, 0))
4968 else if (SvTYPE(hv) == SVt_PVAV) {
4969 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4970 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4975 DIE(aTHX_ "Not a HASH reference");
4982 dVAR; dSP; dMARK; dORIGMARK;
4983 register HV * const hv = MUTABLE_HV(POPs);
4984 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4985 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4986 bool can_preserve = FALSE;
4992 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4993 can_preserve = TRUE;
4996 while (++MARK <= SP) {
4997 SV * const keysv = *MARK;
5000 bool preeminent = TRUE;
5002 if (localizing && can_preserve) {
5003 /* If we can determine whether the element exist,
5004 * try to preserve the existenceness of a tied hash
5005 * element by using EXISTS and DELETE if possible.
5006 * Fallback to FETCH and STORE otherwise. */
5007 preeminent = hv_exists_ent(hv, keysv, 0);
5010 he = hv_fetch_ent(hv, keysv, lval, 0);
5011 svp = he ? &HeVAL(he) : NULL;
5014 if (!svp || *svp == &PL_sv_undef) {
5015 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5018 if (HvNAME_get(hv) && isGV(*svp))
5019 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5020 else if (preeminent)
5021 save_helem_flags(hv, keysv, svp,
5022 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5024 SAVEHDELETE(hv, keysv);
5027 *MARK = svp ? *svp : &PL_sv_undef;
5029 if (GIMME != G_ARRAY) {
5031 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5037 /* List operators. */
5042 if (GIMME != G_ARRAY) {
5044 *MARK = *SP; /* unwanted list, return last item */
5046 *MARK = &PL_sv_undef;
5056 SV ** const lastrelem = PL_stack_sp;
5057 SV ** const lastlelem = PL_stack_base + POPMARK;
5058 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5059 register SV ** const firstrelem = lastlelem + 1;
5060 const I32 arybase = CopARYBASE_get(PL_curcop);
5061 I32 is_something_there = FALSE;
5063 register const I32 max = lastrelem - lastlelem;
5064 register SV **lelem;
5066 if (GIMME != G_ARRAY) {
5067 I32 ix = SvIV(*lastlelem);
5072 if (ix < 0 || ix >= max)
5073 *firstlelem = &PL_sv_undef;
5075 *firstlelem = firstrelem[ix];
5081 SP = firstlelem - 1;
5085 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5086 I32 ix = SvIV(*lelem);
5091 if (ix < 0 || ix >= max)
5092 *lelem = &PL_sv_undef;
5094 is_something_there = TRUE;
5095 if (!(*lelem = firstrelem[ix]))
5096 *lelem = &PL_sv_undef;
5099 if (is_something_there)
5102 SP = firstlelem - 1;
5108 dVAR; dSP; dMARK; dORIGMARK;
5109 const I32 items = SP - MARK;
5110 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5111 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5112 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5113 ? newRV_noinc(av) : av);
5119 dVAR; dSP; dMARK; dORIGMARK;
5120 HV* const hv = newHV();
5123 SV * const key = *++MARK;
5124 SV * const val = newSV(0);
5126 sv_setsv(val, *++MARK);
5128 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5129 (void)hv_store_ent(hv,key,val,0);
5132 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5133 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5139 dVAR; dSP; dMARK; dORIGMARK;
5140 register AV *ary = MUTABLE_AV(*++MARK);
5144 register I32 offset;
5145 register I32 length;
5149 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5152 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5155 ENTER_with_name("call_SPLICE");
5156 call_method("SPLICE",GIMME_V);
5157 LEAVE_with_name("call_SPLICE");
5165 offset = i = SvIV(*MARK);
5167 offset += AvFILLp(ary) + 1;
5169 offset -= CopARYBASE_get(PL_curcop);
5171 DIE(aTHX_ PL_no_aelem, i);
5173 length = SvIVx(*MARK++);
5175 length += AvFILLp(ary) - offset + 1;
5181 length = AvMAX(ary) + 1; /* close enough to infinity */
5185 length = AvMAX(ary) + 1;
5187 if (offset > AvFILLp(ary) + 1) {
5188 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5189 offset = AvFILLp(ary) + 1;
5191 after = AvFILLp(ary) + 1 - (offset + length);
5192 if (after < 0) { /* not that much array */
5193 length += after; /* offset+length now in array */
5199 /* At this point, MARK .. SP-1 is our new LIST */
5202 diff = newlen - length;
5203 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5206 /* make new elements SVs now: avoid problems if they're from the array */
5207 for (dst = MARK, i = newlen; i; i--) {
5208 SV * const h = *dst;
5209 *dst++ = newSVsv(h);
5212 if (diff < 0) { /* shrinking the area */
5213 SV **tmparyval = NULL;
5215 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5216 Copy(MARK, tmparyval, newlen, SV*);
5219 MARK = ORIGMARK + 1;
5220 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5221 MEXTEND(MARK, length);
5222 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5224 EXTEND_MORTAL(length);
5225 for (i = length, dst = MARK; i; i--) {
5226 sv_2mortal(*dst); /* free them eventualy */
5233 *MARK = AvARRAY(ary)[offset+length-1];
5236 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5237 SvREFCNT_dec(*dst++); /* free them now */
5240 AvFILLp(ary) += diff;
5242 /* pull up or down? */
5244 if (offset < after) { /* easier to pull up */
5245 if (offset) { /* esp. if nothing to pull */
5246 src = &AvARRAY(ary)[offset-1];
5247 dst = src - diff; /* diff is negative */
5248 for (i = offset; i > 0; i--) /* can't trust Copy */
5252 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5256 if (after) { /* anything to pull down? */
5257 src = AvARRAY(ary) + offset + length;
5258 dst = src + diff; /* diff is negative */
5259 Move(src, dst, after, SV*);
5261 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5262 /* avoid later double free */
5266 dst[--i] = &PL_sv_undef;
5269 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5270 Safefree(tmparyval);
5273 else { /* no, expanding (or same) */
5274 SV** tmparyval = NULL;
5276 Newx(tmparyval, length, SV*); /* so remember deletion */
5277 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5280 if (diff > 0) { /* expanding */
5281 /* push up or down? */
5282 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5286 Move(src, dst, offset, SV*);
5288 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5290 AvFILLp(ary) += diff;
5293 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5294 av_extend(ary, AvFILLp(ary) + diff);
5295 AvFILLp(ary) += diff;
5298 dst = AvARRAY(ary) + AvFILLp(ary);
5300 for (i = after; i; i--) {
5308 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5311 MARK = ORIGMARK + 1;
5312 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5314 Copy(tmparyval, MARK, length, SV*);
5316 EXTEND_MORTAL(length);
5317 for (i = length, dst = MARK; i; i--) {
5318 sv_2mortal(*dst); /* free them eventualy */
5325 else if (length--) {
5326 *MARK = tmparyval[length];
5329 while (length-- > 0)
5330 SvREFCNT_dec(tmparyval[length]);
5334 *MARK = &PL_sv_undef;
5335 Safefree(tmparyval);
5343 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5344 register AV * const ary = MUTABLE_AV(*++MARK);
5345 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5348 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5351 ENTER_with_name("call_PUSH");
5352 call_method("PUSH",G_SCALAR|G_DISCARD);
5353 LEAVE_with_name("call_PUSH");
5357 PL_delaymagic = DM_DELAY;
5358 for (++MARK; MARK <= SP; MARK++) {
5359 SV * const sv = newSV(0);
5361 sv_setsv(sv, *MARK);
5362 av_store(ary, AvFILLp(ary)+1, sv);
5364 if (PL_delaymagic & DM_ARRAY_ISA)
5365 mg_set(MUTABLE_SV(ary));
5370 if (OP_GIMME(PL_op, 0) != G_VOID) {
5371 PUSHi( AvFILL(ary) + 1 );
5380 AV * const av = PL_op->op_flags & OPf_SPECIAL
5381 ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5382 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5386 (void)sv_2mortal(sv);
5393 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5394 register AV *ary = MUTABLE_AV(*++MARK);
5395 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5398 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5401 ENTER_with_name("call_UNSHIFT");
5402 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5403 LEAVE_with_name("call_UNSHIFT");
5408 av_unshift(ary, SP - MARK);
5410 SV * const sv = newSVsv(*++MARK);
5411 (void)av_store(ary, i++, sv);
5415 if (OP_GIMME(PL_op, 0) != G_VOID) {
5416 PUSHi( AvFILL(ary) + 1 );
5425 if (GIMME == G_ARRAY) {
5426 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5430 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5431 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5432 av = MUTABLE_AV((*SP));
5433 /* In-place reversing only happens in void context for the array
5434 * assignment. We don't need to push anything on the stack. */
5437 if (SvMAGICAL(av)) {
5439 register SV *tmp = sv_newmortal();
5440 /* For SvCANEXISTDELETE */
5443 bool can_preserve = SvCANEXISTDELETE(av);
5445 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5446 register SV *begin, *end;
5449 if (!av_exists(av, i)) {
5450 if (av_exists(av, j)) {
5451 register SV *sv = av_delete(av, j, 0);
5452 begin = *av_fetch(av, i, TRUE);
5453 sv_setsv_mg(begin, sv);
5457 else if (!av_exists(av, j)) {
5458 register SV *sv = av_delete(av, i, 0);
5459 end = *av_fetch(av, j, TRUE);
5460 sv_setsv_mg(end, sv);
5465 begin = *av_fetch(av, i, TRUE);
5466 end = *av_fetch(av, j, TRUE);
5467 sv_setsv(tmp, begin);
5468 sv_setsv_mg(begin, end);
5469 sv_setsv_mg(end, tmp);
5473 SV **begin = AvARRAY(av);
5476 SV **end = begin + AvFILLp(av);
5478 while (begin < end) {
5479 register SV * const tmp = *begin;
5490 register SV * const tmp = *MARK;
5494 /* safe as long as stack cannot get extended in the above */
5500 register char *down;
5505 SvUTF8_off(TARG); /* decontaminate */
5507 do_join(TARG, &PL_sv_no, MARK, SP);
5509 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5510 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5511 report_uninit(TARG);
5514 up = SvPV_force(TARG, len);
5516 if (DO_UTF8(TARG)) { /* first reverse each character */
5517 U8* s = (U8*)SvPVX(TARG);
5518 const U8* send = (U8*)(s + len);
5520 if (UTF8_IS_INVARIANT(*s)) {
5525 if (!utf8_to_uvchr(s, 0))
5529 down = (char*)(s - 1);
5530 /* reverse this character */
5534 *down-- = (char)tmp;
5540 down = SvPVX(TARG) + len - 1;
5544 *down-- = (char)tmp;
5546 (void)SvPOK_only_UTF8(TARG);
5558 register IV limit = POPi; /* note, negative is forever */
5559 SV * const sv = POPs;
5561 register const char *s = SvPV_const(sv, len);
5562 const bool do_utf8 = DO_UTF8(sv);
5563 const char *strend = s + len;
5565 register REGEXP *rx;
5567 register const char *m;
5569 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5570 I32 maxiters = slen + 10;
5571 I32 trailing_empty = 0;
5573 const I32 origlimit = limit;
5576 const I32 gimme = GIMME_V;
5578 const I32 oldsave = PL_savestack_ix;
5579 U32 make_mortal = SVs_TEMP;
5584 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5589 DIE(aTHX_ "panic: pp_split");
5592 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5593 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5595 RX_MATCH_UTF8_set(rx, do_utf8);
5598 if (pm->op_pmreplrootu.op_pmtargetoff) {
5599 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5602 if (pm->op_pmreplrootu.op_pmtargetgv) {
5603 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5608 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5614 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5616 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5623 for (i = AvFILLp(ary); i >= 0; i--)
5624 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5626 /* temporarily switch stacks */
5627 SAVESWITCHSTACK(PL_curstack, ary);
5631 base = SP - PL_stack_base;
5633 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5635 while (*s == ' ' || is_utf8_space((U8*)s))
5638 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5639 while (isSPACE_LC(*s))
5647 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5651 gimme_scalar = gimme == G_SCALAR && !ary;
5654 limit = maxiters + 2;
5655 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5658 /* this one uses 'm' and is a negative test */
5660 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5661 const int t = UTF8SKIP(m);
5662 /* is_utf8_space returns FALSE for malform utf8 */
5668 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5669 while (m < strend && !isSPACE_LC(*m))
5672 while (m < strend && !isSPACE(*m))
5685 dstr = newSVpvn_flags(s, m-s,
5686 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5690 /* skip the whitespace found last */
5692 s = m + UTF8SKIP(m);
5696 /* this one uses 's' and is a positive test */
5698 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5700 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5701 while (s < strend && isSPACE_LC(*s))
5704 while (s < strend && isSPACE(*s))
5709 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5711 for (m = s; m < strend && *m != '\n'; m++)
5724 dstr = newSVpvn_flags(s, m-s,
5725 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5731 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5733 Pre-extend the stack, either the number of bytes or
5734 characters in the string or a limited amount, triggered by:
5736 my ($x, $y) = split //, $str;
5740 if (!gimme_scalar) {
5741 const U32 items = limit - 1;
5750 /* keep track of how many bytes we skip over */
5760 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5773 dstr = newSVpvn(s, 1);
5789 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5790 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5791 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5792 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5793 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5794 SV * const csv = CALLREG_INTUIT_STRING(rx);
5796 len = RX_MINLENRET(rx);
5797 if (len == 1 && !RX_UTF8(rx) && !tail) {
5798 const char c = *SvPV_nolen_const(csv);
5800 for (m = s; m < strend && *m != c; m++)
5811 dstr = newSVpvn_flags(s, m-s,
5812 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5815 /* The rx->minlen is in characters but we want to step
5816 * s ahead by bytes. */
5818 s = (char*)utf8_hop((U8*)m, len);
5820 s = m + len; /* Fake \n at the end */
5824 while (s < strend && --limit &&
5825 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5826 csv, multiline ? FBMrf_MULTILINE : 0)) )
5835 dstr = newSVpvn_flags(s, m-s,
5836 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5839 /* The rx->minlen is in characters but we want to step
5840 * s ahead by bytes. */
5842 s = (char*)utf8_hop((U8*)m, len);
5844 s = m + len; /* Fake \n at the end */
5849 maxiters += slen * RX_NPARENS(rx);
5850 while (s < strend && --limit)
5854 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5857 if (rex_return == 0)
5859 TAINT_IF(RX_MATCH_TAINTED(rx));
5860 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5863 orig = RX_SUBBEG(rx);
5865 strend = s + (strend - m);
5867 m = RX_OFFS(rx)[0].start + orig;
5876 dstr = newSVpvn_flags(s, m-s,
5877 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5880 if (RX_NPARENS(rx)) {
5882 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5883 s = RX_OFFS(rx)[i].start + orig;
5884 m = RX_OFFS(rx)[i].end + orig;
5886 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5887 parens that didn't match -- they should be set to
5888 undef, not the empty string */
5896 if (m >= orig && s >= orig) {
5897 dstr = newSVpvn_flags(s, m-s,
5898 (do_utf8 ? SVf_UTF8 : 0)
5902 dstr = &PL_sv_undef; /* undef, not "" */
5908 s = RX_OFFS(rx)[0].end + orig;
5912 if (!gimme_scalar) {
5913 iters = (SP - PL_stack_base) - base;
5915 if (iters > maxiters)
5916 DIE(aTHX_ "Split loop");
5918 /* keep field after final delim? */
5919 if (s < strend || (iters && origlimit)) {
5920 if (!gimme_scalar) {
5921 const STRLEN l = strend - s;
5922 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5927 else if (!origlimit) {
5929 iters -= trailing_empty;
5931 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5932 if (TOPs && !make_mortal)
5934 *SP-- = &PL_sv_undef;
5941 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5945 if (SvSMAGICAL(ary)) {
5947 mg_set(MUTABLE_SV(ary));
5950 if (gimme == G_ARRAY) {
5952 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5959 ENTER_with_name("call_PUSH");
5960 call_method("PUSH",G_SCALAR|G_DISCARD);
5961 LEAVE_with_name("call_PUSH");
5963 if (gimme == G_ARRAY) {
5965 /* EXTEND should not be needed - we just popped them */
5967 for (i=0; i < iters; i++) {
5968 SV **svp = av_fetch(ary, i, FALSE);
5969 PUSHs((svp) ? *svp : &PL_sv_undef);
5976 if (gimme == G_ARRAY)
5988 SV *const sv = PAD_SVl(PL_op->op_targ);
5990 if (SvPADSTALE(sv)) {
5993 RETURNOP(cLOGOP->op_other);
5995 RETURNOP(cLOGOP->op_next);
6004 assert(SvTYPE(retsv) != SVt_PVCV);
6006 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6007 retsv = refto(retsv);
6014 PP(unimplemented_op)
6017 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6025 HV * const hv = (HV*)POPs;
6027 if (SvRMAGICAL(hv)) {
6028 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6030 XPUSHs(magic_scalarpack(hv, mg));
6035 XPUSHs(boolSV(HvKEYS(hv) != 0));
6041 * c-indentation-style: bsd
6043 * indent-tabs-mode: t
6046 * ex: set ts=8 sts=4 sw=4 noet: