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);
579 if (len == 0 && ckWARN(WARN_MISC))
580 Perl_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) && ckWARN(WARN_MISC))
817 Perl_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 if (ckWARN(WARN_SUBSTR))
3152 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3156 const I32 upos = pos;
3157 const I32 urem = rem;
3159 sv_pos_u2b(sv, &pos, &rem);
3161 /* we either return a PV or an LV. If the TARG hasn't been used
3162 * before, or is of that type, reuse it; otherwise use a mortal
3163 * instead. Note that LVs can have an extended lifetime, so also
3164 * dont reuse if refcount > 1 (bug #20933) */
3165 if (SvTYPE(TARG) > SVt_NULL) {
3166 if ( (SvTYPE(TARG) == SVt_PVLV)
3167 ? (!lvalue || SvREFCNT(TARG) > 1)
3170 TARG = sv_newmortal();
3174 sv_setpvn(TARG, tmps, rem);
3175 #ifdef USE_LOCALE_COLLATE
3176 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3181 SV* repl_sv_copy = NULL;
3183 if (repl_need_utf8_upgrade) {
3184 repl_sv_copy = newSVsv(repl_sv);
3185 sv_utf8_upgrade(repl_sv_copy);
3186 repl = SvPV_const(repl_sv_copy, repl_len);
3187 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3191 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3195 SvREFCNT_dec(repl_sv_copy);
3197 else if (lvalue) { /* it's an lvalue! */
3198 if (!SvGMAGICAL(sv)) {
3200 SvPV_force_nolen(sv);
3201 if (ckWARN(WARN_SUBSTR))
3202 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3203 "Attempt to use reference as lvalue in substr");
3205 if (isGV_with_GP(sv))
3206 SvPV_force_nolen(sv);
3207 else if (SvOK(sv)) /* is it defined ? */
3208 (void)SvPOK_only_UTF8(sv);
3210 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3213 if (SvTYPE(TARG) < SVt_PVLV) {
3214 sv_upgrade(TARG, SVt_PVLV);
3215 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3219 if (LvTARG(TARG) != sv) {
3221 SvREFCNT_dec(LvTARG(TARG));
3222 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3224 LvTARGOFF(TARG) = upos;
3225 LvTARGLEN(TARG) = urem;
3229 PUSHs(TARG); /* avoid SvSETMAGIC here */
3236 register const IV size = POPi;
3237 register const IV offset = POPi;
3238 register SV * const src = POPs;
3239 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3241 SvTAINTED_off(TARG); /* decontaminate */
3242 if (lvalue) { /* it's an lvalue! */
3243 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3244 TARG = sv_newmortal();
3245 if (SvTYPE(TARG) < SVt_PVLV) {
3246 sv_upgrade(TARG, SVt_PVLV);
3247 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3250 if (LvTARG(TARG) != src) {
3252 SvREFCNT_dec(LvTARG(TARG));
3253 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3255 LvTARGOFF(TARG) = offset;
3256 LvTARGLEN(TARG) = size;
3259 sv_setuv(TARG, do_vecget(src, offset, size));
3275 const char *little_p;
3276 const I32 arybase = CopARYBASE_get(PL_curcop);
3279 const bool is_index = PL_op->op_type == OP_INDEX;
3282 /* arybase is in characters, like offset, so combine prior to the
3283 UTF-8 to bytes calculation. */
3284 offset = POPi - arybase;
3288 big_p = SvPV_const(big, biglen);
3289 little_p = SvPV_const(little, llen);
3291 big_utf8 = DO_UTF8(big);
3292 little_utf8 = DO_UTF8(little);
3293 if (big_utf8 ^ little_utf8) {
3294 /* One needs to be upgraded. */
3295 if (little_utf8 && !PL_encoding) {
3296 /* Well, maybe instead we might be able to downgrade the small
3298 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3301 /* If the large string is ISO-8859-1, and it's not possible to
3302 convert the small string to ISO-8859-1, then there is no
3303 way that it could be found anywhere by index. */
3308 /* At this point, pv is a malloc()ed string. So donate it to temp
3309 to ensure it will get free()d */
3310 little = temp = newSV(0);
3311 sv_usepvn(temp, pv, llen);
3312 little_p = SvPVX(little);
3315 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3318 sv_recode_to_utf8(temp, PL_encoding);
3320 sv_utf8_upgrade(temp);
3325 big_p = SvPV_const(big, biglen);
3328 little_p = SvPV_const(little, llen);
3332 if (SvGAMAGIC(big)) {
3333 /* Life just becomes a lot easier if I use a temporary here.
3334 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3335 will trigger magic and overloading again, as will fbm_instr()
3337 big = newSVpvn_flags(big_p, biglen,
3338 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3341 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3342 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3343 warn on undef, and we've already triggered a warning with the
3344 SvPV_const some lines above. We can't remove that, as we need to
3345 call some SvPV to trigger overloading early and find out if the
3347 This is all getting to messy. The API isn't quite clean enough,
3348 because data access has side effects.
3350 little = newSVpvn_flags(little_p, llen,
3351 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3352 little_p = SvPVX(little);
3356 offset = is_index ? 0 : biglen;
3358 if (big_utf8 && offset > 0)
3359 sv_pos_u2b(big, &offset, 0);
3365 else if (offset > (I32)biglen)
3367 if (!(little_p = is_index
3368 ? fbm_instr((unsigned char*)big_p + offset,
3369 (unsigned char*)big_p + biglen, little, 0)
3370 : rninstr(big_p, big_p + offset,
3371 little_p, little_p + llen)))
3374 retval = little_p - big_p;
3375 if (retval > 0 && big_utf8)
3376 sv_pos_b2u(big, &retval);
3381 PUSHi(retval + arybase);
3387 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3388 if (SvTAINTED(MARK[1]))
3389 TAINT_PROPER("sprintf");
3390 do_sprintf(TARG, SP-MARK, MARK+1);
3391 TAINT_IF(SvTAINTED(TARG));
3403 const U8 *s = (U8*)SvPV_const(argsv, len);
3405 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3406 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3407 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3411 XPUSHu(DO_UTF8(argsv) ?
3412 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3424 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3426 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3428 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3430 (void) POPs; /* Ignore the argument value. */
3431 value = UNICODE_REPLACEMENT;
3437 SvUPGRADE(TARG,SVt_PV);
3439 if (value > 255 && !IN_BYTES) {
3440 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3441 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3442 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3444 (void)SvPOK_only(TARG);
3453 *tmps++ = (char)value;
3455 (void)SvPOK_only(TARG);
3457 if (PL_encoding && !IN_BYTES) {
3458 sv_recode_to_utf8(TARG, PL_encoding);
3460 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3461 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3465 *tmps++ = (char)value;
3481 const char *tmps = SvPV_const(left, len);
3483 if (DO_UTF8(left)) {
3484 /* If Unicode, try to downgrade.
3485 * If not possible, croak.
3486 * Yes, we made this up. */
3487 SV* const tsv = sv_2mortal(newSVsv(left));
3490 sv_utf8_downgrade(tsv, FALSE);
3491 tmps = SvPV_const(tsv, len);
3493 # ifdef USE_ITHREADS
3495 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3496 /* This should be threadsafe because in ithreads there is only
3497 * one thread per interpreter. If this would not be true,
3498 * we would need a mutex to protect this malloc. */
3499 PL_reentrant_buffer->_crypt_struct_buffer =
3500 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3501 #if defined(__GLIBC__) || defined(__EMX__)
3502 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3503 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3504 /* work around glibc-2.2.5 bug */
3505 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3509 # endif /* HAS_CRYPT_R */
3510 # endif /* USE_ITHREADS */
3512 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3514 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3520 "The crypt() function is unimplemented due to excessive paranoia.");
3532 bool inplace = TRUE;
3534 const int op_type = PL_op->op_type;
3537 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3543 s = (const U8*)SvPV_nomg_const(source, slen);
3545 if (ckWARN(WARN_UNINITIALIZED))
3546 report_uninit(source);
3551 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3553 utf8_to_uvchr(s, &ulen);
3554 if (op_type == OP_UCFIRST) {
3555 toTITLE_utf8(s, tmpbuf, &tculen);
3557 toLOWER_utf8(s, tmpbuf, &tculen);
3559 /* If the two differ, we definately cannot do inplace. */
3560 inplace = (ulen == tculen);
3561 need = slen + 1 - ulen + tculen;
3567 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3568 /* We can convert in place. */
3571 s = d = (U8*)SvPV_force_nomg(source, slen);
3577 SvUPGRADE(dest, SVt_PV);
3578 d = (U8*)SvGROW(dest, need);
3579 (void)SvPOK_only(dest);
3588 /* slen is the byte length of the whole SV.
3589 * ulen is the byte length of the original Unicode character
3590 * stored as UTF-8 at s.
3591 * tculen is the byte length of the freshly titlecased (or
3592 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3593 * We first set the result to be the titlecased (/lowercased)
3594 * character, and then append the rest of the SV data. */
3595 sv_setpvn(dest, (char*)tmpbuf, tculen);
3597 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3601 Copy(tmpbuf, d, tculen, U8);
3602 SvCUR_set(dest, need - 1);
3607 if (IN_LOCALE_RUNTIME) {
3610 *d = (op_type == OP_UCFIRST)
3611 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3614 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3616 /* See bug #39028 */
3624 /* This will copy the trailing NUL */
3625 Copy(s + 1, d + 1, slen, U8);
3626 SvCUR_set(dest, need - 1);
3633 /* There's so much setup/teardown code common between uc and lc, I wonder if
3634 it would be worth merging the two, and just having a switch outside each
3635 of the three tight loops. */
3649 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3650 && SvTEMP(source) && !DO_UTF8(source)) {
3651 /* We can convert in place. */
3654 s = d = (U8*)SvPV_force_nomg(source, len);
3661 /* The old implementation would copy source into TARG at this point.
3662 This had the side effect that if source was undef, TARG was now
3663 an undefined SV with PADTMP set, and they don't warn inside
3664 sv_2pv_flags(). However, we're now getting the PV direct from
3665 source, which doesn't have PADTMP set, so it would warn. Hence the
3669 s = (const U8*)SvPV_nomg_const(source, len);
3671 if (ckWARN(WARN_UNINITIALIZED))
3672 report_uninit(source);
3678 SvUPGRADE(dest, SVt_PV);
3679 d = (U8*)SvGROW(dest, min);
3680 (void)SvPOK_only(dest);
3685 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3686 to check DO_UTF8 again here. */
3688 if (DO_UTF8(source)) {
3689 const U8 *const send = s + len;
3690 U8 tmpbuf[UTF8_MAXBYTES+1];
3693 const STRLEN u = UTF8SKIP(s);
3696 toUPPER_utf8(s, tmpbuf, &ulen);
3697 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3698 /* If the eventually required minimum size outgrows
3699 * the available space, we need to grow. */
3700 const UV o = d - (U8*)SvPVX_const(dest);
3702 /* If someone uppercases one million U+03B0s we SvGROW() one
3703 * million times. Or we could try guessing how much to
3704 allocate without allocating too much. Such is life. */
3706 d = (U8*)SvPVX(dest) + o;
3708 Copy(tmpbuf, d, ulen, U8);
3714 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3717 const U8 *const send = s + len;
3718 if (IN_LOCALE_RUNTIME) {
3721 for (; s < send; d++, s++)
3722 *d = toUPPER_LC(*s);
3725 for (; s < send; d++, s++)
3729 if (source != dest) {
3731 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3751 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3752 && SvTEMP(source) && !DO_UTF8(source)) {
3753 /* We can convert in place. */
3756 s = d = (U8*)SvPV_force_nomg(source, len);
3763 /* The old implementation would copy source into TARG at this point.
3764 This had the side effect that if source was undef, TARG was now
3765 an undefined SV with PADTMP set, and they don't warn inside
3766 sv_2pv_flags(). However, we're now getting the PV direct from
3767 source, which doesn't have PADTMP set, so it would warn. Hence the
3771 s = (const U8*)SvPV_nomg_const(source, len);
3773 if (ckWARN(WARN_UNINITIALIZED))
3774 report_uninit(source);
3780 SvUPGRADE(dest, SVt_PV);
3781 d = (U8*)SvGROW(dest, min);
3782 (void)SvPOK_only(dest);
3787 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3788 to check DO_UTF8 again here. */
3790 if (DO_UTF8(source)) {
3791 const U8 *const send = s + len;
3792 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3795 const STRLEN u = UTF8SKIP(s);
3797 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3799 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3800 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3803 * Now if the sigma is NOT followed by
3804 * /$ignorable_sequence$cased_letter/;
3805 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3806 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3807 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3808 * then it should be mapped to 0x03C2,
3809 * (GREEK SMALL LETTER FINAL SIGMA),
3810 * instead of staying 0x03A3.
3811 * "should be": in other words, this is not implemented yet.
3812 * See lib/unicore/SpecialCasing.txt.
3815 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3816 /* If the eventually required minimum size outgrows
3817 * the available space, we need to grow. */
3818 const UV o = d - (U8*)SvPVX_const(dest);
3820 /* If someone lowercases one million U+0130s we SvGROW() one
3821 * million times. Or we could try guessing how much to
3822 allocate without allocating too much. Such is life. */
3824 d = (U8*)SvPVX(dest) + o;
3826 Copy(tmpbuf, d, ulen, U8);
3832 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3835 const U8 *const send = s + len;
3836 if (IN_LOCALE_RUNTIME) {
3839 for (; s < send; d++, s++)
3840 *d = toLOWER_LC(*s);
3843 for (; s < send; d++, s++)
3847 if (source != dest) {
3849 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3859 SV * const sv = TOPs;
3861 register const char *s = SvPV_const(sv,len);
3863 SvUTF8_off(TARG); /* decontaminate */
3866 SvUPGRADE(TARG, SVt_PV);
3867 SvGROW(TARG, (len * 2) + 1);
3871 if (UTF8_IS_CONTINUED(*s)) {
3872 STRLEN ulen = UTF8SKIP(s);
3896 SvCUR_set(TARG, d - SvPVX_const(TARG));
3897 (void)SvPOK_only_UTF8(TARG);
3900 sv_setpvn(TARG, s, len);
3909 dVAR; dSP; dMARK; dORIGMARK;
3910 register AV *const av = MUTABLE_AV(POPs);
3911 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3913 if (SvTYPE(av) == SVt_PVAV) {
3914 const I32 arybase = CopARYBASE_get(PL_curcop);
3915 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3918 for (svp = MARK + 1; svp <= SP; svp++) {
3919 const I32 elem = SvIV(*svp);
3923 if (max > AvMAX(av))
3926 while (++MARK <= SP) {
3928 I32 elem = SvIV(*MARK);
3932 svp = av_fetch(av, elem, lval);
3934 if (!svp || *svp == &PL_sv_undef)
3935 DIE(aTHX_ PL_no_aelem, elem);
3936 if (PL_op->op_private & OPpLVAL_INTRO)
3937 save_aelem(av, elem, svp);
3939 *MARK = svp ? *svp : &PL_sv_undef;
3942 if (GIMME != G_ARRAY) {
3944 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3954 AV *array = MUTABLE_AV(POPs);
3955 const I32 gimme = GIMME_V;
3956 IV *iterp = Perl_av_iter_p(aTHX_ array);
3957 const IV current = (*iterp)++;
3959 if (current > av_len(array)) {
3961 if (gimme == G_SCALAR)
3968 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3969 if (gimme == G_ARRAY) {
3970 SV **const element = av_fetch(array, current, 0);
3971 PUSHs(element ? *element : &PL_sv_undef);
3980 AV *array = MUTABLE_AV(POPs);
3981 const I32 gimme = GIMME_V;
3983 *Perl_av_iter_p(aTHX_ array) = 0;
3985 if (gimme == G_SCALAR) {
3987 PUSHi(av_len(array) + 1);
3989 else if (gimme == G_ARRAY) {
3990 IV n = Perl_av_len(aTHX_ array);
3991 IV i = CopARYBASE_get(PL_curcop);
3995 if (PL_op->op_type == OP_AKEYS) {
3997 for (; i <= n; i++) {
4002 for (i = 0; i <= n; i++) {
4003 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4004 PUSHs(elem ? *elem : &PL_sv_undef);
4011 /* Associative arrays. */
4017 HV * hash = MUTABLE_HV(POPs);
4019 const I32 gimme = GIMME_V;
4022 /* might clobber stack_sp */
4023 entry = hv_iternext(hash);
4028 SV* const sv = hv_iterkeysv(entry);
4029 PUSHs(sv); /* won't clobber stack_sp */
4030 if (gimme == G_ARRAY) {
4033 /* might clobber stack_sp */
4034 val = hv_iterval(hash, entry);
4039 else if (gimme == G_SCALAR)
4049 const I32 gimme = GIMME_V;
4050 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4052 if (PL_op->op_private & OPpSLICE) {
4054 HV * const hv = MUTABLE_HV(POPs);
4055 const U32 hvtype = SvTYPE(hv);
4056 if (hvtype == SVt_PVHV) { /* hash element */
4057 while (++MARK <= SP) {
4058 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4059 *MARK = sv ? sv : &PL_sv_undef;
4062 else if (hvtype == SVt_PVAV) { /* array element */
4063 if (PL_op->op_flags & OPf_SPECIAL) {
4064 while (++MARK <= SP) {
4065 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4066 *MARK = sv ? sv : &PL_sv_undef;
4071 DIE(aTHX_ "Not a HASH reference");
4074 else if (gimme == G_SCALAR) {
4079 *++MARK = &PL_sv_undef;
4085 HV * const hv = MUTABLE_HV(POPs);
4087 if (SvTYPE(hv) == SVt_PVHV)
4088 sv = hv_delete_ent(hv, keysv, discard, 0);
4089 else if (SvTYPE(hv) == SVt_PVAV) {
4090 if (PL_op->op_flags & OPf_SPECIAL)
4091 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4093 DIE(aTHX_ "panic: avhv_delete no longer supported");
4096 DIE(aTHX_ "Not a HASH reference");
4112 if (PL_op->op_private & OPpEXISTS_SUB) {
4114 SV * const sv = POPs;
4115 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4118 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4123 hv = MUTABLE_HV(POPs);
4124 if (SvTYPE(hv) == SVt_PVHV) {
4125 if (hv_exists_ent(hv, tmpsv, 0))
4128 else if (SvTYPE(hv) == SVt_PVAV) {
4129 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4130 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4135 DIE(aTHX_ "Not a HASH reference");
4142 dVAR; dSP; dMARK; dORIGMARK;
4143 register HV * const hv = MUTABLE_HV(POPs);
4144 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4145 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4146 bool other_magic = FALSE;
4152 other_magic = mg_find((const SV *)hv, PERL_MAGIC_env) ||
4153 ((mg = mg_find((const SV *)hv, PERL_MAGIC_tied))
4154 /* Try to preserve the existenceness of a tied hash
4155 * element by using EXISTS and DELETE if possible.
4156 * Fallback to FETCH and STORE otherwise */
4157 && (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(hv), mg))))
4158 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4159 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4162 while (++MARK <= SP) {
4163 SV * const keysv = *MARK;
4166 bool preeminent = FALSE;
4169 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4170 hv_exists_ent(hv, keysv, 0);
4173 he = hv_fetch_ent(hv, keysv, lval, 0);
4174 svp = he ? &HeVAL(he) : NULL;
4177 if (!svp || *svp == &PL_sv_undef) {
4178 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4181 if (HvNAME_get(hv) && isGV(*svp))
4182 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4185 save_helem_flags(hv, keysv, svp,
4186 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4189 const char * const key = SvPV_const(keysv, keylen);
4190 SAVEDELETE(hv, savepvn(key,keylen),
4191 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4196 *MARK = svp ? *svp : &PL_sv_undef;
4198 if (GIMME != G_ARRAY) {
4200 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4206 /* List operators. */
4211 if (GIMME != G_ARRAY) {
4213 *MARK = *SP; /* unwanted list, return last item */
4215 *MARK = &PL_sv_undef;
4225 SV ** const lastrelem = PL_stack_sp;
4226 SV ** const lastlelem = PL_stack_base + POPMARK;
4227 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4228 register SV ** const firstrelem = lastlelem + 1;
4229 const I32 arybase = CopARYBASE_get(PL_curcop);
4230 I32 is_something_there = FALSE;
4232 register const I32 max = lastrelem - lastlelem;
4233 register SV **lelem;
4235 if (GIMME != G_ARRAY) {
4236 I32 ix = SvIV(*lastlelem);
4241 if (ix < 0 || ix >= max)
4242 *firstlelem = &PL_sv_undef;
4244 *firstlelem = firstrelem[ix];
4250 SP = firstlelem - 1;
4254 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4255 I32 ix = SvIV(*lelem);
4260 if (ix < 0 || ix >= max)
4261 *lelem = &PL_sv_undef;
4263 is_something_there = TRUE;
4264 if (!(*lelem = firstrelem[ix]))
4265 *lelem = &PL_sv_undef;
4268 if (is_something_there)
4271 SP = firstlelem - 1;
4277 dVAR; dSP; dMARK; dORIGMARK;
4278 const I32 items = SP - MARK;
4279 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4280 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4281 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4282 ? newRV_noinc(av) : av);
4288 dVAR; dSP; dMARK; dORIGMARK;
4289 HV* const hv = newHV();
4292 SV * const key = *++MARK;
4293 SV * const val = newSV(0);
4295 sv_setsv(val, *++MARK);
4296 else if (ckWARN(WARN_MISC))
4297 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4298 (void)hv_store_ent(hv,key,val,0);
4301 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4302 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4308 dVAR; dSP; dMARK; dORIGMARK;
4309 register AV *ary = MUTABLE_AV(*++MARK);
4313 register I32 offset;
4314 register I32 length;
4318 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4321 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4325 call_method("SPLICE",GIMME_V);
4334 offset = i = SvIV(*MARK);
4336 offset += AvFILLp(ary) + 1;
4338 offset -= CopARYBASE_get(PL_curcop);
4340 DIE(aTHX_ PL_no_aelem, i);
4342 length = SvIVx(*MARK++);
4344 length += AvFILLp(ary) - offset + 1;
4350 length = AvMAX(ary) + 1; /* close enough to infinity */
4354 length = AvMAX(ary) + 1;
4356 if (offset > AvFILLp(ary) + 1) {
4357 if (ckWARN(WARN_MISC))
4358 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4359 offset = AvFILLp(ary) + 1;
4361 after = AvFILLp(ary) + 1 - (offset + length);
4362 if (after < 0) { /* not that much array */
4363 length += after; /* offset+length now in array */
4369 /* At this point, MARK .. SP-1 is our new LIST */
4372 diff = newlen - length;
4373 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4376 /* make new elements SVs now: avoid problems if they're from the array */
4377 for (dst = MARK, i = newlen; i; i--) {
4378 SV * const h = *dst;
4379 *dst++ = newSVsv(h);
4382 if (diff < 0) { /* shrinking the area */
4383 SV **tmparyval = NULL;
4385 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4386 Copy(MARK, tmparyval, newlen, SV*);
4389 MARK = ORIGMARK + 1;
4390 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4391 MEXTEND(MARK, length);
4392 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4394 EXTEND_MORTAL(length);
4395 for (i = length, dst = MARK; i; i--) {
4396 sv_2mortal(*dst); /* free them eventualy */
4403 *MARK = AvARRAY(ary)[offset+length-1];
4406 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4407 SvREFCNT_dec(*dst++); /* free them now */
4410 AvFILLp(ary) += diff;
4412 /* pull up or down? */
4414 if (offset < after) { /* easier to pull up */
4415 if (offset) { /* esp. if nothing to pull */
4416 src = &AvARRAY(ary)[offset-1];
4417 dst = src - diff; /* diff is negative */
4418 for (i = offset; i > 0; i--) /* can't trust Copy */
4422 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4426 if (after) { /* anything to pull down? */
4427 src = AvARRAY(ary) + offset + length;
4428 dst = src + diff; /* diff is negative */
4429 Move(src, dst, after, SV*);
4431 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4432 /* avoid later double free */
4436 dst[--i] = &PL_sv_undef;
4439 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4440 Safefree(tmparyval);
4443 else { /* no, expanding (or same) */
4444 SV** tmparyval = NULL;
4446 Newx(tmparyval, length, SV*); /* so remember deletion */
4447 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4450 if (diff > 0) { /* expanding */
4451 /* push up or down? */
4452 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4456 Move(src, dst, offset, SV*);
4458 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4460 AvFILLp(ary) += diff;
4463 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4464 av_extend(ary, AvFILLp(ary) + diff);
4465 AvFILLp(ary) += diff;
4468 dst = AvARRAY(ary) + AvFILLp(ary);
4470 for (i = after; i; i--) {
4478 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4481 MARK = ORIGMARK + 1;
4482 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4484 Copy(tmparyval, MARK, length, SV*);
4486 EXTEND_MORTAL(length);
4487 for (i = length, dst = MARK; i; i--) {
4488 sv_2mortal(*dst); /* free them eventualy */
4495 else if (length--) {
4496 *MARK = tmparyval[length];
4499 while (length-- > 0)
4500 SvREFCNT_dec(tmparyval[length]);
4504 *MARK = &PL_sv_undef;
4505 Safefree(tmparyval);
4513 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4514 register AV * const ary = MUTABLE_AV(*++MARK);
4515 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4518 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4522 call_method("PUSH",G_SCALAR|G_DISCARD);
4526 PUSHi( AvFILL(ary) + 1 );
4529 PL_delaymagic = DM_DELAY;
4530 for (++MARK; MARK <= SP; MARK++) {
4531 SV * const sv = newSV(0);
4533 sv_setsv(sv, *MARK);
4534 av_store(ary, AvFILLp(ary)+1, sv);
4536 if (PL_delaymagic & DM_ARRAY)
4537 mg_set(MUTABLE_SV(ary));
4541 PUSHi( AvFILLp(ary) + 1 );
4550 AV * const av = MUTABLE_AV(POPs);
4551 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4555 (void)sv_2mortal(sv);
4562 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4563 register AV *ary = MUTABLE_AV(*++MARK);
4564 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4567 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4571 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4577 av_unshift(ary, SP - MARK);
4579 SV * const sv = newSVsv(*++MARK);
4580 (void)av_store(ary, i++, sv);
4584 PUSHi( AvFILL(ary) + 1 );
4591 SV ** const oldsp = SP;
4593 if (GIMME == G_ARRAY) {
4596 register SV * const tmp = *MARK;
4600 /* safe as long as stack cannot get extended in the above */
4605 register char *down;
4609 PADOFFSET padoff_du;
4611 SvUTF8_off(TARG); /* decontaminate */
4613 do_join(TARG, &PL_sv_no, MARK, SP);
4615 sv_setsv(TARG, (SP > MARK)
4617 : (padoff_du = find_rundefsvoffset(),
4618 (padoff_du == NOT_IN_PAD
4619 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4620 ? DEFSV : PAD_SVl(padoff_du)));
4622 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4623 report_uninit(TARG);
4626 up = SvPV_force(TARG, len);
4628 if (DO_UTF8(TARG)) { /* first reverse each character */
4629 U8* s = (U8*)SvPVX(TARG);
4630 const U8* send = (U8*)(s + len);
4632 if (UTF8_IS_INVARIANT(*s)) {
4637 if (!utf8_to_uvchr(s, 0))
4641 down = (char*)(s - 1);
4642 /* reverse this character */
4646 *down-- = (char)tmp;
4652 down = SvPVX(TARG) + len - 1;
4656 *down-- = (char)tmp;
4658 (void)SvPOK_only_UTF8(TARG);
4670 register IV limit = POPi; /* note, negative is forever */
4671 SV * const sv = POPs;
4673 register const char *s = SvPV_const(sv, len);
4674 const bool do_utf8 = DO_UTF8(sv);
4675 const char *strend = s + len;
4677 register REGEXP *rx;
4679 register const char *m;
4681 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4682 I32 maxiters = slen + 10;
4684 const I32 origlimit = limit;
4687 const I32 gimme = GIMME_V;
4688 const I32 oldsave = PL_savestack_ix;
4689 U32 make_mortal = SVs_TEMP;
4694 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4699 DIE(aTHX_ "panic: pp_split");
4702 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4703 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4705 RX_MATCH_UTF8_set(rx, do_utf8);
4708 if (pm->op_pmreplrootu.op_pmtargetoff) {
4709 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
4712 if (pm->op_pmreplrootu.op_pmtargetgv) {
4713 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4716 else if (gimme != G_ARRAY)
4717 ary = GvAVn(PL_defgv);
4720 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4726 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
4728 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
4735 for (i = AvFILLp(ary); i >= 0; i--)
4736 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4738 /* temporarily switch stacks */
4739 SAVESWITCHSTACK(PL_curstack, ary);
4743 base = SP - PL_stack_base;
4745 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4747 while (*s == ' ' || is_utf8_space((U8*)s))
4750 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4751 while (isSPACE_LC(*s))
4759 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4764 limit = maxiters + 2;
4765 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4768 /* this one uses 'm' and is a negative test */
4770 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4771 const int t = UTF8SKIP(m);
4772 /* is_utf8_space returns FALSE for malform utf8 */
4778 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4779 while (m < strend && !isSPACE_LC(*m))
4782 while (m < strend && !isSPACE(*m))
4788 dstr = newSVpvn_flags(s, m-s,
4789 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4792 /* skip the whitespace found last */
4794 s = m + UTF8SKIP(m);
4798 /* this one uses 's' and is a positive test */
4800 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4802 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4803 while (s < strend && isSPACE_LC(*s))
4806 while (s < strend && isSPACE(*s))
4811 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4813 for (m = s; m < strend && *m != '\n'; m++)
4818 dstr = newSVpvn_flags(s, m-s,
4819 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4824 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4826 Pre-extend the stack, either the number of bytes or
4827 characters in the string or a limited amount, triggered by:
4829 my ($x, $y) = split //, $str;
4833 const U32 items = limit - 1;
4841 /* keep track of how many bytes we skip over */
4844 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
4853 dstr = newSVpvn(s, 1);
4867 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4868 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4869 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4870 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4871 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4872 SV * const csv = CALLREG_INTUIT_STRING(rx);
4874 len = RX_MINLENRET(rx);
4875 if (len == 1 && !RX_UTF8(rx) && !tail) {
4876 const char c = *SvPV_nolen_const(csv);
4878 for (m = s; m < strend && *m != c; m++)
4882 dstr = newSVpvn_flags(s, m-s,
4883 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4885 /* The rx->minlen is in characters but we want to step
4886 * s ahead by bytes. */
4888 s = (char*)utf8_hop((U8*)m, len);
4890 s = m + len; /* Fake \n at the end */
4894 while (s < strend && --limit &&
4895 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4896 csv, multiline ? FBMrf_MULTILINE : 0)) )
4898 dstr = newSVpvn_flags(s, m-s,
4899 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4901 /* The rx->minlen is in characters but we want to step
4902 * s ahead by bytes. */
4904 s = (char*)utf8_hop((U8*)m, len);
4906 s = m + len; /* Fake \n at the end */
4911 maxiters += slen * RX_NPARENS(rx);
4912 while (s < strend && --limit)
4916 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4919 if (rex_return == 0)
4921 TAINT_IF(RX_MATCH_TAINTED(rx));
4922 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4925 orig = RX_SUBBEG(rx);
4927 strend = s + (strend - m);
4929 m = RX_OFFS(rx)[0].start + orig;
4930 dstr = newSVpvn_flags(s, m-s,
4931 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4933 if (RX_NPARENS(rx)) {
4935 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4936 s = RX_OFFS(rx)[i].start + orig;
4937 m = RX_OFFS(rx)[i].end + orig;
4939 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4940 parens that didn't match -- they should be set to
4941 undef, not the empty string */
4942 if (m >= orig && s >= orig) {
4943 dstr = newSVpvn_flags(s, m-s,
4944 (do_utf8 ? SVf_UTF8 : 0)
4948 dstr = &PL_sv_undef; /* undef, not "" */
4952 s = RX_OFFS(rx)[0].end + orig;
4956 iters = (SP - PL_stack_base) - base;
4957 if (iters > maxiters)
4958 DIE(aTHX_ "Split loop");
4960 /* keep field after final delim? */
4961 if (s < strend || (iters && origlimit)) {
4962 const STRLEN l = strend - s;
4963 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4967 else if (!origlimit) {
4968 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4969 if (TOPs && !make_mortal)
4972 *SP-- = &PL_sv_undef;
4977 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4981 if (SvSMAGICAL(ary)) {
4983 mg_set(MUTABLE_SV(ary));
4986 if (gimme == G_ARRAY) {
4988 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4996 call_method("PUSH",G_SCALAR|G_DISCARD);
4999 if (gimme == G_ARRAY) {
5001 /* EXTEND should not be needed - we just popped them */
5003 for (i=0; i < iters; i++) {
5004 SV **svp = av_fetch(ary, i, FALSE);
5005 PUSHs((svp) ? *svp : &PL_sv_undef);
5012 if (gimme == G_ARRAY)
5024 SV *const sv = PAD_SVl(PL_op->op_targ);
5026 if (SvPADSTALE(sv)) {
5029 RETURNOP(cLOGOP->op_other);
5031 RETURNOP(cLOGOP->op_next);
5041 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5042 || SvTYPE(retsv) == SVt_PVCV) {
5043 retsv = refto(retsv);
5050 PP(unimplemented_op)
5053 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5059 * c-indentation-style: bsd
5061 * indent-tabs-mode: t
5064 * ex: set ts=8 sts=4 sw=4 noet: