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 if (PL_op->op_private & OPpLVAL_INTRO)
67 if (!(PL_op->op_private & OPpPAD_STATE))
68 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
70 if (PL_op->op_flags & OPf_REF) {
74 if (GIMME == G_SCALAR)
75 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
80 if (gimme == G_ARRAY) {
81 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
83 if (SvMAGICAL(TARG)) {
85 for (i=0; i < (U32)maxarg; i++) {
86 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
87 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
91 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
95 else if (gimme == G_SCALAR) {
96 SV* const sv = sv_newmortal();
97 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
110 if (PL_op->op_private & OPpLVAL_INTRO)
111 if (!(PL_op->op_private & OPpPAD_STATE))
112 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
113 if (PL_op->op_flags & OPf_REF)
116 if (GIMME == G_SCALAR)
117 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
121 if (gimme == G_ARRAY) {
124 else if (gimme == G_SCALAR) {
125 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
139 tryAMAGICunDEREF(to_gv);
142 if (SvTYPE(sv) == SVt_PVIO) {
143 GV * const gv = MUTABLE_GV(sv_newmortal());
144 gv_init(gv, 0, "", 0, 0);
145 GvIOp(gv) = MUTABLE_IO(sv);
146 SvREFCNT_inc_void_NN(sv);
149 else if (!isGV_with_GP(sv))
150 DIE(aTHX_ "Not a GLOB reference");
153 if (!isGV_with_GP(sv)) {
154 if (SvGMAGICAL(sv)) {
159 if (!SvOK(sv) && sv != &PL_sv_undef) {
160 /* If this is a 'my' scalar and flag is set then vivify
164 Perl_croak(aTHX_ "%s", PL_no_modify);
165 if (PL_op->op_private & OPpDEREF) {
167 if (cUNOP->op_targ) {
169 SV * const namesv = PAD_SV(cUNOP->op_targ);
170 const char * const name = SvPV(namesv, len);
171 gv = MUTABLE_GV(newSV(0));
172 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
175 const char * const name = CopSTASHPV(PL_curcop);
178 prepare_SV_for_RV(sv);
179 SvRV_set(sv, MUTABLE_SV(gv));
184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
186 DIE(aTHX_ PL_no_usym, "a symbol");
187 if (ckWARN(WARN_UNINITIALIZED))
191 if ((PL_op->op_flags & OPf_SPECIAL) &&
192 !(PL_op->op_flags & OPf_MOD))
194 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
196 && (!is_gv_magical_sv(sv,0)
197 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
204 if (PL_op->op_private & HINT_STRICT_REFS)
205 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
206 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
207 == OPpDONT_INIT_GV) {
208 /* We are the target of a coderef assignment. Return
209 the scalar unchanged, and let pp_sasssign deal with
213 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
217 if (PL_op->op_private & OPpLVAL_INTRO)
218 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
223 /* Helper function for pp_rv2sv and pp_rv2av */
225 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
226 const svtype type, SV ***spp)
231 PERL_ARGS_ASSERT_SOFTREF2XV;
233 if (PL_op->op_private & HINT_STRICT_REFS) {
235 Perl_die(aTHX_ PL_no_symref_sv, sv, what);
237 Perl_die(aTHX_ PL_no_usym, what);
240 if (PL_op->op_flags & OPf_REF)
241 Perl_die(aTHX_ PL_no_usym, what);
242 if (ckWARN(WARN_UNINITIALIZED))
244 if (type != SVt_PV && GIMME_V == G_ARRAY) {
248 **spp = &PL_sv_undef;
251 if ((PL_op->op_flags & OPf_SPECIAL) &&
252 !(PL_op->op_flags & OPf_MOD))
254 gv = gv_fetchsv(sv, 0, type);
256 && (!is_gv_magical_sv(sv,0)
257 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
259 **spp = &PL_sv_undef;
264 gv = gv_fetchsv(sv, GV_ADD, type);
276 tryAMAGICunDEREF(to_sv);
279 switch (SvTYPE(sv)) {
285 DIE(aTHX_ "Not a SCALAR reference");
292 if (!isGV_with_GP(gv)) {
293 if (SvGMAGICAL(sv)) {
298 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
304 if (PL_op->op_flags & OPf_MOD) {
305 if (PL_op->op_private & OPpLVAL_INTRO) {
306 if (cUNOP->op_first->op_type == OP_NULL)
307 sv = save_scalar(MUTABLE_GV(TOPs));
309 sv = save_scalar(gv);
311 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
313 else if (PL_op->op_private & OPpDEREF)
314 vivify_ref(sv, PL_op->op_private & OPpDEREF);
323 AV * const av = MUTABLE_AV(TOPs);
324 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
326 *sv = newSV_type(SVt_PVMG);
327 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
335 dVAR; dSP; dTARGET; dPOPss;
337 if (PL_op->op_flags & OPf_MOD || LVRET) {
338 if (SvTYPE(TARG) < SVt_PVLV) {
339 sv_upgrade(TARG, SVt_PVLV);
340 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
344 if (LvTARG(TARG) != sv) {
346 SvREFCNT_dec(LvTARG(TARG));
347 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
349 PUSHs(TARG); /* no SvSETMAGIC */
353 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
354 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
355 if (mg && mg->mg_len >= 0) {
359 PUSHi(i + CopARYBASE_get(PL_curcop));
372 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
374 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
377 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
378 /* (But not in defined().) */
380 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
383 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
384 if ((PL_op->op_private & OPpLVAL_INTRO)) {
385 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
388 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
391 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
395 cv = MUTABLE_CV(&PL_sv_undef);
396 SETs(MUTABLE_SV(cv));
406 SV *ret = &PL_sv_undef;
408 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
409 const char * s = SvPVX_const(TOPs);
410 if (strnEQ(s, "CORE::", 6)) {
411 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
412 if (code < 0) { /* Overridable. */
413 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
414 int i = 0, n = 0, seen_question = 0, defgv = 0;
416 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
418 if (code == -KEY_chop || code == -KEY_chomp
419 || code == -KEY_exec || code == -KEY_system)
421 if (code == -KEY_mkdir) {
422 ret = newSVpvs_flags("_;$", SVs_TEMP);
425 if (code == -KEY_readpipe) {
426 s = "CORE::backtick";
428 while (i < MAXO) { /* The slow way. */
429 if (strEQ(s + 6, PL_op_name[i])
430 || strEQ(s + 6, PL_op_desc[i]))
436 goto nonesuch; /* Should not happen... */
438 defgv = PL_opargs[i] & OA_DEFGV;
439 oa = PL_opargs[i] >> OASHIFT;
441 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
445 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
446 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
447 /* But globs are already references (kinda) */
448 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
452 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
455 if (defgv && str[n - 1] == '$')
458 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
460 else if (code) /* Non-Overridable */
462 else { /* None such */
464 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
468 cv = sv_2cv(TOPs, &stash, &gv, 0);
470 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
479 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
481 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
483 PUSHs(MUTABLE_SV(cv));
497 if (GIMME != G_ARRAY) {
501 *MARK = &PL_sv_undef;
502 *MARK = refto(*MARK);
506 EXTEND_MORTAL(SP - MARK);
508 *MARK = refto(*MARK);
513 S_refto(pTHX_ SV *sv)
518 PERL_ARGS_ASSERT_REFTO;
520 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
523 if (!(sv = LvTARG(sv)))
526 SvREFCNT_inc_void_NN(sv);
528 else if (SvTYPE(sv) == SVt_PVAV) {
529 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
530 av_reify(MUTABLE_AV(sv));
532 SvREFCNT_inc_void_NN(sv);
534 else if (SvPADTMP(sv) && !IS_PADGV(sv))
538 SvREFCNT_inc_void_NN(sv);
541 sv_upgrade(rv, SVt_IV);
551 SV * const sv = POPs;
556 if (!sv || !SvROK(sv))
559 pv = sv_reftype(SvRV(sv),TRUE);
560 PUSHp(pv, strlen(pv));
570 stash = CopSTASH(PL_curcop);
572 SV * const ssv = POPs;
576 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
577 Perl_croak(aTHX_ "Attempt to bless into a reference");
578 ptr = SvPV_const(ssv,len);
580 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
581 "Explicit blessing to '' (assuming package main)");
582 stash = gv_stashpvn(ptr, len, GV_ADD);
585 (void)sv_bless(TOPs, stash);
594 const char * const elem = SvPV_nolen_const(sv);
595 GV * const gv = MUTABLE_GV(POPs);
600 /* elem will always be NUL terminated. */
601 const char * const second_letter = elem + 1;
604 if (strEQ(second_letter, "RRAY"))
605 tmpRef = MUTABLE_SV(GvAV(gv));
608 if (strEQ(second_letter, "ODE"))
609 tmpRef = MUTABLE_SV(GvCVu(gv));
612 if (strEQ(second_letter, "ILEHANDLE")) {
613 /* finally deprecated in 5.8.0 */
614 deprecate("*glob{FILEHANDLE}");
615 tmpRef = MUTABLE_SV(GvIOp(gv));
618 if (strEQ(second_letter, "ORMAT"))
619 tmpRef = MUTABLE_SV(GvFORM(gv));
622 if (strEQ(second_letter, "LOB"))
623 tmpRef = MUTABLE_SV(gv);
626 if (strEQ(second_letter, "ASH"))
627 tmpRef = MUTABLE_SV(GvHV(gv));
630 if (*second_letter == 'O' && !elem[2])
631 tmpRef = MUTABLE_SV(GvIOp(gv));
634 if (strEQ(second_letter, "AME"))
635 sv = newSVhek(GvNAME_HEK(gv));
638 if (strEQ(second_letter, "ACKAGE")) {
639 const HV * const stash = GvSTASH(gv);
640 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
641 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
645 if (strEQ(second_letter, "CALAR"))
660 /* Pattern matching */
665 register unsigned char *s;
668 register I32 *sfirst;
672 if (sv == PL_lastscream) {
676 s = (unsigned char*)(SvPV(sv, len));
678 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
679 /* No point in studying a zero length string, and not safe to study
680 anything that doesn't appear to be a simple scalar (and hence might
681 change between now and when the regexp engine runs without our set
682 magic ever running) such as a reference to an object with overloaded
688 SvSCREAM_off(PL_lastscream);
689 SvREFCNT_dec(PL_lastscream);
691 PL_lastscream = SvREFCNT_inc_simple(sv);
693 s = (unsigned char*)(SvPV(sv, len));
697 if (pos > PL_maxscream) {
698 if (PL_maxscream < 0) {
699 PL_maxscream = pos + 80;
700 Newx(PL_screamfirst, 256, I32);
701 Newx(PL_screamnext, PL_maxscream, I32);
704 PL_maxscream = pos + pos / 4;
705 Renew(PL_screamnext, PL_maxscream, I32);
709 sfirst = PL_screamfirst;
710 snext = PL_screamnext;
712 if (!sfirst || !snext)
713 DIE(aTHX_ "do_study: out of memory");
715 for (ch = 256; ch; --ch)
720 register const I32 ch = s[pos];
722 snext[pos] = sfirst[ch] - pos;
729 /* piggyback on m//g magic */
730 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
739 if (PL_op->op_flags & OPf_STACKED)
741 else if (PL_op->op_private & OPpTARGET_MY)
747 TARG = sv_newmortal();
752 /* Lvalue operators. */
764 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
766 do_chop(TARG, *++MARK);
775 SETi(do_chomp(TOPs));
781 dVAR; dSP; dMARK; dTARGET;
782 register I32 count = 0;
785 count += do_chomp(POPs);
795 if (!PL_op->op_private) {
804 SV_CHECK_THINKFIRST_COW_DROP(sv);
806 switch (SvTYPE(sv)) {
810 av_undef(MUTABLE_AV(sv));
813 hv_undef(MUTABLE_HV(sv));
816 if (cv_const_sv((const CV *)sv))
817 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
818 CvANON((const CV *)sv) ? "(anonymous)"
819 : GvENAME(CvGV((const CV *)sv)));
823 /* let user-undef'd sub keep its identity */
824 GV* const gv = CvGV((const CV *)sv);
825 cv_undef(MUTABLE_CV(sv));
826 CvGV((const CV *)sv) = gv;
831 SvSetMagicSV(sv, &PL_sv_undef);
834 else if (isGV_with_GP(sv)) {
839 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
840 mro_isa_changed_in(stash);
841 /* undef *Pkg::meth_name ... */
842 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
843 && HvNAME_get(stash))
844 mro_method_changed_in(stash);
846 gp_free(MUTABLE_GV(sv));
848 GvGP(sv) = gp_ref(gp);
850 GvLINE(sv) = CopLINE(PL_curcop);
851 GvEGV(sv) = MUTABLE_GV(sv);
857 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
872 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
873 DIE(aTHX_ "%s", PL_no_modify);
874 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
875 && SvIVX(TOPs) != IV_MIN)
877 SvIV_set(TOPs, SvIVX(TOPs) - 1);
878 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
889 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
890 DIE(aTHX_ "%s", PL_no_modify);
891 sv_setsv(TARG, TOPs);
892 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
893 && SvIVX(TOPs) != IV_MAX)
895 SvIV_set(TOPs, SvIVX(TOPs) + 1);
896 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
901 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
911 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
912 DIE(aTHX_ "%s", PL_no_modify);
913 sv_setsv(TARG, TOPs);
914 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
915 && SvIVX(TOPs) != IV_MIN)
917 SvIV_set(TOPs, SvIVX(TOPs) - 1);
918 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
927 /* Ordinary operators. */
931 dVAR; dSP; dATARGET; SV *svl, *svr;
932 #ifdef PERL_PRESERVE_IVUV
935 tryAMAGICbin(pow,opASSIGN);
936 svl = sv_2num(TOPm1s);
938 #ifdef PERL_PRESERVE_IVUV
939 /* For integer to integer power, we do the calculation by hand wherever
940 we're sure it is safe; otherwise we call pow() and try to convert to
941 integer afterwards. */
954 const IV iv = SvIVX(svr);
958 goto float_it; /* Can't do negative powers this way. */
962 baseuok = SvUOK(svl);
966 const IV iv = SvIVX(svl);
969 baseuok = TRUE; /* effectively it's a UV now */
971 baseuv = -iv; /* abs, baseuok == false records sign */
974 /* now we have integer ** positive integer. */
977 /* foo & (foo - 1) is zero only for a power of 2. */
978 if (!(baseuv & (baseuv - 1))) {
979 /* We are raising power-of-2 to a positive integer.
980 The logic here will work for any base (even non-integer
981 bases) but it can be less accurate than
982 pow (base,power) or exp (power * log (base)) when the
983 intermediate values start to spill out of the mantissa.
984 With powers of 2 we know this can't happen.
985 And powers of 2 are the favourite thing for perl
986 programmers to notice ** not doing what they mean. */
988 NV base = baseuok ? baseuv : -(NV)baseuv;
993 while (power >>= 1) {
1004 register unsigned int highbit = 8 * sizeof(UV);
1005 register unsigned int diff = 8 * sizeof(UV);
1006 while (diff >>= 1) {
1008 if (baseuv >> highbit) {
1012 /* we now have baseuv < 2 ** highbit */
1013 if (power * highbit <= 8 * sizeof(UV)) {
1014 /* result will definitely fit in UV, so use UV math
1015 on same algorithm as above */
1016 register UV result = 1;
1017 register UV base = baseuv;
1018 const bool odd_power = (bool)(power & 1);
1022 while (power >>= 1) {
1029 if (baseuok || !odd_power)
1030 /* answer is positive */
1032 else if (result <= (UV)IV_MAX)
1033 /* answer negative, fits in IV */
1034 SETi( -(IV)result );
1035 else if (result == (UV)IV_MIN)
1036 /* 2's complement assumption: special case IV_MIN */
1039 /* answer negative, doesn't fit */
1040 SETn( -(NV)result );
1050 NV right = SvNV(svr);
1051 NV left = SvNV(svl);
1054 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1056 We are building perl with long double support and are on an AIX OS
1057 afflicted with a powl() function that wrongly returns NaNQ for any
1058 negative base. This was reported to IBM as PMR #23047-379 on
1059 03/06/2006. The problem exists in at least the following versions
1060 of AIX and the libm fileset, and no doubt others as well:
1062 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1063 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1064 AIX 5.2.0 bos.adt.libm 5.2.0.85
1066 So, until IBM fixes powl(), we provide the following workaround to
1067 handle the problem ourselves. Our logic is as follows: for
1068 negative bases (left), we use fmod(right, 2) to check if the
1069 exponent is an odd or even integer:
1071 - if odd, powl(left, right) == -powl(-left, right)
1072 - if even, powl(left, right) == powl(-left, right)
1074 If the exponent is not an integer, the result is rightly NaNQ, so
1075 we just return that (as NV_NAN).
1079 NV mod2 = Perl_fmod( right, 2.0 );
1080 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1081 SETn( -Perl_pow( -left, right) );
1082 } else if (mod2 == 0.0) { /* even integer */
1083 SETn( Perl_pow( -left, right) );
1084 } else { /* fractional power */
1088 SETn( Perl_pow( left, right) );
1091 SETn( Perl_pow( left, right) );
1092 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1094 #ifdef PERL_PRESERVE_IVUV
1104 dVAR; dSP; dATARGET; SV *svl, *svr;
1105 tryAMAGICbin(mult,opASSIGN);
1106 svl = sv_2num(TOPm1s);
1107 svr = sv_2num(TOPs);
1108 #ifdef PERL_PRESERVE_IVUV
1111 /* Unless the left argument is integer in range we are going to have to
1112 use NV maths. Hence only attempt to coerce the right argument if
1113 we know the left is integer. */
1114 /* Left operand is defined, so is it IV? */
1117 bool auvok = SvUOK(svl);
1118 bool buvok = SvUOK(svr);
1119 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1120 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1129 const IV aiv = SvIVX(svl);
1132 auvok = TRUE; /* effectively it's a UV now */
1134 alow = -aiv; /* abs, auvok == false records sign */
1140 const IV biv = SvIVX(svr);
1143 buvok = TRUE; /* effectively it's a UV now */
1145 blow = -biv; /* abs, buvok == false records sign */
1149 /* If this does sign extension on unsigned it's time for plan B */
1150 ahigh = alow >> (4 * sizeof (UV));
1152 bhigh = blow >> (4 * sizeof (UV));
1154 if (ahigh && bhigh) {
1156 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1157 which is overflow. Drop to NVs below. */
1158 } else if (!ahigh && !bhigh) {
1159 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1160 so the unsigned multiply cannot overflow. */
1161 const UV product = alow * blow;
1162 if (auvok == buvok) {
1163 /* -ve * -ve or +ve * +ve gives a +ve result. */
1167 } else if (product <= (UV)IV_MIN) {
1168 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1169 /* -ve result, which could overflow an IV */
1171 SETi( -(IV)product );
1173 } /* else drop to NVs below. */
1175 /* One operand is large, 1 small */
1178 /* swap the operands */
1180 bhigh = blow; /* bhigh now the temp var for the swap */
1184 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1185 multiplies can't overflow. shift can, add can, -ve can. */
1186 product_middle = ahigh * blow;
1187 if (!(product_middle & topmask)) {
1188 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1190 product_middle <<= (4 * sizeof (UV));
1191 product_low = alow * blow;
1193 /* as for pp_add, UV + something mustn't get smaller.
1194 IIRC ANSI mandates this wrapping *behaviour* for
1195 unsigned whatever the actual representation*/
1196 product_low += product_middle;
1197 if (product_low >= product_middle) {
1198 /* didn't overflow */
1199 if (auvok == buvok) {
1200 /* -ve * -ve or +ve * +ve gives a +ve result. */
1202 SETu( product_low );
1204 } else if (product_low <= (UV)IV_MIN) {
1205 /* 2s complement assumption again */
1206 /* -ve result, which could overflow an IV */
1208 SETi( -(IV)product_low );
1210 } /* else drop to NVs below. */
1212 } /* product_middle too large */
1213 } /* ahigh && bhigh */
1218 NV right = SvNV(svr);
1219 NV left = SvNV(svl);
1221 SETn( left * right );
1228 dVAR; dSP; dATARGET; SV *svl, *svr;
1229 tryAMAGICbin(div,opASSIGN);
1230 svl = sv_2num(TOPm1s);
1231 svr = sv_2num(TOPs);
1232 /* Only try to do UV divide first
1233 if ((SLOPPYDIVIDE is true) or
1234 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1236 The assumption is that it is better to use floating point divide
1237 whenever possible, only doing integer divide first if we can't be sure.
1238 If NV_PRESERVES_UV is true then we know at compile time that no UV
1239 can be too large to preserve, so don't need to compile the code to
1240 test the size of UVs. */
1243 # define PERL_TRY_UV_DIVIDE
1244 /* ensure that 20./5. == 4. */
1246 # ifdef PERL_PRESERVE_IVUV
1247 # ifndef NV_PRESERVES_UV
1248 # define PERL_TRY_UV_DIVIDE
1253 #ifdef PERL_TRY_UV_DIVIDE
1258 bool left_non_neg = SvUOK(svl);
1259 bool right_non_neg = SvUOK(svr);
1263 if (right_non_neg) {
1267 const IV biv = SvIVX(svr);
1270 right_non_neg = TRUE; /* effectively it's a UV now */
1276 /* historically undef()/0 gives a "Use of uninitialized value"
1277 warning before dieing, hence this test goes here.
1278 If it were immediately before the second SvIV_please, then
1279 DIE() would be invoked before left was even inspected, so
1280 no inpsection would give no warning. */
1282 DIE(aTHX_ "Illegal division by zero");
1288 const IV aiv = SvIVX(svl);
1291 left_non_neg = TRUE; /* effectively it's a UV now */
1300 /* For sloppy divide we always attempt integer division. */
1302 /* Otherwise we only attempt it if either or both operands
1303 would not be preserved by an NV. If both fit in NVs
1304 we fall through to the NV divide code below. However,
1305 as left >= right to ensure integer result here, we know that
1306 we can skip the test on the right operand - right big
1307 enough not to be preserved can't get here unless left is
1310 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1313 /* Integer division can't overflow, but it can be imprecise. */
1314 const UV result = left / right;
1315 if (result * right == left) {
1316 SP--; /* result is valid */
1317 if (left_non_neg == right_non_neg) {
1318 /* signs identical, result is positive. */
1322 /* 2s complement assumption */
1323 if (result <= (UV)IV_MIN)
1324 SETi( -(IV)result );
1326 /* It's exact but too negative for IV. */
1327 SETn( -(NV)result );
1330 } /* tried integer divide but it was not an integer result */
1331 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1332 } /* left wasn't SvIOK */
1333 } /* right wasn't SvIOK */
1334 #endif /* PERL_TRY_UV_DIVIDE */
1336 NV right = SvNV(svr);
1337 NV left = SvNV(svl);
1338 (void)POPs;(void)POPs;
1339 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1340 if (! Perl_isnan(right) && right == 0.0)
1344 DIE(aTHX_ "Illegal division by zero");
1345 PUSHn( left / right );
1352 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1356 bool left_neg = FALSE;
1357 bool right_neg = FALSE;
1358 bool use_double = FALSE;
1359 bool dright_valid = FALSE;
1363 SV * const svr = sv_2num(TOPs);
1366 right_neg = !SvUOK(svr);
1370 const IV biv = SvIVX(svr);
1373 right_neg = FALSE; /* effectively it's a UV now */
1381 right_neg = dright < 0;
1384 if (dright < UV_MAX_P1) {
1385 right = U_V(dright);
1386 dright_valid = TRUE; /* In case we need to use double below. */
1393 /* At this point use_double is only true if right is out of range for
1394 a UV. In range NV has been rounded down to nearest UV and
1395 use_double false. */
1396 svl = sv_2num(TOPs);
1398 if (!use_double && SvIOK(svl)) {
1400 left_neg = !SvUOK(svl);
1404 const IV aiv = SvIVX(svl);
1407 left_neg = FALSE; /* effectively it's a UV now */
1416 left_neg = dleft < 0;
1420 /* This should be exactly the 5.6 behaviour - if left and right are
1421 both in range for UV then use U_V() rather than floor. */
1423 if (dleft < UV_MAX_P1) {
1424 /* right was in range, so is dleft, so use UVs not double.
1428 /* left is out of range for UV, right was in range, so promote
1429 right (back) to double. */
1431 /* The +0.5 is used in 5.6 even though it is not strictly
1432 consistent with the implicit +0 floor in the U_V()
1433 inside the #if 1. */
1434 dleft = Perl_floor(dleft + 0.5);
1437 dright = Perl_floor(dright + 0.5);
1448 DIE(aTHX_ "Illegal modulus zero");
1450 dans = Perl_fmod(dleft, dright);
1451 if ((left_neg != right_neg) && dans)
1452 dans = dright - dans;
1455 sv_setnv(TARG, dans);
1461 DIE(aTHX_ "Illegal modulus zero");
1464 if ((left_neg != right_neg) && ans)
1467 /* XXX may warn: unary minus operator applied to unsigned type */
1468 /* could change -foo to be (~foo)+1 instead */
1469 if (ans <= ~((UV)IV_MAX)+1)
1470 sv_setiv(TARG, ~ans+1);
1472 sv_setnv(TARG, -(NV)ans);
1475 sv_setuv(TARG, ans);
1484 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1491 const UV uv = SvUV(sv);
1493 count = IV_MAX; /* The best we can do? */
1497 const IV iv = SvIV(sv);
1504 else if (SvNOKp(sv)) {
1505 const NV nv = SvNV(sv);
1513 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1515 static const char oom_list_extend[] = "Out of memory during list extend";
1516 const I32 items = SP - MARK;
1517 const I32 max = items * count;
1519 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1520 /* Did the max computation overflow? */
1521 if (items > 0 && max > 0 && (max < items || max < count))
1522 Perl_croak(aTHX_ oom_list_extend);
1527 /* This code was intended to fix 20010809.028:
1530 for (($x =~ /./g) x 2) {
1531 print chop; # "abcdabcd" expected as output.
1534 * but that change (#11635) broke this code:
1536 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1538 * I can't think of a better fix that doesn't introduce
1539 * an efficiency hit by copying the SVs. The stack isn't
1540 * refcounted, and mortalisation obviously doesn't
1541 * Do The Right Thing when the stack has more than
1542 * one pointer to the same mortal value.
1546 *SP = sv_2mortal(newSVsv(*SP));
1556 repeatcpy((char*)(MARK + items), (char*)MARK,
1557 items * sizeof(const SV *), count - 1);
1560 else if (count <= 0)
1563 else { /* Note: mark already snarfed by pp_list */
1564 SV * const tmpstr = POPs;
1567 static const char oom_string_extend[] =
1568 "Out of memory during string extend";
1570 SvSetSV(TARG, tmpstr);
1571 SvPV_force(TARG, len);
1572 isutf = DO_UTF8(TARG);
1577 const STRLEN max = (UV)count * len;
1578 if (len > MEM_SIZE_MAX / count)
1579 Perl_croak(aTHX_ oom_string_extend);
1580 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1581 SvGROW(TARG, max + 1);
1582 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1583 SvCUR_set(TARG, SvCUR(TARG) * count);
1585 *SvEND(TARG) = '\0';
1588 (void)SvPOK_only_UTF8(TARG);
1590 (void)SvPOK_only(TARG);
1592 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1593 /* The parser saw this as a list repeat, and there
1594 are probably several items on the stack. But we're
1595 in scalar context, and there's no pp_list to save us
1596 now. So drop the rest of the items -- robin@kitsite.com
1609 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1610 tryAMAGICbin(subtr,opASSIGN);
1611 svl = sv_2num(TOPm1s);
1612 svr = sv_2num(TOPs);
1613 useleft = USE_LEFT(svl);
1614 #ifdef PERL_PRESERVE_IVUV
1615 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1616 "bad things" happen if you rely on signed integers wrapping. */
1619 /* Unless the left argument is integer in range we are going to have to
1620 use NV maths. Hence only attempt to coerce the right argument if
1621 we know the left is integer. */
1622 register UV auv = 0;
1628 a_valid = auvok = 1;
1629 /* left operand is undef, treat as zero. */
1631 /* Left operand is defined, so is it IV? */
1634 if ((auvok = SvUOK(svl)))
1637 register const IV aiv = SvIVX(svl);
1640 auvok = 1; /* Now acting as a sign flag. */
1641 } else { /* 2s complement assumption for IV_MIN */
1649 bool result_good = 0;
1652 bool buvok = SvUOK(svr);
1657 register const IV biv = SvIVX(svr);
1664 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1665 else "IV" now, independent of how it came in.
1666 if a, b represents positive, A, B negative, a maps to -A etc
1671 all UV maths. negate result if A negative.
1672 subtract if signs same, add if signs differ. */
1674 if (auvok ^ buvok) {
1683 /* Must get smaller */
1688 if (result <= buv) {
1689 /* result really should be -(auv-buv). as its negation
1690 of true value, need to swap our result flag */
1702 if (result <= (UV)IV_MIN)
1703 SETi( -(IV)result );
1705 /* result valid, but out of range for IV. */
1706 SETn( -(NV)result );
1710 } /* Overflow, drop through to NVs. */
1715 NV value = SvNV(svr);
1719 /* left operand is undef, treat as zero - value */
1723 SETn( SvNV(svl) - value );
1730 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1732 const IV shift = POPi;
1733 if (PL_op->op_private & HINT_INTEGER) {
1747 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1749 const IV shift = POPi;
1750 if (PL_op->op_private & HINT_INTEGER) {
1764 dVAR; dSP; tryAMAGICbinSET(lt,0);
1765 #ifdef PERL_PRESERVE_IVUV
1768 SvIV_please(TOPm1s);
1769 if (SvIOK(TOPm1s)) {
1770 bool auvok = SvUOK(TOPm1s);
1771 bool buvok = SvUOK(TOPs);
1773 if (!auvok && !buvok) { /* ## IV < IV ## */
1774 const IV aiv = SvIVX(TOPm1s);
1775 const IV biv = SvIVX(TOPs);
1778 SETs(boolSV(aiv < biv));
1781 if (auvok && buvok) { /* ## UV < UV ## */
1782 const UV auv = SvUVX(TOPm1s);
1783 const UV buv = SvUVX(TOPs);
1786 SETs(boolSV(auv < buv));
1789 if (auvok) { /* ## UV < IV ## */
1791 const IV biv = SvIVX(TOPs);
1794 /* As (a) is a UV, it's >=0, so it cannot be < */
1799 SETs(boolSV(auv < (UV)biv));
1802 { /* ## IV < UV ## */
1803 const IV aiv = SvIVX(TOPm1s);
1807 /* As (b) is a UV, it's >=0, so it must be < */
1814 SETs(boolSV((UV)aiv < buv));
1820 #ifndef NV_PRESERVES_UV
1821 #ifdef PERL_PRESERVE_IVUV
1824 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1826 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1831 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1833 if (Perl_isnan(left) || Perl_isnan(right))
1835 SETs(boolSV(left < right));
1838 SETs(boolSV(TOPn < value));
1846 dVAR; dSP; tryAMAGICbinSET(gt,0);
1847 #ifdef PERL_PRESERVE_IVUV
1850 SvIV_please(TOPm1s);
1851 if (SvIOK(TOPm1s)) {
1852 bool auvok = SvUOK(TOPm1s);
1853 bool buvok = SvUOK(TOPs);
1855 if (!auvok && !buvok) { /* ## IV > IV ## */
1856 const IV aiv = SvIVX(TOPm1s);
1857 const IV biv = SvIVX(TOPs);
1860 SETs(boolSV(aiv > biv));
1863 if (auvok && buvok) { /* ## UV > UV ## */
1864 const UV auv = SvUVX(TOPm1s);
1865 const UV buv = SvUVX(TOPs);
1868 SETs(boolSV(auv > buv));
1871 if (auvok) { /* ## UV > IV ## */
1873 const IV biv = SvIVX(TOPs);
1877 /* As (a) is a UV, it's >=0, so it must be > */
1882 SETs(boolSV(auv > (UV)biv));
1885 { /* ## IV > UV ## */
1886 const IV aiv = SvIVX(TOPm1s);
1890 /* As (b) is a UV, it's >=0, so it cannot be > */
1897 SETs(boolSV((UV)aiv > buv));
1903 #ifndef NV_PRESERVES_UV
1904 #ifdef PERL_PRESERVE_IVUV
1907 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1909 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1914 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1916 if (Perl_isnan(left) || Perl_isnan(right))
1918 SETs(boolSV(left > right));
1921 SETs(boolSV(TOPn > value));
1929 dVAR; dSP; tryAMAGICbinSET(le,0);
1930 #ifdef PERL_PRESERVE_IVUV
1933 SvIV_please(TOPm1s);
1934 if (SvIOK(TOPm1s)) {
1935 bool auvok = SvUOK(TOPm1s);
1936 bool buvok = SvUOK(TOPs);
1938 if (!auvok && !buvok) { /* ## IV <= IV ## */
1939 const IV aiv = SvIVX(TOPm1s);
1940 const IV biv = SvIVX(TOPs);
1943 SETs(boolSV(aiv <= biv));
1946 if (auvok && buvok) { /* ## UV <= UV ## */
1947 UV auv = SvUVX(TOPm1s);
1948 UV buv = SvUVX(TOPs);
1951 SETs(boolSV(auv <= buv));
1954 if (auvok) { /* ## UV <= IV ## */
1956 const IV biv = SvIVX(TOPs);
1960 /* As (a) is a UV, it's >=0, so a cannot be <= */
1965 SETs(boolSV(auv <= (UV)biv));
1968 { /* ## IV <= UV ## */
1969 const IV aiv = SvIVX(TOPm1s);
1973 /* As (b) is a UV, it's >=0, so a must be <= */
1980 SETs(boolSV((UV)aiv <= buv));
1986 #ifndef NV_PRESERVES_UV
1987 #ifdef PERL_PRESERVE_IVUV
1990 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1992 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1997 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1999 if (Perl_isnan(left) || Perl_isnan(right))
2001 SETs(boolSV(left <= right));
2004 SETs(boolSV(TOPn <= value));
2012 dVAR; dSP; tryAMAGICbinSET(ge,0);
2013 #ifdef PERL_PRESERVE_IVUV
2016 SvIV_please(TOPm1s);
2017 if (SvIOK(TOPm1s)) {
2018 bool auvok = SvUOK(TOPm1s);
2019 bool buvok = SvUOK(TOPs);
2021 if (!auvok && !buvok) { /* ## IV >= IV ## */
2022 const IV aiv = SvIVX(TOPm1s);
2023 const IV biv = SvIVX(TOPs);
2026 SETs(boolSV(aiv >= biv));
2029 if (auvok && buvok) { /* ## UV >= UV ## */
2030 const UV auv = SvUVX(TOPm1s);
2031 const UV buv = SvUVX(TOPs);
2034 SETs(boolSV(auv >= buv));
2037 if (auvok) { /* ## UV >= IV ## */
2039 const IV biv = SvIVX(TOPs);
2043 /* As (a) is a UV, it's >=0, so it must be >= */
2048 SETs(boolSV(auv >= (UV)biv));
2051 { /* ## IV >= UV ## */
2052 const IV aiv = SvIVX(TOPm1s);
2056 /* As (b) is a UV, it's >=0, so a cannot be >= */
2063 SETs(boolSV((UV)aiv >= buv));
2069 #ifndef NV_PRESERVES_UV
2070 #ifdef PERL_PRESERVE_IVUV
2073 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2075 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2080 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2082 if (Perl_isnan(left) || Perl_isnan(right))
2084 SETs(boolSV(left >= right));
2087 SETs(boolSV(TOPn >= value));
2095 dVAR; dSP; tryAMAGICbinSET(ne,0);
2096 #ifndef NV_PRESERVES_UV
2097 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2099 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2103 #ifdef PERL_PRESERVE_IVUV
2106 SvIV_please(TOPm1s);
2107 if (SvIOK(TOPm1s)) {
2108 const bool auvok = SvUOK(TOPm1s);
2109 const bool buvok = SvUOK(TOPs);
2111 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2112 /* Casting IV to UV before comparison isn't going to matter
2113 on 2s complement. On 1s complement or sign&magnitude
2114 (if we have any of them) it could make negative zero
2115 differ from normal zero. As I understand it. (Need to
2116 check - is negative zero implementation defined behaviour
2118 const UV buv = SvUVX(POPs);
2119 const UV auv = SvUVX(TOPs);
2121 SETs(boolSV(auv != buv));
2124 { /* ## Mixed IV,UV ## */
2128 /* != is commutative so swap if needed (save code) */
2130 /* swap. top of stack (b) is the iv */
2134 /* As (a) is a UV, it's >0, so it cannot be == */
2143 /* As (b) is a UV, it's >0, so it cannot be == */
2147 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2149 SETs(boolSV((UV)iv != uv));
2156 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2158 if (Perl_isnan(left) || Perl_isnan(right))
2160 SETs(boolSV(left != right));
2163 SETs(boolSV(TOPn != value));
2171 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2172 #ifndef NV_PRESERVES_UV
2173 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2174 const UV right = PTR2UV(SvRV(POPs));
2175 const UV left = PTR2UV(SvRV(TOPs));
2176 SETi((left > right) - (left < right));
2180 #ifdef PERL_PRESERVE_IVUV
2181 /* Fortunately it seems NaN isn't IOK */
2184 SvIV_please(TOPm1s);
2185 if (SvIOK(TOPm1s)) {
2186 const bool leftuvok = SvUOK(TOPm1s);
2187 const bool rightuvok = SvUOK(TOPs);
2189 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2190 const IV leftiv = SvIVX(TOPm1s);
2191 const IV rightiv = SvIVX(TOPs);
2193 if (leftiv > rightiv)
2195 else if (leftiv < rightiv)
2199 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2200 const UV leftuv = SvUVX(TOPm1s);
2201 const UV rightuv = SvUVX(TOPs);
2203 if (leftuv > rightuv)
2205 else if (leftuv < rightuv)
2209 } else if (leftuvok) { /* ## UV <=> IV ## */
2210 const IV rightiv = SvIVX(TOPs);
2212 /* As (a) is a UV, it's >=0, so it cannot be < */
2215 const UV leftuv = SvUVX(TOPm1s);
2216 if (leftuv > (UV)rightiv) {
2218 } else if (leftuv < (UV)rightiv) {
2224 } else { /* ## IV <=> UV ## */
2225 const IV leftiv = SvIVX(TOPm1s);
2227 /* As (b) is a UV, it's >=0, so it must be < */
2230 const UV rightuv = SvUVX(TOPs);
2231 if ((UV)leftiv > rightuv) {
2233 } else if ((UV)leftiv < rightuv) {
2251 if (Perl_isnan(left) || Perl_isnan(right)) {
2255 value = (left > right) - (left < right);
2259 else if (left < right)
2261 else if (left > right)
2277 int amg_type = sle_amg;
2281 switch (PL_op->op_type) {
2300 tryAMAGICbinSET_var(amg_type,0);
2303 const int cmp = (IN_LOCALE_RUNTIME
2304 ? sv_cmp_locale(left, right)
2305 : sv_cmp(left, right));
2306 SETs(boolSV(cmp * multiplier < rhs));
2313 dVAR; dSP; tryAMAGICbinSET(seq,0);
2316 SETs(boolSV(sv_eq(left, right)));
2323 dVAR; dSP; tryAMAGICbinSET(sne,0);
2326 SETs(boolSV(!sv_eq(left, right)));
2333 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2336 const int cmp = (IN_LOCALE_RUNTIME
2337 ? sv_cmp_locale(left, right)
2338 : sv_cmp(left, right));
2346 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2351 if (SvNIOKp(left) || SvNIOKp(right)) {
2352 if (PL_op->op_private & HINT_INTEGER) {
2353 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2357 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2362 do_vop(PL_op->op_type, TARG, left, right);
2371 dVAR; dSP; dATARGET;
2372 const int op_type = PL_op->op_type;
2374 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2379 if (SvNIOKp(left) || SvNIOKp(right)) {
2380 if (PL_op->op_private & HINT_INTEGER) {
2381 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2382 const IV r = SvIV_nomg(right);
2383 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2387 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2388 const UV r = SvUV_nomg(right);
2389 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2394 do_vop(op_type, TARG, left, right);
2403 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2405 SV * const sv = sv_2num(TOPs);
2406 const int flags = SvFLAGS(sv);
2408 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2409 /* It's publicly an integer, or privately an integer-not-float */
2412 if (SvIVX(sv) == IV_MIN) {
2413 /* 2s complement assumption. */
2414 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2417 else if (SvUVX(sv) <= IV_MAX) {
2422 else if (SvIVX(sv) != IV_MIN) {
2426 #ifdef PERL_PRESERVE_IVUV
2435 else if (SvPOKp(sv)) {
2437 const char * const s = SvPV_const(sv, len);
2438 if (isIDFIRST(*s)) {
2439 sv_setpvs(TARG, "-");
2442 else if (*s == '+' || *s == '-') {
2444 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2446 else if (DO_UTF8(sv)) {
2449 goto oops_its_an_int;
2451 sv_setnv(TARG, -SvNV(sv));
2453 sv_setpvs(TARG, "-");
2460 goto oops_its_an_int;
2461 sv_setnv(TARG, -SvNV(sv));
2473 dVAR; dSP; tryAMAGICunSET(not);
2474 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2480 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2485 if (PL_op->op_private & HINT_INTEGER) {
2486 const IV i = ~SvIV_nomg(sv);
2490 const UV u = ~SvUV_nomg(sv);
2499 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2500 sv_setsv_nomg(TARG, sv);
2501 tmps = (U8*)SvPV_force(TARG, len);
2504 /* Calculate exact length, let's not estimate. */
2509 U8 * const send = tmps + len;
2510 U8 * const origtmps = tmps;
2511 const UV utf8flags = UTF8_ALLOW_ANYUV;
2513 while (tmps < send) {
2514 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2516 targlen += UNISKIP(~c);
2522 /* Now rewind strings and write them. */
2529 Newx(result, targlen + 1, U8);
2531 while (tmps < send) {
2532 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2534 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2537 sv_usepvn_flags(TARG, (char*)result, targlen,
2538 SV_HAS_TRAILING_NUL);
2545 Newx(result, nchar + 1, U8);
2547 while (tmps < send) {
2548 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2553 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2561 register long *tmpl;
2562 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2565 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2570 for ( ; anum > 0; anum--, tmps++)
2578 /* integer versions of some of the above */
2582 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2585 SETi( left * right );
2593 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2597 DIE(aTHX_ "Illegal division by zero");
2600 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2604 value = num / value;
2610 #if defined(__GLIBC__) && IVSIZE == 8
2617 /* This is the vanilla old i_modulo. */
2618 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2622 DIE(aTHX_ "Illegal modulus zero");
2623 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2627 SETi( left % right );
2632 #if defined(__GLIBC__) && IVSIZE == 8
2637 /* This is the i_modulo with the workaround for the _moddi3 bug
2638 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2639 * See below for pp_i_modulo. */
2640 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2644 DIE(aTHX_ "Illegal modulus zero");
2645 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2649 SETi( left % PERL_ABS(right) );
2656 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2660 DIE(aTHX_ "Illegal modulus zero");
2661 /* The assumption is to use hereafter the old vanilla version... */
2663 PL_ppaddr[OP_I_MODULO] =
2665 /* .. but if we have glibc, we might have a buggy _moddi3
2666 * (at least glicb 2.2.5 is known to have this bug), in other
2667 * words our integer modulus with negative quad as the second
2668 * argument might be broken. Test for this and re-patch the
2669 * opcode dispatch table if that is the case, remembering to
2670 * also apply the workaround so that this first round works
2671 * right, too. See [perl #9402] for more information. */
2675 /* Cannot do this check with inlined IV constants since
2676 * that seems to work correctly even with the buggy glibc. */
2678 /* Yikes, we have the bug.
2679 * Patch in the workaround version. */
2681 PL_ppaddr[OP_I_MODULO] =
2682 &Perl_pp_i_modulo_1;
2683 /* Make certain we work right this time, too. */
2684 right = PERL_ABS(right);
2687 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2691 SETi( left % right );
2699 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2702 SETi( left + right );
2709 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2712 SETi( left - right );
2719 dVAR; dSP; tryAMAGICbinSET(lt,0);
2722 SETs(boolSV(left < right));
2729 dVAR; dSP; tryAMAGICbinSET(gt,0);
2732 SETs(boolSV(left > right));
2739 dVAR; dSP; tryAMAGICbinSET(le,0);
2742 SETs(boolSV(left <= right));
2749 dVAR; dSP; tryAMAGICbinSET(ge,0);
2752 SETs(boolSV(left >= right));
2759 dVAR; dSP; tryAMAGICbinSET(eq,0);
2762 SETs(boolSV(left == right));
2769 dVAR; dSP; tryAMAGICbinSET(ne,0);
2772 SETs(boolSV(left != right));
2779 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2786 else if (left < right)
2797 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2802 /* High falutin' math. */
2806 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2809 SETn(Perl_atan2(left, right));
2817 int amg_type = sin_amg;
2818 const char *neg_report = NULL;
2819 NV (*func)(NV) = Perl_sin;
2820 const int op_type = PL_op->op_type;
2837 amg_type = sqrt_amg;
2839 neg_report = "sqrt";
2843 tryAMAGICun_var(amg_type);
2845 const NV value = POPn;
2847 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2848 SET_NUMERIC_STANDARD();
2849 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2852 XPUSHn(func(value));
2857 /* Support Configure command-line overrides for rand() functions.
2858 After 5.005, perhaps we should replace this by Configure support
2859 for drand48(), random(), or rand(). For 5.005, though, maintain
2860 compatibility by calling rand() but allow the user to override it.
2861 See INSTALL for details. --Andy Dougherty 15 July 1998
2863 /* Now it's after 5.005, and Configure supports drand48() and random(),
2864 in addition to rand(). So the overrides should not be needed any more.
2865 --Jarkko Hietaniemi 27 September 1998
2868 #ifndef HAS_DRAND48_PROTO
2869 extern double drand48 (void);
2882 if (!PL_srand_called) {
2883 (void)seedDrand01((Rand_seed_t)seed());
2884 PL_srand_called = TRUE;
2894 const UV anum = (MAXARG < 1) ? seed() : POPu;
2895 (void)seedDrand01((Rand_seed_t)anum);
2896 PL_srand_called = TRUE;
2903 dVAR; dSP; dTARGET; tryAMAGICun(int);
2905 SV * const sv = sv_2num(TOPs);
2906 const IV iv = SvIV(sv);
2907 /* XXX it's arguable that compiler casting to IV might be subtly
2908 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2909 else preferring IV has introduced a subtle behaviour change bug. OTOH
2910 relying on floating point to be accurate is a bug. */
2915 else if (SvIOK(sv)) {
2922 const NV value = SvNV(sv);
2924 if (value < (NV)UV_MAX + 0.5) {
2927 SETn(Perl_floor(value));
2931 if (value > (NV)IV_MIN - 0.5) {
2934 SETn(Perl_ceil(value));
2944 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2946 SV * const sv = sv_2num(TOPs);
2947 /* This will cache the NV value if string isn't actually integer */
2948 const IV iv = SvIV(sv);
2953 else if (SvIOK(sv)) {
2954 /* IVX is precise */
2956 SETu(SvUV(sv)); /* force it to be numeric only */
2964 /* 2s complement assumption. Also, not really needed as
2965 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2971 const NV value = SvNV(sv);
2985 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2989 SV* const sv = POPs;
2991 tmps = (SvPV_const(sv, len));
2993 /* If Unicode, try to downgrade
2994 * If not possible, croak. */
2995 SV* const tsv = sv_2mortal(newSVsv(sv));
2998 sv_utf8_downgrade(tsv, FALSE);
2999 tmps = SvPV_const(tsv, len);
3001 if (PL_op->op_type == OP_HEX)
3004 while (*tmps && len && isSPACE(*tmps))
3010 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3012 else if (*tmps == 'b')
3013 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3015 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3017 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3031 SV * const sv = TOPs;
3033 if (SvGAMAGIC(sv)) {
3034 /* For an overloaded or magic scalar, we can't know in advance if
3035 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3036 it likes to cache the length. Maybe that should be a documented
3041 = sv_2pv_flags(sv, &len,
3042 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3046 else if (DO_UTF8(sv)) {
3047 SETi(utf8_length((U8*)p, (U8*)p + len));
3051 } else if (SvOK(sv)) {
3052 /* Neither magic nor overloaded. */
3054 SETi(sv_len_utf8(sv));
3073 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3075 const I32 arybase = CopARYBASE_get(PL_curcop);
3077 const char *repl = NULL;
3079 const int num_args = PL_op->op_private & 7;
3080 bool repl_need_utf8_upgrade = FALSE;
3081 bool repl_is_utf8 = FALSE;
3083 SvTAINTED_off(TARG); /* decontaminate */
3084 SvUTF8_off(TARG); /* decontaminate */
3088 repl = SvPV_const(repl_sv, repl_len);
3089 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3099 sv_utf8_upgrade(sv);
3101 else if (DO_UTF8(sv))
3102 repl_need_utf8_upgrade = TRUE;
3104 tmps = SvPV_const(sv, curlen);
3106 utf8_curlen = sv_len_utf8(sv);
3107 if (utf8_curlen == curlen)
3110 curlen = utf8_curlen;
3115 if (pos >= arybase) {
3133 else if (len >= 0) {
3135 if (rem > (I32)curlen)
3150 Perl_croak(aTHX_ "substr outside of string");
3151 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3155 const I32 upos = pos;
3156 const I32 urem = rem;
3158 sv_pos_u2b(sv, &pos, &rem);
3160 /* we either return a PV or an LV. If the TARG hasn't been used
3161 * before, or is of that type, reuse it; otherwise use a mortal
3162 * instead. Note that LVs can have an extended lifetime, so also
3163 * dont reuse if refcount > 1 (bug #20933) */
3164 if (SvTYPE(TARG) > SVt_NULL) {
3165 if ( (SvTYPE(TARG) == SVt_PVLV)
3166 ? (!lvalue || SvREFCNT(TARG) > 1)
3169 TARG = sv_newmortal();
3173 sv_setpvn(TARG, tmps, rem);
3174 #ifdef USE_LOCALE_COLLATE
3175 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3180 SV* repl_sv_copy = NULL;
3182 if (repl_need_utf8_upgrade) {
3183 repl_sv_copy = newSVsv(repl_sv);
3184 sv_utf8_upgrade(repl_sv_copy);
3185 repl = SvPV_const(repl_sv_copy, repl_len);
3186 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3190 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3194 SvREFCNT_dec(repl_sv_copy);
3196 else if (lvalue) { /* it's an lvalue! */
3197 if (!SvGMAGICAL(sv)) {
3199 SvPV_force_nolen(sv);
3200 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3201 "Attempt to use reference as lvalue in substr");
3203 if (isGV_with_GP(sv))
3204 SvPV_force_nolen(sv);
3205 else if (SvOK(sv)) /* is it defined ? */
3206 (void)SvPOK_only_UTF8(sv);
3208 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3211 if (SvTYPE(TARG) < SVt_PVLV) {
3212 sv_upgrade(TARG, SVt_PVLV);
3213 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3217 if (LvTARG(TARG) != sv) {
3219 SvREFCNT_dec(LvTARG(TARG));
3220 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3222 LvTARGOFF(TARG) = upos;
3223 LvTARGLEN(TARG) = urem;
3227 PUSHs(TARG); /* avoid SvSETMAGIC here */
3234 register const IV size = POPi;
3235 register const IV offset = POPi;
3236 register SV * const src = POPs;
3237 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3239 SvTAINTED_off(TARG); /* decontaminate */
3240 if (lvalue) { /* it's an lvalue! */
3241 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3242 TARG = sv_newmortal();
3243 if (SvTYPE(TARG) < SVt_PVLV) {
3244 sv_upgrade(TARG, SVt_PVLV);
3245 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3248 if (LvTARG(TARG) != src) {
3250 SvREFCNT_dec(LvTARG(TARG));
3251 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3253 LvTARGOFF(TARG) = offset;
3254 LvTARGLEN(TARG) = size;
3257 sv_setuv(TARG, do_vecget(src, offset, size));
3273 const char *little_p;
3274 const I32 arybase = CopARYBASE_get(PL_curcop);
3277 const bool is_index = PL_op->op_type == OP_INDEX;
3280 /* arybase is in characters, like offset, so combine prior to the
3281 UTF-8 to bytes calculation. */
3282 offset = POPi - arybase;
3286 big_p = SvPV_const(big, biglen);
3287 little_p = SvPV_const(little, llen);
3289 big_utf8 = DO_UTF8(big);
3290 little_utf8 = DO_UTF8(little);
3291 if (big_utf8 ^ little_utf8) {
3292 /* One needs to be upgraded. */
3293 if (little_utf8 && !PL_encoding) {
3294 /* Well, maybe instead we might be able to downgrade the small
3296 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3299 /* If the large string is ISO-8859-1, and it's not possible to
3300 convert the small string to ISO-8859-1, then there is no
3301 way that it could be found anywhere by index. */
3306 /* At this point, pv is a malloc()ed string. So donate it to temp
3307 to ensure it will get free()d */
3308 little = temp = newSV(0);
3309 sv_usepvn(temp, pv, llen);
3310 little_p = SvPVX(little);
3313 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3316 sv_recode_to_utf8(temp, PL_encoding);
3318 sv_utf8_upgrade(temp);
3323 big_p = SvPV_const(big, biglen);
3326 little_p = SvPV_const(little, llen);
3330 if (SvGAMAGIC(big)) {
3331 /* Life just becomes a lot easier if I use a temporary here.
3332 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3333 will trigger magic and overloading again, as will fbm_instr()
3335 big = newSVpvn_flags(big_p, biglen,
3336 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3339 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3340 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3341 warn on undef, and we've already triggered a warning with the
3342 SvPV_const some lines above. We can't remove that, as we need to
3343 call some SvPV to trigger overloading early and find out if the
3345 This is all getting to messy. The API isn't quite clean enough,
3346 because data access has side effects.
3348 little = newSVpvn_flags(little_p, llen,
3349 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3350 little_p = SvPVX(little);
3354 offset = is_index ? 0 : biglen;
3356 if (big_utf8 && offset > 0)
3357 sv_pos_u2b(big, &offset, 0);
3363 else if (offset > (I32)biglen)
3365 if (!(little_p = is_index
3366 ? fbm_instr((unsigned char*)big_p + offset,
3367 (unsigned char*)big_p + biglen, little, 0)
3368 : rninstr(big_p, big_p + offset,
3369 little_p, little_p + llen)))
3372 retval = little_p - big_p;
3373 if (retval > 0 && big_utf8)
3374 sv_pos_b2u(big, &retval);
3379 PUSHi(retval + arybase);
3385 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3386 if (SvTAINTED(MARK[1]))
3387 TAINT_PROPER("sprintf");
3388 do_sprintf(TARG, SP-MARK, MARK+1);
3389 TAINT_IF(SvTAINTED(TARG));
3401 const U8 *s = (U8*)SvPV_const(argsv, len);
3403 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3404 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3405 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3409 XPUSHu(DO_UTF8(argsv) ?
3410 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3422 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3424 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3426 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3428 (void) POPs; /* Ignore the argument value. */
3429 value = UNICODE_REPLACEMENT;
3435 SvUPGRADE(TARG,SVt_PV);
3437 if (value > 255 && !IN_BYTES) {
3438 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3439 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3440 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3442 (void)SvPOK_only(TARG);
3451 *tmps++ = (char)value;
3453 (void)SvPOK_only(TARG);
3455 if (PL_encoding && !IN_BYTES) {
3456 sv_recode_to_utf8(TARG, PL_encoding);
3458 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3459 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3463 *tmps++ = (char)value;
3479 const char *tmps = SvPV_const(left, len);
3481 if (DO_UTF8(left)) {
3482 /* If Unicode, try to downgrade.
3483 * If not possible, croak.
3484 * Yes, we made this up. */
3485 SV* const tsv = sv_2mortal(newSVsv(left));
3488 sv_utf8_downgrade(tsv, FALSE);
3489 tmps = SvPV_const(tsv, len);
3491 # ifdef USE_ITHREADS
3493 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3494 /* This should be threadsafe because in ithreads there is only
3495 * one thread per interpreter. If this would not be true,
3496 * we would need a mutex to protect this malloc. */
3497 PL_reentrant_buffer->_crypt_struct_buffer =
3498 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3499 #if defined(__GLIBC__) || defined(__EMX__)
3500 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3501 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3502 /* work around glibc-2.2.5 bug */
3503 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3507 # endif /* HAS_CRYPT_R */
3508 # endif /* USE_ITHREADS */
3510 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3512 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3518 "The crypt() function is unimplemented due to excessive paranoia.");
3530 bool inplace = TRUE;
3532 const int op_type = PL_op->op_type;
3535 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3541 s = (const U8*)SvPV_nomg_const(source, slen);
3543 if (ckWARN(WARN_UNINITIALIZED))
3544 report_uninit(source);
3549 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3551 utf8_to_uvchr(s, &ulen);
3552 if (op_type == OP_UCFIRST) {
3553 toTITLE_utf8(s, tmpbuf, &tculen);
3555 toLOWER_utf8(s, tmpbuf, &tculen);
3557 /* If the two differ, we definately cannot do inplace. */
3558 inplace = (ulen == tculen);
3559 need = slen + 1 - ulen + tculen;
3565 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3566 /* We can convert in place. */
3569 s = d = (U8*)SvPV_force_nomg(source, slen);
3575 SvUPGRADE(dest, SVt_PV);
3576 d = (U8*)SvGROW(dest, need);
3577 (void)SvPOK_only(dest);
3586 /* slen is the byte length of the whole SV.
3587 * ulen is the byte length of the original Unicode character
3588 * stored as UTF-8 at s.
3589 * tculen is the byte length of the freshly titlecased (or
3590 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3591 * We first set the result to be the titlecased (/lowercased)
3592 * character, and then append the rest of the SV data. */
3593 sv_setpvn(dest, (char*)tmpbuf, tculen);
3595 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3599 Copy(tmpbuf, d, tculen, U8);
3600 SvCUR_set(dest, need - 1);
3605 if (IN_LOCALE_RUNTIME) {
3608 *d = (op_type == OP_UCFIRST)
3609 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3612 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3614 /* See bug #39028 */
3622 /* This will copy the trailing NUL */
3623 Copy(s + 1, d + 1, slen, U8);
3624 SvCUR_set(dest, need - 1);
3631 /* There's so much setup/teardown code common between uc and lc, I wonder if
3632 it would be worth merging the two, and just having a switch outside each
3633 of the three tight loops. */
3647 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3648 && SvTEMP(source) && !DO_UTF8(source)) {
3649 /* We can convert in place. */
3652 s = d = (U8*)SvPV_force_nomg(source, len);
3659 /* The old implementation would copy source into TARG at this point.
3660 This had the side effect that if source was undef, TARG was now
3661 an undefined SV with PADTMP set, and they don't warn inside
3662 sv_2pv_flags(). However, we're now getting the PV direct from
3663 source, which doesn't have PADTMP set, so it would warn. Hence the
3667 s = (const U8*)SvPV_nomg_const(source, len);
3669 if (ckWARN(WARN_UNINITIALIZED))
3670 report_uninit(source);
3676 SvUPGRADE(dest, SVt_PV);
3677 d = (U8*)SvGROW(dest, min);
3678 (void)SvPOK_only(dest);
3683 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3684 to check DO_UTF8 again here. */
3686 if (DO_UTF8(source)) {
3687 const U8 *const send = s + len;
3688 U8 tmpbuf[UTF8_MAXBYTES+1];
3691 const STRLEN u = UTF8SKIP(s);
3694 toUPPER_utf8(s, tmpbuf, &ulen);
3695 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3696 /* If the eventually required minimum size outgrows
3697 * the available space, we need to grow. */
3698 const UV o = d - (U8*)SvPVX_const(dest);
3700 /* If someone uppercases one million U+03B0s we SvGROW() one
3701 * million times. Or we could try guessing how much to
3702 allocate without allocating too much. Such is life. */
3704 d = (U8*)SvPVX(dest) + o;
3706 Copy(tmpbuf, d, ulen, U8);
3712 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3715 const U8 *const send = s + len;
3716 if (IN_LOCALE_RUNTIME) {
3719 for (; s < send; d++, s++)
3720 *d = toUPPER_LC(*s);
3723 for (; s < send; d++, s++)
3727 if (source != dest) {
3729 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3749 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3750 && SvTEMP(source) && !DO_UTF8(source)) {
3751 /* We can convert in place. */
3754 s = d = (U8*)SvPV_force_nomg(source, len);
3761 /* The old implementation would copy source into TARG at this point.
3762 This had the side effect that if source was undef, TARG was now
3763 an undefined SV with PADTMP set, and they don't warn inside
3764 sv_2pv_flags(). However, we're now getting the PV direct from
3765 source, which doesn't have PADTMP set, so it would warn. Hence the
3769 s = (const U8*)SvPV_nomg_const(source, len);
3771 if (ckWARN(WARN_UNINITIALIZED))
3772 report_uninit(source);
3778 SvUPGRADE(dest, SVt_PV);
3779 d = (U8*)SvGROW(dest, min);
3780 (void)SvPOK_only(dest);
3785 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3786 to check DO_UTF8 again here. */
3788 if (DO_UTF8(source)) {
3789 const U8 *const send = s + len;
3790 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3793 const STRLEN u = UTF8SKIP(s);
3795 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3797 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3798 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3801 * Now if the sigma is NOT followed by
3802 * /$ignorable_sequence$cased_letter/;
3803 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3804 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3805 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3806 * then it should be mapped to 0x03C2,
3807 * (GREEK SMALL LETTER FINAL SIGMA),
3808 * instead of staying 0x03A3.
3809 * "should be": in other words, this is not implemented yet.
3810 * See lib/unicore/SpecialCasing.txt.
3813 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3814 /* If the eventually required minimum size outgrows
3815 * the available space, we need to grow. */
3816 const UV o = d - (U8*)SvPVX_const(dest);
3818 /* If someone lowercases one million U+0130s we SvGROW() one
3819 * million times. Or we could try guessing how much to
3820 allocate without allocating too much. Such is life. */
3822 d = (U8*)SvPVX(dest) + o;
3824 Copy(tmpbuf, d, ulen, U8);
3830 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3833 const U8 *const send = s + len;
3834 if (IN_LOCALE_RUNTIME) {
3837 for (; s < send; d++, s++)
3838 *d = toLOWER_LC(*s);
3841 for (; s < send; d++, s++)
3845 if (source != dest) {
3847 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3857 SV * const sv = TOPs;
3859 register const char *s = SvPV_const(sv,len);
3861 SvUTF8_off(TARG); /* decontaminate */
3864 SvUPGRADE(TARG, SVt_PV);
3865 SvGROW(TARG, (len * 2) + 1);
3869 if (UTF8_IS_CONTINUED(*s)) {
3870 STRLEN ulen = UTF8SKIP(s);
3894 SvCUR_set(TARG, d - SvPVX_const(TARG));
3895 (void)SvPOK_only_UTF8(TARG);
3898 sv_setpvn(TARG, s, len);
3907 dVAR; dSP; dMARK; dORIGMARK;
3908 register AV *const av = MUTABLE_AV(POPs);
3909 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3911 if (SvTYPE(av) == SVt_PVAV) {
3912 const I32 arybase = CopARYBASE_get(PL_curcop);
3913 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3914 bool can_preserve = FALSE;
3920 can_preserve = SvCANEXISTDELETE(av);
3923 if (lval && localizing) {
3926 for (svp = MARK + 1; svp <= SP; svp++) {
3927 const I32 elem = SvIV(*svp);
3931 if (max > AvMAX(av))
3935 while (++MARK <= SP) {
3937 I32 elem = SvIV(*MARK);
3938 bool preeminent = TRUE;
3942 if (localizing && can_preserve) {
3943 /* If we can determine whether the element exist,
3944 * Try to preserve the existenceness of a tied array
3945 * element by using EXISTS and DELETE if possible.
3946 * Fallback to FETCH and STORE otherwise. */
3947 preeminent = av_exists(av, elem);
3950 svp = av_fetch(av, elem, lval);
3952 if (!svp || *svp == &PL_sv_undef)
3953 DIE(aTHX_ PL_no_aelem, elem);
3956 save_aelem(av, elem, svp);
3958 SAVEADELETE(av, elem);
3961 *MARK = svp ? *svp : &PL_sv_undef;
3964 if (GIMME != G_ARRAY) {
3966 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3976 AV *array = MUTABLE_AV(POPs);
3977 const I32 gimme = GIMME_V;
3978 IV *iterp = Perl_av_iter_p(aTHX_ array);
3979 const IV current = (*iterp)++;
3981 if (current > av_len(array)) {
3983 if (gimme == G_SCALAR)
3990 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3991 if (gimme == G_ARRAY) {
3992 SV **const element = av_fetch(array, current, 0);
3993 PUSHs(element ? *element : &PL_sv_undef);
4002 AV *array = MUTABLE_AV(POPs);
4003 const I32 gimme = GIMME_V;
4005 *Perl_av_iter_p(aTHX_ array) = 0;
4007 if (gimme == G_SCALAR) {
4009 PUSHi(av_len(array) + 1);
4011 else if (gimme == G_ARRAY) {
4012 IV n = Perl_av_len(aTHX_ array);
4013 IV i = CopARYBASE_get(PL_curcop);
4017 if (PL_op->op_type == OP_AKEYS) {
4019 for (; i <= n; i++) {
4024 for (i = 0; i <= n; i++) {
4025 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4026 PUSHs(elem ? *elem : &PL_sv_undef);
4033 /* Associative arrays. */
4039 HV * hash = MUTABLE_HV(POPs);
4041 const I32 gimme = GIMME_V;
4044 /* might clobber stack_sp */
4045 entry = hv_iternext(hash);
4050 SV* const sv = hv_iterkeysv(entry);
4051 PUSHs(sv); /* won't clobber stack_sp */
4052 if (gimme == G_ARRAY) {
4055 /* might clobber stack_sp */
4056 val = hv_iterval(hash, entry);
4061 else if (gimme == G_SCALAR)
4068 S_do_delete_local(pTHX)
4072 const I32 gimme = GIMME_V;
4076 if (PL_op->op_private & OPpSLICE) {
4078 SV * const osv = POPs;
4079 const bool tied = SvRMAGICAL(osv)
4080 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4081 const bool can_preserve = SvCANEXISTDELETE(osv)
4082 || mg_find((const SV *)osv, PERL_MAGIC_env);
4083 const U32 type = SvTYPE(osv);
4084 if (type == SVt_PVHV) { /* hash element */
4085 HV * const hv = MUTABLE_HV(osv);
4086 while (++MARK <= SP) {
4087 SV * const keysv = *MARK;
4089 bool preeminent = TRUE;
4091 preeminent = hv_exists_ent(hv, keysv, 0);
4093 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4100 sv = hv_delete_ent(hv, keysv, 0, 0);
4101 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4104 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4106 *MARK = sv_mortalcopy(sv);
4112 SAVEHDELETE(hv, keysv);
4113 *MARK = &PL_sv_undef;
4117 else if (type == SVt_PVAV) { /* array element */
4118 if (PL_op->op_flags & OPf_SPECIAL) {
4119 AV * const av = MUTABLE_AV(osv);
4120 while (++MARK <= SP) {
4121 I32 idx = SvIV(*MARK);
4123 bool preeminent = TRUE;
4125 preeminent = av_exists(av, idx);
4127 SV **svp = av_fetch(av, idx, 1);
4134 sv = av_delete(av, idx, 0);
4135 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4138 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4140 *MARK = sv_mortalcopy(sv);
4146 SAVEADELETE(av, idx);
4147 *MARK = &PL_sv_undef;
4153 DIE(aTHX_ "Not a HASH reference");
4154 if (gimme == G_VOID)
4156 else if (gimme == G_SCALAR) {
4161 *++MARK = &PL_sv_undef;
4166 SV * const keysv = POPs;
4167 SV * const osv = POPs;
4168 const bool tied = SvRMAGICAL(osv)
4169 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4170 const bool can_preserve = SvCANEXISTDELETE(osv)
4171 || mg_find((const SV *)osv, PERL_MAGIC_env);
4172 const U32 type = SvTYPE(osv);
4174 if (type == SVt_PVHV) {
4175 HV * const hv = MUTABLE_HV(osv);
4176 bool preeminent = TRUE;
4178 preeminent = hv_exists_ent(hv, keysv, 0);
4180 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4187 sv = hv_delete_ent(hv, keysv, 0, 0);
4188 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4191 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4193 SV *nsv = sv_mortalcopy(sv);
4199 SAVEHDELETE(hv, keysv);
4201 else if (type == SVt_PVAV) {
4202 if (PL_op->op_flags & OPf_SPECIAL) {
4203 AV * const av = MUTABLE_AV(osv);
4204 I32 idx = SvIV(keysv);
4205 bool preeminent = TRUE;
4207 preeminent = av_exists(av, idx);
4209 SV **svp = av_fetch(av, idx, 1);
4216 sv = av_delete(av, idx, 0);
4217 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4220 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4222 SV *nsv = sv_mortalcopy(sv);
4228 SAVEADELETE(av, idx);
4231 DIE(aTHX_ "panic: avhv_delete no longer supported");
4234 DIE(aTHX_ "Not a HASH reference");
4237 if (gimme != G_VOID)
4251 if (PL_op->op_private & OPpLVAL_INTRO)
4252 return do_delete_local();
4255 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4257 if (PL_op->op_private & OPpSLICE) {
4259 HV * const hv = MUTABLE_HV(POPs);
4260 const U32 hvtype = SvTYPE(hv);
4261 if (hvtype == SVt_PVHV) { /* hash element */
4262 while (++MARK <= SP) {
4263 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4264 *MARK = sv ? sv : &PL_sv_undef;
4267 else if (hvtype == SVt_PVAV) { /* array element */
4268 if (PL_op->op_flags & OPf_SPECIAL) {
4269 while (++MARK <= SP) {
4270 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4271 *MARK = sv ? sv : &PL_sv_undef;
4276 DIE(aTHX_ "Not a HASH reference");
4279 else if (gimme == G_SCALAR) {
4284 *++MARK = &PL_sv_undef;
4290 HV * const hv = MUTABLE_HV(POPs);
4292 if (SvTYPE(hv) == SVt_PVHV)
4293 sv = hv_delete_ent(hv, keysv, discard, 0);
4294 else if (SvTYPE(hv) == SVt_PVAV) {
4295 if (PL_op->op_flags & OPf_SPECIAL)
4296 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4298 DIE(aTHX_ "panic: avhv_delete no longer supported");
4301 DIE(aTHX_ "Not a HASH reference");
4317 if (PL_op->op_private & OPpEXISTS_SUB) {
4319 SV * const sv = POPs;
4320 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4323 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4328 hv = MUTABLE_HV(POPs);
4329 if (SvTYPE(hv) == SVt_PVHV) {
4330 if (hv_exists_ent(hv, tmpsv, 0))
4333 else if (SvTYPE(hv) == SVt_PVAV) {
4334 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4335 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4340 DIE(aTHX_ "Not a HASH reference");
4347 dVAR; dSP; dMARK; dORIGMARK;
4348 register HV * const hv = MUTABLE_HV(POPs);
4349 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4350 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4351 bool can_preserve = FALSE;
4357 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4358 can_preserve = TRUE;
4361 while (++MARK <= SP) {
4362 SV * const keysv = *MARK;
4365 bool preeminent = TRUE;
4367 if (localizing && can_preserve) {
4368 /* If we can determine whether the element exist,
4369 * try to preserve the existenceness of a tied hash
4370 * element by using EXISTS and DELETE if possible.
4371 * Fallback to FETCH and STORE otherwise. */
4372 preeminent = hv_exists_ent(hv, keysv, 0);
4375 he = hv_fetch_ent(hv, keysv, lval, 0);
4376 svp = he ? &HeVAL(he) : NULL;
4379 if (!svp || *svp == &PL_sv_undef) {
4380 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4383 if (HvNAME_get(hv) && isGV(*svp))
4384 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4385 else if (preeminent)
4386 save_helem_flags(hv, keysv, svp,
4387 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4389 SAVEHDELETE(hv, keysv);
4392 *MARK = svp ? *svp : &PL_sv_undef;
4394 if (GIMME != G_ARRAY) {
4396 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4402 /* List operators. */
4407 if (GIMME != G_ARRAY) {
4409 *MARK = *SP; /* unwanted list, return last item */
4411 *MARK = &PL_sv_undef;
4421 SV ** const lastrelem = PL_stack_sp;
4422 SV ** const lastlelem = PL_stack_base + POPMARK;
4423 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4424 register SV ** const firstrelem = lastlelem + 1;
4425 const I32 arybase = CopARYBASE_get(PL_curcop);
4426 I32 is_something_there = FALSE;
4428 register const I32 max = lastrelem - lastlelem;
4429 register SV **lelem;
4431 if (GIMME != G_ARRAY) {
4432 I32 ix = SvIV(*lastlelem);
4437 if (ix < 0 || ix >= max)
4438 *firstlelem = &PL_sv_undef;
4440 *firstlelem = firstrelem[ix];
4446 SP = firstlelem - 1;
4450 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4451 I32 ix = SvIV(*lelem);
4456 if (ix < 0 || ix >= max)
4457 *lelem = &PL_sv_undef;
4459 is_something_there = TRUE;
4460 if (!(*lelem = firstrelem[ix]))
4461 *lelem = &PL_sv_undef;
4464 if (is_something_there)
4467 SP = firstlelem - 1;
4473 dVAR; dSP; dMARK; dORIGMARK;
4474 const I32 items = SP - MARK;
4475 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4476 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4477 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4478 ? newRV_noinc(av) : av);
4484 dVAR; dSP; dMARK; dORIGMARK;
4485 HV* const hv = newHV();
4488 SV * const key = *++MARK;
4489 SV * const val = newSV(0);
4491 sv_setsv(val, *++MARK);
4493 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4494 (void)hv_store_ent(hv,key,val,0);
4497 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4498 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4504 dVAR; dSP; dMARK; dORIGMARK;
4505 register AV *ary = MUTABLE_AV(*++MARK);
4509 register I32 offset;
4510 register I32 length;
4514 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4517 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4521 call_method("SPLICE",GIMME_V);
4530 offset = i = SvIV(*MARK);
4532 offset += AvFILLp(ary) + 1;
4534 offset -= CopARYBASE_get(PL_curcop);
4536 DIE(aTHX_ PL_no_aelem, i);
4538 length = SvIVx(*MARK++);
4540 length += AvFILLp(ary) - offset + 1;
4546 length = AvMAX(ary) + 1; /* close enough to infinity */
4550 length = AvMAX(ary) + 1;
4552 if (offset > AvFILLp(ary) + 1) {
4553 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4554 offset = AvFILLp(ary) + 1;
4556 after = AvFILLp(ary) + 1 - (offset + length);
4557 if (after < 0) { /* not that much array */
4558 length += after; /* offset+length now in array */
4564 /* At this point, MARK .. SP-1 is our new LIST */
4567 diff = newlen - length;
4568 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4571 /* make new elements SVs now: avoid problems if they're from the array */
4572 for (dst = MARK, i = newlen; i; i--) {
4573 SV * const h = *dst;
4574 *dst++ = newSVsv(h);
4577 if (diff < 0) { /* shrinking the area */
4578 SV **tmparyval = NULL;
4580 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4581 Copy(MARK, tmparyval, newlen, SV*);
4584 MARK = ORIGMARK + 1;
4585 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4586 MEXTEND(MARK, length);
4587 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4589 EXTEND_MORTAL(length);
4590 for (i = length, dst = MARK; i; i--) {
4591 sv_2mortal(*dst); /* free them eventualy */
4598 *MARK = AvARRAY(ary)[offset+length-1];
4601 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4602 SvREFCNT_dec(*dst++); /* free them now */
4605 AvFILLp(ary) += diff;
4607 /* pull up or down? */
4609 if (offset < after) { /* easier to pull up */
4610 if (offset) { /* esp. if nothing to pull */
4611 src = &AvARRAY(ary)[offset-1];
4612 dst = src - diff; /* diff is negative */
4613 for (i = offset; i > 0; i--) /* can't trust Copy */
4617 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4621 if (after) { /* anything to pull down? */
4622 src = AvARRAY(ary) + offset + length;
4623 dst = src + diff; /* diff is negative */
4624 Move(src, dst, after, SV*);
4626 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4627 /* avoid later double free */
4631 dst[--i] = &PL_sv_undef;
4634 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4635 Safefree(tmparyval);
4638 else { /* no, expanding (or same) */
4639 SV** tmparyval = NULL;
4641 Newx(tmparyval, length, SV*); /* so remember deletion */
4642 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4645 if (diff > 0) { /* expanding */
4646 /* push up or down? */
4647 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4651 Move(src, dst, offset, SV*);
4653 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4655 AvFILLp(ary) += diff;
4658 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4659 av_extend(ary, AvFILLp(ary) + diff);
4660 AvFILLp(ary) += diff;
4663 dst = AvARRAY(ary) + AvFILLp(ary);
4665 for (i = after; i; i--) {
4673 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4676 MARK = ORIGMARK + 1;
4677 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4679 Copy(tmparyval, MARK, length, SV*);
4681 EXTEND_MORTAL(length);
4682 for (i = length, dst = MARK; i; i--) {
4683 sv_2mortal(*dst); /* free them eventualy */
4690 else if (length--) {
4691 *MARK = tmparyval[length];
4694 while (length-- > 0)
4695 SvREFCNT_dec(tmparyval[length]);
4699 *MARK = &PL_sv_undef;
4700 Safefree(tmparyval);
4708 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4709 register AV * const ary = MUTABLE_AV(*++MARK);
4710 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4713 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4717 call_method("PUSH",G_SCALAR|G_DISCARD);
4722 PL_delaymagic = DM_DELAY;
4723 for (++MARK; MARK <= SP; MARK++) {
4724 SV * const sv = newSV(0);
4726 sv_setsv(sv, *MARK);
4727 av_store(ary, AvFILLp(ary)+1, sv);
4729 if (PL_delaymagic & DM_ARRAY)
4730 mg_set(MUTABLE_SV(ary));
4735 if (OP_GIMME(PL_op, 0) != G_VOID) {
4736 PUSHi( AvFILL(ary) + 1 );
4745 AV * const av = MUTABLE_AV(POPs);
4746 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4750 (void)sv_2mortal(sv);
4757 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4758 register AV *ary = MUTABLE_AV(*++MARK);
4759 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4762 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4766 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4772 av_unshift(ary, SP - MARK);
4774 SV * const sv = newSVsv(*++MARK);
4775 (void)av_store(ary, i++, sv);
4779 if (OP_GIMME(PL_op, 0) != G_VOID) {
4780 PUSHi( AvFILL(ary) + 1 );
4788 SV ** const oldsp = SP;
4790 if (GIMME == G_ARRAY) {
4793 register SV * const tmp = *MARK;
4797 /* safe as long as stack cannot get extended in the above */
4802 register char *down;
4806 PADOFFSET padoff_du;
4808 SvUTF8_off(TARG); /* decontaminate */
4810 do_join(TARG, &PL_sv_no, MARK, SP);
4812 sv_setsv(TARG, (SP > MARK)
4814 : (padoff_du = find_rundefsvoffset(),
4815 (padoff_du == NOT_IN_PAD
4816 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4817 ? DEFSV : PAD_SVl(padoff_du)));
4819 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4820 report_uninit(TARG);
4823 up = SvPV_force(TARG, len);
4825 if (DO_UTF8(TARG)) { /* first reverse each character */
4826 U8* s = (U8*)SvPVX(TARG);
4827 const U8* send = (U8*)(s + len);
4829 if (UTF8_IS_INVARIANT(*s)) {
4834 if (!utf8_to_uvchr(s, 0))
4838 down = (char*)(s - 1);
4839 /* reverse this character */
4843 *down-- = (char)tmp;
4849 down = SvPVX(TARG) + len - 1;
4853 *down-- = (char)tmp;
4855 (void)SvPOK_only_UTF8(TARG);
4867 register IV limit = POPi; /* note, negative is forever */
4868 SV * const sv = POPs;
4870 register const char *s = SvPV_const(sv, len);
4871 const bool do_utf8 = DO_UTF8(sv);
4872 const char *strend = s + len;
4874 register REGEXP *rx;
4876 register const char *m;
4878 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4879 I32 maxiters = slen + 10;
4880 I32 trailing_empty = 0;
4882 const I32 origlimit = limit;
4885 const I32 gimme = GIMME_V;
4886 const bool gimme_scalar = (GIMME_V == G_SCALAR);
4887 const I32 oldsave = PL_savestack_ix;
4888 U32 make_mortal = SVs_TEMP;
4893 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4898 DIE(aTHX_ "panic: pp_split");
4901 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4902 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4904 RX_MATCH_UTF8_set(rx, do_utf8);
4907 if (pm->op_pmreplrootu.op_pmtargetoff) {
4908 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
4911 if (pm->op_pmreplrootu.op_pmtargetgv) {
4912 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4917 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4923 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
4925 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
4932 for (i = AvFILLp(ary); i >= 0; i--)
4933 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4935 /* temporarily switch stacks */
4936 SAVESWITCHSTACK(PL_curstack, ary);
4940 base = SP - PL_stack_base;
4942 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4944 while (*s == ' ' || is_utf8_space((U8*)s))
4947 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4948 while (isSPACE_LC(*s))
4956 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4961 limit = maxiters + 2;
4962 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4965 /* this one uses 'm' and is a negative test */
4967 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4968 const int t = UTF8SKIP(m);
4969 /* is_utf8_space returns FALSE for malform utf8 */
4975 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4976 while (m < strend && !isSPACE_LC(*m))
4979 while (m < strend && !isSPACE(*m))
4992 dstr = newSVpvn_flags(s, m-s,
4993 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4997 /* skip the whitespace found last */
4999 s = m + UTF8SKIP(m);
5003 /* this one uses 's' and is a positive test */
5005 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5007 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5008 while (s < strend && isSPACE_LC(*s))
5011 while (s < strend && isSPACE(*s))
5016 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5018 for (m = s; m < strend && *m != '\n'; m++)
5031 dstr = newSVpvn_flags(s, m-s,
5032 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5038 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5040 Pre-extend the stack, either the number of bytes or
5041 characters in the string or a limited amount, triggered by:
5043 my ($x, $y) = split //, $str;
5047 if (!gimme_scalar) {
5048 const U32 items = limit - 1;
5057 /* keep track of how many bytes we skip over */
5067 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5080 dstr = newSVpvn(s, 1);
5096 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5097 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5098 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5099 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5100 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5101 SV * const csv = CALLREG_INTUIT_STRING(rx);
5103 len = RX_MINLENRET(rx);
5104 if (len == 1 && !RX_UTF8(rx) && !tail) {
5105 const char c = *SvPV_nolen_const(csv);
5107 for (m = s; m < strend && *m != c; m++)
5118 dstr = newSVpvn_flags(s, m-s,
5119 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5122 /* The rx->minlen is in characters but we want to step
5123 * s ahead by bytes. */
5125 s = (char*)utf8_hop((U8*)m, len);
5127 s = m + len; /* Fake \n at the end */
5131 while (s < strend && --limit &&
5132 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5133 csv, multiline ? FBMrf_MULTILINE : 0)) )
5142 dstr = newSVpvn_flags(s, m-s,
5143 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5146 /* The rx->minlen is in characters but we want to step
5147 * s ahead by bytes. */
5149 s = (char*)utf8_hop((U8*)m, len);
5151 s = m + len; /* Fake \n at the end */
5156 maxiters += slen * RX_NPARENS(rx);
5157 while (s < strend && --limit)
5161 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5164 if (rex_return == 0)
5166 TAINT_IF(RX_MATCH_TAINTED(rx));
5167 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5170 orig = RX_SUBBEG(rx);
5172 strend = s + (strend - m);
5174 m = RX_OFFS(rx)[0].start + orig;
5183 dstr = newSVpvn_flags(s, m-s,
5184 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5187 if (RX_NPARENS(rx)) {
5189 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5190 s = RX_OFFS(rx)[i].start + orig;
5191 m = RX_OFFS(rx)[i].end + orig;
5193 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5194 parens that didn't match -- they should be set to
5195 undef, not the empty string */
5203 if (m >= orig && s >= orig) {
5204 dstr = newSVpvn_flags(s, m-s,
5205 (do_utf8 ? SVf_UTF8 : 0)
5209 dstr = &PL_sv_undef; /* undef, not "" */
5215 s = RX_OFFS(rx)[0].end + orig;
5219 if (!gimme_scalar) {
5220 iters = (SP - PL_stack_base) - base;
5222 if (iters > maxiters)
5223 DIE(aTHX_ "Split loop");
5225 /* keep field after final delim? */
5226 if (s < strend || (iters && origlimit)) {
5227 if (!gimme_scalar) {
5228 const STRLEN l = strend - s;
5229 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5234 else if (!origlimit) {
5236 iters -= trailing_empty;
5238 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5239 if (TOPs && !make_mortal)
5241 *SP-- = &PL_sv_undef;
5248 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5252 if (SvSMAGICAL(ary)) {
5254 mg_set(MUTABLE_SV(ary));
5257 if (gimme == G_ARRAY) {
5259 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5267 call_method("PUSH",G_SCALAR|G_DISCARD);
5270 if (gimme == G_ARRAY) {
5272 /* EXTEND should not be needed - we just popped them */
5274 for (i=0; i < iters; i++) {
5275 SV **svp = av_fetch(ary, i, FALSE);
5276 PUSHs((svp) ? *svp : &PL_sv_undef);
5283 if (gimme == G_ARRAY)
5295 SV *const sv = PAD_SVl(PL_op->op_targ);
5297 if (SvPADSTALE(sv)) {
5300 RETURNOP(cLOGOP->op_other);
5302 RETURNOP(cLOGOP->op_next);
5311 assert(SvTYPE(retsv) != SVt_PVCV);
5313 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
5314 retsv = refto(retsv);
5321 PP(unimplemented_op)
5324 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5332 HV * const hv = (HV*)POPs;
5334 if (SvRMAGICAL(hv)) {
5335 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5337 XPUSHs(magic_scalarpack(hv, mg));
5342 XPUSHs(boolSV(HvKEYS(hv) != 0));
5348 * c-indentation-style: bsd
5350 * indent-tabs-mode: t
5353 * ex: set ts=8 sts=4 sw=4 noet: