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";
144 tryAMAGICunDEREF(to_gv);
147 if (SvTYPE(sv) == SVt_PVIO) {
148 GV * const gv = MUTABLE_GV(sv_newmortal());
149 gv_init(gv, 0, "", 0, 0);
150 GvIOp(gv) = MUTABLE_IO(sv);
151 SvREFCNT_inc_void_NN(sv);
154 else if (!isGV_with_GP(sv))
155 DIE(aTHX_ "Not a GLOB reference");
158 if (!isGV_with_GP(sv)) {
159 if (SvGMAGICAL(sv)) {
164 if (!SvOK(sv) && sv != &PL_sv_undef) {
165 /* If this is a 'my' scalar and flag is set then vivify
169 Perl_croak(aTHX_ "%s", PL_no_modify);
170 if (PL_op->op_private & OPpDEREF) {
172 if (cUNOP->op_targ) {
174 SV * const namesv = PAD_SV(cUNOP->op_targ);
175 const char * const name = SvPV(namesv, len);
176 gv = MUTABLE_GV(newSV(0));
177 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
180 const char * const name = CopSTASHPV(PL_curcop);
183 prepare_SV_for_RV(sv);
184 SvRV_set(sv, MUTABLE_SV(gv));
189 if (PL_op->op_flags & OPf_REF ||
190 PL_op->op_private & HINT_STRICT_REFS)
191 DIE(aTHX_ PL_no_usym, "a symbol");
192 if (ckWARN(WARN_UNINITIALIZED))
196 if ((PL_op->op_flags & OPf_SPECIAL) &&
197 !(PL_op->op_flags & OPf_MOD))
199 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
201 && (!is_gv_magical_sv(sv,0)
202 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
209 if (PL_op->op_private & HINT_STRICT_REFS)
210 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
211 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
212 == OPpDONT_INIT_GV) {
213 /* We are the target of a coderef assignment. Return
214 the scalar unchanged, and let pp_sasssign deal with
218 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
222 if (PL_op->op_private & OPpLVAL_INTRO)
223 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
228 /* Helper function for pp_rv2sv and pp_rv2av */
230 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
231 const svtype type, SV ***spp)
236 PERL_ARGS_ASSERT_SOFTREF2XV;
238 if (PL_op->op_private & HINT_STRICT_REFS) {
240 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
242 Perl_die(aTHX_ PL_no_usym, what);
245 if (PL_op->op_flags & OPf_REF)
246 Perl_die(aTHX_ PL_no_usym, what);
247 if (ckWARN(WARN_UNINITIALIZED))
249 if (type != SVt_PV && GIMME_V == G_ARRAY) {
253 **spp = &PL_sv_undef;
256 if ((PL_op->op_flags & OPf_SPECIAL) &&
257 !(PL_op->op_flags & OPf_MOD))
259 gv = gv_fetchsv(sv, 0, type);
261 && (!is_gv_magical_sv(sv,0)
262 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
264 **spp = &PL_sv_undef;
269 gv = gv_fetchsv(sv, GV_ADD, type);
281 tryAMAGICunDEREF(to_sv);
284 switch (SvTYPE(sv)) {
290 DIE(aTHX_ "Not a SCALAR reference");
297 if (!isGV_with_GP(gv)) {
298 if (SvGMAGICAL(sv)) {
303 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
309 if (PL_op->op_flags & OPf_MOD) {
310 if (PL_op->op_private & OPpLVAL_INTRO) {
311 if (cUNOP->op_first->op_type == OP_NULL)
312 sv = save_scalar(MUTABLE_GV(TOPs));
314 sv = save_scalar(gv);
316 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
318 else if (PL_op->op_private & OPpDEREF)
319 vivify_ref(sv, PL_op->op_private & OPpDEREF);
328 AV * const av = MUTABLE_AV(TOPs);
329 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
331 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
333 *sv = newSV_type(SVt_PVMG);
334 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
338 SETs(sv_2mortal(newSViv(
339 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
347 dVAR; dSP; dTARGET; dPOPss;
349 if (PL_op->op_flags & OPf_MOD || LVRET) {
350 if (SvTYPE(TARG) < SVt_PVLV) {
351 sv_upgrade(TARG, SVt_PVLV);
352 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
356 if (LvTARG(TARG) != sv) {
357 SvREFCNT_dec(LvTARG(TARG));
358 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
360 PUSHs(TARG); /* no SvSETMAGIC */
364 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
365 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
366 if (mg && mg->mg_len >= 0) {
370 PUSHi(i + CopARYBASE_get(PL_curcop));
383 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
385 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
388 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
389 /* (But not in defined().) */
391 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
394 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
395 if ((PL_op->op_private & OPpLVAL_INTRO)) {
396 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
399 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
402 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
406 cv = MUTABLE_CV(&PL_sv_undef);
407 SETs(MUTABLE_SV(cv));
417 SV *ret = &PL_sv_undef;
419 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
420 const char * s = SvPVX_const(TOPs);
421 if (strnEQ(s, "CORE::", 6)) {
422 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
423 if (code < 0) { /* Overridable. */
424 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
425 int i = 0, n = 0, seen_question = 0, defgv = 0;
427 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
429 if (code == -KEY_chop || code == -KEY_chomp
430 || code == -KEY_exec || code == -KEY_system)
432 if (code == -KEY_mkdir) {
433 ret = newSVpvs_flags("_;$", SVs_TEMP);
436 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
437 ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
440 if (code == -KEY_readpipe) {
441 s = "CORE::backtick";
443 while (i < MAXO) { /* The slow way. */
444 if (strEQ(s + 6, PL_op_name[i])
445 || strEQ(s + 6, PL_op_desc[i]))
451 goto nonesuch; /* Should not happen... */
453 defgv = PL_opargs[i] & OA_DEFGV;
454 oa = PL_opargs[i] >> OASHIFT;
456 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
460 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
461 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
462 /* But globs are already references (kinda) */
463 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
467 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
470 if (defgv && str[n - 1] == '$')
473 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
475 else if (code) /* Non-Overridable */
477 else { /* None such */
479 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
483 cv = sv_2cv(TOPs, &stash, &gv, 0);
485 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
494 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
496 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
498 PUSHs(MUTABLE_SV(cv));
512 if (GIMME != G_ARRAY) {
516 *MARK = &PL_sv_undef;
517 *MARK = refto(*MARK);
521 EXTEND_MORTAL(SP - MARK);
523 *MARK = refto(*MARK);
528 S_refto(pTHX_ SV *sv)
533 PERL_ARGS_ASSERT_REFTO;
535 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
538 if (!(sv = LvTARG(sv)))
541 SvREFCNT_inc_void_NN(sv);
543 else if (SvTYPE(sv) == SVt_PVAV) {
544 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
545 av_reify(MUTABLE_AV(sv));
547 SvREFCNT_inc_void_NN(sv);
549 else if (SvPADTMP(sv) && !IS_PADGV(sv))
553 SvREFCNT_inc_void_NN(sv);
556 sv_upgrade(rv, SVt_IV);
566 SV * const sv = POPs;
571 if (!sv || !SvROK(sv))
574 pv = sv_reftype(SvRV(sv),TRUE);
575 PUSHp(pv, strlen(pv));
585 stash = CopSTASH(PL_curcop);
587 SV * const ssv = POPs;
591 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
592 Perl_croak(aTHX_ "Attempt to bless into a reference");
593 ptr = SvPV_const(ssv,len);
595 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
596 "Explicit blessing to '' (assuming package main)");
597 stash = gv_stashpvn(ptr, len, GV_ADD);
600 (void)sv_bless(TOPs, stash);
609 const char * const elem = SvPV_nolen_const(sv);
610 GV * const gv = MUTABLE_GV(POPs);
615 /* elem will always be NUL terminated. */
616 const char * const second_letter = elem + 1;
619 if (strEQ(second_letter, "RRAY"))
620 tmpRef = MUTABLE_SV(GvAV(gv));
623 if (strEQ(second_letter, "ODE"))
624 tmpRef = MUTABLE_SV(GvCVu(gv));
627 if (strEQ(second_letter, "ILEHANDLE")) {
628 /* finally deprecated in 5.8.0 */
629 deprecate("*glob{FILEHANDLE}");
630 tmpRef = MUTABLE_SV(GvIOp(gv));
633 if (strEQ(second_letter, "ORMAT"))
634 tmpRef = MUTABLE_SV(GvFORM(gv));
637 if (strEQ(second_letter, "LOB"))
638 tmpRef = MUTABLE_SV(gv);
641 if (strEQ(second_letter, "ASH"))
642 tmpRef = MUTABLE_SV(GvHV(gv));
645 if (*second_letter == 'O' && !elem[2])
646 tmpRef = MUTABLE_SV(GvIOp(gv));
649 if (strEQ(second_letter, "AME"))
650 sv = newSVhek(GvNAME_HEK(gv));
653 if (strEQ(second_letter, "ACKAGE")) {
654 const HV * const stash = GvSTASH(gv);
655 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
656 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
660 if (strEQ(second_letter, "CALAR"))
675 /* Pattern matching */
680 register unsigned char *s;
683 register I32 *sfirst;
687 if (sv == PL_lastscream) {
691 s = (unsigned char*)(SvPV(sv, len));
693 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
694 /* No point in studying a zero length string, and not safe to study
695 anything that doesn't appear to be a simple scalar (and hence might
696 change between now and when the regexp engine runs without our set
697 magic ever running) such as a reference to an object with overloaded
703 SvSCREAM_off(PL_lastscream);
704 SvREFCNT_dec(PL_lastscream);
706 PL_lastscream = SvREFCNT_inc_simple(sv);
708 s = (unsigned char*)(SvPV(sv, len));
712 if (pos > PL_maxscream) {
713 if (PL_maxscream < 0) {
714 PL_maxscream = pos + 80;
715 Newx(PL_screamfirst, 256, I32);
716 Newx(PL_screamnext, PL_maxscream, I32);
719 PL_maxscream = pos + pos / 4;
720 Renew(PL_screamnext, PL_maxscream, I32);
724 sfirst = PL_screamfirst;
725 snext = PL_screamnext;
727 if (!sfirst || !snext)
728 DIE(aTHX_ "do_study: out of memory");
730 for (ch = 256; ch; --ch)
735 register const I32 ch = s[pos];
737 snext[pos] = sfirst[ch] - pos;
744 /* piggyback on m//g magic */
745 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
754 if (PL_op->op_flags & OPf_STACKED)
756 else if (PL_op->op_private & OPpTARGET_MY)
762 TARG = sv_newmortal();
767 /* Lvalue operators. */
779 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
781 do_chop(TARG, *++MARK);
790 SETi(do_chomp(TOPs));
796 dVAR; dSP; dMARK; dTARGET;
797 register I32 count = 0;
800 count += do_chomp(POPs);
810 if (!PL_op->op_private) {
819 SV_CHECK_THINKFIRST_COW_DROP(sv);
821 switch (SvTYPE(sv)) {
825 av_undef(MUTABLE_AV(sv));
828 hv_undef(MUTABLE_HV(sv));
831 if (cv_const_sv((const CV *)sv))
832 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
833 CvANON((const CV *)sv) ? "(anonymous)"
834 : GvENAME(CvGV((const CV *)sv)));
838 /* let user-undef'd sub keep its identity */
839 GV* const gv = CvGV((const CV *)sv);
840 cv_undef(MUTABLE_CV(sv));
841 CvGV((const CV *)sv) = gv;
846 SvSetMagicSV(sv, &PL_sv_undef);
849 else if (isGV_with_GP(sv)) {
854 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
855 mro_isa_changed_in(stash);
856 /* undef *Pkg::meth_name ... */
857 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
858 && HvNAME_get(stash))
859 mro_method_changed_in(stash);
861 gp_free(MUTABLE_GV(sv));
863 GvGP(sv) = gp_ref(gp);
865 GvLINE(sv) = CopLINE(PL_curcop);
866 GvEGV(sv) = MUTABLE_GV(sv);
872 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
887 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
888 DIE(aTHX_ "%s", PL_no_modify);
889 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
890 && SvIVX(TOPs) != IV_MIN)
892 SvIV_set(TOPs, SvIVX(TOPs) - 1);
893 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
904 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
905 DIE(aTHX_ "%s", PL_no_modify);
906 sv_setsv(TARG, TOPs);
907 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
908 && SvIVX(TOPs) != IV_MAX)
910 SvIV_set(TOPs, SvIVX(TOPs) + 1);
911 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
916 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
926 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
927 DIE(aTHX_ "%s", PL_no_modify);
928 sv_setsv(TARG, TOPs);
929 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
930 && SvIVX(TOPs) != IV_MIN)
932 SvIV_set(TOPs, SvIVX(TOPs) - 1);
933 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
942 /* Ordinary operators. */
946 dVAR; dSP; dATARGET; SV *svl, *svr;
947 #ifdef PERL_PRESERVE_IVUV
950 tryAMAGICbin(pow,opASSIGN);
951 svl = sv_2num(TOPm1s);
953 #ifdef PERL_PRESERVE_IVUV
954 /* For integer to integer power, we do the calculation by hand wherever
955 we're sure it is safe; otherwise we call pow() and try to convert to
956 integer afterwards. */
969 const IV iv = SvIVX(svr);
973 goto float_it; /* Can't do negative powers this way. */
977 baseuok = SvUOK(svl);
981 const IV iv = SvIVX(svl);
984 baseuok = TRUE; /* effectively it's a UV now */
986 baseuv = -iv; /* abs, baseuok == false records sign */
989 /* now we have integer ** positive integer. */
992 /* foo & (foo - 1) is zero only for a power of 2. */
993 if (!(baseuv & (baseuv - 1))) {
994 /* We are raising power-of-2 to a positive integer.
995 The logic here will work for any base (even non-integer
996 bases) but it can be less accurate than
997 pow (base,power) or exp (power * log (base)) when the
998 intermediate values start to spill out of the mantissa.
999 With powers of 2 we know this can't happen.
1000 And powers of 2 are the favourite thing for perl
1001 programmers to notice ** not doing what they mean. */
1003 NV base = baseuok ? baseuv : -(NV)baseuv;
1008 while (power >>= 1) {
1019 register unsigned int highbit = 8 * sizeof(UV);
1020 register unsigned int diff = 8 * sizeof(UV);
1021 while (diff >>= 1) {
1023 if (baseuv >> highbit) {
1027 /* we now have baseuv < 2 ** highbit */
1028 if (power * highbit <= 8 * sizeof(UV)) {
1029 /* result will definitely fit in UV, so use UV math
1030 on same algorithm as above */
1031 register UV result = 1;
1032 register UV base = baseuv;
1033 const bool odd_power = cBOOL(power & 1);
1037 while (power >>= 1) {
1044 if (baseuok || !odd_power)
1045 /* answer is positive */
1047 else if (result <= (UV)IV_MAX)
1048 /* answer negative, fits in IV */
1049 SETi( -(IV)result );
1050 else if (result == (UV)IV_MIN)
1051 /* 2's complement assumption: special case IV_MIN */
1054 /* answer negative, doesn't fit */
1055 SETn( -(NV)result );
1065 NV right = SvNV(svr);
1066 NV left = SvNV(svl);
1069 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1071 We are building perl with long double support and are on an AIX OS
1072 afflicted with a powl() function that wrongly returns NaNQ for any
1073 negative base. This was reported to IBM as PMR #23047-379 on
1074 03/06/2006. The problem exists in at least the following versions
1075 of AIX and the libm fileset, and no doubt others as well:
1077 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1078 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1079 AIX 5.2.0 bos.adt.libm 5.2.0.85
1081 So, until IBM fixes powl(), we provide the following workaround to
1082 handle the problem ourselves. Our logic is as follows: for
1083 negative bases (left), we use fmod(right, 2) to check if the
1084 exponent is an odd or even integer:
1086 - if odd, powl(left, right) == -powl(-left, right)
1087 - if even, powl(left, right) == powl(-left, right)
1089 If the exponent is not an integer, the result is rightly NaNQ, so
1090 we just return that (as NV_NAN).
1094 NV mod2 = Perl_fmod( right, 2.0 );
1095 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1096 SETn( -Perl_pow( -left, right) );
1097 } else if (mod2 == 0.0) { /* even integer */
1098 SETn( Perl_pow( -left, right) );
1099 } else { /* fractional power */
1103 SETn( Perl_pow( left, right) );
1106 SETn( Perl_pow( left, right) );
1107 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1109 #ifdef PERL_PRESERVE_IVUV
1119 dVAR; dSP; dATARGET; SV *svl, *svr;
1120 tryAMAGICbin(mult,opASSIGN);
1121 svl = sv_2num(TOPm1s);
1122 svr = sv_2num(TOPs);
1123 #ifdef PERL_PRESERVE_IVUV
1126 /* Unless the left argument is integer in range we are going to have to
1127 use NV maths. Hence only attempt to coerce the right argument if
1128 we know the left is integer. */
1129 /* Left operand is defined, so is it IV? */
1132 bool auvok = SvUOK(svl);
1133 bool buvok = SvUOK(svr);
1134 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1135 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1144 const IV aiv = SvIVX(svl);
1147 auvok = TRUE; /* effectively it's a UV now */
1149 alow = -aiv; /* abs, auvok == false records sign */
1155 const IV biv = SvIVX(svr);
1158 buvok = TRUE; /* effectively it's a UV now */
1160 blow = -biv; /* abs, buvok == false records sign */
1164 /* If this does sign extension on unsigned it's time for plan B */
1165 ahigh = alow >> (4 * sizeof (UV));
1167 bhigh = blow >> (4 * sizeof (UV));
1169 if (ahigh && bhigh) {
1171 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1172 which is overflow. Drop to NVs below. */
1173 } else if (!ahigh && !bhigh) {
1174 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1175 so the unsigned multiply cannot overflow. */
1176 const UV product = alow * blow;
1177 if (auvok == buvok) {
1178 /* -ve * -ve or +ve * +ve gives a +ve result. */
1182 } else if (product <= (UV)IV_MIN) {
1183 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1184 /* -ve result, which could overflow an IV */
1186 SETi( -(IV)product );
1188 } /* else drop to NVs below. */
1190 /* One operand is large, 1 small */
1193 /* swap the operands */
1195 bhigh = blow; /* bhigh now the temp var for the swap */
1199 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1200 multiplies can't overflow. shift can, add can, -ve can. */
1201 product_middle = ahigh * blow;
1202 if (!(product_middle & topmask)) {
1203 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1205 product_middle <<= (4 * sizeof (UV));
1206 product_low = alow * blow;
1208 /* as for pp_add, UV + something mustn't get smaller.
1209 IIRC ANSI mandates this wrapping *behaviour* for
1210 unsigned whatever the actual representation*/
1211 product_low += product_middle;
1212 if (product_low >= product_middle) {
1213 /* didn't overflow */
1214 if (auvok == buvok) {
1215 /* -ve * -ve or +ve * +ve gives a +ve result. */
1217 SETu( product_low );
1219 } else if (product_low <= (UV)IV_MIN) {
1220 /* 2s complement assumption again */
1221 /* -ve result, which could overflow an IV */
1223 SETi( -(IV)product_low );
1225 } /* else drop to NVs below. */
1227 } /* product_middle too large */
1228 } /* ahigh && bhigh */
1233 NV right = SvNV(svr);
1234 NV left = SvNV(svl);
1236 SETn( left * right );
1243 dVAR; dSP; dATARGET; SV *svl, *svr;
1244 tryAMAGICbin(div,opASSIGN);
1245 svl = sv_2num(TOPm1s);
1246 svr = sv_2num(TOPs);
1247 /* Only try to do UV divide first
1248 if ((SLOPPYDIVIDE is true) or
1249 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1251 The assumption is that it is better to use floating point divide
1252 whenever possible, only doing integer divide first if we can't be sure.
1253 If NV_PRESERVES_UV is true then we know at compile time that no UV
1254 can be too large to preserve, so don't need to compile the code to
1255 test the size of UVs. */
1258 # define PERL_TRY_UV_DIVIDE
1259 /* ensure that 20./5. == 4. */
1261 # ifdef PERL_PRESERVE_IVUV
1262 # ifndef NV_PRESERVES_UV
1263 # define PERL_TRY_UV_DIVIDE
1268 #ifdef PERL_TRY_UV_DIVIDE
1273 bool left_non_neg = SvUOK(svl);
1274 bool right_non_neg = SvUOK(svr);
1278 if (right_non_neg) {
1282 const IV biv = SvIVX(svr);
1285 right_non_neg = TRUE; /* effectively it's a UV now */
1291 /* historically undef()/0 gives a "Use of uninitialized value"
1292 warning before dieing, hence this test goes here.
1293 If it were immediately before the second SvIV_please, then
1294 DIE() would be invoked before left was even inspected, so
1295 no inpsection would give no warning. */
1297 DIE(aTHX_ "Illegal division by zero");
1303 const IV aiv = SvIVX(svl);
1306 left_non_neg = TRUE; /* effectively it's a UV now */
1315 /* For sloppy divide we always attempt integer division. */
1317 /* Otherwise we only attempt it if either or both operands
1318 would not be preserved by an NV. If both fit in NVs
1319 we fall through to the NV divide code below. However,
1320 as left >= right to ensure integer result here, we know that
1321 we can skip the test on the right operand - right big
1322 enough not to be preserved can't get here unless left is
1325 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1328 /* Integer division can't overflow, but it can be imprecise. */
1329 const UV result = left / right;
1330 if (result * right == left) {
1331 SP--; /* result is valid */
1332 if (left_non_neg == right_non_neg) {
1333 /* signs identical, result is positive. */
1337 /* 2s complement assumption */
1338 if (result <= (UV)IV_MIN)
1339 SETi( -(IV)result );
1341 /* It's exact but too negative for IV. */
1342 SETn( -(NV)result );
1345 } /* tried integer divide but it was not an integer result */
1346 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1347 } /* left wasn't SvIOK */
1348 } /* right wasn't SvIOK */
1349 #endif /* PERL_TRY_UV_DIVIDE */
1351 NV right = SvNV(svr);
1352 NV left = SvNV(svl);
1353 (void)POPs;(void)POPs;
1354 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1355 if (! Perl_isnan(right) && right == 0.0)
1359 DIE(aTHX_ "Illegal division by zero");
1360 PUSHn( left / right );
1367 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1371 bool left_neg = FALSE;
1372 bool right_neg = FALSE;
1373 bool use_double = FALSE;
1374 bool dright_valid = FALSE;
1378 SV * const svr = sv_2num(TOPs);
1381 right_neg = !SvUOK(svr);
1385 const IV biv = SvIVX(svr);
1388 right_neg = FALSE; /* effectively it's a UV now */
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. */
1408 /* At this point use_double is only true if right is out of range for
1409 a UV. In range NV has been rounded down to nearest UV and
1410 use_double false. */
1411 svl = sv_2num(TOPs);
1413 if (!use_double && SvIOK(svl)) {
1415 left_neg = !SvUOK(svl);
1419 const IV aiv = SvIVX(svl);
1422 left_neg = FALSE; /* effectively it's a UV now */
1431 left_neg = dleft < 0;
1435 /* This should be exactly the 5.6 behaviour - if left and right are
1436 both in range for UV then use U_V() rather than floor. */
1438 if (dleft < UV_MAX_P1) {
1439 /* right was in range, so is dleft, so use UVs not double.
1443 /* left is out of range for UV, right was in range, so promote
1444 right (back) to double. */
1446 /* The +0.5 is used in 5.6 even though it is not strictly
1447 consistent with the implicit +0 floor in the U_V()
1448 inside the #if 1. */
1449 dleft = Perl_floor(dleft + 0.5);
1452 dright = Perl_floor(dright + 0.5);
1463 DIE(aTHX_ "Illegal modulus zero");
1465 dans = Perl_fmod(dleft, dright);
1466 if ((left_neg != right_neg) && dans)
1467 dans = dright - dans;
1470 sv_setnv(TARG, dans);
1476 DIE(aTHX_ "Illegal modulus zero");
1479 if ((left_neg != right_neg) && ans)
1482 /* XXX may warn: unary minus operator applied to unsigned type */
1483 /* could change -foo to be (~foo)+1 instead */
1484 if (ans <= ~((UV)IV_MAX)+1)
1485 sv_setiv(TARG, ~ans+1);
1487 sv_setnv(TARG, -(NV)ans);
1490 sv_setuv(TARG, ans);
1499 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1506 const UV uv = SvUV(sv);
1508 count = IV_MAX; /* The best we can do? */
1512 const IV iv = SvIV(sv);
1519 else if (SvNOKp(sv)) {
1520 const NV nv = SvNV(sv);
1528 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1530 static const char oom_list_extend[] = "Out of memory during list extend";
1531 const I32 items = SP - MARK;
1532 const I32 max = items * count;
1534 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1535 /* Did the max computation overflow? */
1536 if (items > 0 && max > 0 && (max < items || max < count))
1537 Perl_croak(aTHX_ oom_list_extend);
1542 /* This code was intended to fix 20010809.028:
1545 for (($x =~ /./g) x 2) {
1546 print chop; # "abcdabcd" expected as output.
1549 * but that change (#11635) broke this code:
1551 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1553 * I can't think of a better fix that doesn't introduce
1554 * an efficiency hit by copying the SVs. The stack isn't
1555 * refcounted, and mortalisation obviously doesn't
1556 * Do The Right Thing when the stack has more than
1557 * one pointer to the same mortal value.
1561 *SP = sv_2mortal(newSVsv(*SP));
1571 repeatcpy((char*)(MARK + items), (char*)MARK,
1572 items * sizeof(const SV *), count - 1);
1575 else if (count <= 0)
1578 else { /* Note: mark already snarfed by pp_list */
1579 SV * const tmpstr = POPs;
1582 static const char oom_string_extend[] =
1583 "Out of memory during string extend";
1585 SvSetSV(TARG, tmpstr);
1586 SvPV_force(TARG, len);
1587 isutf = DO_UTF8(TARG);
1592 const STRLEN max = (UV)count * len;
1593 if (len > MEM_SIZE_MAX / count)
1594 Perl_croak(aTHX_ oom_string_extend);
1595 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1596 SvGROW(TARG, max + 1);
1597 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1598 SvCUR_set(TARG, SvCUR(TARG) * count);
1600 *SvEND(TARG) = '\0';
1603 (void)SvPOK_only_UTF8(TARG);
1605 (void)SvPOK_only(TARG);
1607 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1608 /* The parser saw this as a list repeat, and there
1609 are probably several items on the stack. But we're
1610 in scalar context, and there's no pp_list to save us
1611 now. So drop the rest of the items -- robin@kitsite.com
1624 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1625 tryAMAGICbin(subtr,opASSIGN);
1626 svl = sv_2num(TOPm1s);
1627 svr = sv_2num(TOPs);
1628 useleft = USE_LEFT(svl);
1629 #ifdef PERL_PRESERVE_IVUV
1630 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1631 "bad things" happen if you rely on signed integers wrapping. */
1634 /* Unless the left argument is integer in range we are going to have to
1635 use NV maths. Hence only attempt to coerce the right argument if
1636 we know the left is integer. */
1637 register UV auv = 0;
1643 a_valid = auvok = 1;
1644 /* left operand is undef, treat as zero. */
1646 /* Left operand is defined, so is it IV? */
1649 if ((auvok = SvUOK(svl)))
1652 register const IV aiv = SvIVX(svl);
1655 auvok = 1; /* Now acting as a sign flag. */
1656 } else { /* 2s complement assumption for IV_MIN */
1664 bool result_good = 0;
1667 bool buvok = SvUOK(svr);
1672 register const IV biv = SvIVX(svr);
1679 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1680 else "IV" now, independent of how it came in.
1681 if a, b represents positive, A, B negative, a maps to -A etc
1686 all UV maths. negate result if A negative.
1687 subtract if signs same, add if signs differ. */
1689 if (auvok ^ buvok) {
1698 /* Must get smaller */
1703 if (result <= buv) {
1704 /* result really should be -(auv-buv). as its negation
1705 of true value, need to swap our result flag */
1717 if (result <= (UV)IV_MIN)
1718 SETi( -(IV)result );
1720 /* result valid, but out of range for IV. */
1721 SETn( -(NV)result );
1725 } /* Overflow, drop through to NVs. */
1730 NV value = SvNV(svr);
1734 /* left operand is undef, treat as zero - value */
1738 SETn( SvNV(svl) - value );
1745 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1747 const IV shift = POPi;
1748 if (PL_op->op_private & HINT_INTEGER) {
1762 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1764 const IV shift = POPi;
1765 if (PL_op->op_private & HINT_INTEGER) {
1779 dVAR; dSP; tryAMAGICbinSET(lt,0);
1780 #ifdef PERL_PRESERVE_IVUV
1783 SvIV_please(TOPm1s);
1784 if (SvIOK(TOPm1s)) {
1785 bool auvok = SvUOK(TOPm1s);
1786 bool buvok = SvUOK(TOPs);
1788 if (!auvok && !buvok) { /* ## IV < IV ## */
1789 const IV aiv = SvIVX(TOPm1s);
1790 const IV biv = SvIVX(TOPs);
1793 SETs(boolSV(aiv < biv));
1796 if (auvok && buvok) { /* ## UV < UV ## */
1797 const UV auv = SvUVX(TOPm1s);
1798 const UV buv = SvUVX(TOPs);
1801 SETs(boolSV(auv < buv));
1804 if (auvok) { /* ## UV < IV ## */
1806 const IV biv = SvIVX(TOPs);
1809 /* As (a) is a UV, it's >=0, so it cannot be < */
1814 SETs(boolSV(auv < (UV)biv));
1817 { /* ## IV < UV ## */
1818 const IV aiv = SvIVX(TOPm1s);
1822 /* As (b) is a UV, it's >=0, so it must be < */
1829 SETs(boolSV((UV)aiv < buv));
1835 #ifndef NV_PRESERVES_UV
1836 #ifdef PERL_PRESERVE_IVUV
1839 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1841 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1846 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1848 if (Perl_isnan(left) || Perl_isnan(right))
1850 SETs(boolSV(left < right));
1853 SETs(boolSV(TOPn < value));
1861 dVAR; dSP; tryAMAGICbinSET(gt,0);
1862 #ifdef PERL_PRESERVE_IVUV
1865 SvIV_please(TOPm1s);
1866 if (SvIOK(TOPm1s)) {
1867 bool auvok = SvUOK(TOPm1s);
1868 bool buvok = SvUOK(TOPs);
1870 if (!auvok && !buvok) { /* ## IV > IV ## */
1871 const IV aiv = SvIVX(TOPm1s);
1872 const IV biv = SvIVX(TOPs);
1875 SETs(boolSV(aiv > biv));
1878 if (auvok && buvok) { /* ## UV > UV ## */
1879 const UV auv = SvUVX(TOPm1s);
1880 const UV buv = SvUVX(TOPs);
1883 SETs(boolSV(auv > buv));
1886 if (auvok) { /* ## UV > IV ## */
1888 const IV biv = SvIVX(TOPs);
1892 /* As (a) is a UV, it's >=0, so it must be > */
1897 SETs(boolSV(auv > (UV)biv));
1900 { /* ## IV > UV ## */
1901 const IV aiv = SvIVX(TOPm1s);
1905 /* As (b) is a UV, it's >=0, so it cannot be > */
1912 SETs(boolSV((UV)aiv > buv));
1918 #ifndef NV_PRESERVES_UV
1919 #ifdef PERL_PRESERVE_IVUV
1922 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1924 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1929 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1931 if (Perl_isnan(left) || Perl_isnan(right))
1933 SETs(boolSV(left > right));
1936 SETs(boolSV(TOPn > value));
1944 dVAR; dSP; tryAMAGICbinSET(le,0);
1945 #ifdef PERL_PRESERVE_IVUV
1948 SvIV_please(TOPm1s);
1949 if (SvIOK(TOPm1s)) {
1950 bool auvok = SvUOK(TOPm1s);
1951 bool buvok = SvUOK(TOPs);
1953 if (!auvok && !buvok) { /* ## IV <= IV ## */
1954 const IV aiv = SvIVX(TOPm1s);
1955 const IV biv = SvIVX(TOPs);
1958 SETs(boolSV(aiv <= biv));
1961 if (auvok && buvok) { /* ## UV <= UV ## */
1962 UV auv = SvUVX(TOPm1s);
1963 UV buv = SvUVX(TOPs);
1966 SETs(boolSV(auv <= buv));
1969 if (auvok) { /* ## UV <= IV ## */
1971 const IV biv = SvIVX(TOPs);
1975 /* As (a) is a UV, it's >=0, so a cannot be <= */
1980 SETs(boolSV(auv <= (UV)biv));
1983 { /* ## IV <= UV ## */
1984 const IV aiv = SvIVX(TOPm1s);
1988 /* As (b) is a UV, it's >=0, so a must be <= */
1995 SETs(boolSV((UV)aiv <= buv));
2001 #ifndef NV_PRESERVES_UV
2002 #ifdef PERL_PRESERVE_IVUV
2005 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2007 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2012 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2014 if (Perl_isnan(left) || Perl_isnan(right))
2016 SETs(boolSV(left <= right));
2019 SETs(boolSV(TOPn <= value));
2027 dVAR; dSP; tryAMAGICbinSET(ge,0);
2028 #ifdef PERL_PRESERVE_IVUV
2031 SvIV_please(TOPm1s);
2032 if (SvIOK(TOPm1s)) {
2033 bool auvok = SvUOK(TOPm1s);
2034 bool buvok = SvUOK(TOPs);
2036 if (!auvok && !buvok) { /* ## IV >= IV ## */
2037 const IV aiv = SvIVX(TOPm1s);
2038 const IV biv = SvIVX(TOPs);
2041 SETs(boolSV(aiv >= biv));
2044 if (auvok && buvok) { /* ## UV >= UV ## */
2045 const UV auv = SvUVX(TOPm1s);
2046 const UV buv = SvUVX(TOPs);
2049 SETs(boolSV(auv >= buv));
2052 if (auvok) { /* ## UV >= IV ## */
2054 const IV biv = SvIVX(TOPs);
2058 /* As (a) is a UV, it's >=0, so it must be >= */
2063 SETs(boolSV(auv >= (UV)biv));
2066 { /* ## IV >= UV ## */
2067 const IV aiv = SvIVX(TOPm1s);
2071 /* As (b) is a UV, it's >=0, so a cannot be >= */
2078 SETs(boolSV((UV)aiv >= buv));
2084 #ifndef NV_PRESERVES_UV
2085 #ifdef PERL_PRESERVE_IVUV
2088 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2090 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2095 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2097 if (Perl_isnan(left) || Perl_isnan(right))
2099 SETs(boolSV(left >= right));
2102 SETs(boolSV(TOPn >= value));
2110 dVAR; dSP; tryAMAGICbinSET(ne,0);
2111 #ifndef NV_PRESERVES_UV
2112 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2114 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2118 #ifdef PERL_PRESERVE_IVUV
2121 SvIV_please(TOPm1s);
2122 if (SvIOK(TOPm1s)) {
2123 const bool auvok = SvUOK(TOPm1s);
2124 const bool buvok = SvUOK(TOPs);
2126 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2127 /* Casting IV to UV before comparison isn't going to matter
2128 on 2s complement. On 1s complement or sign&magnitude
2129 (if we have any of them) it could make negative zero
2130 differ from normal zero. As I understand it. (Need to
2131 check - is negative zero implementation defined behaviour
2133 const UV buv = SvUVX(POPs);
2134 const UV auv = SvUVX(TOPs);
2136 SETs(boolSV(auv != buv));
2139 { /* ## Mixed IV,UV ## */
2143 /* != is commutative so swap if needed (save code) */
2145 /* swap. top of stack (b) is the iv */
2149 /* As (a) is a UV, it's >0, so it cannot be == */
2158 /* As (b) is a UV, it's >0, so it cannot be == */
2162 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2164 SETs(boolSV((UV)iv != uv));
2171 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2173 if (Perl_isnan(left) || Perl_isnan(right))
2175 SETs(boolSV(left != right));
2178 SETs(boolSV(TOPn != value));
2186 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2187 #ifndef NV_PRESERVES_UV
2188 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2189 const UV right = PTR2UV(SvRV(POPs));
2190 const UV left = PTR2UV(SvRV(TOPs));
2191 SETi((left > right) - (left < right));
2195 #ifdef PERL_PRESERVE_IVUV
2196 /* Fortunately it seems NaN isn't IOK */
2199 SvIV_please(TOPm1s);
2200 if (SvIOK(TOPm1s)) {
2201 const bool leftuvok = SvUOK(TOPm1s);
2202 const bool rightuvok = SvUOK(TOPs);
2204 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2205 const IV leftiv = SvIVX(TOPm1s);
2206 const IV rightiv = SvIVX(TOPs);
2208 if (leftiv > rightiv)
2210 else if (leftiv < rightiv)
2214 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2215 const UV leftuv = SvUVX(TOPm1s);
2216 const UV rightuv = SvUVX(TOPs);
2218 if (leftuv > rightuv)
2220 else if (leftuv < rightuv)
2224 } else if (leftuvok) { /* ## UV <=> IV ## */
2225 const IV rightiv = SvIVX(TOPs);
2227 /* As (a) is a UV, it's >=0, so it cannot be < */
2230 const UV leftuv = SvUVX(TOPm1s);
2231 if (leftuv > (UV)rightiv) {
2233 } else if (leftuv < (UV)rightiv) {
2239 } else { /* ## IV <=> UV ## */
2240 const IV leftiv = SvIVX(TOPm1s);
2242 /* As (b) is a UV, it's >=0, so it must be < */
2245 const UV rightuv = SvUVX(TOPs);
2246 if ((UV)leftiv > rightuv) {
2248 } else if ((UV)leftiv < rightuv) {
2266 if (Perl_isnan(left) || Perl_isnan(right)) {
2270 value = (left > right) - (left < right);
2274 else if (left < right)
2276 else if (left > right)
2292 int amg_type = sle_amg;
2296 switch (PL_op->op_type) {
2315 tryAMAGICbinSET_var(amg_type,0);
2318 const int cmp = (IN_LOCALE_RUNTIME
2319 ? sv_cmp_locale(left, right)
2320 : sv_cmp(left, right));
2321 SETs(boolSV(cmp * multiplier < rhs));
2328 dVAR; dSP; tryAMAGICbinSET(seq,0);
2331 SETs(boolSV(sv_eq(left, right)));
2338 dVAR; dSP; tryAMAGICbinSET(sne,0);
2341 SETs(boolSV(!sv_eq(left, right)));
2348 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2351 const int cmp = (IN_LOCALE_RUNTIME
2352 ? sv_cmp_locale(left, right)
2353 : sv_cmp(left, right));
2361 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2366 if (SvNIOKp(left) || SvNIOKp(right)) {
2367 if (PL_op->op_private & HINT_INTEGER) {
2368 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2372 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2377 do_vop(PL_op->op_type, TARG, left, right);
2386 dVAR; dSP; dATARGET;
2387 const int op_type = PL_op->op_type;
2389 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2394 if (SvNIOKp(left) || SvNIOKp(right)) {
2395 if (PL_op->op_private & HINT_INTEGER) {
2396 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2397 const IV r = SvIV_nomg(right);
2398 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2402 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2403 const UV r = SvUV_nomg(right);
2404 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2409 do_vop(op_type, TARG, left, right);
2418 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2420 SV * const sv = sv_2num(TOPs);
2421 const int flags = SvFLAGS(sv);
2423 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2424 /* It's publicly an integer, or privately an integer-not-float */
2427 if (SvIVX(sv) == IV_MIN) {
2428 /* 2s complement assumption. */
2429 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2432 else if (SvUVX(sv) <= IV_MAX) {
2437 else if (SvIVX(sv) != IV_MIN) {
2441 #ifdef PERL_PRESERVE_IVUV
2450 else if (SvPOKp(sv)) {
2452 const char * const s = SvPV_const(sv, len);
2453 if (isIDFIRST(*s)) {
2454 sv_setpvs(TARG, "-");
2457 else if (*s == '+' || *s == '-') {
2459 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2461 else if (DO_UTF8(sv)) {
2464 goto oops_its_an_int;
2466 sv_setnv(TARG, -SvNV(sv));
2468 sv_setpvs(TARG, "-");
2475 goto oops_its_an_int;
2476 sv_setnv(TARG, -SvNV(sv));
2488 dVAR; dSP; tryAMAGICunSET(not);
2489 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2495 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2500 if (PL_op->op_private & HINT_INTEGER) {
2501 const IV i = ~SvIV_nomg(sv);
2505 const UV u = ~SvUV_nomg(sv);
2514 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2515 sv_setsv_nomg(TARG, sv);
2516 tmps = (U8*)SvPV_force(TARG, len);
2519 /* Calculate exact length, let's not estimate. */
2524 U8 * const send = tmps + len;
2525 U8 * const origtmps = tmps;
2526 const UV utf8flags = UTF8_ALLOW_ANYUV;
2528 while (tmps < send) {
2529 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2531 targlen += UNISKIP(~c);
2537 /* Now rewind strings and write them. */
2544 Newx(result, targlen + 1, U8);
2546 while (tmps < send) {
2547 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2549 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2552 sv_usepvn_flags(TARG, (char*)result, targlen,
2553 SV_HAS_TRAILING_NUL);
2560 Newx(result, nchar + 1, U8);
2562 while (tmps < send) {
2563 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2568 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2576 register long *tmpl;
2577 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2580 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2585 for ( ; anum > 0; anum--, tmps++)
2593 /* integer versions of some of the above */
2597 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2600 SETi( left * right );
2608 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2612 DIE(aTHX_ "Illegal division by zero");
2615 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2619 value = num / value;
2625 #if defined(__GLIBC__) && IVSIZE == 8
2632 /* This is the vanilla old i_modulo. */
2633 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2637 DIE(aTHX_ "Illegal modulus zero");
2638 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2642 SETi( left % right );
2647 #if defined(__GLIBC__) && IVSIZE == 8
2652 /* This is the i_modulo with the workaround for the _moddi3 bug
2653 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2654 * See below for pp_i_modulo. */
2655 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2659 DIE(aTHX_ "Illegal modulus zero");
2660 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2664 SETi( left % PERL_ABS(right) );
2671 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2675 DIE(aTHX_ "Illegal modulus zero");
2676 /* The assumption is to use hereafter the old vanilla version... */
2678 PL_ppaddr[OP_I_MODULO] =
2680 /* .. but if we have glibc, we might have a buggy _moddi3
2681 * (at least glicb 2.2.5 is known to have this bug), in other
2682 * words our integer modulus with negative quad as the second
2683 * argument might be broken. Test for this and re-patch the
2684 * opcode dispatch table if that is the case, remembering to
2685 * also apply the workaround so that this first round works
2686 * right, too. See [perl #9402] for more information. */
2690 /* Cannot do this check with inlined IV constants since
2691 * that seems to work correctly even with the buggy glibc. */
2693 /* Yikes, we have the bug.
2694 * Patch in the workaround version. */
2696 PL_ppaddr[OP_I_MODULO] =
2697 &Perl_pp_i_modulo_1;
2698 /* Make certain we work right this time, too. */
2699 right = PERL_ABS(right);
2702 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2706 SETi( left % right );
2714 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2717 SETi( left + right );
2724 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2727 SETi( left - right );
2734 dVAR; dSP; tryAMAGICbinSET(lt,0);
2737 SETs(boolSV(left < right));
2744 dVAR; dSP; tryAMAGICbinSET(gt,0);
2747 SETs(boolSV(left > right));
2754 dVAR; dSP; tryAMAGICbinSET(le,0);
2757 SETs(boolSV(left <= right));
2764 dVAR; dSP; tryAMAGICbinSET(ge,0);
2767 SETs(boolSV(left >= right));
2774 dVAR; dSP; tryAMAGICbinSET(eq,0);
2777 SETs(boolSV(left == right));
2784 dVAR; dSP; tryAMAGICbinSET(ne,0);
2787 SETs(boolSV(left != right));
2794 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2801 else if (left < right)
2812 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2817 /* High falutin' math. */
2821 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2824 SETn(Perl_atan2(left, right));
2832 int amg_type = sin_amg;
2833 const char *neg_report = NULL;
2834 NV (*func)(NV) = Perl_sin;
2835 const int op_type = PL_op->op_type;
2852 amg_type = sqrt_amg;
2854 neg_report = "sqrt";
2858 tryAMAGICun_var(amg_type);
2860 const NV value = POPn;
2862 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2863 SET_NUMERIC_STANDARD();
2864 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2867 XPUSHn(func(value));
2872 /* Support Configure command-line overrides for rand() functions.
2873 After 5.005, perhaps we should replace this by Configure support
2874 for drand48(), random(), or rand(). For 5.005, though, maintain
2875 compatibility by calling rand() but allow the user to override it.
2876 See INSTALL for details. --Andy Dougherty 15 July 1998
2878 /* Now it's after 5.005, and Configure supports drand48() and random(),
2879 in addition to rand(). So the overrides should not be needed any more.
2880 --Jarkko Hietaniemi 27 September 1998
2883 #ifndef HAS_DRAND48_PROTO
2884 extern double drand48 (void);
2897 if (!PL_srand_called) {
2898 (void)seedDrand01((Rand_seed_t)seed());
2899 PL_srand_called = TRUE;
2909 const UV anum = (MAXARG < 1) ? seed() : POPu;
2910 (void)seedDrand01((Rand_seed_t)anum);
2911 PL_srand_called = TRUE;
2918 dVAR; dSP; dTARGET; tryAMAGICun(int);
2920 SV * const sv = sv_2num(TOPs);
2921 const IV iv = SvIV(sv);
2922 /* XXX it's arguable that compiler casting to IV might be subtly
2923 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2924 else preferring IV has introduced a subtle behaviour change bug. OTOH
2925 relying on floating point to be accurate is a bug. */
2930 else if (SvIOK(sv)) {
2937 const NV value = SvNV(sv);
2939 if (value < (NV)UV_MAX + 0.5) {
2942 SETn(Perl_floor(value));
2946 if (value > (NV)IV_MIN - 0.5) {
2949 SETn(Perl_ceil(value));
2959 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2961 SV * const sv = sv_2num(TOPs);
2962 /* This will cache the NV value if string isn't actually integer */
2963 const IV iv = SvIV(sv);
2968 else if (SvIOK(sv)) {
2969 /* IVX is precise */
2971 SETu(SvUV(sv)); /* force it to be numeric only */
2979 /* 2s complement assumption. Also, not really needed as
2980 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2986 const NV value = SvNV(sv);
3000 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3004 SV* const sv = POPs;
3006 tmps = (SvPV_const(sv, len));
3008 /* If Unicode, try to downgrade
3009 * If not possible, croak. */
3010 SV* const tsv = sv_2mortal(newSVsv(sv));
3013 sv_utf8_downgrade(tsv, FALSE);
3014 tmps = SvPV_const(tsv, len);
3016 if (PL_op->op_type == OP_HEX)
3019 while (*tmps && len && isSPACE(*tmps))
3025 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3027 else if (*tmps == 'b')
3028 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3030 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3032 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3046 SV * const sv = TOPs;
3048 if (SvGAMAGIC(sv)) {
3049 /* For an overloaded or magic scalar, we can't know in advance if
3050 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3051 it likes to cache the length. Maybe that should be a documented
3056 = sv_2pv_flags(sv, &len,
3057 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3061 else if (DO_UTF8(sv)) {
3062 SETi(utf8_length((U8*)p, (U8*)p + len));
3066 } else if (SvOK(sv)) {
3067 /* Neither magic nor overloaded. */
3069 SETi(sv_len_utf8(sv));
3092 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3094 const IV arybase = CopARYBASE_get(PL_curcop);
3096 const char *repl = NULL;
3098 const int num_args = PL_op->op_private & 7;
3099 bool repl_need_utf8_upgrade = FALSE;
3100 bool repl_is_utf8 = FALSE;
3102 SvTAINTED_off(TARG); /* decontaminate */
3103 SvUTF8_off(TARG); /* decontaminate */
3107 repl = SvPV_const(repl_sv, repl_len);
3108 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3111 len_iv = SvIV(len_sv);
3112 len_is_uv = SvIOK_UV(len_sv);
3115 pos1_iv = SvIV(pos_sv);
3116 pos1_is_uv = SvIOK_UV(pos_sv);
3122 sv_utf8_upgrade(sv);
3124 else if (DO_UTF8(sv))
3125 repl_need_utf8_upgrade = TRUE;
3127 tmps = SvPV_const(sv, curlen);
3129 utf8_curlen = sv_len_utf8(sv);
3130 if (utf8_curlen == curlen)
3133 curlen = utf8_curlen;
3138 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3139 UV pos1_uv = pos1_iv-arybase;
3140 /* Overflow can occur when $[ < 0 */
3141 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3146 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3147 goto bound_fail; /* $[=3; substr($_,2,...) */
3149 else { /* pos < $[ */
3150 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3155 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3160 if (pos1_is_uv || pos1_iv > 0) {
3161 if ((UV)pos1_iv > curlen)
3166 if (!len_is_uv && len_iv < 0) {
3167 pos2_iv = curlen + len_iv;
3169 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3172 } else { /* len_iv >= 0 */
3173 if (!pos1_is_uv && pos1_iv < 0) {
3174 pos2_iv = pos1_iv + len_iv;
3175 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3177 if ((UV)len_iv > curlen-(UV)pos1_iv)
3180 pos2_iv = pos1_iv+len_iv;
3190 if (!pos2_is_uv && pos2_iv < 0) {
3191 if (!pos1_is_uv && pos1_iv < 0)
3195 else if (!pos1_is_uv && pos1_iv < 0)
3198 if ((UV)pos2_iv < (UV)pos1_iv)
3200 if ((UV)pos2_iv > curlen)
3204 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3205 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3206 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3207 STRLEN byte_len = len;
3208 STRLEN byte_pos = utf8_curlen
3209 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3212 /* we either return a PV or an LV. If the TARG hasn't been used
3213 * before, or is of that type, reuse it; otherwise use a mortal
3214 * instead. Note that LVs can have an extended lifetime, so also
3215 * dont reuse if refcount > 1 (bug #20933) */
3216 if (SvTYPE(TARG) > SVt_NULL) {
3217 if ( (SvTYPE(TARG) == SVt_PVLV)
3218 ? (!lvalue || SvREFCNT(TARG) > 1)
3221 TARG = sv_newmortal();
3225 sv_setpvn(TARG, tmps, byte_len);
3226 #ifdef USE_LOCALE_COLLATE
3227 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3232 SV* repl_sv_copy = NULL;
3234 if (repl_need_utf8_upgrade) {
3235 repl_sv_copy = newSVsv(repl_sv);
3236 sv_utf8_upgrade(repl_sv_copy);
3237 repl = SvPV_const(repl_sv_copy, repl_len);
3238 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3242 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3245 SvREFCNT_dec(repl_sv_copy);
3247 else if (lvalue) { /* it's an lvalue! */
3248 if (!SvGMAGICAL(sv)) {
3250 SvPV_force_nolen(sv);
3251 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3252 "Attempt to use reference as lvalue in substr");
3254 if (isGV_with_GP(sv))
3255 SvPV_force_nolen(sv);
3256 else if (SvOK(sv)) /* is it defined ? */
3257 (void)SvPOK_only_UTF8(sv);
3259 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3262 if (SvTYPE(TARG) < SVt_PVLV) {
3263 sv_upgrade(TARG, SVt_PVLV);
3264 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3268 if (LvTARG(TARG) != sv) {
3269 SvREFCNT_dec(LvTARG(TARG));
3270 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3272 LvTARGOFF(TARG) = pos;
3273 LvTARGLEN(TARG) = len;
3277 PUSHs(TARG); /* avoid SvSETMAGIC here */
3282 Perl_croak(aTHX_ "substr outside of string");
3283 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3290 register const IV size = POPi;
3291 register const IV offset = POPi;
3292 register SV * const src = POPs;
3293 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3295 SvTAINTED_off(TARG); /* decontaminate */
3296 if (lvalue) { /* it's an lvalue! */
3297 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3298 TARG = sv_newmortal();
3299 if (SvTYPE(TARG) < SVt_PVLV) {
3300 sv_upgrade(TARG, SVt_PVLV);
3301 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3304 if (LvTARG(TARG) != src) {
3305 SvREFCNT_dec(LvTARG(TARG));
3306 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3308 LvTARGOFF(TARG) = offset;
3309 LvTARGLEN(TARG) = size;
3312 sv_setuv(TARG, do_vecget(src, offset, size));
3328 const char *little_p;
3329 const I32 arybase = CopARYBASE_get(PL_curcop);
3332 const bool is_index = PL_op->op_type == OP_INDEX;
3335 /* arybase is in characters, like offset, so combine prior to the
3336 UTF-8 to bytes calculation. */
3337 offset = POPi - arybase;
3341 big_p = SvPV_const(big, biglen);
3342 little_p = SvPV_const(little, llen);
3344 big_utf8 = DO_UTF8(big);
3345 little_utf8 = DO_UTF8(little);
3346 if (big_utf8 ^ little_utf8) {
3347 /* One needs to be upgraded. */
3348 if (little_utf8 && !PL_encoding) {
3349 /* Well, maybe instead we might be able to downgrade the small
3351 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3354 /* If the large string is ISO-8859-1, and it's not possible to
3355 convert the small string to ISO-8859-1, then there is no
3356 way that it could be found anywhere by index. */
3361 /* At this point, pv is a malloc()ed string. So donate it to temp
3362 to ensure it will get free()d */
3363 little = temp = newSV(0);
3364 sv_usepvn(temp, pv, llen);
3365 little_p = SvPVX(little);
3368 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3371 sv_recode_to_utf8(temp, PL_encoding);
3373 sv_utf8_upgrade(temp);
3378 big_p = SvPV_const(big, biglen);
3381 little_p = SvPV_const(little, llen);
3385 if (SvGAMAGIC(big)) {
3386 /* Life just becomes a lot easier if I use a temporary here.
3387 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3388 will trigger magic and overloading again, as will fbm_instr()
3390 big = newSVpvn_flags(big_p, biglen,
3391 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3394 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3395 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3396 warn on undef, and we've already triggered a warning with the
3397 SvPV_const some lines above. We can't remove that, as we need to
3398 call some SvPV to trigger overloading early and find out if the
3400 This is all getting to messy. The API isn't quite clean enough,
3401 because data access has side effects.
3403 little = newSVpvn_flags(little_p, llen,
3404 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3405 little_p = SvPVX(little);
3409 offset = is_index ? 0 : biglen;
3411 if (big_utf8 && offset > 0)
3412 sv_pos_u2b(big, &offset, 0);
3418 else if (offset > (I32)biglen)
3420 if (!(little_p = is_index
3421 ? fbm_instr((unsigned char*)big_p + offset,
3422 (unsigned char*)big_p + biglen, little, 0)
3423 : rninstr(big_p, big_p + offset,
3424 little_p, little_p + llen)))
3427 retval = little_p - big_p;
3428 if (retval > 0 && big_utf8)
3429 sv_pos_b2u(big, &retval);
3433 PUSHi(retval + arybase);
3439 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3440 if (SvTAINTED(MARK[1]))
3441 TAINT_PROPER("sprintf");
3442 SvTAINTED_off(TARG);
3443 do_sprintf(TARG, SP-MARK, MARK+1);
3444 TAINT_IF(SvTAINTED(TARG));
3456 const U8 *s = (U8*)SvPV_const(argsv, len);
3458 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3459 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3460 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3464 XPUSHu(DO_UTF8(argsv) ?
3465 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3477 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3479 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3481 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3483 (void) POPs; /* Ignore the argument value. */
3484 value = UNICODE_REPLACEMENT;
3490 SvUPGRADE(TARG,SVt_PV);
3492 if (value > 255 && !IN_BYTES) {
3493 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3494 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3495 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3497 (void)SvPOK_only(TARG);
3506 *tmps++ = (char)value;
3508 (void)SvPOK_only(TARG);
3510 if (PL_encoding && !IN_BYTES) {
3511 sv_recode_to_utf8(TARG, PL_encoding);
3513 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3514 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3518 *tmps++ = (char)value;
3534 const char *tmps = SvPV_const(left, len);
3536 if (DO_UTF8(left)) {
3537 /* If Unicode, try to downgrade.
3538 * If not possible, croak.
3539 * Yes, we made this up. */
3540 SV* const tsv = sv_2mortal(newSVsv(left));
3543 sv_utf8_downgrade(tsv, FALSE);
3544 tmps = SvPV_const(tsv, len);
3546 # ifdef USE_ITHREADS
3548 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3549 /* This should be threadsafe because in ithreads there is only
3550 * one thread per interpreter. If this would not be true,
3551 * we would need a mutex to protect this malloc. */
3552 PL_reentrant_buffer->_crypt_struct_buffer =
3553 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3554 #if defined(__GLIBC__) || defined(__EMX__)
3555 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3556 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3557 /* work around glibc-2.2.5 bug */
3558 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3562 # endif /* HAS_CRYPT_R */
3563 # endif /* USE_ITHREADS */
3565 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3567 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3573 "The crypt() function is unimplemented due to excessive paranoia.");
3578 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3579 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3581 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3582 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3583 * See http://www.unicode.org/unicode/reports/tr16 */
3584 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3585 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3587 /* Below are several macros that generate code */
3588 /* Generates code to store a unicode codepoint c that is known to occupy
3589 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3590 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3592 *(p) = UTF8_TWO_BYTE_HI(c); \
3593 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3596 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3597 * available byte after the two bytes */
3598 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3600 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3601 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3604 /* Generates code to store the upper case of latin1 character l which is known
3605 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3606 * are only two characters that fit this description, and this macro knows
3607 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3609 #define STORE_NON_LATIN1_UC(p, l) \
3611 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3612 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3613 } else { /* Must be the following letter */ \
3614 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3618 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3619 * after the character stored */
3620 #define CAT_NON_LATIN1_UC(p, l) \
3622 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3623 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3625 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3629 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3630 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3631 * and must require two bytes to store it. Advances p to point to the next
3632 * available position */
3633 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3635 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3636 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3637 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3638 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3639 } else {/* else is one of the other two special cases */ \
3640 CAT_NON_LATIN1_UC((p), (l)); \
3646 /* Actually is both lcfirst() and ucfirst(). Only the first character
3647 * changes. This means that possibly we can change in-place, ie., just
3648 * take the source and change that one character and store it back, but not
3649 * if read-only etc, or if the length changes */
3654 STRLEN slen; /* slen is the byte length of the whole SV. */
3657 bool inplace; /* ? Convert first char only, in-place */
3658 bool doing_utf8 = FALSE; /* ? using utf8 */
3659 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3660 const int op_type = PL_op->op_type;
3663 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3664 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3665 * stored as UTF-8 at s. */
3666 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3667 * lowercased) character stored in tmpbuf. May be either
3668 * UTF-8 or not, but in either case is the number of bytes */
3672 s = (const U8*)SvPV_nomg_const(source, slen);
3674 if (ckWARN(WARN_UNINITIALIZED))
3675 report_uninit(source);
3680 /* We may be able to get away with changing only the first character, in
3681 * place, but not if read-only, etc. Later we may discover more reasons to
3682 * not convert in-place. */
3683 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3685 /* First calculate what the changed first character should be. This affects
3686 * whether we can just swap it out, leaving the rest of the string unchanged,
3687 * or even if have to convert the dest to UTF-8 when the source isn't */
3689 if (! slen) { /* If empty */
3690 need = 1; /* still need a trailing NUL */
3692 else if (DO_UTF8(source)) { /* Is the source utf8? */
3695 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3696 * and doesn't allow for the user to specify their own. When code is added to
3697 * detect if there is a user-defined mapping in force here, and if so to use
3698 * that, then the code below can be compiled. The detection would be a good
3699 * thing anyway, as currently the user-defined mappings only work on utf8
3700 * strings, and thus depend on the chosen internal storage method, which is a
3702 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3703 if (UTF8_IS_INVARIANT(*s)) {
3705 /* An invariant source character is either ASCII or, in EBCDIC, an
3706 * ASCII equivalent or a caseless C1 control. In both these cases,
3707 * the lower and upper cases of any character are also invariants
3708 * (and title case is the same as upper case). So it is safe to
3709 * use the simple case change macros which avoid the overhead of
3710 * the general functions. Note that if perl were to be extended to
3711 * do locale handling in UTF-8 strings, this wouldn't be true in,
3712 * for example, Lithuanian or Turkic. */
3713 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3717 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3720 /* Similarly, if the source character isn't invariant but is in the
3721 * latin1 range (or EBCDIC equivalent thereof), we have the case
3722 * changes compiled into perl, and can avoid the overhead of the
3723 * general functions. In this range, the characters are stored as
3724 * two UTF-8 bytes, and it so happens that any changed-case version
3725 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3729 /* Convert the two source bytes to a single Unicode code point
3730 * value, change case and save for below */
3731 chr = UTF8_ACCUMULATE(*s, *(s+1));
3732 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3733 U8 lower = toLOWER_LATIN1(chr);
3734 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3736 else { /* ucfirst */
3737 U8 upper = toUPPER_LATIN1_MOD(chr);
3739 /* Most of the latin1 range characters are well-behaved. Their
3740 * title and upper cases are the same, and are also in the
3741 * latin1 range. The macro above returns their upper (hence
3742 * title) case, and all that need be done is to save the result
3743 * for below. However, several characters are problematic, and
3744 * have to be handled specially. The MOD in the macro name
3745 * above means that these tricky characters all get mapped to
3746 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3747 * This mapping saves some tests for the majority of the
3750 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3752 /* Not tricky. Just save it. */
3753 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3755 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3757 /* This one is tricky because it is two characters long,
3758 * though the UTF-8 is still two bytes, so the stored
3759 * length doesn't change */
3760 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3761 *(tmpbuf + 1) = 's';
3765 /* The other two have their title and upper cases the same,
3766 * but are tricky because the changed-case characters
3767 * aren't in the latin1 range. They, however, do fit into
3768 * two UTF-8 bytes */
3769 STORE_NON_LATIN1_UC(tmpbuf, chr);
3774 #endif /* end of dont want to break user-defined casing */
3776 /* Here, can't short-cut the general case */
3778 utf8_to_uvchr(s, &ulen);
3779 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3780 else toLOWER_utf8(s, tmpbuf, &tculen);
3782 /* we can't do in-place if the length changes. */
3783 if (ulen != tculen) inplace = FALSE;
3784 need = slen + 1 - ulen + tculen;
3785 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3789 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3790 * latin1 is treated as caseless. Note that a locale takes
3792 tculen = 1; /* Most characters will require one byte, but this will
3793 * need to be overridden for the tricky ones */
3796 if (op_type == OP_LCFIRST) {
3798 /* lower case the first letter: no trickiness for any character */
3799 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3800 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3803 else if (IN_LOCALE_RUNTIME) {
3804 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3805 * have upper and title case different
3808 else if (! IN_UNI_8_BIT) {
3809 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3810 * on EBCDIC machines whatever the
3811 * native function does */
3813 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3814 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3816 /* tmpbuf now has the correct title case for all latin1 characters
3817 * except for the several ones that have tricky handling. All
3818 * of these are mapped by the MOD to the letter below. */
3819 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3821 /* The length is going to change, with all three of these, so
3822 * can't replace just the first character */
3825 /* We use the original to distinguish between these tricky
3827 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3828 /* Two character title case 'Ss', but can remain non-UTF-8 */
3831 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3836 /* The other two tricky ones have their title case outside
3837 * latin1. It is the same as their upper case. */
3839 STORE_NON_LATIN1_UC(tmpbuf, *s);
3841 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3842 * and their upper cases is 2. */
3845 /* The entire result will have to be in UTF-8. Assume worst
3846 * case sizing in conversion. (all latin1 characters occupy
3847 * at most two bytes in utf8) */
3848 convert_source_to_utf8 = TRUE;
3849 need = slen * 2 + 1;
3851 } /* End of is one of the three special chars */
3852 } /* End of use Unicode (Latin1) semantics */
3853 } /* End of changing the case of the first character */
3855 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3856 * generate the result */
3859 /* We can convert in place. This means we change just the first
3860 * character without disturbing the rest; no need to grow */
3862 s = d = (U8*)SvPV_force_nomg(source, slen);
3868 /* Here, we can't convert in place; we earlier calculated how much
3869 * space we will need, so grow to accommodate that */
3870 SvUPGRADE(dest, SVt_PV);
3871 d = (U8*)SvGROW(dest, need);
3872 (void)SvPOK_only(dest);
3879 if (! convert_source_to_utf8) {
3881 /* Here both source and dest are in UTF-8, but have to create
3882 * the entire output. We initialize the result to be the
3883 * title/lower cased first character, and then append the rest
3885 sv_setpvn(dest, (char*)tmpbuf, tculen);
3887 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3891 const U8 *const send = s + slen;
3893 /* Here the dest needs to be in UTF-8, but the source isn't,
3894 * except we earlier UTF-8'd the first character of the source
3895 * into tmpbuf. First put that into dest, and then append the
3896 * rest of the source, converting it to UTF-8 as we go. */
3898 /* Assert tculen is 2 here because the only two characters that
3899 * get to this part of the code have 2-byte UTF-8 equivalents */
3901 *d++ = *(tmpbuf + 1);
3902 s++; /* We have just processed the 1st char */
3904 for (; s < send; s++) {
3905 d = uvchr_to_utf8(d, *s);
3908 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3912 else { /* in-place UTF-8. Just overwrite the first character */
3913 Copy(tmpbuf, d, tculen, U8);
3914 SvCUR_set(dest, need - 1);
3917 else { /* Neither source nor dest are in or need to be UTF-8 */
3919 if (IN_LOCALE_RUNTIME) {
3923 if (inplace) { /* in-place, only need to change the 1st char */
3926 else { /* Not in-place */
3928 /* Copy the case-changed character(s) from tmpbuf */
3929 Copy(tmpbuf, d, tculen, U8);
3930 d += tculen - 1; /* Code below expects d to point to final
3931 * character stored */
3934 else { /* empty source */
3935 /* See bug #39028: Don't taint if empty */
3939 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3940 * the destination to retain that flag */
3944 if (!inplace) { /* Finish the rest of the string, unchanged */
3945 /* This will copy the trailing NUL */
3946 Copy(s + 1, d + 1, slen, U8);
3947 SvCUR_set(dest, need - 1);
3954 /* There's so much setup/teardown code common between uc and lc, I wonder if
3955 it would be worth merging the two, and just having a switch outside each
3956 of the three tight loops. There is less and less commonality though */
3970 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3971 && SvTEMP(source) && !DO_UTF8(source)
3972 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3974 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3975 * make the loop tight, so we overwrite the source with the dest before
3976 * looking at it, and we need to look at the original source
3977 * afterwards. There would also need to be code added to handle
3978 * switching to not in-place in midstream if we run into characters
3979 * that change the length.
3982 s = d = (U8*)SvPV_force_nomg(source, len);
3989 /* The old implementation would copy source into TARG at this point.
3990 This had the side effect that if source was undef, TARG was now
3991 an undefined SV with PADTMP set, and they don't warn inside
3992 sv_2pv_flags(). However, we're now getting the PV direct from
3993 source, which doesn't have PADTMP set, so it would warn. Hence the
3997 s = (const U8*)SvPV_nomg_const(source, len);
3999 if (ckWARN(WARN_UNINITIALIZED))
4000 report_uninit(source);
4006 SvUPGRADE(dest, SVt_PV);
4007 d = (U8*)SvGROW(dest, min);
4008 (void)SvPOK_only(dest);
4013 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4014 to check DO_UTF8 again here. */
4016 if (DO_UTF8(source)) {
4017 const U8 *const send = s + len;
4018 U8 tmpbuf[UTF8_MAXBYTES+1];
4020 /* This is ifdefd out because it needs more work and thought. It isn't clear
4021 * that we should do it. These are hard-coded rules from the Unicode standard,
4022 * and may change. 5.2 gives new guidance on the iota subscript, for example,
4023 * which has not been checked against this; and secondly it may be that we are
4024 * passed a subset of the context, via a \U...\E, for example, and its not
4025 * clear what the best approach is to that */
4026 #ifdef CONTEXT_DEPENDENT_CASING
4027 bool in_iota_subscript = FALSE;
4031 #ifdef CONTEXT_DEPENDENT_CASING
4032 if (in_iota_subscript && ! is_utf8_mark(s)) {
4033 /* A non-mark. Time to output the iota subscript */
4034 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4035 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4037 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4038 in_iota_subscript = FALSE;
4043 /* See comments at the first instance in this file of this ifdef */
4044 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4046 /* If the UTF-8 character is invariant, then it is in the range
4047 * known by the standard macro; result is only one byte long */
4048 if (UTF8_IS_INVARIANT(*s)) {
4052 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4054 /* Likewise, if it fits in a byte, its case change is in our
4056 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4057 U8 upper = toUPPER_LATIN1_MOD(orig);
4058 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4066 /* Otherwise, need the general UTF-8 case. Get the changed
4067 * case value and copy it to the output buffer */
4069 const STRLEN u = UTF8SKIP(s);
4072 #ifndef CONTEXT_DEPENDENT_CASING
4073 toUPPER_utf8(s, tmpbuf, &ulen);
4075 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4076 if (uv == GREEK_CAPITAL_LETTER_IOTA && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI) {
4077 in_iota_subscript = TRUE;
4081 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4082 /* If the eventually required minimum size outgrows
4083 * the available space, we need to grow. */
4084 const UV o = d - (U8*)SvPVX_const(dest);
4086 /* If someone uppercases one million U+03B0s we
4087 * SvGROW() one million times. Or we could try
4088 * guessing how much to allocate without allocating too
4089 * much. Such is life. See corresponding comment in lc code
4090 * for another option */
4092 d = (U8*)SvPVX(dest) + o;
4094 Copy(tmpbuf, d, ulen, U8);
4096 #ifdef CONTEXT_DEPENDENT_CASING
4102 #ifdef CONTEXT_DEPENDENT_CASING
4103 if (in_iota_subscript) CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4107 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4108 } else { /* Not UTF-8 */
4110 const U8 *const send = s + len;
4112 /* Use locale casing if in locale; regular style if not treating
4113 * latin1 as having case; otherwise the latin1 casing. Do the
4114 * whole thing in a tight loop, for speed, */
4115 if (IN_LOCALE_RUNTIME) {
4118 for (; s < send; d++, s++)
4119 *d = toUPPER_LC(*s);
4121 else if (! IN_UNI_8_BIT) {
4122 for (; s < send; d++, s++) {
4127 for (; s < send; d++, s++) {
4128 *d = toUPPER_LATIN1_MOD(*s);
4129 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4131 /* The mainstream case is the tight loop above. To avoid
4132 * extra tests in that, all three characters that require
4133 * special handling are mapped by the MOD to the one tested
4135 * Use the source to distinguish between the three cases */
4137 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4139 /* uc() of this requires 2 characters, but they are
4140 * ASCII. If not enough room, grow the string */
4141 if (SvLEN(dest) < ++min) {
4142 const UV o = d - (U8*)SvPVX_const(dest);
4144 d = (U8*)SvPVX(dest) + o;
4146 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4147 continue; /* Back to the tight loop; still in ASCII */
4150 /* The other two special handling characters have their
4151 * upper cases outside the latin1 range, hence need to be
4152 * in UTF-8, so the whole result needs to be in UTF-8. So,
4153 * here we are somewhere in the middle of processing a
4154 * non-UTF-8 string, and realize that we will have to convert
4155 * the whole thing to UTF-8. What to do? There are
4156 * several possibilities. The simplest to code is to
4157 * convert what we have so far, set a flag, and continue on
4158 * in the loop. The flag would be tested each time through
4159 * the loop, and if set, the next character would be
4160 * converted to UTF-8 and stored. But, I (khw) didn't want
4161 * to slow down the mainstream case at all for this fairly
4162 * rare case, so I didn't want to add a test that didn't
4163 * absolutely have to be there in the loop, besides the
4164 * possibility that it would get too complicated for
4165 * optimizers to deal with. Another possibility is to just
4166 * give up, convert the source to UTF-8, and restart the
4167 * function that way. Another possibility is to convert
4168 * both what has already been processed and what is yet to
4169 * come separately to UTF-8, then jump into the loop that
4170 * handles UTF-8. But the most efficient time-wise of the
4171 * ones I could think of is what follows, and turned out to
4172 * not require much extra code. */
4174 /* Convert what we have so far into UTF-8, telling the
4175 * function that we know it should be converted, and to
4176 * allow extra space for what we haven't processed yet.
4177 * Assume the worst case space requirements for converting
4178 * what we haven't processed so far: that it will require
4179 * two bytes for each remaining source character, plus the
4180 * NUL at the end. This may cause the string pointer to
4181 * move, so re-find it. */
4183 len = d - (U8*)SvPVX_const(dest);
4184 SvCUR_set(dest, len);
4185 len = sv_utf8_upgrade_flags_grow(dest,
4186 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4188 d = (U8*)SvPVX(dest) + len;
4190 /* And append the current character's upper case in UTF-8 */
4191 CAT_NON_LATIN1_UC(d, *s);
4193 /* Now process the remainder of the source, converting to
4194 * upper and UTF-8. If a resulting byte is invariant in
4195 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4196 * append it to the output. */
4199 for (; s < send; s++) {
4200 U8 upper = toUPPER_LATIN1_MOD(*s);
4201 if UTF8_IS_INVARIANT(upper) {
4205 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4209 /* Here have processed the whole source; no need to continue
4210 * with the outer loop. Each character has been converted
4211 * to upper case and converted to UTF-8 */
4214 } /* End of processing all latin1-style chars */
4215 } /* End of processing all chars */
4216 } /* End of source is not empty */
4218 if (source != dest) {
4219 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4220 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4222 } /* End of isn't utf8 */
4240 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4241 && SvTEMP(source) && !DO_UTF8(source)) {
4243 /* We can convert in place, as lowercasing anything in the latin1 range
4244 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4246 s = d = (U8*)SvPV_force_nomg(source, len);
4253 /* The old implementation would copy source into TARG at this point.
4254 This had the side effect that if source was undef, TARG was now
4255 an undefined SV with PADTMP set, and they don't warn inside
4256 sv_2pv_flags(). However, we're now getting the PV direct from
4257 source, which doesn't have PADTMP set, so it would warn. Hence the
4261 s = (const U8*)SvPV_nomg_const(source, len);
4263 if (ckWARN(WARN_UNINITIALIZED))
4264 report_uninit(source);
4270 SvUPGRADE(dest, SVt_PV);
4271 d = (U8*)SvGROW(dest, min);
4272 (void)SvPOK_only(dest);
4277 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4278 to check DO_UTF8 again here. */
4280 if (DO_UTF8(source)) {
4281 const U8 *const send = s + len;
4282 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4285 /* See comments at the first instance in this file of this ifdef */
4286 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4287 if (UTF8_IS_INVARIANT(*s)) {
4289 /* Invariant characters use the standard mappings compiled in.
4294 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4296 /* As do the ones in the Latin1 range */
4297 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4298 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4303 /* Here, is utf8 not in Latin-1 range, have to go out and get
4304 * the mappings from the tables. */
4306 const STRLEN u = UTF8SKIP(s);
4309 /* See comments at the first instance in this file of this ifdef */
4310 #ifndef CONTEXT_DEPENDENT_CASING
4311 toLOWER_utf8(s, tmpbuf, &ulen);
4313 /* Here is context dependent casing, not compiled in currently;
4314 * needs more thought and work */
4316 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4318 /* If the lower case is a small sigma, it may be that we need
4319 * to change it to a final sigma. This happens at the end of
4320 * a word that contains more than just this character, and only
4321 * when we started with a capital sigma. */
4322 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4323 s > send - len && /* Makes sure not the first letter */
4324 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4327 /* We use the algorithm in:
4328 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4329 * is a CAPITAL SIGMA): If C is preceded by a sequence
4330 * consisting of a cased letter and a case-ignorable
4331 * sequence, and C is not followed by a sequence consisting
4332 * of a case ignorable sequence and then a cased letter,
4333 * then when lowercasing C, C becomes a final sigma */
4335 /* To determine if this is the end of a word, need to peek
4336 * ahead. Look at the next character */
4337 const U8 *peek = s + u;
4339 /* Skip any case ignorable characters */
4340 while (peek < send && is_utf8_case_ignorable(peek)) {
4341 peek += UTF8SKIP(peek);
4344 /* If we reached the end of the string without finding any
4345 * non-case ignorable characters, or if the next such one
4346 * is not-cased, then we have met the conditions for it
4347 * being a final sigma with regards to peek ahead, and so
4348 * must do peek behind for the remaining conditions. (We
4349 * know there is stuff behind to look at since we tested
4350 * above that this isn't the first letter) */
4351 if (peek >= send || ! is_utf8_cased(peek)) {
4352 peek = utf8_hop(s, -1);
4354 /* Here are at the beginning of the first character
4355 * before the original upper case sigma. Keep backing
4356 * up, skipping any case ignorable characters */
4357 while (is_utf8_case_ignorable(peek)) {
4358 peek = utf8_hop(peek, -1);
4361 /* Here peek points to the first byte of the closest
4362 * non-case-ignorable character before the capital
4363 * sigma. If it is cased, then by the Unicode
4364 * algorithm, we should use a small final sigma instead
4365 * of what we have */
4366 if (is_utf8_cased(peek)) {
4367 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4368 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4372 else { /* Not a context sensitive mapping */
4373 #endif /* End of commented out context sensitive */
4374 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4376 /* If the eventually required minimum size outgrows
4377 * the available space, we need to grow. */
4378 const UV o = d - (U8*)SvPVX_const(dest);
4380 /* If someone lowercases one million U+0130s we
4381 * SvGROW() one million times. Or we could try
4382 * guessing how much to allocate without allocating too
4383 * much. Such is life. Another option would be to
4384 * grow an extra byte or two more each time we need to
4385 * grow, which would cut down the million to 500K, with
4388 d = (U8*)SvPVX(dest) + o;
4390 #ifdef CONTEXT_DEPENDENT_CASING
4393 /* Copy the newly lowercased letter to the output buffer we're
4395 Copy(tmpbuf, d, ulen, U8);
4398 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4401 } /* End of looping through the source string */
4404 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4405 } else { /* Not utf8 */
4407 const U8 *const send = s + len;
4409 /* Use locale casing if in locale; regular style if not treating
4410 * latin1 as having case; otherwise the latin1 casing. Do the
4411 * whole thing in a tight loop, for speed, */
4412 if (IN_LOCALE_RUNTIME) {
4415 for (; s < send; d++, s++)
4416 *d = toLOWER_LC(*s);
4418 else if (! IN_UNI_8_BIT) {
4419 for (; s < send; d++, s++) {
4424 for (; s < send; d++, s++) {
4425 *d = toLOWER_LATIN1(*s);
4429 if (source != dest) {
4431 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4441 SV * const sv = TOPs;
4443 register const char *s = SvPV_const(sv,len);
4445 SvUTF8_off(TARG); /* decontaminate */
4448 SvUPGRADE(TARG, SVt_PV);
4449 SvGROW(TARG, (len * 2) + 1);
4453 if (UTF8_IS_CONTINUED(*s)) {
4454 STRLEN ulen = UTF8SKIP(s);
4478 SvCUR_set(TARG, d - SvPVX_const(TARG));
4479 (void)SvPOK_only_UTF8(TARG);
4482 sv_setpvn(TARG, s, len);
4491 dVAR; dSP; dMARK; dORIGMARK;
4492 register AV *const av = MUTABLE_AV(POPs);
4493 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4495 if (SvTYPE(av) == SVt_PVAV) {
4496 const I32 arybase = CopARYBASE_get(PL_curcop);
4497 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4498 bool can_preserve = FALSE;
4504 can_preserve = SvCANEXISTDELETE(av);
4507 if (lval && localizing) {
4510 for (svp = MARK + 1; svp <= SP; svp++) {
4511 const I32 elem = SvIV(*svp);
4515 if (max > AvMAX(av))
4519 while (++MARK <= SP) {
4521 I32 elem = SvIV(*MARK);
4522 bool preeminent = TRUE;
4526 if (localizing && can_preserve) {
4527 /* If we can determine whether the element exist,
4528 * Try to preserve the existenceness of a tied array
4529 * element by using EXISTS and DELETE if possible.
4530 * Fallback to FETCH and STORE otherwise. */
4531 preeminent = av_exists(av, elem);
4534 svp = av_fetch(av, elem, lval);
4536 if (!svp || *svp == &PL_sv_undef)
4537 DIE(aTHX_ PL_no_aelem, elem);
4540 save_aelem(av, elem, svp);
4542 SAVEADELETE(av, elem);
4545 *MARK = svp ? *svp : &PL_sv_undef;
4548 if (GIMME != G_ARRAY) {
4550 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4560 AV *array = MUTABLE_AV(POPs);
4561 const I32 gimme = GIMME_V;
4562 IV *iterp = Perl_av_iter_p(aTHX_ array);
4563 const IV current = (*iterp)++;
4565 if (current > av_len(array)) {
4567 if (gimme == G_SCALAR)
4574 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4575 if (gimme == G_ARRAY) {
4576 SV **const element = av_fetch(array, current, 0);
4577 PUSHs(element ? *element : &PL_sv_undef);
4586 AV *array = MUTABLE_AV(POPs);
4587 const I32 gimme = GIMME_V;
4589 *Perl_av_iter_p(aTHX_ array) = 0;
4591 if (gimme == G_SCALAR) {
4593 PUSHi(av_len(array) + 1);
4595 else if (gimme == G_ARRAY) {
4596 IV n = Perl_av_len(aTHX_ array);
4597 IV i = CopARYBASE_get(PL_curcop);
4601 if (PL_op->op_type == OP_AKEYS) {
4603 for (; i <= n; i++) {
4608 for (i = 0; i <= n; i++) {
4609 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4610 PUSHs(elem ? *elem : &PL_sv_undef);
4617 /* Associative arrays. */
4623 HV * hash = MUTABLE_HV(POPs);
4625 const I32 gimme = GIMME_V;
4628 /* might clobber stack_sp */
4629 entry = hv_iternext(hash);
4634 SV* const sv = hv_iterkeysv(entry);
4635 PUSHs(sv); /* won't clobber stack_sp */
4636 if (gimme == G_ARRAY) {
4639 /* might clobber stack_sp */
4640 val = hv_iterval(hash, entry);
4645 else if (gimme == G_SCALAR)
4652 S_do_delete_local(pTHX)
4656 const I32 gimme = GIMME_V;
4660 if (PL_op->op_private & OPpSLICE) {
4662 SV * const osv = POPs;
4663 const bool tied = SvRMAGICAL(osv)
4664 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4665 const bool can_preserve = SvCANEXISTDELETE(osv)
4666 || mg_find((const SV *)osv, PERL_MAGIC_env);
4667 const U32 type = SvTYPE(osv);
4668 if (type == SVt_PVHV) { /* hash element */
4669 HV * const hv = MUTABLE_HV(osv);
4670 while (++MARK <= SP) {
4671 SV * const keysv = *MARK;
4673 bool preeminent = TRUE;
4675 preeminent = hv_exists_ent(hv, keysv, 0);
4677 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4684 sv = hv_delete_ent(hv, keysv, 0, 0);
4685 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4688 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4690 *MARK = sv_mortalcopy(sv);
4696 SAVEHDELETE(hv, keysv);
4697 *MARK = &PL_sv_undef;
4701 else if (type == SVt_PVAV) { /* array element */
4702 if (PL_op->op_flags & OPf_SPECIAL) {
4703 AV * const av = MUTABLE_AV(osv);
4704 while (++MARK <= SP) {
4705 I32 idx = SvIV(*MARK);
4707 bool preeminent = TRUE;
4709 preeminent = av_exists(av, idx);
4711 SV **svp = av_fetch(av, idx, 1);
4718 sv = av_delete(av, idx, 0);
4719 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4722 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4724 *MARK = sv_mortalcopy(sv);
4730 SAVEADELETE(av, idx);
4731 *MARK = &PL_sv_undef;
4737 DIE(aTHX_ "Not a HASH reference");
4738 if (gimme == G_VOID)
4740 else if (gimme == G_SCALAR) {
4745 *++MARK = &PL_sv_undef;
4750 SV * const keysv = POPs;
4751 SV * const osv = POPs;
4752 const bool tied = SvRMAGICAL(osv)
4753 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4754 const bool can_preserve = SvCANEXISTDELETE(osv)
4755 || mg_find((const SV *)osv, PERL_MAGIC_env);
4756 const U32 type = SvTYPE(osv);
4758 if (type == SVt_PVHV) {
4759 HV * const hv = MUTABLE_HV(osv);
4760 bool preeminent = TRUE;
4762 preeminent = hv_exists_ent(hv, keysv, 0);
4764 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4771 sv = hv_delete_ent(hv, keysv, 0, 0);
4772 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4775 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4777 SV *nsv = sv_mortalcopy(sv);
4783 SAVEHDELETE(hv, keysv);
4785 else if (type == SVt_PVAV) {
4786 if (PL_op->op_flags & OPf_SPECIAL) {
4787 AV * const av = MUTABLE_AV(osv);
4788 I32 idx = SvIV(keysv);
4789 bool preeminent = TRUE;
4791 preeminent = av_exists(av, idx);
4793 SV **svp = av_fetch(av, idx, 1);
4800 sv = av_delete(av, idx, 0);
4801 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4804 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4806 SV *nsv = sv_mortalcopy(sv);
4812 SAVEADELETE(av, idx);
4815 DIE(aTHX_ "panic: avhv_delete no longer supported");
4818 DIE(aTHX_ "Not a HASH reference");
4821 if (gimme != G_VOID)
4835 if (PL_op->op_private & OPpLVAL_INTRO)
4836 return do_delete_local();
4839 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4841 if (PL_op->op_private & OPpSLICE) {
4843 HV * const hv = MUTABLE_HV(POPs);
4844 const U32 hvtype = SvTYPE(hv);
4845 if (hvtype == SVt_PVHV) { /* hash element */
4846 while (++MARK <= SP) {
4847 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4848 *MARK = sv ? sv : &PL_sv_undef;
4851 else if (hvtype == SVt_PVAV) { /* array element */
4852 if (PL_op->op_flags & OPf_SPECIAL) {
4853 while (++MARK <= SP) {
4854 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4855 *MARK = sv ? sv : &PL_sv_undef;
4860 DIE(aTHX_ "Not a HASH reference");
4863 else if (gimme == G_SCALAR) {
4868 *++MARK = &PL_sv_undef;
4874 HV * const hv = MUTABLE_HV(POPs);
4876 if (SvTYPE(hv) == SVt_PVHV)
4877 sv = hv_delete_ent(hv, keysv, discard, 0);
4878 else if (SvTYPE(hv) == SVt_PVAV) {
4879 if (PL_op->op_flags & OPf_SPECIAL)
4880 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4882 DIE(aTHX_ "panic: avhv_delete no longer supported");
4885 DIE(aTHX_ "Not a HASH reference");
4901 if (PL_op->op_private & OPpEXISTS_SUB) {
4903 SV * const sv = POPs;
4904 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4907 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4912 hv = MUTABLE_HV(POPs);
4913 if (SvTYPE(hv) == SVt_PVHV) {
4914 if (hv_exists_ent(hv, tmpsv, 0))
4917 else if (SvTYPE(hv) == SVt_PVAV) {
4918 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4919 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4924 DIE(aTHX_ "Not a HASH reference");
4931 dVAR; dSP; dMARK; dORIGMARK;
4932 register HV * const hv = MUTABLE_HV(POPs);
4933 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4934 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4935 bool can_preserve = FALSE;
4941 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4942 can_preserve = TRUE;
4945 while (++MARK <= SP) {
4946 SV * const keysv = *MARK;
4949 bool preeminent = TRUE;
4951 if (localizing && can_preserve) {
4952 /* If we can determine whether the element exist,
4953 * try to preserve the existenceness of a tied hash
4954 * element by using EXISTS and DELETE if possible.
4955 * Fallback to FETCH and STORE otherwise. */
4956 preeminent = hv_exists_ent(hv, keysv, 0);
4959 he = hv_fetch_ent(hv, keysv, lval, 0);
4960 svp = he ? &HeVAL(he) : NULL;
4963 if (!svp || *svp == &PL_sv_undef) {
4964 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4967 if (HvNAME_get(hv) && isGV(*svp))
4968 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4969 else if (preeminent)
4970 save_helem_flags(hv, keysv, svp,
4971 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4973 SAVEHDELETE(hv, keysv);
4976 *MARK = svp ? *svp : &PL_sv_undef;
4978 if (GIMME != G_ARRAY) {
4980 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4986 /* List operators. */
4991 if (GIMME != G_ARRAY) {
4993 *MARK = *SP; /* unwanted list, return last item */
4995 *MARK = &PL_sv_undef;
5005 SV ** const lastrelem = PL_stack_sp;
5006 SV ** const lastlelem = PL_stack_base + POPMARK;
5007 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5008 register SV ** const firstrelem = lastlelem + 1;
5009 const I32 arybase = CopARYBASE_get(PL_curcop);
5010 I32 is_something_there = FALSE;
5012 register const I32 max = lastrelem - lastlelem;
5013 register SV **lelem;
5015 if (GIMME != G_ARRAY) {
5016 I32 ix = SvIV(*lastlelem);
5021 if (ix < 0 || ix >= max)
5022 *firstlelem = &PL_sv_undef;
5024 *firstlelem = firstrelem[ix];
5030 SP = firstlelem - 1;
5034 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5035 I32 ix = SvIV(*lelem);
5040 if (ix < 0 || ix >= max)
5041 *lelem = &PL_sv_undef;
5043 is_something_there = TRUE;
5044 if (!(*lelem = firstrelem[ix]))
5045 *lelem = &PL_sv_undef;
5048 if (is_something_there)
5051 SP = firstlelem - 1;
5057 dVAR; dSP; dMARK; dORIGMARK;
5058 const I32 items = SP - MARK;
5059 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5060 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5061 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5062 ? newRV_noinc(av) : av);
5068 dVAR; dSP; dMARK; dORIGMARK;
5069 HV* const hv = newHV();
5072 SV * const key = *++MARK;
5073 SV * const val = newSV(0);
5075 sv_setsv(val, *++MARK);
5077 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5078 (void)hv_store_ent(hv,key,val,0);
5081 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5082 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5088 dVAR; dSP; dMARK; dORIGMARK;
5089 register AV *ary = MUTABLE_AV(*++MARK);
5093 register I32 offset;
5094 register I32 length;
5098 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5101 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5104 ENTER_with_name("call_SPLICE");
5105 call_method("SPLICE",GIMME_V);
5106 LEAVE_with_name("call_SPLICE");
5114 offset = i = SvIV(*MARK);
5116 offset += AvFILLp(ary) + 1;
5118 offset -= CopARYBASE_get(PL_curcop);
5120 DIE(aTHX_ PL_no_aelem, i);
5122 length = SvIVx(*MARK++);
5124 length += AvFILLp(ary) - offset + 1;
5130 length = AvMAX(ary) + 1; /* close enough to infinity */
5134 length = AvMAX(ary) + 1;
5136 if (offset > AvFILLp(ary) + 1) {
5137 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5138 offset = AvFILLp(ary) + 1;
5140 after = AvFILLp(ary) + 1 - (offset + length);
5141 if (after < 0) { /* not that much array */
5142 length += after; /* offset+length now in array */
5148 /* At this point, MARK .. SP-1 is our new LIST */
5151 diff = newlen - length;
5152 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5155 /* make new elements SVs now: avoid problems if they're from the array */
5156 for (dst = MARK, i = newlen; i; i--) {
5157 SV * const h = *dst;
5158 *dst++ = newSVsv(h);
5161 if (diff < 0) { /* shrinking the area */
5162 SV **tmparyval = NULL;
5164 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5165 Copy(MARK, tmparyval, newlen, SV*);
5168 MARK = ORIGMARK + 1;
5169 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5170 MEXTEND(MARK, length);
5171 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5173 EXTEND_MORTAL(length);
5174 for (i = length, dst = MARK; i; i--) {
5175 sv_2mortal(*dst); /* free them eventualy */
5182 *MARK = AvARRAY(ary)[offset+length-1];
5185 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5186 SvREFCNT_dec(*dst++); /* free them now */
5189 AvFILLp(ary) += diff;
5191 /* pull up or down? */
5193 if (offset < after) { /* easier to pull up */
5194 if (offset) { /* esp. if nothing to pull */
5195 src = &AvARRAY(ary)[offset-1];
5196 dst = src - diff; /* diff is negative */
5197 for (i = offset; i > 0; i--) /* can't trust Copy */
5201 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5205 if (after) { /* anything to pull down? */
5206 src = AvARRAY(ary) + offset + length;
5207 dst = src + diff; /* diff is negative */
5208 Move(src, dst, after, SV*);
5210 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5211 /* avoid later double free */
5215 dst[--i] = &PL_sv_undef;
5218 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5219 Safefree(tmparyval);
5222 else { /* no, expanding (or same) */
5223 SV** tmparyval = NULL;
5225 Newx(tmparyval, length, SV*); /* so remember deletion */
5226 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5229 if (diff > 0) { /* expanding */
5230 /* push up or down? */
5231 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5235 Move(src, dst, offset, SV*);
5237 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5239 AvFILLp(ary) += diff;
5242 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5243 av_extend(ary, AvFILLp(ary) + diff);
5244 AvFILLp(ary) += diff;
5247 dst = AvARRAY(ary) + AvFILLp(ary);
5249 for (i = after; i; i--) {
5257 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5260 MARK = ORIGMARK + 1;
5261 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5263 Copy(tmparyval, MARK, length, SV*);
5265 EXTEND_MORTAL(length);
5266 for (i = length, dst = MARK; i; i--) {
5267 sv_2mortal(*dst); /* free them eventualy */
5274 else if (length--) {
5275 *MARK = tmparyval[length];
5278 while (length-- > 0)
5279 SvREFCNT_dec(tmparyval[length]);
5283 *MARK = &PL_sv_undef;
5284 Safefree(tmparyval);
5292 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5293 register AV * const ary = MUTABLE_AV(*++MARK);
5294 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5297 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5300 ENTER_with_name("call_PUSH");
5301 call_method("PUSH",G_SCALAR|G_DISCARD);
5302 LEAVE_with_name("call_PUSH");
5306 PL_delaymagic = DM_DELAY;
5307 for (++MARK; MARK <= SP; MARK++) {
5308 SV * const sv = newSV(0);
5310 sv_setsv(sv, *MARK);
5311 av_store(ary, AvFILLp(ary)+1, sv);
5313 if (PL_delaymagic & DM_ARRAY)
5314 mg_set(MUTABLE_SV(ary));
5319 if (OP_GIMME(PL_op, 0) != G_VOID) {
5320 PUSHi( AvFILL(ary) + 1 );
5329 AV * const av = MUTABLE_AV(POPs);
5330 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5334 (void)sv_2mortal(sv);
5341 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5342 register AV *ary = MUTABLE_AV(*++MARK);
5343 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5346 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5349 ENTER_with_name("call_UNSHIFT");
5350 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5351 LEAVE_with_name("call_UNSHIFT");
5356 av_unshift(ary, SP - MARK);
5358 SV * const sv = newSVsv(*++MARK);
5359 (void)av_store(ary, i++, sv);
5363 if (OP_GIMME(PL_op, 0) != G_VOID) {
5364 PUSHi( AvFILL(ary) + 1 );
5373 if (GIMME == G_ARRAY) {
5374 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5378 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5379 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5380 av = MUTABLE_AV((*SP));
5381 /* In-place reversing only happens in void context for the array
5382 * assignment. We don't need to push anything on the stack. */
5385 if (SvMAGICAL(av)) {
5387 register SV *tmp = sv_newmortal();
5388 /* For SvCANEXISTDELETE */
5391 bool can_preserve = SvCANEXISTDELETE(av);
5393 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5394 register SV *begin, *end;
5397 if (!av_exists(av, i)) {
5398 if (av_exists(av, j)) {
5399 register SV *sv = av_delete(av, j, 0);
5400 begin = *av_fetch(av, i, TRUE);
5401 sv_setsv_mg(begin, sv);
5405 else if (!av_exists(av, j)) {
5406 register SV *sv = av_delete(av, i, 0);
5407 end = *av_fetch(av, j, TRUE);
5408 sv_setsv_mg(end, sv);
5413 begin = *av_fetch(av, i, TRUE);
5414 end = *av_fetch(av, j, TRUE);
5415 sv_setsv(tmp, begin);
5416 sv_setsv_mg(begin, end);
5417 sv_setsv_mg(end, tmp);
5421 SV **begin = AvARRAY(av);
5424 SV **end = begin + AvFILLp(av);
5426 while (begin < end) {
5427 register SV * const tmp = *begin;
5438 register SV * const tmp = *MARK;
5442 /* safe as long as stack cannot get extended in the above */
5448 register char *down;
5452 PADOFFSET padoff_du;
5454 SvUTF8_off(TARG); /* decontaminate */
5456 do_join(TARG, &PL_sv_no, MARK, SP);
5458 sv_setsv(TARG, (SP > MARK)
5460 : (padoff_du = find_rundefsvoffset(),
5461 (padoff_du == NOT_IN_PAD
5462 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
5463 ? DEFSV : PAD_SVl(padoff_du)));
5465 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5466 report_uninit(TARG);
5469 up = SvPV_force(TARG, len);
5471 if (DO_UTF8(TARG)) { /* first reverse each character */
5472 U8* s = (U8*)SvPVX(TARG);
5473 const U8* send = (U8*)(s + len);
5475 if (UTF8_IS_INVARIANT(*s)) {
5480 if (!utf8_to_uvchr(s, 0))
5484 down = (char*)(s - 1);
5485 /* reverse this character */
5489 *down-- = (char)tmp;
5495 down = SvPVX(TARG) + len - 1;
5499 *down-- = (char)tmp;
5501 (void)SvPOK_only_UTF8(TARG);
5513 register IV limit = POPi; /* note, negative is forever */
5514 SV * const sv = POPs;
5516 register const char *s = SvPV_const(sv, len);
5517 const bool do_utf8 = DO_UTF8(sv);
5518 const char *strend = s + len;
5520 register REGEXP *rx;
5522 register const char *m;
5524 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5525 I32 maxiters = slen + 10;
5526 I32 trailing_empty = 0;
5528 const I32 origlimit = limit;
5531 const I32 gimme = GIMME_V;
5533 const I32 oldsave = PL_savestack_ix;
5534 U32 make_mortal = SVs_TEMP;
5539 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5544 DIE(aTHX_ "panic: pp_split");
5547 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5548 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5550 RX_MATCH_UTF8_set(rx, do_utf8);
5553 if (pm->op_pmreplrootu.op_pmtargetoff) {
5554 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5557 if (pm->op_pmreplrootu.op_pmtargetgv) {
5558 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5563 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5569 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5571 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5578 for (i = AvFILLp(ary); i >= 0; i--)
5579 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5581 /* temporarily switch stacks */
5582 SAVESWITCHSTACK(PL_curstack, ary);
5586 base = SP - PL_stack_base;
5588 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5590 while (*s == ' ' || is_utf8_space((U8*)s))
5593 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5594 while (isSPACE_LC(*s))
5602 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5606 gimme_scalar = gimme == G_SCALAR && !ary;
5609 limit = maxiters + 2;
5610 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5613 /* this one uses 'm' and is a negative test */
5615 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5616 const int t = UTF8SKIP(m);
5617 /* is_utf8_space returns FALSE for malform utf8 */
5623 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5624 while (m < strend && !isSPACE_LC(*m))
5627 while (m < strend && !isSPACE(*m))
5640 dstr = newSVpvn_flags(s, m-s,
5641 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5645 /* skip the whitespace found last */
5647 s = m + UTF8SKIP(m);
5651 /* this one uses 's' and is a positive test */
5653 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5655 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5656 while (s < strend && isSPACE_LC(*s))
5659 while (s < strend && isSPACE(*s))
5664 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5666 for (m = s; m < strend && *m != '\n'; m++)
5679 dstr = newSVpvn_flags(s, m-s,
5680 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5686 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5688 Pre-extend the stack, either the number of bytes or
5689 characters in the string or a limited amount, triggered by:
5691 my ($x, $y) = split //, $str;
5695 if (!gimme_scalar) {
5696 const U32 items = limit - 1;
5705 /* keep track of how many bytes we skip over */
5715 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5728 dstr = newSVpvn(s, 1);
5744 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5745 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5746 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5747 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5748 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5749 SV * const csv = CALLREG_INTUIT_STRING(rx);
5751 len = RX_MINLENRET(rx);
5752 if (len == 1 && !RX_UTF8(rx) && !tail) {
5753 const char c = *SvPV_nolen_const(csv);
5755 for (m = s; m < strend && *m != c; m++)
5766 dstr = newSVpvn_flags(s, m-s,
5767 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5770 /* The rx->minlen is in characters but we want to step
5771 * s ahead by bytes. */
5773 s = (char*)utf8_hop((U8*)m, len);
5775 s = m + len; /* Fake \n at the end */
5779 while (s < strend && --limit &&
5780 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5781 csv, multiline ? FBMrf_MULTILINE : 0)) )
5790 dstr = newSVpvn_flags(s, m-s,
5791 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5794 /* The rx->minlen is in characters but we want to step
5795 * s ahead by bytes. */
5797 s = (char*)utf8_hop((U8*)m, len);
5799 s = m + len; /* Fake \n at the end */
5804 maxiters += slen * RX_NPARENS(rx);
5805 while (s < strend && --limit)
5809 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5812 if (rex_return == 0)
5814 TAINT_IF(RX_MATCH_TAINTED(rx));
5815 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5818 orig = RX_SUBBEG(rx);
5820 strend = s + (strend - m);
5822 m = RX_OFFS(rx)[0].start + orig;
5831 dstr = newSVpvn_flags(s, m-s,
5832 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5835 if (RX_NPARENS(rx)) {
5837 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5838 s = RX_OFFS(rx)[i].start + orig;
5839 m = RX_OFFS(rx)[i].end + orig;
5841 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5842 parens that didn't match -- they should be set to
5843 undef, not the empty string */
5851 if (m >= orig && s >= orig) {
5852 dstr = newSVpvn_flags(s, m-s,
5853 (do_utf8 ? SVf_UTF8 : 0)
5857 dstr = &PL_sv_undef; /* undef, not "" */
5863 s = RX_OFFS(rx)[0].end + orig;
5867 if (!gimme_scalar) {
5868 iters = (SP - PL_stack_base) - base;
5870 if (iters > maxiters)
5871 DIE(aTHX_ "Split loop");
5873 /* keep field after final delim? */
5874 if (s < strend || (iters && origlimit)) {
5875 if (!gimme_scalar) {
5876 const STRLEN l = strend - s;
5877 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5882 else if (!origlimit) {
5884 iters -= trailing_empty;
5886 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5887 if (TOPs && !make_mortal)
5889 *SP-- = &PL_sv_undef;
5896 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5900 if (SvSMAGICAL(ary)) {
5902 mg_set(MUTABLE_SV(ary));
5905 if (gimme == G_ARRAY) {
5907 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5914 ENTER_with_name("call_PUSH");
5915 call_method("PUSH",G_SCALAR|G_DISCARD);
5916 LEAVE_with_name("call_PUSH");
5918 if (gimme == G_ARRAY) {
5920 /* EXTEND should not be needed - we just popped them */
5922 for (i=0; i < iters; i++) {
5923 SV **svp = av_fetch(ary, i, FALSE);
5924 PUSHs((svp) ? *svp : &PL_sv_undef);
5931 if (gimme == G_ARRAY)
5943 SV *const sv = PAD_SVl(PL_op->op_targ);
5945 if (SvPADSTALE(sv)) {
5948 RETURNOP(cLOGOP->op_other);
5950 RETURNOP(cLOGOP->op_next);
5959 assert(SvTYPE(retsv) != SVt_PVCV);
5961 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
5962 retsv = refto(retsv);
5969 PP(unimplemented_op)
5972 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5981 HV * const hv = (HV*)POPs;
5983 if (SvRMAGICAL(hv)) {
5984 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5986 XPUSHs(magic_scalarpack(hv, mg));
5991 XPUSHs(boolSV(HvKEYS(hv) != 0));
5997 * c-indentation-style: bsd
5999 * indent-tabs-mode: t
6002 * ex: set ts=8 sts=4 sw=4 noet: