3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
34 it, since pid_t is an integral type.
37 #ifdef NEED_GETPID_PROTO
38 extern Pid_t getpid (void);
42 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
43 * This switches them over to IEEE.
45 #if defined(LIBM_LIB_VERSION)
46 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
49 /* variations on pp_null */
55 if (GIMME_V == G_SCALAR)
66 assert(SvTYPE(TARG) == SVt_PVAV);
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 if (!(PL_op->op_private & OPpPAD_STATE))
69 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
71 if (PL_op->op_flags & OPf_REF) {
75 if (GIMME == G_SCALAR)
76 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
81 if (gimme == G_ARRAY) {
82 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
84 if (SvMAGICAL(TARG)) {
86 for (i=0; i < (U32)maxarg; i++) {
87 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
88 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
92 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
96 else if (gimme == G_SCALAR) {
97 SV* const sv = sv_newmortal();
98 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
110 assert(SvTYPE(TARG) == SVt_PVHV);
112 if (PL_op->op_private & OPpLVAL_INTRO)
113 if (!(PL_op->op_private & OPpPAD_STATE))
114 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
115 if (PL_op->op_flags & OPf_REF)
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
123 if (gimme == G_ARRAY) {
126 else if (gimme == G_SCALAR) {
127 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
135 static const char S_no_symref_sv[] =
136 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
145 tryAMAGICunDEREF(to_gv);
148 if (SvTYPE(sv) == SVt_PVIO) {
149 GV * const gv = MUTABLE_GV(sv_newmortal());
150 gv_init(gv, 0, "", 0, 0);
151 GvIOp(gv) = MUTABLE_IO(sv);
152 SvREFCNT_inc_void_NN(sv);
155 else if (!isGV_with_GP(sv))
156 DIE(aTHX_ "Not a GLOB reference");
159 if (!isGV_with_GP(sv)) {
160 if (!SvOK(sv) && sv != &PL_sv_undef) {
161 /* If this is a 'my' scalar and flag is set then vivify
165 Perl_croak(aTHX_ "%s", PL_no_modify);
166 if (PL_op->op_private & OPpDEREF) {
168 if (cUNOP->op_targ) {
170 SV * const namesv = PAD_SV(cUNOP->op_targ);
171 const char * const name = SvPV(namesv, len);
172 gv = MUTABLE_GV(newSV(0));
173 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
176 const char * const name = CopSTASHPV(PL_curcop);
179 prepare_SV_for_RV(sv);
180 SvRV_set(sv, MUTABLE_SV(gv));
185 if (PL_op->op_flags & OPf_REF ||
186 PL_op->op_private & HINT_STRICT_REFS)
187 DIE(aTHX_ PL_no_usym, "a symbol");
188 if (ckWARN(WARN_UNINITIALIZED))
192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
195 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
197 && (!is_gv_magical_sv(sv,0)
198 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
205 if (PL_op->op_private & HINT_STRICT_REFS)
206 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
207 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
208 == OPpDONT_INIT_GV) {
209 /* We are the target of a coderef assignment. Return
210 the scalar unchanged, and let pp_sasssign deal with
214 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
218 if (PL_op->op_private & OPpLVAL_INTRO)
219 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
224 /* Helper function for pp_rv2sv and pp_rv2av */
226 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
227 const svtype type, SV ***spp)
232 PERL_ARGS_ASSERT_SOFTREF2XV;
234 if (PL_op->op_private & HINT_STRICT_REFS) {
236 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
238 Perl_die(aTHX_ PL_no_usym, what);
241 if (PL_op->op_flags & OPf_REF)
242 Perl_die(aTHX_ PL_no_usym, what);
243 if (ckWARN(WARN_UNINITIALIZED))
245 if (type != SVt_PV && GIMME_V == G_ARRAY) {
249 **spp = &PL_sv_undef;
252 if ((PL_op->op_flags & OPf_SPECIAL) &&
253 !(PL_op->op_flags & OPf_MOD))
255 gv = gv_fetchsv(sv, 0, type);
257 && (!is_gv_magical_sv(sv,0)
258 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
260 **spp = &PL_sv_undef;
265 gv = gv_fetchsv(sv, GV_ADD, type);
275 if (!(PL_op->op_private & OPpDEREFed))
278 tryAMAGICunDEREF(to_sv);
281 switch (SvTYPE(sv)) {
287 DIE(aTHX_ "Not a SCALAR reference");
294 if (!isGV_with_GP(gv)) {
295 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
301 if (PL_op->op_flags & OPf_MOD) {
302 if (PL_op->op_private & OPpLVAL_INTRO) {
303 if (cUNOP->op_first->op_type == OP_NULL)
304 sv = save_scalar(MUTABLE_GV(TOPs));
306 sv = save_scalar(gv);
308 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
310 else if (PL_op->op_private & OPpDEREF)
311 vivify_ref(sv, PL_op->op_private & OPpDEREF);
320 AV * const av = MUTABLE_AV(TOPs);
321 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
323 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
325 *sv = newSV_type(SVt_PVMG);
326 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
330 SETs(sv_2mortal(newSViv(
331 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
339 dVAR; dSP; dTARGET; dPOPss;
341 if (PL_op->op_flags & OPf_MOD || LVRET) {
342 if (SvTYPE(TARG) < SVt_PVLV) {
343 sv_upgrade(TARG, SVt_PVLV);
344 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
348 if (LvTARG(TARG) != sv) {
349 SvREFCNT_dec(LvTARG(TARG));
350 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
352 PUSHs(TARG); /* no SvSETMAGIC */
356 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
357 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
358 if (mg && mg->mg_len >= 0) {
362 PUSHi(i + CopARYBASE_get(PL_curcop));
375 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
377 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
380 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
381 /* (But not in defined().) */
383 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
386 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
387 if ((PL_op->op_private & OPpLVAL_INTRO)) {
388 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
391 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
394 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
398 cv = MUTABLE_CV(&PL_sv_undef);
399 SETs(MUTABLE_SV(cv));
409 SV *ret = &PL_sv_undef;
411 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
412 const char * s = SvPVX_const(TOPs);
413 if (strnEQ(s, "CORE::", 6)) {
414 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
415 if (code < 0) { /* Overridable. */
416 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
417 int i = 0, n = 0, seen_question = 0, defgv = 0;
419 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
421 if (code == -KEY_chop || code == -KEY_chomp
422 || code == -KEY_exec || code == -KEY_system)
424 if (code == -KEY_mkdir) {
425 ret = newSVpvs_flags("_;$", SVs_TEMP);
428 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
429 ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
432 if (code == -KEY_readpipe) {
433 s = "CORE::backtick";
435 while (i < MAXO) { /* The slow way. */
436 if (strEQ(s + 6, PL_op_name[i])
437 || strEQ(s + 6, PL_op_desc[i]))
443 goto nonesuch; /* Should not happen... */
445 defgv = PL_opargs[i] & OA_DEFGV;
446 oa = PL_opargs[i] >> OASHIFT;
448 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
452 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
453 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
454 /* But globs are already references (kinda) */
455 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
459 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
462 if (defgv && str[n - 1] == '$')
465 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
467 else if (code) /* Non-Overridable */
469 else { /* None such */
471 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
475 cv = sv_2cv(TOPs, &stash, &gv, 0);
477 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
486 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
488 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
490 PUSHs(MUTABLE_SV(cv));
504 if (GIMME != G_ARRAY) {
508 *MARK = &PL_sv_undef;
509 *MARK = refto(*MARK);
513 EXTEND_MORTAL(SP - MARK);
515 *MARK = refto(*MARK);
520 S_refto(pTHX_ SV *sv)
525 PERL_ARGS_ASSERT_REFTO;
527 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
530 if (!(sv = LvTARG(sv)))
533 SvREFCNT_inc_void_NN(sv);
535 else if (SvTYPE(sv) == SVt_PVAV) {
536 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
537 av_reify(MUTABLE_AV(sv));
539 SvREFCNT_inc_void_NN(sv);
541 else if (SvPADTMP(sv) && !IS_PADGV(sv))
545 SvREFCNT_inc_void_NN(sv);
548 sv_upgrade(rv, SVt_IV);
558 SV * const sv = POPs;
563 if (!sv || !SvROK(sv))
566 pv = sv_reftype(SvRV(sv),TRUE);
567 PUSHp(pv, strlen(pv));
577 stash = CopSTASH(PL_curcop);
579 SV * const ssv = POPs;
583 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
584 Perl_croak(aTHX_ "Attempt to bless into a reference");
585 ptr = SvPV_const(ssv,len);
587 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
588 "Explicit blessing to '' (assuming package main)");
589 stash = gv_stashpvn(ptr, len, GV_ADD);
592 (void)sv_bless(TOPs, stash);
601 const char * const elem = SvPV_nolen_const(sv);
602 GV * const gv = MUTABLE_GV(POPs);
607 /* elem will always be NUL terminated. */
608 const char * const second_letter = elem + 1;
611 if (strEQ(second_letter, "RRAY"))
612 tmpRef = MUTABLE_SV(GvAV(gv));
615 if (strEQ(second_letter, "ODE"))
616 tmpRef = MUTABLE_SV(GvCVu(gv));
619 if (strEQ(second_letter, "ILEHANDLE")) {
620 /* finally deprecated in 5.8.0 */
621 deprecate("*glob{FILEHANDLE}");
622 tmpRef = MUTABLE_SV(GvIOp(gv));
625 if (strEQ(second_letter, "ORMAT"))
626 tmpRef = MUTABLE_SV(GvFORM(gv));
629 if (strEQ(second_letter, "LOB"))
630 tmpRef = MUTABLE_SV(gv);
633 if (strEQ(second_letter, "ASH"))
634 tmpRef = MUTABLE_SV(GvHV(gv));
637 if (*second_letter == 'O' && !elem[2])
638 tmpRef = MUTABLE_SV(GvIOp(gv));
641 if (strEQ(second_letter, "AME"))
642 sv = newSVhek(GvNAME_HEK(gv));
645 if (strEQ(second_letter, "ACKAGE")) {
646 const HV * const stash = GvSTASH(gv);
647 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
648 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
652 if (strEQ(second_letter, "CALAR"))
667 /* Pattern matching */
672 register unsigned char *s;
675 register I32 *sfirst;
679 if (sv == PL_lastscream) {
683 s = (unsigned char*)(SvPV(sv, len));
685 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
686 /* No point in studying a zero length string, and not safe to study
687 anything that doesn't appear to be a simple scalar (and hence might
688 change between now and when the regexp engine runs without our set
689 magic ever running) such as a reference to an object with overloaded
695 SvSCREAM_off(PL_lastscream);
696 SvREFCNT_dec(PL_lastscream);
698 PL_lastscream = SvREFCNT_inc_simple(sv);
700 s = (unsigned char*)(SvPV(sv, len));
704 if (pos > PL_maxscream) {
705 if (PL_maxscream < 0) {
706 PL_maxscream = pos + 80;
707 Newx(PL_screamfirst, 256, I32);
708 Newx(PL_screamnext, PL_maxscream, I32);
711 PL_maxscream = pos + pos / 4;
712 Renew(PL_screamnext, PL_maxscream, I32);
716 sfirst = PL_screamfirst;
717 snext = PL_screamnext;
719 if (!sfirst || !snext)
720 DIE(aTHX_ "do_study: out of memory");
722 for (ch = 256; ch; --ch)
727 register const I32 ch = s[pos];
729 snext[pos] = sfirst[ch] - pos;
736 /* piggyback on m//g magic */
737 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
746 if (PL_op->op_flags & OPf_STACKED)
748 else if (PL_op->op_private & OPpTARGET_MY)
754 TARG = sv_newmortal();
759 /* Lvalue operators. */
771 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
773 do_chop(TARG, *++MARK);
782 SETi(do_chomp(TOPs));
788 dVAR; dSP; dMARK; dTARGET;
789 register I32 count = 0;
792 count += do_chomp(POPs);
802 if (!PL_op->op_private) {
811 SV_CHECK_THINKFIRST_COW_DROP(sv);
813 switch (SvTYPE(sv)) {
817 av_undef(MUTABLE_AV(sv));
820 hv_undef(MUTABLE_HV(sv));
823 if (cv_const_sv((const CV *)sv))
824 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
825 CvANON((const CV *)sv) ? "(anonymous)"
826 : GvENAME(CvGV((const CV *)sv)));
830 /* let user-undef'd sub keep its identity */
831 GV* const gv = CvGV((const CV *)sv);
832 cv_undef(MUTABLE_CV(sv));
833 CvGV((const CV *)sv) = gv;
838 SvSetMagicSV(sv, &PL_sv_undef);
841 else if (isGV_with_GP(sv)) {
846 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
847 mro_isa_changed_in(stash);
848 /* undef *Pkg::meth_name ... */
849 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
850 && HvNAME_get(stash))
851 mro_method_changed_in(stash);
853 gp_free(MUTABLE_GV(sv));
855 GvGP(sv) = gp_ref(gp);
857 GvLINE(sv) = CopLINE(PL_curcop);
858 GvEGV(sv) = MUTABLE_GV(sv);
864 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
879 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
880 DIE(aTHX_ "%s", PL_no_modify);
881 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
882 && SvIVX(TOPs) != IV_MIN)
884 SvIV_set(TOPs, SvIVX(TOPs) - 1);
885 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
896 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
897 DIE(aTHX_ "%s", PL_no_modify);
898 sv_setsv(TARG, TOPs);
899 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
900 && SvIVX(TOPs) != IV_MAX)
902 SvIV_set(TOPs, SvIVX(TOPs) + 1);
903 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
908 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
918 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
919 DIE(aTHX_ "%s", PL_no_modify);
920 sv_setsv(TARG, TOPs);
921 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
922 && SvIVX(TOPs) != IV_MIN)
924 SvIV_set(TOPs, SvIVX(TOPs) - 1);
925 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
934 /* Ordinary operators. */
938 dVAR; dSP; dATARGET; SV *svl, *svr;
939 #ifdef PERL_PRESERVE_IVUV
942 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
945 #ifdef PERL_PRESERVE_IVUV
946 /* For integer to integer power, we do the calculation by hand wherever
947 we're sure it is safe; otherwise we call pow() and try to convert to
948 integer afterwards. */
950 SvIV_please_nomg(svr);
952 SvIV_please_nomg(svl);
961 const IV iv = SvIVX(svr);
965 goto float_it; /* Can't do negative powers this way. */
969 baseuok = SvUOK(svl);
973 const IV iv = SvIVX(svl);
976 baseuok = TRUE; /* effectively it's a UV now */
978 baseuv = -iv; /* abs, baseuok == false records sign */
981 /* now we have integer ** positive integer. */
984 /* foo & (foo - 1) is zero only for a power of 2. */
985 if (!(baseuv & (baseuv - 1))) {
986 /* We are raising power-of-2 to a positive integer.
987 The logic here will work for any base (even non-integer
988 bases) but it can be less accurate than
989 pow (base,power) or exp (power * log (base)) when the
990 intermediate values start to spill out of the mantissa.
991 With powers of 2 we know this can't happen.
992 And powers of 2 are the favourite thing for perl
993 programmers to notice ** not doing what they mean. */
995 NV base = baseuok ? baseuv : -(NV)baseuv;
1000 while (power >>= 1) {
1008 SvIV_please_nomg(svr);
1011 register unsigned int highbit = 8 * sizeof(UV);
1012 register unsigned int diff = 8 * sizeof(UV);
1013 while (diff >>= 1) {
1015 if (baseuv >> highbit) {
1019 /* we now have baseuv < 2 ** highbit */
1020 if (power * highbit <= 8 * sizeof(UV)) {
1021 /* result will definitely fit in UV, so use UV math
1022 on same algorithm as above */
1023 register UV result = 1;
1024 register UV base = baseuv;
1025 const bool odd_power = cBOOL(power & 1);
1029 while (power >>= 1) {
1036 if (baseuok || !odd_power)
1037 /* answer is positive */
1039 else if (result <= (UV)IV_MAX)
1040 /* answer negative, fits in IV */
1041 SETi( -(IV)result );
1042 else if (result == (UV)IV_MIN)
1043 /* 2's complement assumption: special case IV_MIN */
1046 /* answer negative, doesn't fit */
1047 SETn( -(NV)result );
1057 NV right = SvNV_nomg(svr);
1058 NV left = SvNV_nomg(svl);
1061 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1063 We are building perl with long double support and are on an AIX OS
1064 afflicted with a powl() function that wrongly returns NaNQ for any
1065 negative base. This was reported to IBM as PMR #23047-379 on
1066 03/06/2006. The problem exists in at least the following versions
1067 of AIX and the libm fileset, and no doubt others as well:
1069 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1070 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1071 AIX 5.2.0 bos.adt.libm 5.2.0.85
1073 So, until IBM fixes powl(), we provide the following workaround to
1074 handle the problem ourselves. Our logic is as follows: for
1075 negative bases (left), we use fmod(right, 2) to check if the
1076 exponent is an odd or even integer:
1078 - if odd, powl(left, right) == -powl(-left, right)
1079 - if even, powl(left, right) == powl(-left, right)
1081 If the exponent is not an integer, the result is rightly NaNQ, so
1082 we just return that (as NV_NAN).
1086 NV mod2 = Perl_fmod( right, 2.0 );
1087 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1088 SETn( -Perl_pow( -left, right) );
1089 } else if (mod2 == 0.0) { /* even integer */
1090 SETn( Perl_pow( -left, right) );
1091 } else { /* fractional power */
1095 SETn( Perl_pow( left, right) );
1098 SETn( Perl_pow( left, right) );
1099 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1101 #ifdef PERL_PRESERVE_IVUV
1103 SvIV_please_nomg(svr);
1111 dVAR; dSP; dATARGET; SV *svl, *svr;
1112 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1115 #ifdef PERL_PRESERVE_IVUV
1116 SvIV_please_nomg(svr);
1118 /* Unless the left argument is integer in range we are going to have to
1119 use NV maths. Hence only attempt to coerce the right argument if
1120 we know the left is integer. */
1121 /* Left operand is defined, so is it IV? */
1122 SvIV_please_nomg(svl);
1124 bool auvok = SvUOK(svl);
1125 bool buvok = SvUOK(svr);
1126 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1127 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1136 const IV aiv = SvIVX(svl);
1139 auvok = TRUE; /* effectively it's a UV now */
1141 alow = -aiv; /* abs, auvok == false records sign */
1147 const IV biv = SvIVX(svr);
1150 buvok = TRUE; /* effectively it's a UV now */
1152 blow = -biv; /* abs, buvok == false records sign */
1156 /* If this does sign extension on unsigned it's time for plan B */
1157 ahigh = alow >> (4 * sizeof (UV));
1159 bhigh = blow >> (4 * sizeof (UV));
1161 if (ahigh && bhigh) {
1163 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1164 which is overflow. Drop to NVs below. */
1165 } else if (!ahigh && !bhigh) {
1166 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1167 so the unsigned multiply cannot overflow. */
1168 const UV product = alow * blow;
1169 if (auvok == buvok) {
1170 /* -ve * -ve or +ve * +ve gives a +ve result. */
1174 } else if (product <= (UV)IV_MIN) {
1175 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1176 /* -ve result, which could overflow an IV */
1178 SETi( -(IV)product );
1180 } /* else drop to NVs below. */
1182 /* One operand is large, 1 small */
1185 /* swap the operands */
1187 bhigh = blow; /* bhigh now the temp var for the swap */
1191 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1192 multiplies can't overflow. shift can, add can, -ve can. */
1193 product_middle = ahigh * blow;
1194 if (!(product_middle & topmask)) {
1195 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1197 product_middle <<= (4 * sizeof (UV));
1198 product_low = alow * blow;
1200 /* as for pp_add, UV + something mustn't get smaller.
1201 IIRC ANSI mandates this wrapping *behaviour* for
1202 unsigned whatever the actual representation*/
1203 product_low += product_middle;
1204 if (product_low >= product_middle) {
1205 /* didn't overflow */
1206 if (auvok == buvok) {
1207 /* -ve * -ve or +ve * +ve gives a +ve result. */
1209 SETu( product_low );
1211 } else if (product_low <= (UV)IV_MIN) {
1212 /* 2s complement assumption again */
1213 /* -ve result, which could overflow an IV */
1215 SETi( -(IV)product_low );
1217 } /* else drop to NVs below. */
1219 } /* product_middle too large */
1220 } /* ahigh && bhigh */
1225 NV right = SvNV_nomg(svr);
1226 NV left = SvNV_nomg(svl);
1228 SETn( left * right );
1235 dVAR; dSP; dATARGET; SV *svl, *svr;
1236 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1239 /* Only try to do UV divide first
1240 if ((SLOPPYDIVIDE is true) or
1241 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1243 The assumption is that it is better to use floating point divide
1244 whenever possible, only doing integer divide first if we can't be sure.
1245 If NV_PRESERVES_UV is true then we know at compile time that no UV
1246 can be too large to preserve, so don't need to compile the code to
1247 test the size of UVs. */
1250 # define PERL_TRY_UV_DIVIDE
1251 /* ensure that 20./5. == 4. */
1253 # ifdef PERL_PRESERVE_IVUV
1254 # ifndef NV_PRESERVES_UV
1255 # define PERL_TRY_UV_DIVIDE
1260 #ifdef PERL_TRY_UV_DIVIDE
1261 SvIV_please_nomg(svr);
1263 SvIV_please_nomg(svl);
1265 bool left_non_neg = SvUOK(svl);
1266 bool right_non_neg = SvUOK(svr);
1270 if (right_non_neg) {
1274 const IV biv = SvIVX(svr);
1277 right_non_neg = TRUE; /* effectively it's a UV now */
1283 /* historically undef()/0 gives a "Use of uninitialized value"
1284 warning before dieing, hence this test goes here.
1285 If it were immediately before the second SvIV_please, then
1286 DIE() would be invoked before left was even inspected, so
1287 no inpsection would give no warning. */
1289 DIE(aTHX_ "Illegal division by zero");
1295 const IV aiv = SvIVX(svl);
1298 left_non_neg = TRUE; /* effectively it's a UV now */
1307 /* For sloppy divide we always attempt integer division. */
1309 /* Otherwise we only attempt it if either or both operands
1310 would not be preserved by an NV. If both fit in NVs
1311 we fall through to the NV divide code below. However,
1312 as left >= right to ensure integer result here, we know that
1313 we can skip the test on the right operand - right big
1314 enough not to be preserved can't get here unless left is
1317 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1320 /* Integer division can't overflow, but it can be imprecise. */
1321 const UV result = left / right;
1322 if (result * right == left) {
1323 SP--; /* result is valid */
1324 if (left_non_neg == right_non_neg) {
1325 /* signs identical, result is positive. */
1329 /* 2s complement assumption */
1330 if (result <= (UV)IV_MIN)
1331 SETi( -(IV)result );
1333 /* It's exact but too negative for IV. */
1334 SETn( -(NV)result );
1337 } /* tried integer divide but it was not an integer result */
1338 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1339 } /* left wasn't SvIOK */
1340 } /* right wasn't SvIOK */
1341 #endif /* PERL_TRY_UV_DIVIDE */
1343 NV right = SvNV_nomg(svr);
1344 NV left = SvNV_nomg(svl);
1345 (void)POPs;(void)POPs;
1346 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1347 if (! Perl_isnan(right) && right == 0.0)
1351 DIE(aTHX_ "Illegal division by zero");
1352 PUSHn( left / right );
1359 dVAR; dSP; dATARGET;
1360 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1364 bool left_neg = FALSE;
1365 bool right_neg = FALSE;
1366 bool use_double = FALSE;
1367 bool dright_valid = FALSE;
1370 SV * const svr = TOPs;
1371 SV * const svl = TOPm1s;
1372 SvIV_please_nomg(svr);
1374 right_neg = !SvUOK(svr);
1378 const IV biv = SvIVX(svr);
1381 right_neg = FALSE; /* effectively it's a UV now */
1388 dright = SvNV_nomg(svr);
1389 right_neg = dright < 0;
1392 if (dright < UV_MAX_P1) {
1393 right = U_V(dright);
1394 dright_valid = TRUE; /* In case we need to use double below. */
1400 /* At this point use_double is only true if right is out of range for
1401 a UV. In range NV has been rounded down to nearest UV and
1402 use_double false. */
1403 SvIV_please_nomg(svl);
1404 if (!use_double && SvIOK(svl)) {
1406 left_neg = !SvUOK(svl);
1410 const IV aiv = SvIVX(svl);
1413 left_neg = FALSE; /* effectively it's a UV now */
1421 dleft = SvNV_nomg(svl);
1422 left_neg = dleft < 0;
1426 /* This should be exactly the 5.6 behaviour - if left and right are
1427 both in range for UV then use U_V() rather than floor. */
1429 if (dleft < UV_MAX_P1) {
1430 /* right was in range, so is dleft, so use UVs not double.
1434 /* left is out of range for UV, right was in range, so promote
1435 right (back) to double. */
1437 /* The +0.5 is used in 5.6 even though it is not strictly
1438 consistent with the implicit +0 floor in the U_V()
1439 inside the #if 1. */
1440 dleft = Perl_floor(dleft + 0.5);
1443 dright = Perl_floor(dright + 0.5);
1454 DIE(aTHX_ "Illegal modulus zero");
1456 dans = Perl_fmod(dleft, dright);
1457 if ((left_neg != right_neg) && dans)
1458 dans = dright - dans;
1461 sv_setnv(TARG, dans);
1467 DIE(aTHX_ "Illegal modulus zero");
1470 if ((left_neg != right_neg) && ans)
1473 /* XXX may warn: unary minus operator applied to unsigned type */
1474 /* could change -foo to be (~foo)+1 instead */
1475 if (ans <= ~((UV)IV_MAX)+1)
1476 sv_setiv(TARG, ~ans+1);
1478 sv_setnv(TARG, -(NV)ans);
1481 sv_setuv(TARG, ans);
1490 dVAR; dSP; dATARGET;
1494 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1495 /* TODO: think of some way of doing list-repeat overloading ??? */
1500 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1506 const UV uv = SvUV_nomg(sv);
1508 count = IV_MAX; /* The best we can do? */
1512 const IV iv = SvIV_nomg(sv);
1519 else if (SvNOKp(sv)) {
1520 const NV nv = SvNV_nomg(sv);
1527 count = SvIV_nomg(sv);
1529 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1531 static const char oom_list_extend[] = "Out of memory during list extend";
1532 const I32 items = SP - MARK;
1533 const I32 max = items * count;
1535 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1536 /* Did the max computation overflow? */
1537 if (items > 0 && max > 0 && (max < items || max < count))
1538 Perl_croak(aTHX_ oom_list_extend);
1543 /* This code was intended to fix 20010809.028:
1546 for (($x =~ /./g) x 2) {
1547 print chop; # "abcdabcd" expected as output.
1550 * but that change (#11635) broke this code:
1552 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1554 * I can't think of a better fix that doesn't introduce
1555 * an efficiency hit by copying the SVs. The stack isn't
1556 * refcounted, and mortalisation obviously doesn't
1557 * Do The Right Thing when the stack has more than
1558 * one pointer to the same mortal value.
1562 *SP = sv_2mortal(newSVsv(*SP));
1572 repeatcpy((char*)(MARK + items), (char*)MARK,
1573 items * sizeof(const SV *), count - 1);
1576 else if (count <= 0)
1579 else { /* Note: mark already snarfed by pp_list */
1580 SV * const tmpstr = POPs;
1583 static const char oom_string_extend[] =
1584 "Out of memory during string extend";
1587 sv_setsv_nomg(TARG, tmpstr);
1588 SvPV_force_nomg(TARG, len);
1589 isutf = DO_UTF8(TARG);
1594 const STRLEN max = (UV)count * len;
1595 if (len > MEM_SIZE_MAX / count)
1596 Perl_croak(aTHX_ oom_string_extend);
1597 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1598 SvGROW(TARG, max + 1);
1599 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1600 SvCUR_set(TARG, SvCUR(TARG) * count);
1602 *SvEND(TARG) = '\0';
1605 (void)SvPOK_only_UTF8(TARG);
1607 (void)SvPOK_only(TARG);
1609 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1610 /* The parser saw this as a list repeat, and there
1611 are probably several items on the stack. But we're
1612 in scalar context, and there's no pp_list to save us
1613 now. So drop the rest of the items -- robin@kitsite.com
1625 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1626 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1629 useleft = USE_LEFT(svl);
1630 #ifdef PERL_PRESERVE_IVUV
1631 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1632 "bad things" happen if you rely on signed integers wrapping. */
1633 SvIV_please_nomg(svr);
1635 /* Unless the left argument is integer in range we are going to have to
1636 use NV maths. Hence only attempt to coerce the right argument if
1637 we know the left is integer. */
1638 register UV auv = 0;
1644 a_valid = auvok = 1;
1645 /* left operand is undef, treat as zero. */
1647 /* Left operand is defined, so is it IV? */
1648 SvIV_please_nomg(svl);
1650 if ((auvok = SvUOK(svl)))
1653 register const IV aiv = SvIVX(svl);
1656 auvok = 1; /* Now acting as a sign flag. */
1657 } else { /* 2s complement assumption for IV_MIN */
1665 bool result_good = 0;
1668 bool buvok = SvUOK(svr);
1673 register const IV biv = SvIVX(svr);
1680 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1681 else "IV" now, independent of how it came in.
1682 if a, b represents positive, A, B negative, a maps to -A etc
1687 all UV maths. negate result if A negative.
1688 subtract if signs same, add if signs differ. */
1690 if (auvok ^ buvok) {
1699 /* Must get smaller */
1704 if (result <= buv) {
1705 /* result really should be -(auv-buv). as its negation
1706 of true value, need to swap our result flag */
1718 if (result <= (UV)IV_MIN)
1719 SETi( -(IV)result );
1721 /* result valid, but out of range for IV. */
1722 SETn( -(NV)result );
1726 } /* Overflow, drop through to NVs. */
1731 NV value = SvNV_nomg(svr);
1735 /* left operand is undef, treat as zero - value */
1739 SETn( SvNV_nomg(svl) - value );
1746 dVAR; dSP; dATARGET; SV *svl, *svr;
1747 tryAMAGICbin_MG(lshift_amg, AMGf_assign);
1751 const IV shift = SvIV_nomg(svr);
1752 if (PL_op->op_private & HINT_INTEGER) {
1753 const IV i = SvIV_nomg(svl);
1757 const UV u = SvUV_nomg(svl);
1766 dVAR; dSP; dATARGET; SV *svl, *svr;
1767 tryAMAGICbin_MG(rshift_amg, AMGf_assign);
1771 const IV shift = SvIV_nomg(svr);
1772 if (PL_op->op_private & HINT_INTEGER) {
1773 const IV i = SvIV_nomg(svl);
1777 const UV u = SvUV_nomg(svl);
1787 tryAMAGICbin_MG(lt_amg, AMGf_set);
1788 #ifdef PERL_PRESERVE_IVUV
1789 SvIV_please_nomg(TOPs);
1791 SvIV_please_nomg(TOPm1s);
1792 if (SvIOK(TOPm1s)) {
1793 bool auvok = SvUOK(TOPm1s);
1794 bool buvok = SvUOK(TOPs);
1796 if (!auvok && !buvok) { /* ## IV < IV ## */
1797 const IV aiv = SvIVX(TOPm1s);
1798 const IV biv = SvIVX(TOPs);
1801 SETs(boolSV(aiv < biv));
1804 if (auvok && buvok) { /* ## UV < UV ## */
1805 const UV auv = SvUVX(TOPm1s);
1806 const UV buv = SvUVX(TOPs);
1809 SETs(boolSV(auv < buv));
1812 if (auvok) { /* ## UV < IV ## */
1814 const IV biv = SvIVX(TOPs);
1817 /* As (a) is a UV, it's >=0, so it cannot be < */
1822 SETs(boolSV(auv < (UV)biv));
1825 { /* ## IV < UV ## */
1826 const IV aiv = SvIVX(TOPm1s);
1830 /* As (b) is a UV, it's >=0, so it must be < */
1837 SETs(boolSV((UV)aiv < buv));
1843 #ifndef NV_PRESERVES_UV
1844 #ifdef PERL_PRESERVE_IVUV
1847 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1849 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1854 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1856 if (Perl_isnan(left) || Perl_isnan(right))
1858 SETs(boolSV(left < right));
1861 SETs(boolSV(SvNV_nomg(TOPs) < value));
1870 tryAMAGICbin_MG(gt_amg, AMGf_set);
1871 #ifdef PERL_PRESERVE_IVUV
1872 SvIV_please_nomg(TOPs);
1874 SvIV_please_nomg(TOPm1s);
1875 if (SvIOK(TOPm1s)) {
1876 bool auvok = SvUOK(TOPm1s);
1877 bool buvok = SvUOK(TOPs);
1879 if (!auvok && !buvok) { /* ## IV > IV ## */
1880 const IV aiv = SvIVX(TOPm1s);
1881 const IV biv = SvIVX(TOPs);
1884 SETs(boolSV(aiv > biv));
1887 if (auvok && buvok) { /* ## UV > UV ## */
1888 const UV auv = SvUVX(TOPm1s);
1889 const UV buv = SvUVX(TOPs);
1892 SETs(boolSV(auv > buv));
1895 if (auvok) { /* ## UV > IV ## */
1897 const IV biv = SvIVX(TOPs);
1901 /* As (a) is a UV, it's >=0, so it must be > */
1906 SETs(boolSV(auv > (UV)biv));
1909 { /* ## IV > UV ## */
1910 const IV aiv = SvIVX(TOPm1s);
1914 /* As (b) is a UV, it's >=0, so it cannot be > */
1921 SETs(boolSV((UV)aiv > buv));
1927 #ifndef NV_PRESERVES_UV
1928 #ifdef PERL_PRESERVE_IVUV
1931 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1933 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1938 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1940 if (Perl_isnan(left) || Perl_isnan(right))
1942 SETs(boolSV(left > right));
1945 SETs(boolSV(SvNV_nomg(TOPs) > value));
1954 tryAMAGICbin_MG(le_amg, AMGf_set);
1955 #ifdef PERL_PRESERVE_IVUV
1956 SvIV_please_nomg(TOPs);
1958 SvIV_please_nomg(TOPm1s);
1959 if (SvIOK(TOPm1s)) {
1960 bool auvok = SvUOK(TOPm1s);
1961 bool buvok = SvUOK(TOPs);
1963 if (!auvok && !buvok) { /* ## IV <= IV ## */
1964 const IV aiv = SvIVX(TOPm1s);
1965 const IV biv = SvIVX(TOPs);
1968 SETs(boolSV(aiv <= biv));
1971 if (auvok && buvok) { /* ## UV <= UV ## */
1972 UV auv = SvUVX(TOPm1s);
1973 UV buv = SvUVX(TOPs);
1976 SETs(boolSV(auv <= buv));
1979 if (auvok) { /* ## UV <= IV ## */
1981 const IV biv = SvIVX(TOPs);
1985 /* As (a) is a UV, it's >=0, so a cannot be <= */
1990 SETs(boolSV(auv <= (UV)biv));
1993 { /* ## IV <= UV ## */
1994 const IV aiv = SvIVX(TOPm1s);
1998 /* As (b) is a UV, it's >=0, so a must be <= */
2005 SETs(boolSV((UV)aiv <= buv));
2011 #ifndef NV_PRESERVES_UV
2012 #ifdef PERL_PRESERVE_IVUV
2015 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2017 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2022 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2024 if (Perl_isnan(left) || Perl_isnan(right))
2026 SETs(boolSV(left <= right));
2029 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2038 tryAMAGICbin_MG(ge_amg,AMGf_set);
2039 #ifdef PERL_PRESERVE_IVUV
2040 SvIV_please_nomg(TOPs);
2042 SvIV_please_nomg(TOPm1s);
2043 if (SvIOK(TOPm1s)) {
2044 bool auvok = SvUOK(TOPm1s);
2045 bool buvok = SvUOK(TOPs);
2047 if (!auvok && !buvok) { /* ## IV >= IV ## */
2048 const IV aiv = SvIVX(TOPm1s);
2049 const IV biv = SvIVX(TOPs);
2052 SETs(boolSV(aiv >= biv));
2055 if (auvok && buvok) { /* ## UV >= UV ## */
2056 const UV auv = SvUVX(TOPm1s);
2057 const UV buv = SvUVX(TOPs);
2060 SETs(boolSV(auv >= buv));
2063 if (auvok) { /* ## UV >= IV ## */
2065 const IV biv = SvIVX(TOPs);
2069 /* As (a) is a UV, it's >=0, so it must be >= */
2074 SETs(boolSV(auv >= (UV)biv));
2077 { /* ## IV >= UV ## */
2078 const IV aiv = SvIVX(TOPm1s);
2082 /* As (b) is a UV, it's >=0, so a cannot be >= */
2089 SETs(boolSV((UV)aiv >= buv));
2095 #ifndef NV_PRESERVES_UV
2096 #ifdef PERL_PRESERVE_IVUV
2099 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2101 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2106 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2108 if (Perl_isnan(left) || Perl_isnan(right))
2110 SETs(boolSV(left >= right));
2113 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2122 tryAMAGICbin_MG(ne_amg,AMGf_set);
2123 #ifndef NV_PRESERVES_UV
2124 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2126 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2130 #ifdef PERL_PRESERVE_IVUV
2131 SvIV_please_nomg(TOPs);
2133 SvIV_please_nomg(TOPm1s);
2134 if (SvIOK(TOPm1s)) {
2135 const bool auvok = SvUOK(TOPm1s);
2136 const bool buvok = SvUOK(TOPs);
2138 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2139 /* Casting IV to UV before comparison isn't going to matter
2140 on 2s complement. On 1s complement or sign&magnitude
2141 (if we have any of them) it could make negative zero
2142 differ from normal zero. As I understand it. (Need to
2143 check - is negative zero implementation defined behaviour
2145 const UV buv = SvUVX(POPs);
2146 const UV auv = SvUVX(TOPs);
2148 SETs(boolSV(auv != buv));
2151 { /* ## Mixed IV,UV ## */
2155 /* != is commutative so swap if needed (save code) */
2157 /* swap. top of stack (b) is the iv */
2161 /* As (a) is a UV, it's >0, so it cannot be == */
2170 /* As (b) is a UV, it's >0, so it cannot be == */
2174 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2176 SETs(boolSV((UV)iv != uv));
2183 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2185 if (Perl_isnan(left) || Perl_isnan(right))
2187 SETs(boolSV(left != right));
2190 SETs(boolSV(SvNV_nomg(TOPs) != value));
2199 tryAMAGICbin_MG(ncmp_amg, 0);
2200 #ifndef NV_PRESERVES_UV
2201 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2202 const UV right = PTR2UV(SvRV(POPs));
2203 const UV left = PTR2UV(SvRV(TOPs));
2204 SETi((left > right) - (left < right));
2208 #ifdef PERL_PRESERVE_IVUV
2209 /* Fortunately it seems NaN isn't IOK */
2210 SvIV_please_nomg(TOPs);
2212 SvIV_please_nomg(TOPm1s);
2213 if (SvIOK(TOPm1s)) {
2214 const bool leftuvok = SvUOK(TOPm1s);
2215 const bool rightuvok = SvUOK(TOPs);
2217 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2218 const IV leftiv = SvIVX(TOPm1s);
2219 const IV rightiv = SvIVX(TOPs);
2221 if (leftiv > rightiv)
2223 else if (leftiv < rightiv)
2227 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2228 const UV leftuv = SvUVX(TOPm1s);
2229 const UV rightuv = SvUVX(TOPs);
2231 if (leftuv > rightuv)
2233 else if (leftuv < rightuv)
2237 } else if (leftuvok) { /* ## UV <=> IV ## */
2238 const IV rightiv = SvIVX(TOPs);
2240 /* As (a) is a UV, it's >=0, so it cannot be < */
2243 const UV leftuv = SvUVX(TOPm1s);
2244 if (leftuv > (UV)rightiv) {
2246 } else if (leftuv < (UV)rightiv) {
2252 } else { /* ## IV <=> UV ## */
2253 const IV leftiv = SvIVX(TOPm1s);
2255 /* As (b) is a UV, it's >=0, so it must be < */
2258 const UV rightuv = SvUVX(TOPs);
2259 if ((UV)leftiv > rightuv) {
2261 } else if ((UV)leftiv < rightuv) {
2279 if (Perl_isnan(left) || Perl_isnan(right)) {
2283 value = (left > right) - (left < right);
2287 else if (left < right)
2289 else if (left > right)
2305 int amg_type = sle_amg;
2309 switch (PL_op->op_type) {
2328 tryAMAGICbin_MG(amg_type, AMGf_set);
2331 const int cmp = (IN_LOCALE_RUNTIME
2332 ? sv_cmp_locale(left, right)
2333 : sv_cmp(left, right));
2334 SETs(boolSV(cmp * multiplier < rhs));
2342 tryAMAGICbin_MG(seq_amg, AMGf_set);
2345 SETs(boolSV(sv_eq(left, right)));
2353 tryAMAGICbin_MG(sne_amg, AMGf_set);
2356 SETs(boolSV(!sv_eq(left, right)));
2364 tryAMAGICbin_MG(scmp_amg, 0);
2367 const int cmp = (IN_LOCALE_RUNTIME
2368 ? sv_cmp_locale(left, right)
2369 : sv_cmp(left, right));
2377 dVAR; dSP; dATARGET;
2378 tryAMAGICbin_MG(band_amg, AMGf_assign);
2381 if (SvNIOKp(left) || SvNIOKp(right)) {
2382 if (PL_op->op_private & HINT_INTEGER) {
2383 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2387 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2392 do_vop(PL_op->op_type, TARG, left, right);
2401 dVAR; dSP; dATARGET;
2402 const int op_type = PL_op->op_type;
2404 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2407 if (SvNIOKp(left) || SvNIOKp(right)) {
2408 if (PL_op->op_private & HINT_INTEGER) {
2409 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2410 const IV r = SvIV_nomg(right);
2411 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2415 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2416 const UV r = SvUV_nomg(right);
2417 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2422 do_vop(op_type, TARG, left, right);
2432 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2434 SV * const sv = TOPs;
2435 const int flags = SvFLAGS(sv);
2436 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2437 /* It's publicly an integer, or privately an integer-not-float */
2440 if (SvIVX(sv) == IV_MIN) {
2441 /* 2s complement assumption. */
2442 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2445 else if (SvUVX(sv) <= IV_MAX) {
2450 else if (SvIVX(sv) != IV_MIN) {
2454 #ifdef PERL_PRESERVE_IVUV
2462 SETn(-SvNV_nomg(sv));
2463 else if (SvPOKp(sv)) {
2465 const char * const s = SvPV_nomg_const(sv, len);
2466 if (isIDFIRST(*s)) {
2467 sv_setpvs(TARG, "-");
2470 else if (*s == '+' || *s == '-') {
2471 sv_setsv_nomg(TARG, sv);
2472 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2474 else if (DO_UTF8(sv)) {
2475 SvIV_please_nomg(sv);
2477 goto oops_its_an_int;
2479 sv_setnv(TARG, -SvNV_nomg(sv));
2481 sv_setpvs(TARG, "-");
2486 SvIV_please_nomg(sv);
2488 goto oops_its_an_int;
2489 sv_setnv(TARG, -SvNV_nomg(sv));
2494 SETn(-SvNV_nomg(sv));
2502 tryAMAGICun_MG(not_amg, AMGf_set);
2503 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2510 tryAMAGICun_MG(compl_amg, 0);
2514 if (PL_op->op_private & HINT_INTEGER) {
2515 const IV i = ~SvIV_nomg(sv);
2519 const UV u = ~SvUV_nomg(sv);
2528 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2529 sv_setsv_nomg(TARG, sv);
2530 tmps = (U8*)SvPV_force_nomg(TARG, len);
2533 /* Calculate exact length, let's not estimate. */
2538 U8 * const send = tmps + len;
2539 U8 * const origtmps = tmps;
2540 const UV utf8flags = UTF8_ALLOW_ANYUV;
2542 while (tmps < send) {
2543 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2545 targlen += UNISKIP(~c);
2551 /* Now rewind strings and write them. */
2558 Newx(result, targlen + 1, U8);
2560 while (tmps < send) {
2561 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2563 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2566 sv_usepvn_flags(TARG, (char*)result, targlen,
2567 SV_HAS_TRAILING_NUL);
2574 Newx(result, nchar + 1, U8);
2576 while (tmps < send) {
2577 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2582 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2590 register long *tmpl;
2591 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2594 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2599 for ( ; anum > 0; anum--, tmps++)
2607 /* integer versions of some of the above */
2611 dVAR; dSP; dATARGET;
2612 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2615 SETi( left * right );
2623 dVAR; dSP; dATARGET;
2624 tryAMAGICbin_MG(div_amg, AMGf_assign);
2627 IV value = SvIV_nomg(right);
2629 DIE(aTHX_ "Illegal division by zero");
2630 num = SvIV_nomg(left);
2632 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2636 value = num / value;
2642 #if defined(__GLIBC__) && IVSIZE == 8
2649 /* This is the vanilla old i_modulo. */
2650 dVAR; dSP; dATARGET;
2651 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2655 DIE(aTHX_ "Illegal modulus zero");
2656 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2660 SETi( left % right );
2665 #if defined(__GLIBC__) && IVSIZE == 8
2670 /* This is the i_modulo with the workaround for the _moddi3 bug
2671 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2672 * See below for pp_i_modulo. */
2673 dVAR; dSP; dATARGET;
2674 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2678 DIE(aTHX_ "Illegal modulus zero");
2679 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2683 SETi( left % PERL_ABS(right) );
2690 dVAR; dSP; dATARGET;
2691 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2695 DIE(aTHX_ "Illegal modulus zero");
2696 /* The assumption is to use hereafter the old vanilla version... */
2698 PL_ppaddr[OP_I_MODULO] =
2700 /* .. but if we have glibc, we might have a buggy _moddi3
2701 * (at least glicb 2.2.5 is known to have this bug), in other
2702 * words our integer modulus with negative quad as the second
2703 * argument might be broken. Test for this and re-patch the
2704 * opcode dispatch table if that is the case, remembering to
2705 * also apply the workaround so that this first round works
2706 * right, too. See [perl #9402] for more information. */
2710 /* Cannot do this check with inlined IV constants since
2711 * that seems to work correctly even with the buggy glibc. */
2713 /* Yikes, we have the bug.
2714 * Patch in the workaround version. */
2716 PL_ppaddr[OP_I_MODULO] =
2717 &Perl_pp_i_modulo_1;
2718 /* Make certain we work right this time, too. */
2719 right = PERL_ABS(right);
2722 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2726 SETi( left % right );
2734 dVAR; dSP; dATARGET;
2735 tryAMAGICbin_MG(add_amg, AMGf_assign);
2737 dPOPTOPiirl_ul_nomg;
2738 SETi( left + right );
2745 dVAR; dSP; dATARGET;
2746 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2748 dPOPTOPiirl_ul_nomg;
2749 SETi( left - right );
2757 tryAMAGICbin_MG(lt_amg, AMGf_set);
2760 SETs(boolSV(left < right));
2768 tryAMAGICbin_MG(gt_amg, AMGf_set);
2771 SETs(boolSV(left > right));
2779 tryAMAGICbin_MG(le_amg, AMGf_set);
2782 SETs(boolSV(left <= right));
2790 tryAMAGICbin_MG(ge_amg, AMGf_set);
2793 SETs(boolSV(left >= right));
2801 tryAMAGICbin_MG(eq_amg, AMGf_set);
2804 SETs(boolSV(left == right));
2812 tryAMAGICbin_MG(ne_amg, AMGf_set);
2815 SETs(boolSV(left != right));
2823 tryAMAGICbin_MG(ncmp_amg, 0);
2830 else if (left < right)
2842 tryAMAGICun_MG(neg_amg, 0);
2844 SV * const sv = TOPs;
2845 IV const i = SvIV_nomg(sv);
2851 /* High falutin' math. */
2856 tryAMAGICbin_MG(atan2_amg, 0);
2859 SETn(Perl_atan2(left, right));
2867 int amg_type = sin_amg;
2868 const char *neg_report = NULL;
2869 NV (*func)(NV) = Perl_sin;
2870 const int op_type = PL_op->op_type;
2887 amg_type = sqrt_amg;
2889 neg_report = "sqrt";
2894 tryAMAGICun_MG(amg_type, 0);
2896 SV * const arg = POPs;
2897 const NV value = SvNV_nomg(arg);
2899 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2900 SET_NUMERIC_STANDARD();
2901 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2904 XPUSHn(func(value));
2909 /* Support Configure command-line overrides for rand() functions.
2910 After 5.005, perhaps we should replace this by Configure support
2911 for drand48(), random(), or rand(). For 5.005, though, maintain
2912 compatibility by calling rand() but allow the user to override it.
2913 See INSTALL for details. --Andy Dougherty 15 July 1998
2915 /* Now it's after 5.005, and Configure supports drand48() and random(),
2916 in addition to rand(). So the overrides should not be needed any more.
2917 --Jarkko Hietaniemi 27 September 1998
2920 #ifndef HAS_DRAND48_PROTO
2921 extern double drand48 (void);
2934 if (!PL_srand_called) {
2935 (void)seedDrand01((Rand_seed_t)seed());
2936 PL_srand_called = TRUE;
2946 const UV anum = (MAXARG < 1) ? seed() : POPu;
2947 (void)seedDrand01((Rand_seed_t)anum);
2948 PL_srand_called = TRUE;
2956 tryAMAGICun_MG(int_amg, AMGf_numeric);
2958 SV * const sv = TOPs;
2959 const IV iv = SvIV_nomg(sv);
2960 /* XXX it's arguable that compiler casting to IV might be subtly
2961 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2962 else preferring IV has introduced a subtle behaviour change bug. OTOH
2963 relying on floating point to be accurate is a bug. */
2968 else if (SvIOK(sv)) {
2970 SETu(SvUV_nomg(sv));
2975 const NV value = SvNV_nomg(sv);
2977 if (value < (NV)UV_MAX + 0.5) {
2980 SETn(Perl_floor(value));
2984 if (value > (NV)IV_MIN - 0.5) {
2987 SETn(Perl_ceil(value));
2998 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3000 SV * const sv = TOPs;
3001 /* This will cache the NV value if string isn't actually integer */
3002 const IV iv = SvIV_nomg(sv);
3007 else if (SvIOK(sv)) {
3008 /* IVX is precise */
3010 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3018 /* 2s complement assumption. Also, not really needed as
3019 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3025 const NV value = SvNV_nomg(sv);
3039 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3043 SV* const sv = POPs;
3045 tmps = (SvPV_const(sv, len));
3047 /* If Unicode, try to downgrade
3048 * If not possible, croak. */
3049 SV* const tsv = sv_2mortal(newSVsv(sv));
3052 sv_utf8_downgrade(tsv, FALSE);
3053 tmps = SvPV_const(tsv, len);
3055 if (PL_op->op_type == OP_HEX)
3058 while (*tmps && len && isSPACE(*tmps))
3064 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3066 else if (*tmps == 'b')
3067 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3069 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3071 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3085 SV * const sv = TOPs;
3087 if (SvGAMAGIC(sv)) {
3088 /* For an overloaded or magic scalar, we can't know in advance if
3089 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3090 it likes to cache the length. Maybe that should be a documented
3095 = sv_2pv_flags(sv, &len,
3096 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3100 else if (DO_UTF8(sv)) {
3101 SETi(utf8_length((U8*)p, (U8*)p + len));
3105 } else if (SvOK(sv)) {
3106 /* Neither magic nor overloaded. */
3108 SETi(sv_len_utf8(sv));
3131 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3133 const IV arybase = CopARYBASE_get(PL_curcop);
3135 const char *repl = NULL;
3137 const int num_args = PL_op->op_private & 7;
3138 bool repl_need_utf8_upgrade = FALSE;
3139 bool repl_is_utf8 = FALSE;
3141 SvTAINTED_off(TARG); /* decontaminate */
3142 SvUTF8_off(TARG); /* decontaminate */
3146 repl = SvPV_const(repl_sv, repl_len);
3147 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3150 len_iv = SvIV(len_sv);
3151 len_is_uv = SvIOK_UV(len_sv);
3154 pos1_iv = SvIV(pos_sv);
3155 pos1_is_uv = SvIOK_UV(pos_sv);
3161 sv_utf8_upgrade(sv);
3163 else if (DO_UTF8(sv))
3164 repl_need_utf8_upgrade = TRUE;
3166 tmps = SvPV_const(sv, curlen);
3168 utf8_curlen = sv_len_utf8(sv);
3169 if (utf8_curlen == curlen)
3172 curlen = utf8_curlen;
3177 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3178 UV pos1_uv = pos1_iv-arybase;
3179 /* Overflow can occur when $[ < 0 */
3180 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3185 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3186 goto bound_fail; /* $[=3; substr($_,2,...) */
3188 else { /* pos < $[ */
3189 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3194 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3199 if (pos1_is_uv || pos1_iv > 0) {
3200 if ((UV)pos1_iv > curlen)
3205 if (!len_is_uv && len_iv < 0) {
3206 pos2_iv = curlen + len_iv;
3208 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3211 } else { /* len_iv >= 0 */
3212 if (!pos1_is_uv && pos1_iv < 0) {
3213 pos2_iv = pos1_iv + len_iv;
3214 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3216 if ((UV)len_iv > curlen-(UV)pos1_iv)
3219 pos2_iv = pos1_iv+len_iv;
3229 if (!pos2_is_uv && pos2_iv < 0) {
3230 if (!pos1_is_uv && pos1_iv < 0)
3234 else if (!pos1_is_uv && pos1_iv < 0)
3237 if ((UV)pos2_iv < (UV)pos1_iv)
3239 if ((UV)pos2_iv > curlen)
3243 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3244 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3245 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3246 STRLEN byte_len = len;
3247 STRLEN byte_pos = utf8_curlen
3248 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3251 /* we either return a PV or an LV. If the TARG hasn't been used
3252 * before, or is of that type, reuse it; otherwise use a mortal
3253 * instead. Note that LVs can have an extended lifetime, so also
3254 * dont reuse if refcount > 1 (bug #20933) */
3255 if (SvTYPE(TARG) > SVt_NULL) {
3256 if ( (SvTYPE(TARG) == SVt_PVLV)
3257 ? (!lvalue || SvREFCNT(TARG) > 1)
3260 TARG = sv_newmortal();
3264 sv_setpvn(TARG, tmps, byte_len);
3265 #ifdef USE_LOCALE_COLLATE
3266 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3271 SV* repl_sv_copy = NULL;
3273 if (repl_need_utf8_upgrade) {
3274 repl_sv_copy = newSVsv(repl_sv);
3275 sv_utf8_upgrade(repl_sv_copy);
3276 repl = SvPV_const(repl_sv_copy, repl_len);
3277 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3281 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3284 SvREFCNT_dec(repl_sv_copy);
3286 else if (lvalue) { /* it's an lvalue! */
3287 if (!SvGMAGICAL(sv)) {
3289 SvPV_force_nolen(sv);
3290 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3291 "Attempt to use reference as lvalue in substr");
3293 if (isGV_with_GP(sv))
3294 SvPV_force_nolen(sv);
3295 else if (SvOK(sv)) /* is it defined ? */
3296 (void)SvPOK_only_UTF8(sv);
3298 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3301 if (SvTYPE(TARG) < SVt_PVLV) {
3302 sv_upgrade(TARG, SVt_PVLV);
3303 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3307 if (LvTARG(TARG) != sv) {
3308 SvREFCNT_dec(LvTARG(TARG));
3309 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3311 LvTARGOFF(TARG) = pos;
3312 LvTARGLEN(TARG) = len;
3316 PUSHs(TARG); /* avoid SvSETMAGIC here */
3321 Perl_croak(aTHX_ "substr outside of string");
3322 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3329 register const IV size = POPi;
3330 register const IV offset = POPi;
3331 register SV * const src = POPs;
3332 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3334 SvTAINTED_off(TARG); /* decontaminate */
3335 if (lvalue) { /* it's an lvalue! */
3336 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3337 TARG = sv_newmortal();
3338 if (SvTYPE(TARG) < SVt_PVLV) {
3339 sv_upgrade(TARG, SVt_PVLV);
3340 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3343 if (LvTARG(TARG) != src) {
3344 SvREFCNT_dec(LvTARG(TARG));
3345 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3347 LvTARGOFF(TARG) = offset;
3348 LvTARGLEN(TARG) = size;
3351 sv_setuv(TARG, do_vecget(src, offset, size));
3367 const char *little_p;
3368 const I32 arybase = CopARYBASE_get(PL_curcop);
3371 const bool is_index = PL_op->op_type == OP_INDEX;
3374 /* arybase is in characters, like offset, so combine prior to the
3375 UTF-8 to bytes calculation. */
3376 offset = POPi - arybase;
3380 big_p = SvPV_const(big, biglen);
3381 little_p = SvPV_const(little, llen);
3383 big_utf8 = DO_UTF8(big);
3384 little_utf8 = DO_UTF8(little);
3385 if (big_utf8 ^ little_utf8) {
3386 /* One needs to be upgraded. */
3387 if (little_utf8 && !PL_encoding) {
3388 /* Well, maybe instead we might be able to downgrade the small
3390 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3393 /* If the large string is ISO-8859-1, and it's not possible to
3394 convert the small string to ISO-8859-1, then there is no
3395 way that it could be found anywhere by index. */
3400 /* At this point, pv is a malloc()ed string. So donate it to temp
3401 to ensure it will get free()d */
3402 little = temp = newSV(0);
3403 sv_usepvn(temp, pv, llen);
3404 little_p = SvPVX(little);
3407 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3410 sv_recode_to_utf8(temp, PL_encoding);
3412 sv_utf8_upgrade(temp);
3417 big_p = SvPV_const(big, biglen);
3420 little_p = SvPV_const(little, llen);
3424 if (SvGAMAGIC(big)) {
3425 /* Life just becomes a lot easier if I use a temporary here.
3426 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3427 will trigger magic and overloading again, as will fbm_instr()
3429 big = newSVpvn_flags(big_p, biglen,
3430 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3433 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3434 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3435 warn on undef, and we've already triggered a warning with the
3436 SvPV_const some lines above. We can't remove that, as we need to
3437 call some SvPV to trigger overloading early and find out if the
3439 This is all getting to messy. The API isn't quite clean enough,
3440 because data access has side effects.
3442 little = newSVpvn_flags(little_p, llen,
3443 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3444 little_p = SvPVX(little);
3448 offset = is_index ? 0 : biglen;
3450 if (big_utf8 && offset > 0)
3451 sv_pos_u2b(big, &offset, 0);
3457 else if (offset > (I32)biglen)
3459 if (!(little_p = is_index
3460 ? fbm_instr((unsigned char*)big_p + offset,
3461 (unsigned char*)big_p + biglen, little, 0)
3462 : rninstr(big_p, big_p + offset,
3463 little_p, little_p + llen)))
3466 retval = little_p - big_p;
3467 if (retval > 0 && big_utf8)
3468 sv_pos_b2u(big, &retval);
3472 PUSHi(retval + arybase);
3478 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3479 if (SvTAINTED(MARK[1]))
3480 TAINT_PROPER("sprintf");
3481 SvTAINTED_off(TARG);
3482 do_sprintf(TARG, SP-MARK, MARK+1);
3483 TAINT_IF(SvTAINTED(TARG));
3495 const U8 *s = (U8*)SvPV_const(argsv, len);
3497 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3498 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3499 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3503 XPUSHu(DO_UTF8(argsv) ?
3504 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3516 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3518 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3520 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3522 (void) POPs; /* Ignore the argument value. */
3523 value = UNICODE_REPLACEMENT;
3529 SvUPGRADE(TARG,SVt_PV);
3531 if (value > 255 && !IN_BYTES) {
3532 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3533 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3534 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3536 (void)SvPOK_only(TARG);
3545 *tmps++ = (char)value;
3547 (void)SvPOK_only(TARG);
3549 if (PL_encoding && !IN_BYTES) {
3550 sv_recode_to_utf8(TARG, PL_encoding);
3552 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3553 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3557 *tmps++ = (char)value;
3573 const char *tmps = SvPV_const(left, len);
3575 if (DO_UTF8(left)) {
3576 /* If Unicode, try to downgrade.
3577 * If not possible, croak.
3578 * Yes, we made this up. */
3579 SV* const tsv = sv_2mortal(newSVsv(left));
3582 sv_utf8_downgrade(tsv, FALSE);
3583 tmps = SvPV_const(tsv, len);
3585 # ifdef USE_ITHREADS
3587 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3588 /* This should be threadsafe because in ithreads there is only
3589 * one thread per interpreter. If this would not be true,
3590 * we would need a mutex to protect this malloc. */
3591 PL_reentrant_buffer->_crypt_struct_buffer =
3592 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3593 #if defined(__GLIBC__) || defined(__EMX__)
3594 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3595 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3596 /* work around glibc-2.2.5 bug */
3597 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3601 # endif /* HAS_CRYPT_R */
3602 # endif /* USE_ITHREADS */
3604 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3606 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3612 "The crypt() function is unimplemented due to excessive paranoia.");
3617 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3618 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3620 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3621 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3622 * See http://www.unicode.org/unicode/reports/tr16 */
3623 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3624 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3626 /* Below are several macros that generate code */
3627 /* Generates code to store a unicode codepoint c that is known to occupy
3628 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3629 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3631 *(p) = UTF8_TWO_BYTE_HI(c); \
3632 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3635 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3636 * available byte after the two bytes */
3637 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3639 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3640 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3643 /* Generates code to store the upper case of latin1 character l which is known
3644 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3645 * are only two characters that fit this description, and this macro knows
3646 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3648 #define STORE_NON_LATIN1_UC(p, l) \
3650 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3651 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3652 } else { /* Must be the following letter */ \
3653 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3657 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3658 * after the character stored */
3659 #define CAT_NON_LATIN1_UC(p, l) \
3661 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3662 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3664 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3668 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3669 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3670 * and must require two bytes to store it. Advances p to point to the next
3671 * available position */
3672 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3674 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3675 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3676 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3677 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3678 } else {/* else is one of the other two special cases */ \
3679 CAT_NON_LATIN1_UC((p), (l)); \
3685 /* Actually is both lcfirst() and ucfirst(). Only the first character
3686 * changes. This means that possibly we can change in-place, ie., just
3687 * take the source and change that one character and store it back, but not
3688 * if read-only etc, or if the length changes */
3693 STRLEN slen; /* slen is the byte length of the whole SV. */
3696 bool inplace; /* ? Convert first char only, in-place */
3697 bool doing_utf8 = FALSE; /* ? using utf8 */
3698 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3699 const int op_type = PL_op->op_type;
3702 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3703 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3704 * stored as UTF-8 at s. */
3705 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3706 * lowercased) character stored in tmpbuf. May be either
3707 * UTF-8 or not, but in either case is the number of bytes */
3711 s = (const U8*)SvPV_nomg_const(source, slen);
3713 if (ckWARN(WARN_UNINITIALIZED))
3714 report_uninit(source);
3719 /* We may be able to get away with changing only the first character, in
3720 * place, but not if read-only, etc. Later we may discover more reasons to
3721 * not convert in-place. */
3722 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3724 /* First calculate what the changed first character should be. This affects
3725 * whether we can just swap it out, leaving the rest of the string unchanged,
3726 * or even if have to convert the dest to UTF-8 when the source isn't */
3728 if (! slen) { /* If empty */
3729 need = 1; /* still need a trailing NUL */
3731 else if (DO_UTF8(source)) { /* Is the source utf8? */
3734 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3735 * and doesn't allow for the user to specify their own. When code is added to
3736 * detect if there is a user-defined mapping in force here, and if so to use
3737 * that, then the code below can be compiled. The detection would be a good
3738 * thing anyway, as currently the user-defined mappings only work on utf8
3739 * strings, and thus depend on the chosen internal storage method, which is a
3741 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3742 if (UTF8_IS_INVARIANT(*s)) {
3744 /* An invariant source character is either ASCII or, in EBCDIC, an
3745 * ASCII equivalent or a caseless C1 control. In both these cases,
3746 * the lower and upper cases of any character are also invariants
3747 * (and title case is the same as upper case). So it is safe to
3748 * use the simple case change macros which avoid the overhead of
3749 * the general functions. Note that if perl were to be extended to
3750 * do locale handling in UTF-8 strings, this wouldn't be true in,
3751 * for example, Lithuanian or Turkic. */
3752 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3756 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3759 /* Similarly, if the source character isn't invariant but is in the
3760 * latin1 range (or EBCDIC equivalent thereof), we have the case
3761 * changes compiled into perl, and can avoid the overhead of the
3762 * general functions. In this range, the characters are stored as
3763 * two UTF-8 bytes, and it so happens that any changed-case version
3764 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3768 /* Convert the two source bytes to a single Unicode code point
3769 * value, change case and save for below */
3770 chr = UTF8_ACCUMULATE(*s, *(s+1));
3771 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3772 U8 lower = toLOWER_LATIN1(chr);
3773 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3775 else { /* ucfirst */
3776 U8 upper = toUPPER_LATIN1_MOD(chr);
3778 /* Most of the latin1 range characters are well-behaved. Their
3779 * title and upper cases are the same, and are also in the
3780 * latin1 range. The macro above returns their upper (hence
3781 * title) case, and all that need be done is to save the result
3782 * for below. However, several characters are problematic, and
3783 * have to be handled specially. The MOD in the macro name
3784 * above means that these tricky characters all get mapped to
3785 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3786 * This mapping saves some tests for the majority of the
3789 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3791 /* Not tricky. Just save it. */
3792 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3794 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3796 /* This one is tricky because it is two characters long,
3797 * though the UTF-8 is still two bytes, so the stored
3798 * length doesn't change */
3799 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3800 *(tmpbuf + 1) = 's';
3804 /* The other two have their title and upper cases the same,
3805 * but are tricky because the changed-case characters
3806 * aren't in the latin1 range. They, however, do fit into
3807 * two UTF-8 bytes */
3808 STORE_NON_LATIN1_UC(tmpbuf, chr);
3813 #endif /* end of dont want to break user-defined casing */
3815 /* Here, can't short-cut the general case */
3817 utf8_to_uvchr(s, &ulen);
3818 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3819 else toLOWER_utf8(s, tmpbuf, &tculen);
3821 /* we can't do in-place if the length changes. */
3822 if (ulen != tculen) inplace = FALSE;
3823 need = slen + 1 - ulen + tculen;
3824 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3828 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3829 * latin1 is treated as caseless. Note that a locale takes
3831 tculen = 1; /* Most characters will require one byte, but this will
3832 * need to be overridden for the tricky ones */
3835 if (op_type == OP_LCFIRST) {
3837 /* lower case the first letter: no trickiness for any character */
3838 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3839 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3842 else if (IN_LOCALE_RUNTIME) {
3843 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3844 * have upper and title case different
3847 else if (! IN_UNI_8_BIT) {
3848 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3849 * on EBCDIC machines whatever the
3850 * native function does */
3852 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3853 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3855 /* tmpbuf now has the correct title case for all latin1 characters
3856 * except for the several ones that have tricky handling. All
3857 * of these are mapped by the MOD to the letter below. */
3858 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3860 /* The length is going to change, with all three of these, so
3861 * can't replace just the first character */
3864 /* We use the original to distinguish between these tricky
3866 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3867 /* Two character title case 'Ss', but can remain non-UTF-8 */
3870 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3875 /* The other two tricky ones have their title case outside
3876 * latin1. It is the same as their upper case. */
3878 STORE_NON_LATIN1_UC(tmpbuf, *s);
3880 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3881 * and their upper cases is 2. */
3884 /* The entire result will have to be in UTF-8. Assume worst
3885 * case sizing in conversion. (all latin1 characters occupy
3886 * at most two bytes in utf8) */
3887 convert_source_to_utf8 = TRUE;
3888 need = slen * 2 + 1;
3890 } /* End of is one of the three special chars */
3891 } /* End of use Unicode (Latin1) semantics */
3892 } /* End of changing the case of the first character */
3894 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3895 * generate the result */
3898 /* We can convert in place. This means we change just the first
3899 * character without disturbing the rest; no need to grow */
3901 s = d = (U8*)SvPV_force_nomg(source, slen);
3907 /* Here, we can't convert in place; we earlier calculated how much
3908 * space we will need, so grow to accommodate that */
3909 SvUPGRADE(dest, SVt_PV);
3910 d = (U8*)SvGROW(dest, need);
3911 (void)SvPOK_only(dest);
3918 if (! convert_source_to_utf8) {
3920 /* Here both source and dest are in UTF-8, but have to create
3921 * the entire output. We initialize the result to be the
3922 * title/lower cased first character, and then append the rest
3924 sv_setpvn(dest, (char*)tmpbuf, tculen);
3926 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3930 const U8 *const send = s + slen;
3932 /* Here the dest needs to be in UTF-8, but the source isn't,
3933 * except we earlier UTF-8'd the first character of the source
3934 * into tmpbuf. First put that into dest, and then append the
3935 * rest of the source, converting it to UTF-8 as we go. */
3937 /* Assert tculen is 2 here because the only two characters that
3938 * get to this part of the code have 2-byte UTF-8 equivalents */
3940 *d++ = *(tmpbuf + 1);
3941 s++; /* We have just processed the 1st char */
3943 for (; s < send; s++) {
3944 d = uvchr_to_utf8(d, *s);
3947 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3951 else { /* in-place UTF-8. Just overwrite the first character */
3952 Copy(tmpbuf, d, tculen, U8);
3953 SvCUR_set(dest, need - 1);
3956 else { /* Neither source nor dest are in or need to be UTF-8 */
3958 if (IN_LOCALE_RUNTIME) {
3962 if (inplace) { /* in-place, only need to change the 1st char */
3965 else { /* Not in-place */
3967 /* Copy the case-changed character(s) from tmpbuf */
3968 Copy(tmpbuf, d, tculen, U8);
3969 d += tculen - 1; /* Code below expects d to point to final
3970 * character stored */
3973 else { /* empty source */
3974 /* See bug #39028: Don't taint if empty */
3978 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3979 * the destination to retain that flag */
3983 if (!inplace) { /* Finish the rest of the string, unchanged */
3984 /* This will copy the trailing NUL */
3985 Copy(s + 1, d + 1, slen, U8);
3986 SvCUR_set(dest, need - 1);
3993 /* There's so much setup/teardown code common between uc and lc, I wonder if
3994 it would be worth merging the two, and just having a switch outside each
3995 of the three tight loops. There is less and less commonality though */
4009 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4010 && SvTEMP(source) && !DO_UTF8(source)
4011 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4013 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4014 * make the loop tight, so we overwrite the source with the dest before
4015 * looking at it, and we need to look at the original source
4016 * afterwards. There would also need to be code added to handle
4017 * switching to not in-place in midstream if we run into characters
4018 * that change the length.
4021 s = d = (U8*)SvPV_force_nomg(source, len);
4028 /* The old implementation would copy source into TARG at this point.
4029 This had the side effect that if source was undef, TARG was now
4030 an undefined SV with PADTMP set, and they don't warn inside
4031 sv_2pv_flags(). However, we're now getting the PV direct from
4032 source, which doesn't have PADTMP set, so it would warn. Hence the
4036 s = (const U8*)SvPV_nomg_const(source, len);
4038 if (ckWARN(WARN_UNINITIALIZED))
4039 report_uninit(source);
4045 SvUPGRADE(dest, SVt_PV);
4046 d = (U8*)SvGROW(dest, min);
4047 (void)SvPOK_only(dest);
4052 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4053 to check DO_UTF8 again here. */
4055 if (DO_UTF8(source)) {
4056 const U8 *const send = s + len;
4057 U8 tmpbuf[UTF8_MAXBYTES+1];
4059 /* All occurrences of these are to be moved to follow any other marks.
4060 * This is context-dependent. We may not be passed enough context to
4061 * move the iota subscript beyond all of them, but we do the best we can
4062 * with what we're given. The result is always better than if we
4063 * hadn't done this. And, the problem would only arise if we are
4064 * passed a character without all its combining marks, which would be
4065 * the caller's mistake. The information this is based on comes from a
4066 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4067 * itself) and so can't be checked properly to see if it ever gets
4068 * revised. But the likelihood of it changing is remote */
4069 bool in_iota_subscript = FALSE;
4072 if (in_iota_subscript && ! is_utf8_mark(s)) {
4073 /* A non-mark. Time to output the iota subscript */
4074 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4075 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4077 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4078 in_iota_subscript = FALSE;
4082 /* See comments at the first instance in this file of this ifdef */
4083 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4085 /* If the UTF-8 character is invariant, then it is in the range
4086 * known by the standard macro; result is only one byte long */
4087 if (UTF8_IS_INVARIANT(*s)) {
4091 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4093 /* Likewise, if it fits in a byte, its case change is in our
4095 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4096 U8 upper = toUPPER_LATIN1_MOD(orig);
4097 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4105 /* Otherwise, need the general UTF-8 case. Get the changed
4106 * case value and copy it to the output buffer */
4108 const STRLEN u = UTF8SKIP(s);
4111 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4112 if (uv == GREEK_CAPITAL_LETTER_IOTA
4113 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4115 in_iota_subscript = TRUE;
4118 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4119 /* If the eventually required minimum size outgrows
4120 * the available space, we need to grow. */
4121 const UV o = d - (U8*)SvPVX_const(dest);
4123 /* If someone uppercases one million U+03B0s we
4124 * SvGROW() one million times. Or we could try
4125 * guessing how much to allocate without allocating too
4126 * much. Such is life. See corresponding comment in
4127 * lc code for another option */
4129 d = (U8*)SvPVX(dest) + o;
4131 Copy(tmpbuf, d, ulen, U8);
4137 if (in_iota_subscript) {
4138 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4142 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4144 else { /* Not UTF-8 */
4146 const U8 *const send = s + len;
4148 /* Use locale casing if in locale; regular style if not treating
4149 * latin1 as having case; otherwise the latin1 casing. Do the
4150 * whole thing in a tight loop, for speed, */
4151 if (IN_LOCALE_RUNTIME) {
4154 for (; s < send; d++, s++)
4155 *d = toUPPER_LC(*s);
4157 else if (! IN_UNI_8_BIT) {
4158 for (; s < send; d++, s++) {
4163 for (; s < send; d++, s++) {
4164 *d = toUPPER_LATIN1_MOD(*s);
4165 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4167 /* The mainstream case is the tight loop above. To avoid
4168 * extra tests in that, all three characters that require
4169 * special handling are mapped by the MOD to the one tested
4171 * Use the source to distinguish between the three cases */
4173 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4175 /* uc() of this requires 2 characters, but they are
4176 * ASCII. If not enough room, grow the string */
4177 if (SvLEN(dest) < ++min) {
4178 const UV o = d - (U8*)SvPVX_const(dest);
4180 d = (U8*)SvPVX(dest) + o;
4182 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4183 continue; /* Back to the tight loop; still in ASCII */
4186 /* The other two special handling characters have their
4187 * upper cases outside the latin1 range, hence need to be
4188 * in UTF-8, so the whole result needs to be in UTF-8. So,
4189 * here we are somewhere in the middle of processing a
4190 * non-UTF-8 string, and realize that we will have to convert
4191 * the whole thing to UTF-8. What to do? There are
4192 * several possibilities. The simplest to code is to
4193 * convert what we have so far, set a flag, and continue on
4194 * in the loop. The flag would be tested each time through
4195 * the loop, and if set, the next character would be
4196 * converted to UTF-8 and stored. But, I (khw) didn't want
4197 * to slow down the mainstream case at all for this fairly
4198 * rare case, so I didn't want to add a test that didn't
4199 * absolutely have to be there in the loop, besides the
4200 * possibility that it would get too complicated for
4201 * optimizers to deal with. Another possibility is to just
4202 * give up, convert the source to UTF-8, and restart the
4203 * function that way. Another possibility is to convert
4204 * both what has already been processed and what is yet to
4205 * come separately to UTF-8, then jump into the loop that
4206 * handles UTF-8. But the most efficient time-wise of the
4207 * ones I could think of is what follows, and turned out to
4208 * not require much extra code. */
4210 /* Convert what we have so far into UTF-8, telling the
4211 * function that we know it should be converted, and to
4212 * allow extra space for what we haven't processed yet.
4213 * Assume the worst case space requirements for converting
4214 * what we haven't processed so far: that it will require
4215 * two bytes for each remaining source character, plus the
4216 * NUL at the end. This may cause the string pointer to
4217 * move, so re-find it. */
4219 len = d - (U8*)SvPVX_const(dest);
4220 SvCUR_set(dest, len);
4221 len = sv_utf8_upgrade_flags_grow(dest,
4222 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4224 d = (U8*)SvPVX(dest) + len;
4226 /* And append the current character's upper case in UTF-8 */
4227 CAT_NON_LATIN1_UC(d, *s);
4229 /* Now process the remainder of the source, converting to
4230 * upper and UTF-8. If a resulting byte is invariant in
4231 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4232 * append it to the output. */
4235 for (; s < send; s++) {
4236 U8 upper = toUPPER_LATIN1_MOD(*s);
4237 if UTF8_IS_INVARIANT(upper) {
4241 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4245 /* Here have processed the whole source; no need to continue
4246 * with the outer loop. Each character has been converted
4247 * to upper case and converted to UTF-8 */
4250 } /* End of processing all latin1-style chars */
4251 } /* End of processing all chars */
4252 } /* End of source is not empty */
4254 if (source != dest) {
4255 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4256 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4258 } /* End of isn't utf8 */
4276 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4277 && SvTEMP(source) && !DO_UTF8(source)) {
4279 /* We can convert in place, as lowercasing anything in the latin1 range
4280 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4282 s = d = (U8*)SvPV_force_nomg(source, len);
4289 /* The old implementation would copy source into TARG at this point.
4290 This had the side effect that if source was undef, TARG was now
4291 an undefined SV with PADTMP set, and they don't warn inside
4292 sv_2pv_flags(). However, we're now getting the PV direct from
4293 source, which doesn't have PADTMP set, so it would warn. Hence the
4297 s = (const U8*)SvPV_nomg_const(source, len);
4299 if (ckWARN(WARN_UNINITIALIZED))
4300 report_uninit(source);
4306 SvUPGRADE(dest, SVt_PV);
4307 d = (U8*)SvGROW(dest, min);
4308 (void)SvPOK_only(dest);
4313 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4314 to check DO_UTF8 again here. */
4316 if (DO_UTF8(source)) {
4317 const U8 *const send = s + len;
4318 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4321 /* See comments at the first instance in this file of this ifdef */
4322 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4323 if (UTF8_IS_INVARIANT(*s)) {
4325 /* Invariant characters use the standard mappings compiled in.
4330 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4332 /* As do the ones in the Latin1 range */
4333 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4334 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4339 /* Here, is utf8 not in Latin-1 range, have to go out and get
4340 * the mappings from the tables. */
4342 const STRLEN u = UTF8SKIP(s);
4345 #ifndef CONTEXT_DEPENDENT_CASING
4346 toLOWER_utf8(s, tmpbuf, &ulen);
4348 /* This is ifdefd out because it needs more work and thought. It isn't clear
4349 * that we should do it.
4350 * A minor objection is that this is based on a hard-coded rule from the
4351 * Unicode standard, and may change, but this is not very likely at all.
4352 * mktables should check and warn if it does.
4353 * More importantly, if the sigma occurs at the end of the string, we don't
4354 * have enough context to know whether it is part of a larger string or going
4355 * to be or not. It may be that we are passed a subset of the context, via
4356 * a \U...\E, for example, and we could conceivably know the larger context if
4357 * code were changed to pass that in. But, if the string passed in is an
4358 * intermediate result, and the user concatenates two strings together
4359 * after we have made a final sigma, that would be wrong. If the final sigma
4360 * occurs in the middle of the string we are working on, then we know that it
4361 * should be a final sigma, but otherwise we can't be sure. */
4363 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4365 /* If the lower case is a small sigma, it may be that we need
4366 * to change it to a final sigma. This happens at the end of
4367 * a word that contains more than just this character, and only
4368 * when we started with a capital sigma. */
4369 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4370 s > send - len && /* Makes sure not the first letter */
4371 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4374 /* We use the algorithm in:
4375 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4376 * is a CAPITAL SIGMA): If C is preceded by a sequence
4377 * consisting of a cased letter and a case-ignorable
4378 * sequence, and C is not followed by a sequence consisting
4379 * of a case ignorable sequence and then a cased letter,
4380 * then when lowercasing C, C becomes a final sigma */
4382 /* To determine if this is the end of a word, need to peek
4383 * ahead. Look at the next character */
4384 const U8 *peek = s + u;
4386 /* Skip any case ignorable characters */
4387 while (peek < send && is_utf8_case_ignorable(peek)) {
4388 peek += UTF8SKIP(peek);
4391 /* If we reached the end of the string without finding any
4392 * non-case ignorable characters, or if the next such one
4393 * is not-cased, then we have met the conditions for it
4394 * being a final sigma with regards to peek ahead, and so
4395 * must do peek behind for the remaining conditions. (We
4396 * know there is stuff behind to look at since we tested
4397 * above that this isn't the first letter) */
4398 if (peek >= send || ! is_utf8_cased(peek)) {
4399 peek = utf8_hop(s, -1);
4401 /* Here are at the beginning of the first character
4402 * before the original upper case sigma. Keep backing
4403 * up, skipping any case ignorable characters */
4404 while (is_utf8_case_ignorable(peek)) {
4405 peek = utf8_hop(peek, -1);
4408 /* Here peek points to the first byte of the closest
4409 * non-case-ignorable character before the capital
4410 * sigma. If it is cased, then by the Unicode
4411 * algorithm, we should use a small final sigma instead
4412 * of what we have */
4413 if (is_utf8_cased(peek)) {
4414 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4415 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4419 else { /* Not a context sensitive mapping */
4420 #endif /* End of commented out context sensitive */
4421 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4423 /* If the eventually required minimum size outgrows
4424 * the available space, we need to grow. */
4425 const UV o = d - (U8*)SvPVX_const(dest);
4427 /* If someone lowercases one million U+0130s we
4428 * SvGROW() one million times. Or we could try
4429 * guessing how much to allocate without allocating too
4430 * much. Such is life. Another option would be to
4431 * grow an extra byte or two more each time we need to
4432 * grow, which would cut down the million to 500K, with
4435 d = (U8*)SvPVX(dest) + o;
4437 #ifdef CONTEXT_DEPENDENT_CASING
4440 /* Copy the newly lowercased letter to the output buffer we're
4442 Copy(tmpbuf, d, ulen, U8);
4445 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4448 } /* End of looping through the source string */
4451 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4452 } else { /* Not utf8 */
4454 const U8 *const send = s + len;
4456 /* Use locale casing if in locale; regular style if not treating
4457 * latin1 as having case; otherwise the latin1 casing. Do the
4458 * whole thing in a tight loop, for speed, */
4459 if (IN_LOCALE_RUNTIME) {
4462 for (; s < send; d++, s++)
4463 *d = toLOWER_LC(*s);
4465 else if (! IN_UNI_8_BIT) {
4466 for (; s < send; d++, s++) {
4471 for (; s < send; d++, s++) {
4472 *d = toLOWER_LATIN1(*s);
4476 if (source != dest) {
4478 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4488 SV * const sv = TOPs;
4490 register const char *s = SvPV_const(sv,len);
4492 SvUTF8_off(TARG); /* decontaminate */
4495 SvUPGRADE(TARG, SVt_PV);
4496 SvGROW(TARG, (len * 2) + 1);
4500 if (UTF8_IS_CONTINUED(*s)) {
4501 STRLEN ulen = UTF8SKIP(s);
4525 SvCUR_set(TARG, d - SvPVX_const(TARG));
4526 (void)SvPOK_only_UTF8(TARG);
4529 sv_setpvn(TARG, s, len);
4538 dVAR; dSP; dMARK; dORIGMARK;
4539 register AV *const av = MUTABLE_AV(POPs);
4540 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4542 if (SvTYPE(av) == SVt_PVAV) {
4543 const I32 arybase = CopARYBASE_get(PL_curcop);
4544 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4545 bool can_preserve = FALSE;
4551 can_preserve = SvCANEXISTDELETE(av);
4554 if (lval && localizing) {
4557 for (svp = MARK + 1; svp <= SP; svp++) {
4558 const I32 elem = SvIV(*svp);
4562 if (max > AvMAX(av))
4566 while (++MARK <= SP) {
4568 I32 elem = SvIV(*MARK);
4569 bool preeminent = TRUE;
4573 if (localizing && can_preserve) {
4574 /* If we can determine whether the element exist,
4575 * Try to preserve the existenceness of a tied array
4576 * element by using EXISTS and DELETE if possible.
4577 * Fallback to FETCH and STORE otherwise. */
4578 preeminent = av_exists(av, elem);
4581 svp = av_fetch(av, elem, lval);
4583 if (!svp || *svp == &PL_sv_undef)
4584 DIE(aTHX_ PL_no_aelem, elem);
4587 save_aelem(av, elem, svp);
4589 SAVEADELETE(av, elem);
4592 *MARK = svp ? *svp : &PL_sv_undef;
4595 if (GIMME != G_ARRAY) {
4597 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4607 AV *array = MUTABLE_AV(POPs);
4608 const I32 gimme = GIMME_V;
4609 IV *iterp = Perl_av_iter_p(aTHX_ array);
4610 const IV current = (*iterp)++;
4612 if (current > av_len(array)) {
4614 if (gimme == G_SCALAR)
4621 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4622 if (gimme == G_ARRAY) {
4623 SV **const element = av_fetch(array, current, 0);
4624 PUSHs(element ? *element : &PL_sv_undef);
4633 AV *array = MUTABLE_AV(POPs);
4634 const I32 gimme = GIMME_V;
4636 *Perl_av_iter_p(aTHX_ array) = 0;
4638 if (gimme == G_SCALAR) {
4640 PUSHi(av_len(array) + 1);
4642 else if (gimme == G_ARRAY) {
4643 IV n = Perl_av_len(aTHX_ array);
4644 IV i = CopARYBASE_get(PL_curcop);
4648 if (PL_op->op_type == OP_AKEYS) {
4650 for (; i <= n; i++) {
4655 for (i = 0; i <= n; i++) {
4656 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4657 PUSHs(elem ? *elem : &PL_sv_undef);
4664 /* Associative arrays. */
4670 HV * hash = MUTABLE_HV(POPs);
4672 const I32 gimme = GIMME_V;
4675 /* might clobber stack_sp */
4676 entry = hv_iternext(hash);
4681 SV* const sv = hv_iterkeysv(entry);
4682 PUSHs(sv); /* won't clobber stack_sp */
4683 if (gimme == G_ARRAY) {
4686 /* might clobber stack_sp */
4687 val = hv_iterval(hash, entry);
4692 else if (gimme == G_SCALAR)
4699 S_do_delete_local(pTHX)
4703 const I32 gimme = GIMME_V;
4707 if (PL_op->op_private & OPpSLICE) {
4709 SV * const osv = POPs;
4710 const bool tied = SvRMAGICAL(osv)
4711 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4712 const bool can_preserve = SvCANEXISTDELETE(osv)
4713 || mg_find((const SV *)osv, PERL_MAGIC_env);
4714 const U32 type = SvTYPE(osv);
4715 if (type == SVt_PVHV) { /* hash element */
4716 HV * const hv = MUTABLE_HV(osv);
4717 while (++MARK <= SP) {
4718 SV * const keysv = *MARK;
4720 bool preeminent = TRUE;
4722 preeminent = hv_exists_ent(hv, keysv, 0);
4724 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4731 sv = hv_delete_ent(hv, keysv, 0, 0);
4732 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4735 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4737 *MARK = sv_mortalcopy(sv);
4743 SAVEHDELETE(hv, keysv);
4744 *MARK = &PL_sv_undef;
4748 else if (type == SVt_PVAV) { /* array element */
4749 if (PL_op->op_flags & OPf_SPECIAL) {
4750 AV * const av = MUTABLE_AV(osv);
4751 while (++MARK <= SP) {
4752 I32 idx = SvIV(*MARK);
4754 bool preeminent = TRUE;
4756 preeminent = av_exists(av, idx);
4758 SV **svp = av_fetch(av, idx, 1);
4765 sv = av_delete(av, idx, 0);
4766 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4769 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4771 *MARK = sv_mortalcopy(sv);
4777 SAVEADELETE(av, idx);
4778 *MARK = &PL_sv_undef;
4784 DIE(aTHX_ "Not a HASH reference");
4785 if (gimme == G_VOID)
4787 else if (gimme == G_SCALAR) {
4792 *++MARK = &PL_sv_undef;
4797 SV * const keysv = POPs;
4798 SV * const osv = POPs;
4799 const bool tied = SvRMAGICAL(osv)
4800 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4801 const bool can_preserve = SvCANEXISTDELETE(osv)
4802 || mg_find((const SV *)osv, PERL_MAGIC_env);
4803 const U32 type = SvTYPE(osv);
4805 if (type == SVt_PVHV) {
4806 HV * const hv = MUTABLE_HV(osv);
4807 bool preeminent = TRUE;
4809 preeminent = hv_exists_ent(hv, keysv, 0);
4811 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4818 sv = hv_delete_ent(hv, keysv, 0, 0);
4819 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4822 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4824 SV *nsv = sv_mortalcopy(sv);
4830 SAVEHDELETE(hv, keysv);
4832 else if (type == SVt_PVAV) {
4833 if (PL_op->op_flags & OPf_SPECIAL) {
4834 AV * const av = MUTABLE_AV(osv);
4835 I32 idx = SvIV(keysv);
4836 bool preeminent = TRUE;
4838 preeminent = av_exists(av, idx);
4840 SV **svp = av_fetch(av, idx, 1);
4847 sv = av_delete(av, idx, 0);
4848 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4851 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4853 SV *nsv = sv_mortalcopy(sv);
4859 SAVEADELETE(av, idx);
4862 DIE(aTHX_ "panic: avhv_delete no longer supported");
4865 DIE(aTHX_ "Not a HASH reference");
4868 if (gimme != G_VOID)
4882 if (PL_op->op_private & OPpLVAL_INTRO)
4883 return do_delete_local();
4886 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4888 if (PL_op->op_private & OPpSLICE) {
4890 HV * const hv = MUTABLE_HV(POPs);
4891 const U32 hvtype = SvTYPE(hv);
4892 if (hvtype == SVt_PVHV) { /* hash element */
4893 while (++MARK <= SP) {
4894 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4895 *MARK = sv ? sv : &PL_sv_undef;
4898 else if (hvtype == SVt_PVAV) { /* array element */
4899 if (PL_op->op_flags & OPf_SPECIAL) {
4900 while (++MARK <= SP) {
4901 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4902 *MARK = sv ? sv : &PL_sv_undef;
4907 DIE(aTHX_ "Not a HASH reference");
4910 else if (gimme == G_SCALAR) {
4915 *++MARK = &PL_sv_undef;
4921 HV * const hv = MUTABLE_HV(POPs);
4923 if (SvTYPE(hv) == SVt_PVHV)
4924 sv = hv_delete_ent(hv, keysv, discard, 0);
4925 else if (SvTYPE(hv) == SVt_PVAV) {
4926 if (PL_op->op_flags & OPf_SPECIAL)
4927 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4929 DIE(aTHX_ "panic: avhv_delete no longer supported");
4932 DIE(aTHX_ "Not a HASH reference");
4948 if (PL_op->op_private & OPpEXISTS_SUB) {
4950 SV * const sv = POPs;
4951 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4954 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4959 hv = MUTABLE_HV(POPs);
4960 if (SvTYPE(hv) == SVt_PVHV) {
4961 if (hv_exists_ent(hv, tmpsv, 0))
4964 else if (SvTYPE(hv) == SVt_PVAV) {
4965 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4966 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4971 DIE(aTHX_ "Not a HASH reference");
4978 dVAR; dSP; dMARK; dORIGMARK;
4979 register HV * const hv = MUTABLE_HV(POPs);
4980 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4981 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4982 bool can_preserve = FALSE;
4988 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4989 can_preserve = TRUE;
4992 while (++MARK <= SP) {
4993 SV * const keysv = *MARK;
4996 bool preeminent = TRUE;
4998 if (localizing && can_preserve) {
4999 /* If we can determine whether the element exist,
5000 * try to preserve the existenceness of a tied hash
5001 * element by using EXISTS and DELETE if possible.
5002 * Fallback to FETCH and STORE otherwise. */
5003 preeminent = hv_exists_ent(hv, keysv, 0);
5006 he = hv_fetch_ent(hv, keysv, lval, 0);
5007 svp = he ? &HeVAL(he) : NULL;
5010 if (!svp || *svp == &PL_sv_undef) {
5011 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5014 if (HvNAME_get(hv) && isGV(*svp))
5015 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5016 else if (preeminent)
5017 save_helem_flags(hv, keysv, svp,
5018 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5020 SAVEHDELETE(hv, keysv);
5023 *MARK = svp ? *svp : &PL_sv_undef;
5025 if (GIMME != G_ARRAY) {
5027 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5033 /* List operators. */
5038 if (GIMME != G_ARRAY) {
5040 *MARK = *SP; /* unwanted list, return last item */
5042 *MARK = &PL_sv_undef;
5052 SV ** const lastrelem = PL_stack_sp;
5053 SV ** const lastlelem = PL_stack_base + POPMARK;
5054 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5055 register SV ** const firstrelem = lastlelem + 1;
5056 const I32 arybase = CopARYBASE_get(PL_curcop);
5057 I32 is_something_there = FALSE;
5059 register const I32 max = lastrelem - lastlelem;
5060 register SV **lelem;
5062 if (GIMME != G_ARRAY) {
5063 I32 ix = SvIV(*lastlelem);
5068 if (ix < 0 || ix >= max)
5069 *firstlelem = &PL_sv_undef;
5071 *firstlelem = firstrelem[ix];
5077 SP = firstlelem - 1;
5081 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5082 I32 ix = SvIV(*lelem);
5087 if (ix < 0 || ix >= max)
5088 *lelem = &PL_sv_undef;
5090 is_something_there = TRUE;
5091 if (!(*lelem = firstrelem[ix]))
5092 *lelem = &PL_sv_undef;
5095 if (is_something_there)
5098 SP = firstlelem - 1;
5104 dVAR; dSP; dMARK; dORIGMARK;
5105 const I32 items = SP - MARK;
5106 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5107 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5108 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5109 ? newRV_noinc(av) : av);
5115 dVAR; dSP; dMARK; dORIGMARK;
5116 HV* const hv = newHV();
5119 SV * const key = *++MARK;
5120 SV * const val = newSV(0);
5122 sv_setsv(val, *++MARK);
5124 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5125 (void)hv_store_ent(hv,key,val,0);
5128 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5129 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5135 dVAR; dSP; dMARK; dORIGMARK;
5136 register AV *ary = MUTABLE_AV(*++MARK);
5140 register I32 offset;
5141 register I32 length;
5145 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5148 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5151 ENTER_with_name("call_SPLICE");
5152 call_method("SPLICE",GIMME_V);
5153 LEAVE_with_name("call_SPLICE");
5161 offset = i = SvIV(*MARK);
5163 offset += AvFILLp(ary) + 1;
5165 offset -= CopARYBASE_get(PL_curcop);
5167 DIE(aTHX_ PL_no_aelem, i);
5169 length = SvIVx(*MARK++);
5171 length += AvFILLp(ary) - offset + 1;
5177 length = AvMAX(ary) + 1; /* close enough to infinity */
5181 length = AvMAX(ary) + 1;
5183 if (offset > AvFILLp(ary) + 1) {
5184 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5185 offset = AvFILLp(ary) + 1;
5187 after = AvFILLp(ary) + 1 - (offset + length);
5188 if (after < 0) { /* not that much array */
5189 length += after; /* offset+length now in array */
5195 /* At this point, MARK .. SP-1 is our new LIST */
5198 diff = newlen - length;
5199 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5202 /* make new elements SVs now: avoid problems if they're from the array */
5203 for (dst = MARK, i = newlen; i; i--) {
5204 SV * const h = *dst;
5205 *dst++ = newSVsv(h);
5208 if (diff < 0) { /* shrinking the area */
5209 SV **tmparyval = NULL;
5211 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5212 Copy(MARK, tmparyval, newlen, SV*);
5215 MARK = ORIGMARK + 1;
5216 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5217 MEXTEND(MARK, length);
5218 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5220 EXTEND_MORTAL(length);
5221 for (i = length, dst = MARK; i; i--) {
5222 sv_2mortal(*dst); /* free them eventualy */
5229 *MARK = AvARRAY(ary)[offset+length-1];
5232 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5233 SvREFCNT_dec(*dst++); /* free them now */
5236 AvFILLp(ary) += diff;
5238 /* pull up or down? */
5240 if (offset < after) { /* easier to pull up */
5241 if (offset) { /* esp. if nothing to pull */
5242 src = &AvARRAY(ary)[offset-1];
5243 dst = src - diff; /* diff is negative */
5244 for (i = offset; i > 0; i--) /* can't trust Copy */
5248 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5252 if (after) { /* anything to pull down? */
5253 src = AvARRAY(ary) + offset + length;
5254 dst = src + diff; /* diff is negative */
5255 Move(src, dst, after, SV*);
5257 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5258 /* avoid later double free */
5262 dst[--i] = &PL_sv_undef;
5265 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5266 Safefree(tmparyval);
5269 else { /* no, expanding (or same) */
5270 SV** tmparyval = NULL;
5272 Newx(tmparyval, length, SV*); /* so remember deletion */
5273 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5276 if (diff > 0) { /* expanding */
5277 /* push up or down? */
5278 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5282 Move(src, dst, offset, SV*);
5284 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5286 AvFILLp(ary) += diff;
5289 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5290 av_extend(ary, AvFILLp(ary) + diff);
5291 AvFILLp(ary) += diff;
5294 dst = AvARRAY(ary) + AvFILLp(ary);
5296 for (i = after; i; i--) {
5304 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5307 MARK = ORIGMARK + 1;
5308 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5310 Copy(tmparyval, MARK, length, SV*);
5312 EXTEND_MORTAL(length);
5313 for (i = length, dst = MARK; i; i--) {
5314 sv_2mortal(*dst); /* free them eventualy */
5321 else if (length--) {
5322 *MARK = tmparyval[length];
5325 while (length-- > 0)
5326 SvREFCNT_dec(tmparyval[length]);
5330 *MARK = &PL_sv_undef;
5331 Safefree(tmparyval);
5339 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5340 register AV * const ary = MUTABLE_AV(*++MARK);
5341 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5344 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5347 ENTER_with_name("call_PUSH");
5348 call_method("PUSH",G_SCALAR|G_DISCARD);
5349 LEAVE_with_name("call_PUSH");
5353 PL_delaymagic = DM_DELAY;
5354 for (++MARK; MARK <= SP; MARK++) {
5355 SV * const sv = newSV(0);
5357 sv_setsv(sv, *MARK);
5358 av_store(ary, AvFILLp(ary)+1, sv);
5360 if (PL_delaymagic & DM_ARRAY_ISA)
5361 mg_set(MUTABLE_SV(ary));
5366 if (OP_GIMME(PL_op, 0) != G_VOID) {
5367 PUSHi( AvFILL(ary) + 1 );
5376 AV * const av = PL_op->op_flags & OPf_SPECIAL
5377 ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5378 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5382 (void)sv_2mortal(sv);
5389 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5390 register AV *ary = MUTABLE_AV(*++MARK);
5391 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5394 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5397 ENTER_with_name("call_UNSHIFT");
5398 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5399 LEAVE_with_name("call_UNSHIFT");
5404 av_unshift(ary, SP - MARK);
5406 SV * const sv = newSVsv(*++MARK);
5407 (void)av_store(ary, i++, sv);
5411 if (OP_GIMME(PL_op, 0) != G_VOID) {
5412 PUSHi( AvFILL(ary) + 1 );
5421 if (GIMME == G_ARRAY) {
5422 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5426 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5427 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5428 av = MUTABLE_AV((*SP));
5429 /* In-place reversing only happens in void context for the array
5430 * assignment. We don't need to push anything on the stack. */
5433 if (SvMAGICAL(av)) {
5435 register SV *tmp = sv_newmortal();
5436 /* For SvCANEXISTDELETE */
5439 bool can_preserve = SvCANEXISTDELETE(av);
5441 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5442 register SV *begin, *end;
5445 if (!av_exists(av, i)) {
5446 if (av_exists(av, j)) {
5447 register SV *sv = av_delete(av, j, 0);
5448 begin = *av_fetch(av, i, TRUE);
5449 sv_setsv_mg(begin, sv);
5453 else if (!av_exists(av, j)) {
5454 register SV *sv = av_delete(av, i, 0);
5455 end = *av_fetch(av, j, TRUE);
5456 sv_setsv_mg(end, sv);
5461 begin = *av_fetch(av, i, TRUE);
5462 end = *av_fetch(av, j, TRUE);
5463 sv_setsv(tmp, begin);
5464 sv_setsv_mg(begin, end);
5465 sv_setsv_mg(end, tmp);
5469 SV **begin = AvARRAY(av);
5472 SV **end = begin + AvFILLp(av);
5474 while (begin < end) {
5475 register SV * const tmp = *begin;
5486 register SV * const tmp = *MARK;
5490 /* safe as long as stack cannot get extended in the above */
5496 register char *down;
5501 SvUTF8_off(TARG); /* decontaminate */
5503 do_join(TARG, &PL_sv_no, MARK, SP);
5505 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5506 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5507 report_uninit(TARG);
5510 up = SvPV_force(TARG, len);
5512 if (DO_UTF8(TARG)) { /* first reverse each character */
5513 U8* s = (U8*)SvPVX(TARG);
5514 const U8* send = (U8*)(s + len);
5516 if (UTF8_IS_INVARIANT(*s)) {
5521 if (!utf8_to_uvchr(s, 0))
5525 down = (char*)(s - 1);
5526 /* reverse this character */
5530 *down-- = (char)tmp;
5536 down = SvPVX(TARG) + len - 1;
5540 *down-- = (char)tmp;
5542 (void)SvPOK_only_UTF8(TARG);
5554 register IV limit = POPi; /* note, negative is forever */
5555 SV * const sv = POPs;
5557 register const char *s = SvPV_const(sv, len);
5558 const bool do_utf8 = DO_UTF8(sv);
5559 const char *strend = s + len;
5561 register REGEXP *rx;
5563 register const char *m;
5565 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5566 I32 maxiters = slen + 10;
5567 I32 trailing_empty = 0;
5569 const I32 origlimit = limit;
5572 const I32 gimme = GIMME_V;
5574 const I32 oldsave = PL_savestack_ix;
5575 U32 make_mortal = SVs_TEMP;
5580 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5585 DIE(aTHX_ "panic: pp_split");
5588 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5589 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5591 RX_MATCH_UTF8_set(rx, do_utf8);
5594 if (pm->op_pmreplrootu.op_pmtargetoff) {
5595 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5598 if (pm->op_pmreplrootu.op_pmtargetgv) {
5599 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5604 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5610 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5612 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5619 for (i = AvFILLp(ary); i >= 0; i--)
5620 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5622 /* temporarily switch stacks */
5623 SAVESWITCHSTACK(PL_curstack, ary);
5627 base = SP - PL_stack_base;
5629 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5631 while (*s == ' ' || is_utf8_space((U8*)s))
5634 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5635 while (isSPACE_LC(*s))
5643 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5647 gimme_scalar = gimme == G_SCALAR && !ary;
5650 limit = maxiters + 2;
5651 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5654 /* this one uses 'm' and is a negative test */
5656 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5657 const int t = UTF8SKIP(m);
5658 /* is_utf8_space returns FALSE for malform utf8 */
5664 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5665 while (m < strend && !isSPACE_LC(*m))
5668 while (m < strend && !isSPACE(*m))
5681 dstr = newSVpvn_flags(s, m-s,
5682 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5686 /* skip the whitespace found last */
5688 s = m + UTF8SKIP(m);
5692 /* this one uses 's' and is a positive test */
5694 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5696 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5697 while (s < strend && isSPACE_LC(*s))
5700 while (s < strend && isSPACE(*s))
5705 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5707 for (m = s; m < strend && *m != '\n'; m++)
5720 dstr = newSVpvn_flags(s, m-s,
5721 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5727 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5729 Pre-extend the stack, either the number of bytes or
5730 characters in the string or a limited amount, triggered by:
5732 my ($x, $y) = split //, $str;
5736 if (!gimme_scalar) {
5737 const U32 items = limit - 1;
5746 /* keep track of how many bytes we skip over */
5756 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5769 dstr = newSVpvn(s, 1);
5785 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5786 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5787 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5788 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5789 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5790 SV * const csv = CALLREG_INTUIT_STRING(rx);
5792 len = RX_MINLENRET(rx);
5793 if (len == 1 && !RX_UTF8(rx) && !tail) {
5794 const char c = *SvPV_nolen_const(csv);
5796 for (m = s; m < strend && *m != c; m++)
5807 dstr = newSVpvn_flags(s, m-s,
5808 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5811 /* The rx->minlen is in characters but we want to step
5812 * s ahead by bytes. */
5814 s = (char*)utf8_hop((U8*)m, len);
5816 s = m + len; /* Fake \n at the end */
5820 while (s < strend && --limit &&
5821 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5822 csv, multiline ? FBMrf_MULTILINE : 0)) )
5831 dstr = newSVpvn_flags(s, m-s,
5832 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5835 /* The rx->minlen is in characters but we want to step
5836 * s ahead by bytes. */
5838 s = (char*)utf8_hop((U8*)m, len);
5840 s = m + len; /* Fake \n at the end */
5845 maxiters += slen * RX_NPARENS(rx);
5846 while (s < strend && --limit)
5850 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5853 if (rex_return == 0)
5855 TAINT_IF(RX_MATCH_TAINTED(rx));
5856 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5859 orig = RX_SUBBEG(rx);
5861 strend = s + (strend - m);
5863 m = RX_OFFS(rx)[0].start + orig;
5872 dstr = newSVpvn_flags(s, m-s,
5873 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5876 if (RX_NPARENS(rx)) {
5878 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5879 s = RX_OFFS(rx)[i].start + orig;
5880 m = RX_OFFS(rx)[i].end + orig;
5882 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5883 parens that didn't match -- they should be set to
5884 undef, not the empty string */
5892 if (m >= orig && s >= orig) {
5893 dstr = newSVpvn_flags(s, m-s,
5894 (do_utf8 ? SVf_UTF8 : 0)
5898 dstr = &PL_sv_undef; /* undef, not "" */
5904 s = RX_OFFS(rx)[0].end + orig;
5908 if (!gimme_scalar) {
5909 iters = (SP - PL_stack_base) - base;
5911 if (iters > maxiters)
5912 DIE(aTHX_ "Split loop");
5914 /* keep field after final delim? */
5915 if (s < strend || (iters && origlimit)) {
5916 if (!gimme_scalar) {
5917 const STRLEN l = strend - s;
5918 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5923 else if (!origlimit) {
5925 iters -= trailing_empty;
5927 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5928 if (TOPs && !make_mortal)
5930 *SP-- = &PL_sv_undef;
5937 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5941 if (SvSMAGICAL(ary)) {
5943 mg_set(MUTABLE_SV(ary));
5946 if (gimme == G_ARRAY) {
5948 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5955 ENTER_with_name("call_PUSH");
5956 call_method("PUSH",G_SCALAR|G_DISCARD);
5957 LEAVE_with_name("call_PUSH");
5959 if (gimme == G_ARRAY) {
5961 /* EXTEND should not be needed - we just popped them */
5963 for (i=0; i < iters; i++) {
5964 SV **svp = av_fetch(ary, i, FALSE);
5965 PUSHs((svp) ? *svp : &PL_sv_undef);
5972 if (gimme == G_ARRAY)
5984 SV *const sv = PAD_SVl(PL_op->op_targ);
5986 if (SvPADSTALE(sv)) {
5989 RETURNOP(cLOGOP->op_other);
5991 RETURNOP(cLOGOP->op_next);
6000 assert(SvTYPE(retsv) != SVt_PVCV);
6002 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6003 retsv = refto(retsv);
6010 PP(unimplemented_op)
6013 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6022 HV * const hv = (HV*)POPs;
6024 if (SvRMAGICAL(hv)) {
6025 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6027 XPUSHs(magic_scalarpack(hv, mg));
6032 XPUSHs(boolSV(HvKEYS(hv) != 0));
6038 * c-indentation-style: bsd
6040 * indent-tabs-mode: t
6043 * ex: set ts=8 sts=4 sw=4 noet: