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++)
2579 /* integer versions of some of the above */
2583 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2586 SETi( left * right );
2594 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2598 DIE(aTHX_ "Illegal division by zero");
2601 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2605 value = num / value;
2611 #if defined(__GLIBC__) && IVSIZE == 8
2618 /* This is the vanilla old i_modulo. */
2619 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2623 DIE(aTHX_ "Illegal modulus zero");
2624 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2628 SETi( left % right );
2633 #if defined(__GLIBC__) && IVSIZE == 8
2638 /* This is the i_modulo with the workaround for the _moddi3 bug
2639 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2640 * See below for pp_i_modulo. */
2641 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2645 DIE(aTHX_ "Illegal modulus zero");
2646 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2650 SETi( left % PERL_ABS(right) );
2657 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2661 DIE(aTHX_ "Illegal modulus zero");
2662 /* The assumption is to use hereafter the old vanilla version... */
2664 PL_ppaddr[OP_I_MODULO] =
2666 /* .. but if we have glibc, we might have a buggy _moddi3
2667 * (at least glicb 2.2.5 is known to have this bug), in other
2668 * words our integer modulus with negative quad as the second
2669 * argument might be broken. Test for this and re-patch the
2670 * opcode dispatch table if that is the case, remembering to
2671 * also apply the workaround so that this first round works
2672 * right, too. See [perl #9402] for more information. */
2676 /* Cannot do this check with inlined IV constants since
2677 * that seems to work correctly even with the buggy glibc. */
2679 /* Yikes, we have the bug.
2680 * Patch in the workaround version. */
2682 PL_ppaddr[OP_I_MODULO] =
2683 &Perl_pp_i_modulo_1;
2684 /* Make certain we work right this time, too. */
2685 right = PERL_ABS(right);
2688 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2692 SETi( left % right );
2700 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2703 SETi( left + right );
2710 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2713 SETi( left - right );
2720 dVAR; dSP; tryAMAGICbinSET(lt,0);
2723 SETs(boolSV(left < right));
2730 dVAR; dSP; tryAMAGICbinSET(gt,0);
2733 SETs(boolSV(left > right));
2740 dVAR; dSP; tryAMAGICbinSET(le,0);
2743 SETs(boolSV(left <= right));
2750 dVAR; dSP; tryAMAGICbinSET(ge,0);
2753 SETs(boolSV(left >= right));
2760 dVAR; dSP; tryAMAGICbinSET(eq,0);
2763 SETs(boolSV(left == right));
2770 dVAR; dSP; tryAMAGICbinSET(ne,0);
2773 SETs(boolSV(left != right));
2780 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2787 else if (left < right)
2798 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2803 /* High falutin' math. */
2807 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2810 SETn(Perl_atan2(left, right));
2818 int amg_type = sin_amg;
2819 const char *neg_report = NULL;
2820 NV (*func)(NV) = Perl_sin;
2821 const int op_type = PL_op->op_type;
2838 amg_type = sqrt_amg;
2840 neg_report = "sqrt";
2844 tryAMAGICun_var(amg_type);
2846 const NV value = POPn;
2848 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2849 SET_NUMERIC_STANDARD();
2850 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2853 XPUSHn(func(value));
2858 /* Support Configure command-line overrides for rand() functions.
2859 After 5.005, perhaps we should replace this by Configure support
2860 for drand48(), random(), or rand(). For 5.005, though, maintain
2861 compatibility by calling rand() but allow the user to override it.
2862 See INSTALL for details. --Andy Dougherty 15 July 1998
2864 /* Now it's after 5.005, and Configure supports drand48() and random(),
2865 in addition to rand(). So the overrides should not be needed any more.
2866 --Jarkko Hietaniemi 27 September 1998
2869 #ifndef HAS_DRAND48_PROTO
2870 extern double drand48 (void);
2883 if (!PL_srand_called) {
2884 (void)seedDrand01((Rand_seed_t)seed());
2885 PL_srand_called = TRUE;
2895 const UV anum = (MAXARG < 1) ? seed() : POPu;
2896 (void)seedDrand01((Rand_seed_t)anum);
2897 PL_srand_called = TRUE;
2904 dVAR; dSP; dTARGET; tryAMAGICun(int);
2906 SV * const sv = sv_2num(TOPs);
2907 const IV iv = SvIV(sv);
2908 /* XXX it's arguable that compiler casting to IV might be subtly
2909 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2910 else preferring IV has introduced a subtle behaviour change bug. OTOH
2911 relying on floating point to be accurate is a bug. */
2916 else if (SvIOK(sv)) {
2923 const NV value = SvNV(sv);
2925 if (value < (NV)UV_MAX + 0.5) {
2928 SETn(Perl_floor(value));
2932 if (value > (NV)IV_MIN - 0.5) {
2935 SETn(Perl_ceil(value));
2945 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2947 SV * const sv = sv_2num(TOPs);
2948 /* This will cache the NV value if string isn't actually integer */
2949 const IV iv = SvIV(sv);
2954 else if (SvIOK(sv)) {
2955 /* IVX is precise */
2957 SETu(SvUV(sv)); /* force it to be numeric only */
2965 /* 2s complement assumption. Also, not really needed as
2966 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2972 const NV value = SvNV(sv);
2986 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2990 SV* const sv = POPs;
2992 tmps = (SvPV_const(sv, len));
2994 /* If Unicode, try to downgrade
2995 * If not possible, croak. */
2996 SV* const tsv = sv_2mortal(newSVsv(sv));
2999 sv_utf8_downgrade(tsv, FALSE);
3000 tmps = SvPV_const(tsv, len);
3002 if (PL_op->op_type == OP_HEX)
3005 while (*tmps && len && isSPACE(*tmps))
3011 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3013 else if (*tmps == 'b')
3014 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3016 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3018 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3032 SV * const sv = TOPs;
3034 if (SvGAMAGIC(sv)) {
3035 /* For an overloaded or magic scalar, we can't know in advance if
3036 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3037 it likes to cache the length. Maybe that should be a documented
3042 = sv_2pv_flags(sv, &len,
3043 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3047 else if (DO_UTF8(sv)) {
3048 SETi(utf8_length((U8*)p, (U8*)p + len));
3052 } else if (SvOK(sv)) {
3053 /* Neither magic nor overloaded. */
3055 SETi(sv_len_utf8(sv));
3074 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3076 const I32 arybase = CopARYBASE_get(PL_curcop);
3078 const char *repl = NULL;
3080 const int num_args = PL_op->op_private & 7;
3081 bool repl_need_utf8_upgrade = FALSE;
3082 bool repl_is_utf8 = FALSE;
3084 SvTAINTED_off(TARG); /* decontaminate */
3085 SvUTF8_off(TARG); /* decontaminate */
3089 repl = SvPV_const(repl_sv, repl_len);
3090 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3100 sv_utf8_upgrade(sv);
3102 else if (DO_UTF8(sv))
3103 repl_need_utf8_upgrade = TRUE;
3105 tmps = SvPV_const(sv, curlen);
3107 utf8_curlen = sv_len_utf8(sv);
3108 if (utf8_curlen == curlen)
3111 curlen = utf8_curlen;
3116 if (pos >= arybase) {
3134 else if (len >= 0) {
3136 if (rem > (I32)curlen)
3151 Perl_croak(aTHX_ "substr outside of string");
3152 if (ckWARN(WARN_SUBSTR))
3153 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3157 const I32 upos = pos;
3158 const I32 urem = rem;
3160 sv_pos_u2b(sv, &pos, &rem);
3162 /* we either return a PV or an LV. If the TARG hasn't been used
3163 * before, or is of that type, reuse it; otherwise use a mortal
3164 * instead. Note that LVs can have an extended lifetime, so also
3165 * dont reuse if refcount > 1 (bug #20933) */
3166 if (SvTYPE(TARG) > SVt_NULL) {
3167 if ( (SvTYPE(TARG) == SVt_PVLV)
3168 ? (!lvalue || SvREFCNT(TARG) > 1)
3171 TARG = sv_newmortal();
3175 sv_setpvn(TARG, tmps, rem);
3176 #ifdef USE_LOCALE_COLLATE
3177 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3182 SV* repl_sv_copy = NULL;
3184 if (repl_need_utf8_upgrade) {
3185 repl_sv_copy = newSVsv(repl_sv);
3186 sv_utf8_upgrade(repl_sv_copy);
3187 repl = SvPV_const(repl_sv_copy, repl_len);
3188 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3192 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3196 SvREFCNT_dec(repl_sv_copy);
3198 else if (lvalue) { /* it's an lvalue! */
3199 if (!SvGMAGICAL(sv)) {
3201 SvPV_force_nolen(sv);
3202 if (ckWARN(WARN_SUBSTR))
3203 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3204 "Attempt to use reference as lvalue in substr");
3206 if (isGV_with_GP(sv))
3207 SvPV_force_nolen(sv);
3208 else if (SvOK(sv)) /* is it defined ? */
3209 (void)SvPOK_only_UTF8(sv);
3211 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3214 if (SvTYPE(TARG) < SVt_PVLV) {
3215 sv_upgrade(TARG, SVt_PVLV);
3216 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3220 if (LvTARG(TARG) != sv) {
3222 SvREFCNT_dec(LvTARG(TARG));
3223 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3225 LvTARGOFF(TARG) = upos;
3226 LvTARGLEN(TARG) = urem;
3230 PUSHs(TARG); /* avoid SvSETMAGIC here */
3237 register const IV size = POPi;
3238 register const IV offset = POPi;
3239 register SV * const src = POPs;
3240 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3242 SvTAINTED_off(TARG); /* decontaminate */
3243 if (lvalue) { /* it's an lvalue! */
3244 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3245 TARG = sv_newmortal();
3246 if (SvTYPE(TARG) < SVt_PVLV) {
3247 sv_upgrade(TARG, SVt_PVLV);
3248 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3251 if (LvTARG(TARG) != src) {
3253 SvREFCNT_dec(LvTARG(TARG));
3254 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3256 LvTARGOFF(TARG) = offset;
3257 LvTARGLEN(TARG) = size;
3260 sv_setuv(TARG, do_vecget(src, offset, size));
3276 const char *little_p;
3277 const I32 arybase = CopARYBASE_get(PL_curcop);
3280 const bool is_index = PL_op->op_type == OP_INDEX;
3283 /* arybase is in characters, like offset, so combine prior to the
3284 UTF-8 to bytes calculation. */
3285 offset = POPi - arybase;
3289 big_p = SvPV_const(big, biglen);
3290 little_p = SvPV_const(little, llen);
3292 big_utf8 = DO_UTF8(big);
3293 little_utf8 = DO_UTF8(little);
3294 if (big_utf8 ^ little_utf8) {
3295 /* One needs to be upgraded. */
3296 if (little_utf8 && !PL_encoding) {
3297 /* Well, maybe instead we might be able to downgrade the small
3299 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3302 /* If the large string is ISO-8859-1, and it's not possible to
3303 convert the small string to ISO-8859-1, then there is no
3304 way that it could be found anywhere by index. */
3309 /* At this point, pv is a malloc()ed string. So donate it to temp
3310 to ensure it will get free()d */
3311 little = temp = newSV(0);
3312 sv_usepvn(temp, pv, llen);
3313 little_p = SvPVX(little);
3316 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3319 sv_recode_to_utf8(temp, PL_encoding);
3321 sv_utf8_upgrade(temp);
3326 big_p = SvPV_const(big, biglen);
3329 little_p = SvPV_const(little, llen);
3333 if (SvGAMAGIC(big)) {
3334 /* Life just becomes a lot easier if I use a temporary here.
3335 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3336 will trigger magic and overloading again, as will fbm_instr()
3338 big = newSVpvn_flags(big_p, biglen,
3339 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3342 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3343 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3344 warn on undef, and we've already triggered a warning with the
3345 SvPV_const some lines above. We can't remove that, as we need to
3346 call some SvPV to trigger overloading early and find out if the
3348 This is all getting to messy. The API isn't quite clean enough,
3349 because data access has side effects.
3351 little = newSVpvn_flags(little_p, llen,
3352 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3353 little_p = SvPVX(little);
3357 offset = is_index ? 0 : biglen;
3359 if (big_utf8 && offset > 0)
3360 sv_pos_u2b(big, &offset, 0);
3366 else if (offset > (I32)biglen)
3368 if (!(little_p = is_index
3369 ? fbm_instr((unsigned char*)big_p + offset,
3370 (unsigned char*)big_p + biglen, little, 0)
3371 : rninstr(big_p, big_p + offset,
3372 little_p, little_p + llen)))
3375 retval = little_p - big_p;
3376 if (retval > 0 && big_utf8)
3377 sv_pos_b2u(big, &retval);
3382 PUSHi(retval + arybase);
3388 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3389 if (SvTAINTED(MARK[1]))
3390 TAINT_PROPER("sprintf");
3391 do_sprintf(TARG, SP-MARK, MARK+1);
3392 TAINT_IF(SvTAINTED(TARG));
3404 const U8 *s = (U8*)SvPV_const(argsv, len);
3406 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3407 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3408 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3412 XPUSHu(DO_UTF8(argsv) ?
3413 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3425 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3427 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3429 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3431 (void) POPs; /* Ignore the argument value. */
3432 value = UNICODE_REPLACEMENT;
3438 SvUPGRADE(TARG,SVt_PV);
3440 if (value > 255 && !IN_BYTES) {
3441 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3442 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3443 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3445 (void)SvPOK_only(TARG);
3454 *tmps++ = (char)value;
3456 (void)SvPOK_only(TARG);
3458 if (PL_encoding && !IN_BYTES) {
3459 sv_recode_to_utf8(TARG, PL_encoding);
3461 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3462 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3466 *tmps++ = (char)value;
3482 const char *tmps = SvPV_const(left, len);
3484 if (DO_UTF8(left)) {
3485 /* If Unicode, try to downgrade.
3486 * If not possible, croak.
3487 * Yes, we made this up. */
3488 SV* const tsv = sv_2mortal(newSVsv(left));
3491 sv_utf8_downgrade(tsv, FALSE);
3492 tmps = SvPV_const(tsv, len);
3494 # ifdef USE_ITHREADS
3496 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3497 /* This should be threadsafe because in ithreads there is only
3498 * one thread per interpreter. If this would not be true,
3499 * we would need a mutex to protect this malloc. */
3500 PL_reentrant_buffer->_crypt_struct_buffer =
3501 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3502 #if defined(__GLIBC__) || defined(__EMX__)
3503 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3504 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3505 /* work around glibc-2.2.5 bug */
3506 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3510 # endif /* HAS_CRYPT_R */
3511 # endif /* USE_ITHREADS */
3513 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3515 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3521 "The crypt() function is unimplemented due to excessive paranoia.");
3533 bool inplace = TRUE;
3535 const int op_type = PL_op->op_type;
3538 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3544 s = (const U8*)SvPV_nomg_const(source, slen);
3546 if (ckWARN(WARN_UNINITIALIZED))
3547 report_uninit(source);
3552 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3554 utf8_to_uvchr(s, &ulen);
3555 if (op_type == OP_UCFIRST) {
3556 toTITLE_utf8(s, tmpbuf, &tculen);
3558 toLOWER_utf8(s, tmpbuf, &tculen);
3560 /* If the two differ, we definately cannot do inplace. */
3561 inplace = (ulen == tculen);
3562 need = slen + 1 - ulen + tculen;
3568 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3569 /* We can convert in place. */
3572 s = d = (U8*)SvPV_force_nomg(source, slen);
3578 SvUPGRADE(dest, SVt_PV);
3579 d = (U8*)SvGROW(dest, need);
3580 (void)SvPOK_only(dest);
3589 /* slen is the byte length of the whole SV.
3590 * ulen is the byte length of the original Unicode character
3591 * stored as UTF-8 at s.
3592 * tculen is the byte length of the freshly titlecased (or
3593 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3594 * We first set the result to be the titlecased (/lowercased)
3595 * character, and then append the rest of the SV data. */
3596 sv_setpvn(dest, (char*)tmpbuf, tculen);
3598 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3602 Copy(tmpbuf, d, tculen, U8);
3603 SvCUR_set(dest, need - 1);
3608 if (IN_LOCALE_RUNTIME) {
3611 *d = (op_type == OP_UCFIRST)
3612 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3615 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3617 /* See bug #39028 */
3625 /* This will copy the trailing NUL */
3626 Copy(s + 1, d + 1, slen, U8);
3627 SvCUR_set(dest, need - 1);
3634 /* There's so much setup/teardown code common between uc and lc, I wonder if
3635 it would be worth merging the two, and just having a switch outside each
3636 of the three tight loops. */
3650 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3651 && SvTEMP(source) && !DO_UTF8(source)) {
3652 /* We can convert in place. */
3655 s = d = (U8*)SvPV_force_nomg(source, len);
3662 /* The old implementation would copy source into TARG at this point.
3663 This had the side effect that if source was undef, TARG was now
3664 an undefined SV with PADTMP set, and they don't warn inside
3665 sv_2pv_flags(). However, we're now getting the PV direct from
3666 source, which doesn't have PADTMP set, so it would warn. Hence the
3670 s = (const U8*)SvPV_nomg_const(source, len);
3672 if (ckWARN(WARN_UNINITIALIZED))
3673 report_uninit(source);
3679 SvUPGRADE(dest, SVt_PV);
3680 d = (U8*)SvGROW(dest, min);
3681 (void)SvPOK_only(dest);
3686 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3687 to check DO_UTF8 again here. */
3689 if (DO_UTF8(source)) {
3690 const U8 *const send = s + len;
3691 U8 tmpbuf[UTF8_MAXBYTES+1];
3694 const STRLEN u = UTF8SKIP(s);
3697 toUPPER_utf8(s, tmpbuf, &ulen);
3698 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3699 /* If the eventually required minimum size outgrows
3700 * the available space, we need to grow. */
3701 const UV o = d - (U8*)SvPVX_const(dest);
3703 /* If someone uppercases one million U+03B0s we SvGROW() one
3704 * million times. Or we could try guessing how much to
3705 allocate without allocating too much. Such is life. */
3707 d = (U8*)SvPVX(dest) + o;
3709 Copy(tmpbuf, d, ulen, U8);
3715 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3718 const U8 *const send = s + len;
3719 if (IN_LOCALE_RUNTIME) {
3722 for (; s < send; d++, s++)
3723 *d = toUPPER_LC(*s);
3726 for (; s < send; d++, s++)
3730 if (source != dest) {
3732 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3752 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3753 && SvTEMP(source) && !DO_UTF8(source)) {
3754 /* We can convert in place. */
3757 s = d = (U8*)SvPV_force_nomg(source, len);
3764 /* The old implementation would copy source into TARG at this point.
3765 This had the side effect that if source was undef, TARG was now
3766 an undefined SV with PADTMP set, and they don't warn inside
3767 sv_2pv_flags(). However, we're now getting the PV direct from
3768 source, which doesn't have PADTMP set, so it would warn. Hence the
3772 s = (const U8*)SvPV_nomg_const(source, len);
3774 if (ckWARN(WARN_UNINITIALIZED))
3775 report_uninit(source);
3781 SvUPGRADE(dest, SVt_PV);
3782 d = (U8*)SvGROW(dest, min);
3783 (void)SvPOK_only(dest);
3788 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3789 to check DO_UTF8 again here. */
3791 if (DO_UTF8(source)) {
3792 const U8 *const send = s + len;
3793 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3796 const STRLEN u = UTF8SKIP(s);
3798 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3800 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3801 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3804 * Now if the sigma is NOT followed by
3805 * /$ignorable_sequence$cased_letter/;
3806 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3807 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3808 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3809 * then it should be mapped to 0x03C2,
3810 * (GREEK SMALL LETTER FINAL SIGMA),
3811 * instead of staying 0x03A3.
3812 * "should be": in other words, this is not implemented yet.
3813 * See lib/unicore/SpecialCasing.txt.
3816 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3817 /* If the eventually required minimum size outgrows
3818 * the available space, we need to grow. */
3819 const UV o = d - (U8*)SvPVX_const(dest);
3821 /* If someone lowercases one million U+0130s we SvGROW() one
3822 * million times. Or we could try guessing how much to
3823 allocate without allocating too much. Such is life. */
3825 d = (U8*)SvPVX(dest) + o;
3827 Copy(tmpbuf, d, ulen, U8);
3833 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3836 const U8 *const send = s + len;
3837 if (IN_LOCALE_RUNTIME) {
3840 for (; s < send; d++, s++)
3841 *d = toLOWER_LC(*s);
3844 for (; s < send; d++, s++)
3848 if (source != dest) {
3850 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3860 SV * const sv = TOPs;
3862 register const char *s = SvPV_const(sv,len);
3864 SvUTF8_off(TARG); /* decontaminate */
3867 SvUPGRADE(TARG, SVt_PV);
3868 SvGROW(TARG, (len * 2) + 1);
3872 if (UTF8_IS_CONTINUED(*s)) {
3873 STRLEN ulen = UTF8SKIP(s);
3897 SvCUR_set(TARG, d - SvPVX_const(TARG));
3898 (void)SvPOK_only_UTF8(TARG);
3901 sv_setpvn(TARG, s, len);
3903 if (SvSMAGICAL(TARG))
3912 dVAR; dSP; dMARK; dORIGMARK;
3913 register AV *const av = MUTABLE_AV(POPs);
3914 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3916 if (SvTYPE(av) == SVt_PVAV) {
3917 const I32 arybase = CopARYBASE_get(PL_curcop);
3918 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3921 for (svp = MARK + 1; svp <= SP; svp++) {
3922 const I32 elem = SvIV(*svp);
3926 if (max > AvMAX(av))
3929 while (++MARK <= SP) {
3931 I32 elem = SvIV(*MARK);
3935 svp = av_fetch(av, elem, lval);
3937 if (!svp || *svp == &PL_sv_undef)
3938 DIE(aTHX_ PL_no_aelem, elem);
3939 if (PL_op->op_private & OPpLVAL_INTRO)
3940 save_aelem(av, elem, svp);
3942 *MARK = svp ? *svp : &PL_sv_undef;
3945 if (GIMME != G_ARRAY) {
3947 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3957 AV *array = MUTABLE_AV(POPs);
3958 const I32 gimme = GIMME_V;
3959 IV *iterp = Perl_av_iter_p(aTHX_ array);
3960 const IV current = (*iterp)++;
3962 if (current > av_len(array)) {
3964 if (gimme == G_SCALAR)
3971 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3972 if (gimme == G_ARRAY) {
3973 SV **const element = av_fetch(array, current, 0);
3974 PUSHs(element ? *element : &PL_sv_undef);
3983 AV *array = MUTABLE_AV(POPs);
3984 const I32 gimme = GIMME_V;
3986 *Perl_av_iter_p(aTHX_ array) = 0;
3988 if (gimme == G_SCALAR) {
3990 PUSHi(av_len(array) + 1);
3992 else if (gimme == G_ARRAY) {
3993 IV n = Perl_av_len(aTHX_ array);
3994 IV i = CopARYBASE_get(PL_curcop);
3998 if (PL_op->op_type == OP_AKEYS) {
4000 for (; i <= n; i++) {
4005 for (i = 0; i <= n; i++) {
4006 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4007 PUSHs(elem ? *elem : &PL_sv_undef);
4014 /* Associative arrays. */
4020 HV * hash = MUTABLE_HV(POPs);
4022 const I32 gimme = GIMME_V;
4025 /* might clobber stack_sp */
4026 entry = hv_iternext(hash);
4031 SV* const sv = hv_iterkeysv(entry);
4032 PUSHs(sv); /* won't clobber stack_sp */
4033 if (gimme == G_ARRAY) {
4036 /* might clobber stack_sp */
4037 val = hv_iterval(hash, entry);
4042 else if (gimme == G_SCALAR)
4052 const I32 gimme = GIMME_V;
4053 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4055 if (PL_op->op_private & OPpSLICE) {
4057 HV * const hv = MUTABLE_HV(POPs);
4058 const U32 hvtype = SvTYPE(hv);
4059 if (hvtype == SVt_PVHV) { /* hash element */
4060 while (++MARK <= SP) {
4061 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4062 *MARK = sv ? sv : &PL_sv_undef;
4065 else if (hvtype == SVt_PVAV) { /* array element */
4066 if (PL_op->op_flags & OPf_SPECIAL) {
4067 while (++MARK <= SP) {
4068 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4069 *MARK = sv ? sv : &PL_sv_undef;
4074 DIE(aTHX_ "Not a HASH reference");
4077 else if (gimme == G_SCALAR) {
4082 *++MARK = &PL_sv_undef;
4088 HV * const hv = MUTABLE_HV(POPs);
4090 if (SvTYPE(hv) == SVt_PVHV)
4091 sv = hv_delete_ent(hv, keysv, discard, 0);
4092 else if (SvTYPE(hv) == SVt_PVAV) {
4093 if (PL_op->op_flags & OPf_SPECIAL)
4094 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4096 DIE(aTHX_ "panic: avhv_delete no longer supported");
4099 DIE(aTHX_ "Not a HASH reference");
4115 if (PL_op->op_private & OPpEXISTS_SUB) {
4117 SV * const sv = POPs;
4118 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4121 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4126 hv = MUTABLE_HV(POPs);
4127 if (SvTYPE(hv) == SVt_PVHV) {
4128 if (hv_exists_ent(hv, tmpsv, 0))
4131 else if (SvTYPE(hv) == SVt_PVAV) {
4132 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4133 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4138 DIE(aTHX_ "Not a HASH reference");
4145 dVAR; dSP; dMARK; dORIGMARK;
4146 register HV * const hv = MUTABLE_HV(POPs);
4147 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4148 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4149 bool other_magic = FALSE;
4155 other_magic = mg_find((const SV *)hv, PERL_MAGIC_env) ||
4156 ((mg = mg_find((const SV *)hv, PERL_MAGIC_tied))
4157 /* Try to preserve the existenceness of a tied hash
4158 * element by using EXISTS and DELETE if possible.
4159 * Fallback to FETCH and STORE otherwise */
4160 && (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(hv), mg))))
4161 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4162 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4165 while (++MARK <= SP) {
4166 SV * const keysv = *MARK;
4169 bool preeminent = FALSE;
4172 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4173 hv_exists_ent(hv, keysv, 0);
4176 he = hv_fetch_ent(hv, keysv, lval, 0);
4177 svp = he ? &HeVAL(he) : NULL;
4180 if (!svp || *svp == &PL_sv_undef) {
4181 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4184 if (HvNAME_get(hv) && isGV(*svp))
4185 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4188 save_helem(hv, keysv, svp, !(PL_op->op_flags & OPf_SPECIAL));
4191 const char * const key = SvPV_const(keysv, keylen);
4192 SAVEDELETE(hv, savepvn(key,keylen),
4193 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4198 *MARK = svp ? *svp : &PL_sv_undef;
4200 if (GIMME != G_ARRAY) {
4202 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4208 /* List operators. */
4213 if (GIMME != G_ARRAY) {
4215 *MARK = *SP; /* unwanted list, return last item */
4217 *MARK = &PL_sv_undef;
4227 SV ** const lastrelem = PL_stack_sp;
4228 SV ** const lastlelem = PL_stack_base + POPMARK;
4229 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4230 register SV ** const firstrelem = lastlelem + 1;
4231 const I32 arybase = CopARYBASE_get(PL_curcop);
4232 I32 is_something_there = FALSE;
4234 register const I32 max = lastrelem - lastlelem;
4235 register SV **lelem;
4237 if (GIMME != G_ARRAY) {
4238 I32 ix = SvIV(*lastlelem);
4243 if (ix < 0 || ix >= max)
4244 *firstlelem = &PL_sv_undef;
4246 *firstlelem = firstrelem[ix];
4252 SP = firstlelem - 1;
4256 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4257 I32 ix = SvIV(*lelem);
4262 if (ix < 0 || ix >= max)
4263 *lelem = &PL_sv_undef;
4265 is_something_there = TRUE;
4266 if (!(*lelem = firstrelem[ix]))
4267 *lelem = &PL_sv_undef;
4270 if (is_something_there)
4273 SP = firstlelem - 1;
4279 dVAR; dSP; dMARK; dORIGMARK;
4280 const I32 items = SP - MARK;
4281 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4282 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4283 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4284 ? newRV_noinc(av) : av);
4290 dVAR; dSP; dMARK; dORIGMARK;
4291 HV* const hv = newHV();
4294 SV * const key = *++MARK;
4295 SV * const val = newSV(0);
4297 sv_setsv(val, *++MARK);
4298 else if (ckWARN(WARN_MISC))
4299 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4300 (void)hv_store_ent(hv,key,val,0);
4303 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4304 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4310 dVAR; dSP; dMARK; dORIGMARK;
4311 register AV *ary = MUTABLE_AV(*++MARK);
4315 register I32 offset;
4316 register I32 length;
4320 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4323 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4327 call_method("SPLICE",GIMME_V);
4336 offset = i = SvIV(*MARK);
4338 offset += AvFILLp(ary) + 1;
4340 offset -= CopARYBASE_get(PL_curcop);
4342 DIE(aTHX_ PL_no_aelem, i);
4344 length = SvIVx(*MARK++);
4346 length += AvFILLp(ary) - offset + 1;
4352 length = AvMAX(ary) + 1; /* close enough to infinity */
4356 length = AvMAX(ary) + 1;
4358 if (offset > AvFILLp(ary) + 1) {
4359 if (ckWARN(WARN_MISC))
4360 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4361 offset = AvFILLp(ary) + 1;
4363 after = AvFILLp(ary) + 1 - (offset + length);
4364 if (after < 0) { /* not that much array */
4365 length += after; /* offset+length now in array */
4371 /* At this point, MARK .. SP-1 is our new LIST */
4374 diff = newlen - length;
4375 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4378 /* make new elements SVs now: avoid problems if they're from the array */
4379 for (dst = MARK, i = newlen; i; i--) {
4380 SV * const h = *dst;
4381 *dst++ = newSVsv(h);
4384 if (diff < 0) { /* shrinking the area */
4385 SV **tmparyval = NULL;
4387 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4388 Copy(MARK, tmparyval, newlen, SV*);
4391 MARK = ORIGMARK + 1;
4392 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4393 MEXTEND(MARK, length);
4394 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4396 EXTEND_MORTAL(length);
4397 for (i = length, dst = MARK; i; i--) {
4398 sv_2mortal(*dst); /* free them eventualy */
4405 *MARK = AvARRAY(ary)[offset+length-1];
4408 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4409 SvREFCNT_dec(*dst++); /* free them now */
4412 AvFILLp(ary) += diff;
4414 /* pull up or down? */
4416 if (offset < after) { /* easier to pull up */
4417 if (offset) { /* esp. if nothing to pull */
4418 src = &AvARRAY(ary)[offset-1];
4419 dst = src - diff; /* diff is negative */
4420 for (i = offset; i > 0; i--) /* can't trust Copy */
4424 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4428 if (after) { /* anything to pull down? */
4429 src = AvARRAY(ary) + offset + length;
4430 dst = src + diff; /* diff is negative */
4431 Move(src, dst, after, SV*);
4433 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4434 /* avoid later double free */
4438 dst[--i] = &PL_sv_undef;
4441 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4442 Safefree(tmparyval);
4445 else { /* no, expanding (or same) */
4446 SV** tmparyval = NULL;
4448 Newx(tmparyval, length, SV*); /* so remember deletion */
4449 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4452 if (diff > 0) { /* expanding */
4453 /* push up or down? */
4454 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4458 Move(src, dst, offset, SV*);
4460 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4462 AvFILLp(ary) += diff;
4465 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4466 av_extend(ary, AvFILLp(ary) + diff);
4467 AvFILLp(ary) += diff;
4470 dst = AvARRAY(ary) + AvFILLp(ary);
4472 for (i = after; i; i--) {
4480 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4483 MARK = ORIGMARK + 1;
4484 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4486 Copy(tmparyval, MARK, length, SV*);
4488 EXTEND_MORTAL(length);
4489 for (i = length, dst = MARK; i; i--) {
4490 sv_2mortal(*dst); /* free them eventualy */
4497 else if (length--) {
4498 *MARK = tmparyval[length];
4501 while (length-- > 0)
4502 SvREFCNT_dec(tmparyval[length]);
4506 *MARK = &PL_sv_undef;
4507 Safefree(tmparyval);
4515 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4516 register AV * const ary = MUTABLE_AV(*++MARK);
4517 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4520 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4524 call_method("PUSH",G_SCALAR|G_DISCARD);
4528 PUSHi( AvFILL(ary) + 1 );
4531 PL_delaymagic = DM_DELAY;
4532 for (++MARK; MARK <= SP; MARK++) {
4533 SV * const sv = newSV(0);
4535 sv_setsv(sv, *MARK);
4536 av_store(ary, AvFILLp(ary)+1, sv);
4538 if (PL_delaymagic & DM_ARRAY)
4539 mg_set(MUTABLE_SV(ary));
4543 PUSHi( AvFILLp(ary) + 1 );
4552 AV * const av = MUTABLE_AV(POPs);
4553 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4557 (void)sv_2mortal(sv);
4564 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4565 register AV *ary = MUTABLE_AV(*++MARK);
4566 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4569 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4573 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4579 av_unshift(ary, SP - MARK);
4581 SV * const sv = newSVsv(*++MARK);
4582 (void)av_store(ary, i++, sv);
4586 PUSHi( AvFILL(ary) + 1 );
4593 SV ** const oldsp = SP;
4595 if (GIMME == G_ARRAY) {
4598 register SV * const tmp = *MARK;
4602 /* safe as long as stack cannot get extended in the above */
4607 register char *down;
4611 PADOFFSET padoff_du;
4613 SvUTF8_off(TARG); /* decontaminate */
4615 do_join(TARG, &PL_sv_no, MARK, SP);
4617 sv_setsv(TARG, (SP > MARK)
4619 : (padoff_du = find_rundefsvoffset(),
4620 (padoff_du == NOT_IN_PAD
4621 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4622 ? DEFSV : PAD_SVl(padoff_du)));
4624 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4625 report_uninit(TARG);
4628 up = SvPV_force(TARG, len);
4630 if (DO_UTF8(TARG)) { /* first reverse each character */
4631 U8* s = (U8*)SvPVX(TARG);
4632 const U8* send = (U8*)(s + len);
4634 if (UTF8_IS_INVARIANT(*s)) {
4639 if (!utf8_to_uvchr(s, 0))
4643 down = (char*)(s - 1);
4644 /* reverse this character */
4648 *down-- = (char)tmp;
4654 down = SvPVX(TARG) + len - 1;
4658 *down-- = (char)tmp;
4660 (void)SvPOK_only_UTF8(TARG);
4672 register IV limit = POPi; /* note, negative is forever */
4673 SV * const sv = POPs;
4675 register const char *s = SvPV_const(sv, len);
4676 const bool do_utf8 = DO_UTF8(sv);
4677 const char *strend = s + len;
4679 register REGEXP *rx;
4681 register const char *m;
4683 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4684 I32 maxiters = slen + 10;
4686 const I32 origlimit = limit;
4689 const I32 gimme = GIMME_V;
4690 const I32 oldsave = PL_savestack_ix;
4691 U32 make_mortal = SVs_TEMP;
4696 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4701 DIE(aTHX_ "panic: pp_split");
4704 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4705 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4707 RX_MATCH_UTF8_set(rx, do_utf8);
4710 if (pm->op_pmreplrootu.op_pmtargetoff) {
4711 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
4714 if (pm->op_pmreplrootu.op_pmtargetgv) {
4715 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4718 else if (gimme != G_ARRAY)
4719 ary = GvAVn(PL_defgv);
4722 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4728 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
4730 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
4737 for (i = AvFILLp(ary); i >= 0; i--)
4738 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4740 /* temporarily switch stacks */
4741 SAVESWITCHSTACK(PL_curstack, ary);
4745 base = SP - PL_stack_base;
4747 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4749 while (*s == ' ' || is_utf8_space((U8*)s))
4752 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4753 while (isSPACE_LC(*s))
4761 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4766 limit = maxiters + 2;
4767 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4770 /* this one uses 'm' and is a negative test */
4772 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4773 const int t = UTF8SKIP(m);
4774 /* is_utf8_space returns FALSE for malform utf8 */
4780 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4781 while (m < strend && !isSPACE_LC(*m))
4784 while (m < strend && !isSPACE(*m))
4790 dstr = newSVpvn_flags(s, m-s,
4791 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4794 /* skip the whitespace found last */
4796 s = m + UTF8SKIP(m);
4800 /* this one uses 's' and is a positive test */
4802 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4804 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4805 while (s < strend && isSPACE_LC(*s))
4808 while (s < strend && isSPACE(*s))
4813 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4815 for (m = s; m < strend && *m != '\n'; m++)
4820 dstr = newSVpvn_flags(s, m-s,
4821 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4826 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4828 Pre-extend the stack, either the number of bytes or
4829 characters in the string or a limited amount, triggered by:
4831 my ($x, $y) = split //, $str;
4835 const U32 items = limit - 1;
4843 /* keep track of how many bytes we skip over */
4846 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
4855 dstr = newSVpvn(s, 1);
4869 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4870 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4871 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4872 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4873 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4874 SV * const csv = CALLREG_INTUIT_STRING(rx);
4876 len = RX_MINLENRET(rx);
4877 if (len == 1 && !RX_UTF8(rx) && !tail) {
4878 const char c = *SvPV_nolen_const(csv);
4880 for (m = s; m < strend && *m != c; m++)
4884 dstr = newSVpvn_flags(s, m-s,
4885 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4887 /* The rx->minlen is in characters but we want to step
4888 * s ahead by bytes. */
4890 s = (char*)utf8_hop((U8*)m, len);
4892 s = m + len; /* Fake \n at the end */
4896 while (s < strend && --limit &&
4897 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4898 csv, multiline ? FBMrf_MULTILINE : 0)) )
4900 dstr = newSVpvn_flags(s, m-s,
4901 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4903 /* The rx->minlen is in characters but we want to step
4904 * s ahead by bytes. */
4906 s = (char*)utf8_hop((U8*)m, len);
4908 s = m + len; /* Fake \n at the end */
4913 maxiters += slen * RX_NPARENS(rx);
4914 while (s < strend && --limit)
4918 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4921 if (rex_return == 0)
4923 TAINT_IF(RX_MATCH_TAINTED(rx));
4924 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4927 orig = RX_SUBBEG(rx);
4929 strend = s + (strend - m);
4931 m = RX_OFFS(rx)[0].start + orig;
4932 dstr = newSVpvn_flags(s, m-s,
4933 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4935 if (RX_NPARENS(rx)) {
4937 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4938 s = RX_OFFS(rx)[i].start + orig;
4939 m = RX_OFFS(rx)[i].end + orig;
4941 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4942 parens that didn't match -- they should be set to
4943 undef, not the empty string */
4944 if (m >= orig && s >= orig) {
4945 dstr = newSVpvn_flags(s, m-s,
4946 (do_utf8 ? SVf_UTF8 : 0)
4950 dstr = &PL_sv_undef; /* undef, not "" */
4954 s = RX_OFFS(rx)[0].end + orig;
4958 iters = (SP - PL_stack_base) - base;
4959 if (iters > maxiters)
4960 DIE(aTHX_ "Split loop");
4962 /* keep field after final delim? */
4963 if (s < strend || (iters && origlimit)) {
4964 const STRLEN l = strend - s;
4965 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4969 else if (!origlimit) {
4970 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4971 if (TOPs && !make_mortal)
4974 *SP-- = &PL_sv_undef;
4979 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4983 if (SvSMAGICAL(ary)) {
4985 mg_set(MUTABLE_SV(ary));
4988 if (gimme == G_ARRAY) {
4990 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4998 call_method("PUSH",G_SCALAR|G_DISCARD);
5001 if (gimme == G_ARRAY) {
5003 /* EXTEND should not be needed - we just popped them */
5005 for (i=0; i < iters; i++) {
5006 SV **svp = av_fetch(ary, i, FALSE);
5007 PUSHs((svp) ? *svp : &PL_sv_undef);
5014 if (gimme == G_ARRAY)
5026 SV *const sv = PAD_SVl(PL_op->op_targ);
5028 if (SvPADSTALE(sv)) {
5031 RETURNOP(cLOGOP->op_other);
5033 RETURNOP(cLOGOP->op_next);
5043 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5044 || SvTYPE(retsv) == SVt_PVCV) {
5045 retsv = refto(retsv);
5052 PP(unimplemented_op)
5055 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5061 * c-indentation-style: bsd
5063 * indent-tabs-mode: t
5066 * ex: set ts=8 sts=4 sw=4 noet: