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, (SvCUR(sv)>32 ? "..." : ""), "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, (SvCUR(sv)>32 ? "..." : ""), 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 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
326 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
328 *sv = newSV_type(SVt_PVMG);
329 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
333 SETs(sv_2mortal(newSViv(
334 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
342 dVAR; dSP; dTARGET; dPOPss;
344 if (PL_op->op_flags & OPf_MOD || LVRET) {
345 if (SvTYPE(TARG) < SVt_PVLV) {
346 sv_upgrade(TARG, SVt_PVLV);
347 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
351 if (LvTARG(TARG) != sv) {
352 SvREFCNT_dec(LvTARG(TARG));
353 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
355 PUSHs(TARG); /* no SvSETMAGIC */
359 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
360 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
361 if (mg && mg->mg_len >= 0) {
365 PUSHi(i + CopARYBASE_get(PL_curcop));
378 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
380 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
383 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
384 /* (But not in defined().) */
386 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
389 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
390 if ((PL_op->op_private & OPpLVAL_INTRO)) {
391 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
394 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
397 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
401 cv = MUTABLE_CV(&PL_sv_undef);
402 SETs(MUTABLE_SV(cv));
412 SV *ret = &PL_sv_undef;
414 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
415 const char * s = SvPVX_const(TOPs);
416 if (strnEQ(s, "CORE::", 6)) {
417 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
418 if (code < 0) { /* Overridable. */
419 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
420 int i = 0, n = 0, seen_question = 0, defgv = 0;
422 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
424 if (code == -KEY_chop || code == -KEY_chomp
425 || code == -KEY_exec || code == -KEY_system)
427 if (code == -KEY_mkdir) {
428 ret = newSVpvs_flags("_;$", SVs_TEMP);
431 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
432 ret = newSVpvs_flags("\\[@%]", SVs_TEMP);
435 if (code == -KEY_readpipe) {
436 s = "CORE::backtick";
438 while (i < MAXO) { /* The slow way. */
439 if (strEQ(s + 6, PL_op_name[i])
440 || strEQ(s + 6, PL_op_desc[i]))
446 goto nonesuch; /* Should not happen... */
448 defgv = PL_opargs[i] & OA_DEFGV;
449 oa = PL_opargs[i] >> OASHIFT;
451 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
455 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
456 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
457 /* But globs are already references (kinda) */
458 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
462 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
465 if (defgv && str[n - 1] == '$')
468 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
470 else if (code) /* Non-Overridable */
472 else { /* None such */
474 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
478 cv = sv_2cv(TOPs, &stash, &gv, 0);
480 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
489 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
491 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
493 PUSHs(MUTABLE_SV(cv));
507 if (GIMME != G_ARRAY) {
511 *MARK = &PL_sv_undef;
512 *MARK = refto(*MARK);
516 EXTEND_MORTAL(SP - MARK);
518 *MARK = refto(*MARK);
523 S_refto(pTHX_ SV *sv)
528 PERL_ARGS_ASSERT_REFTO;
530 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
533 if (!(sv = LvTARG(sv)))
536 SvREFCNT_inc_void_NN(sv);
538 else if (SvTYPE(sv) == SVt_PVAV) {
539 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
540 av_reify(MUTABLE_AV(sv));
542 SvREFCNT_inc_void_NN(sv);
544 else if (SvPADTMP(sv) && !IS_PADGV(sv))
548 SvREFCNT_inc_void_NN(sv);
551 sv_upgrade(rv, SVt_IV);
561 SV * const sv = POPs;
566 if (!sv || !SvROK(sv))
569 pv = sv_reftype(SvRV(sv),TRUE);
570 PUSHp(pv, strlen(pv));
580 stash = CopSTASH(PL_curcop);
582 SV * const ssv = POPs;
586 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
587 Perl_croak(aTHX_ "Attempt to bless into a reference");
588 ptr = SvPV_const(ssv,len);
590 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
591 "Explicit blessing to '' (assuming package main)");
592 stash = gv_stashpvn(ptr, len, GV_ADD);
595 (void)sv_bless(TOPs, stash);
604 const char * const elem = SvPV_nolen_const(sv);
605 GV * const gv = MUTABLE_GV(POPs);
610 /* elem will always be NUL terminated. */
611 const char * const second_letter = elem + 1;
614 if (strEQ(second_letter, "RRAY"))
615 tmpRef = MUTABLE_SV(GvAV(gv));
618 if (strEQ(second_letter, "ODE"))
619 tmpRef = MUTABLE_SV(GvCVu(gv));
622 if (strEQ(second_letter, "ILEHANDLE")) {
623 /* finally deprecated in 5.8.0 */
624 deprecate("*glob{FILEHANDLE}");
625 tmpRef = MUTABLE_SV(GvIOp(gv));
628 if (strEQ(second_letter, "ORMAT"))
629 tmpRef = MUTABLE_SV(GvFORM(gv));
632 if (strEQ(second_letter, "LOB"))
633 tmpRef = MUTABLE_SV(gv);
636 if (strEQ(second_letter, "ASH"))
637 tmpRef = MUTABLE_SV(GvHV(gv));
640 if (*second_letter == 'O' && !elem[2])
641 tmpRef = MUTABLE_SV(GvIOp(gv));
644 if (strEQ(second_letter, "AME"))
645 sv = newSVhek(GvNAME_HEK(gv));
648 if (strEQ(second_letter, "ACKAGE")) {
649 const HV * const stash = GvSTASH(gv);
650 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
651 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
655 if (strEQ(second_letter, "CALAR"))
670 /* Pattern matching */
675 register unsigned char *s;
678 register I32 *sfirst;
682 if (sv == PL_lastscream) {
686 s = (unsigned char*)(SvPV(sv, len));
688 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
689 /* No point in studying a zero length string, and not safe to study
690 anything that doesn't appear to be a simple scalar (and hence might
691 change between now and when the regexp engine runs without our set
692 magic ever running) such as a reference to an object with overloaded
698 SvSCREAM_off(PL_lastscream);
699 SvREFCNT_dec(PL_lastscream);
701 PL_lastscream = SvREFCNT_inc_simple(sv);
703 s = (unsigned char*)(SvPV(sv, len));
707 if (pos > PL_maxscream) {
708 if (PL_maxscream < 0) {
709 PL_maxscream = pos + 80;
710 Newx(PL_screamfirst, 256, I32);
711 Newx(PL_screamnext, PL_maxscream, I32);
714 PL_maxscream = pos + pos / 4;
715 Renew(PL_screamnext, PL_maxscream, I32);
719 sfirst = PL_screamfirst;
720 snext = PL_screamnext;
722 if (!sfirst || !snext)
723 DIE(aTHX_ "do_study: out of memory");
725 for (ch = 256; ch; --ch)
730 register const I32 ch = s[pos];
732 snext[pos] = sfirst[ch] - pos;
739 /* piggyback on m//g magic */
740 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
749 if (PL_op->op_flags & OPf_STACKED)
751 else if (PL_op->op_private & OPpTARGET_MY)
757 TARG = sv_newmortal();
762 /* Lvalue operators. */
774 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
776 do_chop(TARG, *++MARK);
785 SETi(do_chomp(TOPs));
791 dVAR; dSP; dMARK; dTARGET;
792 register I32 count = 0;
795 count += do_chomp(POPs);
805 if (!PL_op->op_private) {
814 SV_CHECK_THINKFIRST_COW_DROP(sv);
816 switch (SvTYPE(sv)) {
820 av_undef(MUTABLE_AV(sv));
823 hv_undef(MUTABLE_HV(sv));
826 if (cv_const_sv((const CV *)sv))
827 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
828 CvANON((const CV *)sv) ? "(anonymous)"
829 : GvENAME(CvGV((const CV *)sv)));
833 /* let user-undef'd sub keep its identity */
834 GV* const gv = CvGV((const CV *)sv);
835 cv_undef(MUTABLE_CV(sv));
836 CvGV((const CV *)sv) = gv;
841 SvSetMagicSV(sv, &PL_sv_undef);
844 else if (isGV_with_GP(sv)) {
849 if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash))
850 mro_isa_changed_in(stash);
851 /* undef *Pkg::meth_name ... */
852 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
853 && HvNAME_get(stash))
854 mro_method_changed_in(stash);
856 gp_free(MUTABLE_GV(sv));
858 GvGP(sv) = gp_ref(gp);
860 GvLINE(sv) = CopLINE(PL_curcop);
861 GvEGV(sv) = MUTABLE_GV(sv);
867 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
882 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
883 DIE(aTHX_ "%s", PL_no_modify);
884 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
885 && SvIVX(TOPs) != IV_MIN)
887 SvIV_set(TOPs, SvIVX(TOPs) - 1);
888 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
899 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
900 DIE(aTHX_ "%s", PL_no_modify);
901 sv_setsv(TARG, TOPs);
902 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
903 && SvIVX(TOPs) != IV_MAX)
905 SvIV_set(TOPs, SvIVX(TOPs) + 1);
906 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
911 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
921 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
922 DIE(aTHX_ "%s", PL_no_modify);
923 sv_setsv(TARG, TOPs);
924 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
925 && SvIVX(TOPs) != IV_MIN)
927 SvIV_set(TOPs, SvIVX(TOPs) - 1);
928 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
937 /* Ordinary operators. */
941 dVAR; dSP; dATARGET; SV *svl, *svr;
942 #ifdef PERL_PRESERVE_IVUV
945 tryAMAGICbin(pow,opASSIGN);
946 svl = sv_2num(TOPm1s);
948 #ifdef PERL_PRESERVE_IVUV
949 /* For integer to integer power, we do the calculation by hand wherever
950 we're sure it is safe; otherwise we call pow() and try to convert to
951 integer afterwards. */
964 const IV iv = SvIVX(svr);
968 goto float_it; /* Can't do negative powers this way. */
972 baseuok = SvUOK(svl);
976 const IV iv = SvIVX(svl);
979 baseuok = TRUE; /* effectively it's a UV now */
981 baseuv = -iv; /* abs, baseuok == false records sign */
984 /* now we have integer ** positive integer. */
987 /* foo & (foo - 1) is zero only for a power of 2. */
988 if (!(baseuv & (baseuv - 1))) {
989 /* We are raising power-of-2 to a positive integer.
990 The logic here will work for any base (even non-integer
991 bases) but it can be less accurate than
992 pow (base,power) or exp (power * log (base)) when the
993 intermediate values start to spill out of the mantissa.
994 With powers of 2 we know this can't happen.
995 And powers of 2 are the favourite thing for perl
996 programmers to notice ** not doing what they mean. */
998 NV base = baseuok ? baseuv : -(NV)baseuv;
1003 while (power >>= 1) {
1014 register unsigned int highbit = 8 * sizeof(UV);
1015 register unsigned int diff = 8 * sizeof(UV);
1016 while (diff >>= 1) {
1018 if (baseuv >> highbit) {
1022 /* we now have baseuv < 2 ** highbit */
1023 if (power * highbit <= 8 * sizeof(UV)) {
1024 /* result will definitely fit in UV, so use UV math
1025 on same algorithm as above */
1026 register UV result = 1;
1027 register UV base = baseuv;
1028 const bool odd_power = (bool)(power & 1);
1032 while (power >>= 1) {
1039 if (baseuok || !odd_power)
1040 /* answer is positive */
1042 else if (result <= (UV)IV_MAX)
1043 /* answer negative, fits in IV */
1044 SETi( -(IV)result );
1045 else if (result == (UV)IV_MIN)
1046 /* 2's complement assumption: special case IV_MIN */
1049 /* answer negative, doesn't fit */
1050 SETn( -(NV)result );
1060 NV right = SvNV(svr);
1061 NV left = SvNV(svl);
1064 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1066 We are building perl with long double support and are on an AIX OS
1067 afflicted with a powl() function that wrongly returns NaNQ for any
1068 negative base. This was reported to IBM as PMR #23047-379 on
1069 03/06/2006. The problem exists in at least the following versions
1070 of AIX and the libm fileset, and no doubt others as well:
1072 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1073 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1074 AIX 5.2.0 bos.adt.libm 5.2.0.85
1076 So, until IBM fixes powl(), we provide the following workaround to
1077 handle the problem ourselves. Our logic is as follows: for
1078 negative bases (left), we use fmod(right, 2) to check if the
1079 exponent is an odd or even integer:
1081 - if odd, powl(left, right) == -powl(-left, right)
1082 - if even, powl(left, right) == powl(-left, right)
1084 If the exponent is not an integer, the result is rightly NaNQ, so
1085 we just return that (as NV_NAN).
1089 NV mod2 = Perl_fmod( right, 2.0 );
1090 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1091 SETn( -Perl_pow( -left, right) );
1092 } else if (mod2 == 0.0) { /* even integer */
1093 SETn( Perl_pow( -left, right) );
1094 } else { /* fractional power */
1098 SETn( Perl_pow( left, right) );
1101 SETn( Perl_pow( left, right) );
1102 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1104 #ifdef PERL_PRESERVE_IVUV
1114 dVAR; dSP; dATARGET; SV *svl, *svr;
1115 tryAMAGICbin(mult,opASSIGN);
1116 svl = sv_2num(TOPm1s);
1117 svr = sv_2num(TOPs);
1118 #ifdef PERL_PRESERVE_IVUV
1121 /* Unless the left argument is integer in range we are going to have to
1122 use NV maths. Hence only attempt to coerce the right argument if
1123 we know the left is integer. */
1124 /* Left operand is defined, so is it IV? */
1127 bool auvok = SvUOK(svl);
1128 bool buvok = SvUOK(svr);
1129 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1130 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1139 const IV aiv = SvIVX(svl);
1142 auvok = TRUE; /* effectively it's a UV now */
1144 alow = -aiv; /* abs, auvok == false records sign */
1150 const IV biv = SvIVX(svr);
1153 buvok = TRUE; /* effectively it's a UV now */
1155 blow = -biv; /* abs, buvok == false records sign */
1159 /* If this does sign extension on unsigned it's time for plan B */
1160 ahigh = alow >> (4 * sizeof (UV));
1162 bhigh = blow >> (4 * sizeof (UV));
1164 if (ahigh && bhigh) {
1166 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1167 which is overflow. Drop to NVs below. */
1168 } else if (!ahigh && !bhigh) {
1169 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1170 so the unsigned multiply cannot overflow. */
1171 const UV product = alow * blow;
1172 if (auvok == buvok) {
1173 /* -ve * -ve or +ve * +ve gives a +ve result. */
1177 } else if (product <= (UV)IV_MIN) {
1178 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1179 /* -ve result, which could overflow an IV */
1181 SETi( -(IV)product );
1183 } /* else drop to NVs below. */
1185 /* One operand is large, 1 small */
1188 /* swap the operands */
1190 bhigh = blow; /* bhigh now the temp var for the swap */
1194 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1195 multiplies can't overflow. shift can, add can, -ve can. */
1196 product_middle = ahigh * blow;
1197 if (!(product_middle & topmask)) {
1198 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1200 product_middle <<= (4 * sizeof (UV));
1201 product_low = alow * blow;
1203 /* as for pp_add, UV + something mustn't get smaller.
1204 IIRC ANSI mandates this wrapping *behaviour* for
1205 unsigned whatever the actual representation*/
1206 product_low += product_middle;
1207 if (product_low >= product_middle) {
1208 /* didn't overflow */
1209 if (auvok == buvok) {
1210 /* -ve * -ve or +ve * +ve gives a +ve result. */
1212 SETu( product_low );
1214 } else if (product_low <= (UV)IV_MIN) {
1215 /* 2s complement assumption again */
1216 /* -ve result, which could overflow an IV */
1218 SETi( -(IV)product_low );
1220 } /* else drop to NVs below. */
1222 } /* product_middle too large */
1223 } /* ahigh && bhigh */
1228 NV right = SvNV(svr);
1229 NV left = SvNV(svl);
1231 SETn( left * right );
1238 dVAR; dSP; dATARGET; SV *svl, *svr;
1239 tryAMAGICbin(div,opASSIGN);
1240 svl = sv_2num(TOPm1s);
1241 svr = sv_2num(TOPs);
1242 /* Only try to do UV divide first
1243 if ((SLOPPYDIVIDE is true) or
1244 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1246 The assumption is that it is better to use floating point divide
1247 whenever possible, only doing integer divide first if we can't be sure.
1248 If NV_PRESERVES_UV is true then we know at compile time that no UV
1249 can be too large to preserve, so don't need to compile the code to
1250 test the size of UVs. */
1253 # define PERL_TRY_UV_DIVIDE
1254 /* ensure that 20./5. == 4. */
1256 # ifdef PERL_PRESERVE_IVUV
1257 # ifndef NV_PRESERVES_UV
1258 # define PERL_TRY_UV_DIVIDE
1263 #ifdef PERL_TRY_UV_DIVIDE
1268 bool left_non_neg = SvUOK(svl);
1269 bool right_non_neg = SvUOK(svr);
1273 if (right_non_neg) {
1277 const IV biv = SvIVX(svr);
1280 right_non_neg = TRUE; /* effectively it's a UV now */
1286 /* historically undef()/0 gives a "Use of uninitialized value"
1287 warning before dieing, hence this test goes here.
1288 If it were immediately before the second SvIV_please, then
1289 DIE() would be invoked before left was even inspected, so
1290 no inpsection would give no warning. */
1292 DIE(aTHX_ "Illegal division by zero");
1298 const IV aiv = SvIVX(svl);
1301 left_non_neg = TRUE; /* effectively it's a UV now */
1310 /* For sloppy divide we always attempt integer division. */
1312 /* Otherwise we only attempt it if either or both operands
1313 would not be preserved by an NV. If both fit in NVs
1314 we fall through to the NV divide code below. However,
1315 as left >= right to ensure integer result here, we know that
1316 we can skip the test on the right operand - right big
1317 enough not to be preserved can't get here unless left is
1320 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1323 /* Integer division can't overflow, but it can be imprecise. */
1324 const UV result = left / right;
1325 if (result * right == left) {
1326 SP--; /* result is valid */
1327 if (left_non_neg == right_non_neg) {
1328 /* signs identical, result is positive. */
1332 /* 2s complement assumption */
1333 if (result <= (UV)IV_MIN)
1334 SETi( -(IV)result );
1336 /* It's exact but too negative for IV. */
1337 SETn( -(NV)result );
1340 } /* tried integer divide but it was not an integer result */
1341 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1342 } /* left wasn't SvIOK */
1343 } /* right wasn't SvIOK */
1344 #endif /* PERL_TRY_UV_DIVIDE */
1346 NV right = SvNV(svr);
1347 NV left = SvNV(svl);
1348 (void)POPs;(void)POPs;
1349 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1350 if (! Perl_isnan(right) && right == 0.0)
1354 DIE(aTHX_ "Illegal division by zero");
1355 PUSHn( left / right );
1362 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1366 bool left_neg = FALSE;
1367 bool right_neg = FALSE;
1368 bool use_double = FALSE;
1369 bool dright_valid = FALSE;
1373 SV * const svr = sv_2num(TOPs);
1376 right_neg = !SvUOK(svr);
1380 const IV biv = SvIVX(svr);
1383 right_neg = FALSE; /* effectively it's a UV now */
1391 right_neg = dright < 0;
1394 if (dright < UV_MAX_P1) {
1395 right = U_V(dright);
1396 dright_valid = TRUE; /* In case we need to use double below. */
1403 /* At this point use_double is only true if right is out of range for
1404 a UV. In range NV has been rounded down to nearest UV and
1405 use_double false. */
1406 svl = sv_2num(TOPs);
1408 if (!use_double && SvIOK(svl)) {
1410 left_neg = !SvUOK(svl);
1414 const IV aiv = SvIVX(svl);
1417 left_neg = FALSE; /* effectively it's a UV now */
1426 left_neg = dleft < 0;
1430 /* This should be exactly the 5.6 behaviour - if left and right are
1431 both in range for UV then use U_V() rather than floor. */
1433 if (dleft < UV_MAX_P1) {
1434 /* right was in range, so is dleft, so use UVs not double.
1438 /* left is out of range for UV, right was in range, so promote
1439 right (back) to double. */
1441 /* The +0.5 is used in 5.6 even though it is not strictly
1442 consistent with the implicit +0 floor in the U_V()
1443 inside the #if 1. */
1444 dleft = Perl_floor(dleft + 0.5);
1447 dright = Perl_floor(dright + 0.5);
1458 DIE(aTHX_ "Illegal modulus zero");
1460 dans = Perl_fmod(dleft, dright);
1461 if ((left_neg != right_neg) && dans)
1462 dans = dright - dans;
1465 sv_setnv(TARG, dans);
1471 DIE(aTHX_ "Illegal modulus zero");
1474 if ((left_neg != right_neg) && ans)
1477 /* XXX may warn: unary minus operator applied to unsigned type */
1478 /* could change -foo to be (~foo)+1 instead */
1479 if (ans <= ~((UV)IV_MAX)+1)
1480 sv_setiv(TARG, ~ans+1);
1482 sv_setnv(TARG, -(NV)ans);
1485 sv_setuv(TARG, ans);
1494 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1501 const UV uv = SvUV(sv);
1503 count = IV_MAX; /* The best we can do? */
1507 const IV iv = SvIV(sv);
1514 else if (SvNOKp(sv)) {
1515 const NV nv = SvNV(sv);
1523 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1525 static const char oom_list_extend[] = "Out of memory during list extend";
1526 const I32 items = SP - MARK;
1527 const I32 max = items * count;
1529 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1530 /* Did the max computation overflow? */
1531 if (items > 0 && max > 0 && (max < items || max < count))
1532 Perl_croak(aTHX_ oom_list_extend);
1537 /* This code was intended to fix 20010809.028:
1540 for (($x =~ /./g) x 2) {
1541 print chop; # "abcdabcd" expected as output.
1544 * but that change (#11635) broke this code:
1546 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1548 * I can't think of a better fix that doesn't introduce
1549 * an efficiency hit by copying the SVs. The stack isn't
1550 * refcounted, and mortalisation obviously doesn't
1551 * Do The Right Thing when the stack has more than
1552 * one pointer to the same mortal value.
1556 *SP = sv_2mortal(newSVsv(*SP));
1566 repeatcpy((char*)(MARK + items), (char*)MARK,
1567 items * sizeof(const SV *), count - 1);
1570 else if (count <= 0)
1573 else { /* Note: mark already snarfed by pp_list */
1574 SV * const tmpstr = POPs;
1577 static const char oom_string_extend[] =
1578 "Out of memory during string extend";
1580 SvSetSV(TARG, tmpstr);
1581 SvPV_force(TARG, len);
1582 isutf = DO_UTF8(TARG);
1587 const STRLEN max = (UV)count * len;
1588 if (len > MEM_SIZE_MAX / count)
1589 Perl_croak(aTHX_ oom_string_extend);
1590 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1591 SvGROW(TARG, max + 1);
1592 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1593 SvCUR_set(TARG, SvCUR(TARG) * count);
1595 *SvEND(TARG) = '\0';
1598 (void)SvPOK_only_UTF8(TARG);
1600 (void)SvPOK_only(TARG);
1602 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1603 /* The parser saw this as a list repeat, and there
1604 are probably several items on the stack. But we're
1605 in scalar context, and there's no pp_list to save us
1606 now. So drop the rest of the items -- robin@kitsite.com
1619 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1620 tryAMAGICbin(subtr,opASSIGN);
1621 svl = sv_2num(TOPm1s);
1622 svr = sv_2num(TOPs);
1623 useleft = USE_LEFT(svl);
1624 #ifdef PERL_PRESERVE_IVUV
1625 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1626 "bad things" happen if you rely on signed integers wrapping. */
1629 /* Unless the left argument is integer in range we are going to have to
1630 use NV maths. Hence only attempt to coerce the right argument if
1631 we know the left is integer. */
1632 register UV auv = 0;
1638 a_valid = auvok = 1;
1639 /* left operand is undef, treat as zero. */
1641 /* Left operand is defined, so is it IV? */
1644 if ((auvok = SvUOK(svl)))
1647 register const IV aiv = SvIVX(svl);
1650 auvok = 1; /* Now acting as a sign flag. */
1651 } else { /* 2s complement assumption for IV_MIN */
1659 bool result_good = 0;
1662 bool buvok = SvUOK(svr);
1667 register const IV biv = SvIVX(svr);
1674 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1675 else "IV" now, independent of how it came in.
1676 if a, b represents positive, A, B negative, a maps to -A etc
1681 all UV maths. negate result if A negative.
1682 subtract if signs same, add if signs differ. */
1684 if (auvok ^ buvok) {
1693 /* Must get smaller */
1698 if (result <= buv) {
1699 /* result really should be -(auv-buv). as its negation
1700 of true value, need to swap our result flag */
1712 if (result <= (UV)IV_MIN)
1713 SETi( -(IV)result );
1715 /* result valid, but out of range for IV. */
1716 SETn( -(NV)result );
1720 } /* Overflow, drop through to NVs. */
1725 NV value = SvNV(svr);
1729 /* left operand is undef, treat as zero - value */
1733 SETn( SvNV(svl) - value );
1740 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1742 const IV shift = POPi;
1743 if (PL_op->op_private & HINT_INTEGER) {
1757 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1759 const IV shift = POPi;
1760 if (PL_op->op_private & HINT_INTEGER) {
1774 dVAR; dSP; tryAMAGICbinSET(lt,0);
1775 #ifdef PERL_PRESERVE_IVUV
1778 SvIV_please(TOPm1s);
1779 if (SvIOK(TOPm1s)) {
1780 bool auvok = SvUOK(TOPm1s);
1781 bool buvok = SvUOK(TOPs);
1783 if (!auvok && !buvok) { /* ## IV < IV ## */
1784 const IV aiv = SvIVX(TOPm1s);
1785 const IV biv = SvIVX(TOPs);
1788 SETs(boolSV(aiv < biv));
1791 if (auvok && buvok) { /* ## UV < UV ## */
1792 const UV auv = SvUVX(TOPm1s);
1793 const UV buv = SvUVX(TOPs);
1796 SETs(boolSV(auv < buv));
1799 if (auvok) { /* ## UV < IV ## */
1801 const IV biv = SvIVX(TOPs);
1804 /* As (a) is a UV, it's >=0, so it cannot be < */
1809 SETs(boolSV(auv < (UV)biv));
1812 { /* ## IV < UV ## */
1813 const IV aiv = SvIVX(TOPm1s);
1817 /* As (b) is a UV, it's >=0, so it must be < */
1824 SETs(boolSV((UV)aiv < buv));
1830 #ifndef NV_PRESERVES_UV
1831 #ifdef PERL_PRESERVE_IVUV
1834 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1836 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1841 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1843 if (Perl_isnan(left) || Perl_isnan(right))
1845 SETs(boolSV(left < right));
1848 SETs(boolSV(TOPn < value));
1856 dVAR; dSP; tryAMAGICbinSET(gt,0);
1857 #ifdef PERL_PRESERVE_IVUV
1860 SvIV_please(TOPm1s);
1861 if (SvIOK(TOPm1s)) {
1862 bool auvok = SvUOK(TOPm1s);
1863 bool buvok = SvUOK(TOPs);
1865 if (!auvok && !buvok) { /* ## IV > IV ## */
1866 const IV aiv = SvIVX(TOPm1s);
1867 const IV biv = SvIVX(TOPs);
1870 SETs(boolSV(aiv > biv));
1873 if (auvok && buvok) { /* ## UV > UV ## */
1874 const UV auv = SvUVX(TOPm1s);
1875 const UV buv = SvUVX(TOPs);
1878 SETs(boolSV(auv > buv));
1881 if (auvok) { /* ## UV > IV ## */
1883 const IV biv = SvIVX(TOPs);
1887 /* As (a) is a UV, it's >=0, so it must be > */
1892 SETs(boolSV(auv > (UV)biv));
1895 { /* ## IV > UV ## */
1896 const IV aiv = SvIVX(TOPm1s);
1900 /* As (b) is a UV, it's >=0, so it cannot be > */
1907 SETs(boolSV((UV)aiv > buv));
1913 #ifndef NV_PRESERVES_UV
1914 #ifdef PERL_PRESERVE_IVUV
1917 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1919 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1924 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1926 if (Perl_isnan(left) || Perl_isnan(right))
1928 SETs(boolSV(left > right));
1931 SETs(boolSV(TOPn > value));
1939 dVAR; dSP; tryAMAGICbinSET(le,0);
1940 #ifdef PERL_PRESERVE_IVUV
1943 SvIV_please(TOPm1s);
1944 if (SvIOK(TOPm1s)) {
1945 bool auvok = SvUOK(TOPm1s);
1946 bool buvok = SvUOK(TOPs);
1948 if (!auvok && !buvok) { /* ## IV <= IV ## */
1949 const IV aiv = SvIVX(TOPm1s);
1950 const IV biv = SvIVX(TOPs);
1953 SETs(boolSV(aiv <= biv));
1956 if (auvok && buvok) { /* ## UV <= UV ## */
1957 UV auv = SvUVX(TOPm1s);
1958 UV buv = SvUVX(TOPs);
1961 SETs(boolSV(auv <= buv));
1964 if (auvok) { /* ## UV <= IV ## */
1966 const IV biv = SvIVX(TOPs);
1970 /* As (a) is a UV, it's >=0, so a cannot be <= */
1975 SETs(boolSV(auv <= (UV)biv));
1978 { /* ## IV <= UV ## */
1979 const IV aiv = SvIVX(TOPm1s);
1983 /* As (b) is a UV, it's >=0, so a must be <= */
1990 SETs(boolSV((UV)aiv <= buv));
1996 #ifndef NV_PRESERVES_UV
1997 #ifdef PERL_PRESERVE_IVUV
2000 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2002 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2007 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2009 if (Perl_isnan(left) || Perl_isnan(right))
2011 SETs(boolSV(left <= right));
2014 SETs(boolSV(TOPn <= value));
2022 dVAR; dSP; tryAMAGICbinSET(ge,0);
2023 #ifdef PERL_PRESERVE_IVUV
2026 SvIV_please(TOPm1s);
2027 if (SvIOK(TOPm1s)) {
2028 bool auvok = SvUOK(TOPm1s);
2029 bool buvok = SvUOK(TOPs);
2031 if (!auvok && !buvok) { /* ## IV >= IV ## */
2032 const IV aiv = SvIVX(TOPm1s);
2033 const IV biv = SvIVX(TOPs);
2036 SETs(boolSV(aiv >= biv));
2039 if (auvok && buvok) { /* ## UV >= UV ## */
2040 const UV auv = SvUVX(TOPm1s);
2041 const UV buv = SvUVX(TOPs);
2044 SETs(boolSV(auv >= buv));
2047 if (auvok) { /* ## UV >= IV ## */
2049 const IV biv = SvIVX(TOPs);
2053 /* As (a) is a UV, it's >=0, so it must be >= */
2058 SETs(boolSV(auv >= (UV)biv));
2061 { /* ## IV >= UV ## */
2062 const IV aiv = SvIVX(TOPm1s);
2066 /* As (b) is a UV, it's >=0, so a cannot be >= */
2073 SETs(boolSV((UV)aiv >= buv));
2079 #ifndef NV_PRESERVES_UV
2080 #ifdef PERL_PRESERVE_IVUV
2083 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2085 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2090 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2092 if (Perl_isnan(left) || Perl_isnan(right))
2094 SETs(boolSV(left >= right));
2097 SETs(boolSV(TOPn >= value));
2105 dVAR; dSP; tryAMAGICbinSET(ne,0);
2106 #ifndef NV_PRESERVES_UV
2107 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2109 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2113 #ifdef PERL_PRESERVE_IVUV
2116 SvIV_please(TOPm1s);
2117 if (SvIOK(TOPm1s)) {
2118 const bool auvok = SvUOK(TOPm1s);
2119 const bool buvok = SvUOK(TOPs);
2121 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2122 /* Casting IV to UV before comparison isn't going to matter
2123 on 2s complement. On 1s complement or sign&magnitude
2124 (if we have any of them) it could make negative zero
2125 differ from normal zero. As I understand it. (Need to
2126 check - is negative zero implementation defined behaviour
2128 const UV buv = SvUVX(POPs);
2129 const UV auv = SvUVX(TOPs);
2131 SETs(boolSV(auv != buv));
2134 { /* ## Mixed IV,UV ## */
2138 /* != is commutative so swap if needed (save code) */
2140 /* swap. top of stack (b) is the iv */
2144 /* As (a) is a UV, it's >0, so it cannot be == */
2153 /* As (b) is a UV, it's >0, so it cannot be == */
2157 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2159 SETs(boolSV((UV)iv != uv));
2166 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2168 if (Perl_isnan(left) || Perl_isnan(right))
2170 SETs(boolSV(left != right));
2173 SETs(boolSV(TOPn != value));
2181 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2182 #ifndef NV_PRESERVES_UV
2183 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2184 const UV right = PTR2UV(SvRV(POPs));
2185 const UV left = PTR2UV(SvRV(TOPs));
2186 SETi((left > right) - (left < right));
2190 #ifdef PERL_PRESERVE_IVUV
2191 /* Fortunately it seems NaN isn't IOK */
2194 SvIV_please(TOPm1s);
2195 if (SvIOK(TOPm1s)) {
2196 const bool leftuvok = SvUOK(TOPm1s);
2197 const bool rightuvok = SvUOK(TOPs);
2199 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2200 const IV leftiv = SvIVX(TOPm1s);
2201 const IV rightiv = SvIVX(TOPs);
2203 if (leftiv > rightiv)
2205 else if (leftiv < rightiv)
2209 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2210 const UV leftuv = SvUVX(TOPm1s);
2211 const UV rightuv = SvUVX(TOPs);
2213 if (leftuv > rightuv)
2215 else if (leftuv < rightuv)
2219 } else if (leftuvok) { /* ## UV <=> IV ## */
2220 const IV rightiv = SvIVX(TOPs);
2222 /* As (a) is a UV, it's >=0, so it cannot be < */
2225 const UV leftuv = SvUVX(TOPm1s);
2226 if (leftuv > (UV)rightiv) {
2228 } else if (leftuv < (UV)rightiv) {
2234 } else { /* ## IV <=> UV ## */
2235 const IV leftiv = SvIVX(TOPm1s);
2237 /* As (b) is a UV, it's >=0, so it must be < */
2240 const UV rightuv = SvUVX(TOPs);
2241 if ((UV)leftiv > rightuv) {
2243 } else if ((UV)leftiv < rightuv) {
2261 if (Perl_isnan(left) || Perl_isnan(right)) {
2265 value = (left > right) - (left < right);
2269 else if (left < right)
2271 else if (left > right)
2287 int amg_type = sle_amg;
2291 switch (PL_op->op_type) {
2310 tryAMAGICbinSET_var(amg_type,0);
2313 const int cmp = (IN_LOCALE_RUNTIME
2314 ? sv_cmp_locale(left, right)
2315 : sv_cmp(left, right));
2316 SETs(boolSV(cmp * multiplier < rhs));
2323 dVAR; dSP; tryAMAGICbinSET(seq,0);
2326 SETs(boolSV(sv_eq(left, right)));
2333 dVAR; dSP; tryAMAGICbinSET(sne,0);
2336 SETs(boolSV(!sv_eq(left, right)));
2343 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2346 const int cmp = (IN_LOCALE_RUNTIME
2347 ? sv_cmp_locale(left, right)
2348 : sv_cmp(left, right));
2356 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2361 if (SvNIOKp(left) || SvNIOKp(right)) {
2362 if (PL_op->op_private & HINT_INTEGER) {
2363 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2367 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2372 do_vop(PL_op->op_type, TARG, left, right);
2381 dVAR; dSP; dATARGET;
2382 const int op_type = PL_op->op_type;
2384 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2389 if (SvNIOKp(left) || SvNIOKp(right)) {
2390 if (PL_op->op_private & HINT_INTEGER) {
2391 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2392 const IV r = SvIV_nomg(right);
2393 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2397 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2398 const UV r = SvUV_nomg(right);
2399 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2404 do_vop(op_type, TARG, left, right);
2413 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2415 SV * const sv = sv_2num(TOPs);
2416 const int flags = SvFLAGS(sv);
2418 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2419 /* It's publicly an integer, or privately an integer-not-float */
2422 if (SvIVX(sv) == IV_MIN) {
2423 /* 2s complement assumption. */
2424 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2427 else if (SvUVX(sv) <= IV_MAX) {
2432 else if (SvIVX(sv) != IV_MIN) {
2436 #ifdef PERL_PRESERVE_IVUV
2445 else if (SvPOKp(sv)) {
2447 const char * const s = SvPV_const(sv, len);
2448 if (isIDFIRST(*s)) {
2449 sv_setpvs(TARG, "-");
2452 else if (*s == '+' || *s == '-') {
2454 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2456 else if (DO_UTF8(sv)) {
2459 goto oops_its_an_int;
2461 sv_setnv(TARG, -SvNV(sv));
2463 sv_setpvs(TARG, "-");
2470 goto oops_its_an_int;
2471 sv_setnv(TARG, -SvNV(sv));
2483 dVAR; dSP; tryAMAGICunSET(not);
2484 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2490 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2495 if (PL_op->op_private & HINT_INTEGER) {
2496 const IV i = ~SvIV_nomg(sv);
2500 const UV u = ~SvUV_nomg(sv);
2509 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2510 sv_setsv_nomg(TARG, sv);
2511 tmps = (U8*)SvPV_force(TARG, len);
2514 /* Calculate exact length, let's not estimate. */
2519 U8 * const send = tmps + len;
2520 U8 * const origtmps = tmps;
2521 const UV utf8flags = UTF8_ALLOW_ANYUV;
2523 while (tmps < send) {
2524 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2526 targlen += UNISKIP(~c);
2532 /* Now rewind strings and write them. */
2539 Newx(result, targlen + 1, U8);
2541 while (tmps < send) {
2542 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2544 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2547 sv_usepvn_flags(TARG, (char*)result, targlen,
2548 SV_HAS_TRAILING_NUL);
2555 Newx(result, nchar + 1, U8);
2557 while (tmps < send) {
2558 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2563 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2571 register long *tmpl;
2572 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2575 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2580 for ( ; anum > 0; anum--, tmps++)
2588 /* integer versions of some of the above */
2592 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2595 SETi( left * right );
2603 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2607 DIE(aTHX_ "Illegal division by zero");
2610 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2614 value = num / value;
2620 #if defined(__GLIBC__) && IVSIZE == 8
2627 /* This is the vanilla old i_modulo. */
2628 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2632 DIE(aTHX_ "Illegal modulus zero");
2633 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2637 SETi( left % right );
2642 #if defined(__GLIBC__) && IVSIZE == 8
2647 /* This is the i_modulo with the workaround for the _moddi3 bug
2648 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2649 * See below for pp_i_modulo. */
2650 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2654 DIE(aTHX_ "Illegal modulus zero");
2655 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2659 SETi( left % PERL_ABS(right) );
2666 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2670 DIE(aTHX_ "Illegal modulus zero");
2671 /* The assumption is to use hereafter the old vanilla version... */
2673 PL_ppaddr[OP_I_MODULO] =
2675 /* .. but if we have glibc, we might have a buggy _moddi3
2676 * (at least glicb 2.2.5 is known to have this bug), in other
2677 * words our integer modulus with negative quad as the second
2678 * argument might be broken. Test for this and re-patch the
2679 * opcode dispatch table if that is the case, remembering to
2680 * also apply the workaround so that this first round works
2681 * right, too. See [perl #9402] for more information. */
2685 /* Cannot do this check with inlined IV constants since
2686 * that seems to work correctly even with the buggy glibc. */
2688 /* Yikes, we have the bug.
2689 * Patch in the workaround version. */
2691 PL_ppaddr[OP_I_MODULO] =
2692 &Perl_pp_i_modulo_1;
2693 /* Make certain we work right this time, too. */
2694 right = PERL_ABS(right);
2697 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2701 SETi( left % right );
2709 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2712 SETi( left + right );
2719 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2722 SETi( left - right );
2729 dVAR; dSP; tryAMAGICbinSET(lt,0);
2732 SETs(boolSV(left < right));
2739 dVAR; dSP; tryAMAGICbinSET(gt,0);
2742 SETs(boolSV(left > right));
2749 dVAR; dSP; tryAMAGICbinSET(le,0);
2752 SETs(boolSV(left <= right));
2759 dVAR; dSP; tryAMAGICbinSET(ge,0);
2762 SETs(boolSV(left >= right));
2769 dVAR; dSP; tryAMAGICbinSET(eq,0);
2772 SETs(boolSV(left == right));
2779 dVAR; dSP; tryAMAGICbinSET(ne,0);
2782 SETs(boolSV(left != right));
2789 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2796 else if (left < right)
2807 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2812 /* High falutin' math. */
2816 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2819 SETn(Perl_atan2(left, right));
2827 int amg_type = sin_amg;
2828 const char *neg_report = NULL;
2829 NV (*func)(NV) = Perl_sin;
2830 const int op_type = PL_op->op_type;
2847 amg_type = sqrt_amg;
2849 neg_report = "sqrt";
2853 tryAMAGICun_var(amg_type);
2855 const NV value = POPn;
2857 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2858 SET_NUMERIC_STANDARD();
2859 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2862 XPUSHn(func(value));
2867 /* Support Configure command-line overrides for rand() functions.
2868 After 5.005, perhaps we should replace this by Configure support
2869 for drand48(), random(), or rand(). For 5.005, though, maintain
2870 compatibility by calling rand() but allow the user to override it.
2871 See INSTALL for details. --Andy Dougherty 15 July 1998
2873 /* Now it's after 5.005, and Configure supports drand48() and random(),
2874 in addition to rand(). So the overrides should not be needed any more.
2875 --Jarkko Hietaniemi 27 September 1998
2878 #ifndef HAS_DRAND48_PROTO
2879 extern double drand48 (void);
2892 if (!PL_srand_called) {
2893 (void)seedDrand01((Rand_seed_t)seed());
2894 PL_srand_called = TRUE;
2904 const UV anum = (MAXARG < 1) ? seed() : POPu;
2905 (void)seedDrand01((Rand_seed_t)anum);
2906 PL_srand_called = TRUE;
2913 dVAR; dSP; dTARGET; tryAMAGICun(int);
2915 SV * const sv = sv_2num(TOPs);
2916 const IV iv = SvIV(sv);
2917 /* XXX it's arguable that compiler casting to IV might be subtly
2918 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2919 else preferring IV has introduced a subtle behaviour change bug. OTOH
2920 relying on floating point to be accurate is a bug. */
2925 else if (SvIOK(sv)) {
2932 const NV value = SvNV(sv);
2934 if (value < (NV)UV_MAX + 0.5) {
2937 SETn(Perl_floor(value));
2941 if (value > (NV)IV_MIN - 0.5) {
2944 SETn(Perl_ceil(value));
2954 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2956 SV * const sv = sv_2num(TOPs);
2957 /* This will cache the NV value if string isn't actually integer */
2958 const IV iv = SvIV(sv);
2963 else if (SvIOK(sv)) {
2964 /* IVX is precise */
2966 SETu(SvUV(sv)); /* force it to be numeric only */
2974 /* 2s complement assumption. Also, not really needed as
2975 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2981 const NV value = SvNV(sv);
2995 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2999 SV* const sv = POPs;
3001 tmps = (SvPV_const(sv, len));
3003 /* If Unicode, try to downgrade
3004 * If not possible, croak. */
3005 SV* const tsv = sv_2mortal(newSVsv(sv));
3008 sv_utf8_downgrade(tsv, FALSE);
3009 tmps = SvPV_const(tsv, len);
3011 if (PL_op->op_type == OP_HEX)
3014 while (*tmps && len && isSPACE(*tmps))
3020 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3022 else if (*tmps == 'b')
3023 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3025 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3027 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3041 SV * const sv = TOPs;
3043 if (SvGAMAGIC(sv)) {
3044 /* For an overloaded or magic scalar, we can't know in advance if
3045 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3046 it likes to cache the length. Maybe that should be a documented
3051 = sv_2pv_flags(sv, &len,
3052 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3056 else if (DO_UTF8(sv)) {
3057 SETi(utf8_length((U8*)p, (U8*)p + len));
3061 } else if (SvOK(sv)) {
3062 /* Neither magic nor overloaded. */
3064 SETi(sv_len_utf8(sv));
3083 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3085 const I32 arybase = CopARYBASE_get(PL_curcop);
3087 const char *repl = NULL;
3089 const int num_args = PL_op->op_private & 7;
3090 bool repl_need_utf8_upgrade = FALSE;
3091 bool repl_is_utf8 = FALSE;
3093 SvTAINTED_off(TARG); /* decontaminate */
3094 SvUTF8_off(TARG); /* decontaminate */
3098 repl = SvPV_const(repl_sv, repl_len);
3099 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3109 sv_utf8_upgrade(sv);
3111 else if (DO_UTF8(sv))
3112 repl_need_utf8_upgrade = TRUE;
3114 tmps = SvPV_const(sv, curlen);
3116 utf8_curlen = sv_len_utf8(sv);
3117 if (utf8_curlen == curlen)
3120 curlen = utf8_curlen;
3125 if (pos >= arybase) {
3143 else if (len >= 0) {
3145 if (rem > (I32)curlen)
3160 Perl_croak(aTHX_ "substr outside of string");
3161 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3165 const I32 upos = pos;
3166 const I32 urem = rem;
3168 sv_pos_u2b(sv, &pos, &rem);
3170 /* we either return a PV or an LV. If the TARG hasn't been used
3171 * before, or is of that type, reuse it; otherwise use a mortal
3172 * instead. Note that LVs can have an extended lifetime, so also
3173 * dont reuse if refcount > 1 (bug #20933) */
3174 if (SvTYPE(TARG) > SVt_NULL) {
3175 if ( (SvTYPE(TARG) == SVt_PVLV)
3176 ? (!lvalue || SvREFCNT(TARG) > 1)
3179 TARG = sv_newmortal();
3183 sv_setpvn(TARG, tmps, rem);
3184 #ifdef USE_LOCALE_COLLATE
3185 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3190 SV* repl_sv_copy = NULL;
3192 if (repl_need_utf8_upgrade) {
3193 repl_sv_copy = newSVsv(repl_sv);
3194 sv_utf8_upgrade(repl_sv_copy);
3195 repl = SvPV_const(repl_sv_copy, repl_len);
3196 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3200 sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3203 SvREFCNT_dec(repl_sv_copy);
3205 else if (lvalue) { /* it's an lvalue! */
3206 if (!SvGMAGICAL(sv)) {
3208 SvPV_force_nolen(sv);
3209 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3210 "Attempt to use reference as lvalue in substr");
3212 if (isGV_with_GP(sv))
3213 SvPV_force_nolen(sv);
3214 else if (SvOK(sv)) /* is it defined ? */
3215 (void)SvPOK_only_UTF8(sv);
3217 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3220 if (SvTYPE(TARG) < SVt_PVLV) {
3221 sv_upgrade(TARG, SVt_PVLV);
3222 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3226 if (LvTARG(TARG) != sv) {
3227 SvREFCNT_dec(LvTARG(TARG));
3228 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3230 LvTARGOFF(TARG) = upos;
3231 LvTARGLEN(TARG) = urem;
3235 PUSHs(TARG); /* avoid SvSETMAGIC here */
3242 register const IV size = POPi;
3243 register const IV offset = POPi;
3244 register SV * const src = POPs;
3245 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3247 SvTAINTED_off(TARG); /* decontaminate */
3248 if (lvalue) { /* it's an lvalue! */
3249 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3250 TARG = sv_newmortal();
3251 if (SvTYPE(TARG) < SVt_PVLV) {
3252 sv_upgrade(TARG, SVt_PVLV);
3253 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3256 if (LvTARG(TARG) != src) {
3257 SvREFCNT_dec(LvTARG(TARG));
3258 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3260 LvTARGOFF(TARG) = offset;
3261 LvTARGLEN(TARG) = size;
3264 sv_setuv(TARG, do_vecget(src, offset, size));
3280 const char *little_p;
3281 const I32 arybase = CopARYBASE_get(PL_curcop);
3284 const bool is_index = PL_op->op_type == OP_INDEX;
3287 /* arybase is in characters, like offset, so combine prior to the
3288 UTF-8 to bytes calculation. */
3289 offset = POPi - arybase;
3293 big_p = SvPV_const(big, biglen);
3294 little_p = SvPV_const(little, llen);
3296 big_utf8 = DO_UTF8(big);
3297 little_utf8 = DO_UTF8(little);
3298 if (big_utf8 ^ little_utf8) {
3299 /* One needs to be upgraded. */
3300 if (little_utf8 && !PL_encoding) {
3301 /* Well, maybe instead we might be able to downgrade the small
3303 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3306 /* If the large string is ISO-8859-1, and it's not possible to
3307 convert the small string to ISO-8859-1, then there is no
3308 way that it could be found anywhere by index. */
3313 /* At this point, pv is a malloc()ed string. So donate it to temp
3314 to ensure it will get free()d */
3315 little = temp = newSV(0);
3316 sv_usepvn(temp, pv, llen);
3317 little_p = SvPVX(little);
3320 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3323 sv_recode_to_utf8(temp, PL_encoding);
3325 sv_utf8_upgrade(temp);
3330 big_p = SvPV_const(big, biglen);
3333 little_p = SvPV_const(little, llen);
3337 if (SvGAMAGIC(big)) {
3338 /* Life just becomes a lot easier if I use a temporary here.
3339 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3340 will trigger magic and overloading again, as will fbm_instr()
3342 big = newSVpvn_flags(big_p, biglen,
3343 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3346 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3347 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3348 warn on undef, and we've already triggered a warning with the
3349 SvPV_const some lines above. We can't remove that, as we need to
3350 call some SvPV to trigger overloading early and find out if the
3352 This is all getting to messy. The API isn't quite clean enough,
3353 because data access has side effects.
3355 little = newSVpvn_flags(little_p, llen,
3356 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3357 little_p = SvPVX(little);
3361 offset = is_index ? 0 : biglen;
3363 if (big_utf8 && offset > 0)
3364 sv_pos_u2b(big, &offset, 0);
3370 else if (offset > (I32)biglen)
3372 if (!(little_p = is_index
3373 ? fbm_instr((unsigned char*)big_p + offset,
3374 (unsigned char*)big_p + biglen, little, 0)
3375 : rninstr(big_p, big_p + offset,
3376 little_p, little_p + llen)))
3379 retval = little_p - big_p;
3380 if (retval > 0 && big_utf8)
3381 sv_pos_b2u(big, &retval);
3385 PUSHi(retval + arybase);
3391 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3392 if (SvTAINTED(MARK[1]))
3393 TAINT_PROPER("sprintf");
3394 do_sprintf(TARG, SP-MARK, MARK+1);
3395 TAINT_IF(SvTAINTED(TARG));
3407 const U8 *s = (U8*)SvPV_const(argsv, len);
3409 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3410 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3411 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3415 XPUSHu(DO_UTF8(argsv) ?
3416 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3428 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3430 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3432 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3434 (void) POPs; /* Ignore the argument value. */
3435 value = UNICODE_REPLACEMENT;
3441 SvUPGRADE(TARG,SVt_PV);
3443 if (value > 255 && !IN_BYTES) {
3444 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3445 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3446 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3448 (void)SvPOK_only(TARG);
3457 *tmps++ = (char)value;
3459 (void)SvPOK_only(TARG);
3461 if (PL_encoding && !IN_BYTES) {
3462 sv_recode_to_utf8(TARG, PL_encoding);
3464 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3465 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3469 *tmps++ = (char)value;
3485 const char *tmps = SvPV_const(left, len);
3487 if (DO_UTF8(left)) {
3488 /* If Unicode, try to downgrade.
3489 * If not possible, croak.
3490 * Yes, we made this up. */
3491 SV* const tsv = sv_2mortal(newSVsv(left));
3494 sv_utf8_downgrade(tsv, FALSE);
3495 tmps = SvPV_const(tsv, len);
3497 # ifdef USE_ITHREADS
3499 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3500 /* This should be threadsafe because in ithreads there is only
3501 * one thread per interpreter. If this would not be true,
3502 * we would need a mutex to protect this malloc. */
3503 PL_reentrant_buffer->_crypt_struct_buffer =
3504 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3505 #if defined(__GLIBC__) || defined(__EMX__)
3506 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3507 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3508 /* work around glibc-2.2.5 bug */
3509 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3513 # endif /* HAS_CRYPT_R */
3514 # endif /* USE_ITHREADS */
3516 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3518 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3524 "The crypt() function is unimplemented due to excessive paranoia.");
3536 bool inplace = TRUE;
3538 const int op_type = PL_op->op_type;
3541 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3547 s = (const U8*)SvPV_nomg_const(source, slen);
3549 if (ckWARN(WARN_UNINITIALIZED))
3550 report_uninit(source);
3555 if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3557 utf8_to_uvchr(s, &ulen);
3558 if (op_type == OP_UCFIRST) {
3559 toTITLE_utf8(s, tmpbuf, &tculen);
3561 toLOWER_utf8(s, tmpbuf, &tculen);
3563 /* If the two differ, we definately cannot do inplace. */
3564 inplace = (ulen == tculen);
3565 need = slen + 1 - ulen + tculen;
3571 if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3572 /* We can convert in place. */
3575 s = d = (U8*)SvPV_force_nomg(source, slen);
3581 SvUPGRADE(dest, SVt_PV);
3582 d = (U8*)SvGROW(dest, need);
3583 (void)SvPOK_only(dest);
3592 /* slen is the byte length of the whole SV.
3593 * ulen is the byte length of the original Unicode character
3594 * stored as UTF-8 at s.
3595 * tculen is the byte length of the freshly titlecased (or
3596 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3597 * We first set the result to be the titlecased (/lowercased)
3598 * character, and then append the rest of the SV data. */
3599 sv_setpvn(dest, (char*)tmpbuf, tculen);
3601 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3605 Copy(tmpbuf, d, tculen, U8);
3606 SvCUR_set(dest, need - 1);
3611 if (IN_LOCALE_RUNTIME) {
3614 *d = (op_type == OP_UCFIRST)
3615 ? toUPPER_LC(*s) : toLOWER_LC(*s);
3618 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3620 /* See bug #39028 */
3628 /* This will copy the trailing NUL */
3629 Copy(s + 1, d + 1, slen, U8);
3630 SvCUR_set(dest, need - 1);
3637 /* There's so much setup/teardown code common between uc and lc, I wonder if
3638 it would be worth merging the two, and just having a switch outside each
3639 of the three tight loops. */
3653 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3654 && SvTEMP(source) && !DO_UTF8(source)) {
3655 /* We can convert in place. */
3658 s = d = (U8*)SvPV_force_nomg(source, len);
3665 /* The old implementation would copy source into TARG at this point.
3666 This had the side effect that if source was undef, TARG was now
3667 an undefined SV with PADTMP set, and they don't warn inside
3668 sv_2pv_flags(). However, we're now getting the PV direct from
3669 source, which doesn't have PADTMP set, so it would warn. Hence the
3673 s = (const U8*)SvPV_nomg_const(source, len);
3675 if (ckWARN(WARN_UNINITIALIZED))
3676 report_uninit(source);
3682 SvUPGRADE(dest, SVt_PV);
3683 d = (U8*)SvGROW(dest, min);
3684 (void)SvPOK_only(dest);
3689 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3690 to check DO_UTF8 again here. */
3692 if (DO_UTF8(source)) {
3693 const U8 *const send = s + len;
3694 U8 tmpbuf[UTF8_MAXBYTES+1];
3697 const STRLEN u = UTF8SKIP(s);
3700 toUPPER_utf8(s, tmpbuf, &ulen);
3701 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3702 /* If the eventually required minimum size outgrows
3703 * the available space, we need to grow. */
3704 const UV o = d - (U8*)SvPVX_const(dest);
3706 /* If someone uppercases one million U+03B0s we SvGROW() one
3707 * million times. Or we could try guessing how much to
3708 allocate without allocating too much. Such is life. */
3710 d = (U8*)SvPVX(dest) + o;
3712 Copy(tmpbuf, d, ulen, U8);
3718 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3721 const U8 *const send = s + len;
3722 if (IN_LOCALE_RUNTIME) {
3725 for (; s < send; d++, s++)
3726 *d = toUPPER_LC(*s);
3729 for (; s < send; d++, s++)
3733 if (source != dest) {
3735 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3755 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3756 && SvTEMP(source) && !DO_UTF8(source)) {
3757 /* We can convert in place. */
3760 s = d = (U8*)SvPV_force_nomg(source, len);
3767 /* The old implementation would copy source into TARG at this point.
3768 This had the side effect that if source was undef, TARG was now
3769 an undefined SV with PADTMP set, and they don't warn inside
3770 sv_2pv_flags(). However, we're now getting the PV direct from
3771 source, which doesn't have PADTMP set, so it would warn. Hence the
3775 s = (const U8*)SvPV_nomg_const(source, len);
3777 if (ckWARN(WARN_UNINITIALIZED))
3778 report_uninit(source);
3784 SvUPGRADE(dest, SVt_PV);
3785 d = (U8*)SvGROW(dest, min);
3786 (void)SvPOK_only(dest);
3791 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3792 to check DO_UTF8 again here. */
3794 if (DO_UTF8(source)) {
3795 const U8 *const send = s + len;
3796 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3799 const STRLEN u = UTF8SKIP(s);
3801 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3803 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3804 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3807 * Now if the sigma is NOT followed by
3808 * /$ignorable_sequence$cased_letter/;
3809 * and it IS preceded by /$cased_letter$ignorable_sequence/;
3810 * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3811 * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3812 * then it should be mapped to 0x03C2,
3813 * (GREEK SMALL LETTER FINAL SIGMA),
3814 * instead of staying 0x03A3.
3815 * "should be": in other words, this is not implemented yet.
3816 * See lib/unicore/SpecialCasing.txt.
3819 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3820 /* If the eventually required minimum size outgrows
3821 * the available space, we need to grow. */
3822 const UV o = d - (U8*)SvPVX_const(dest);
3824 /* If someone lowercases one million U+0130s we SvGROW() one
3825 * million times. Or we could try guessing how much to
3826 allocate without allocating too much. Such is life. */
3828 d = (U8*)SvPVX(dest) + o;
3830 Copy(tmpbuf, d, ulen, U8);
3836 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3839 const U8 *const send = s + len;
3840 if (IN_LOCALE_RUNTIME) {
3843 for (; s < send; d++, s++)
3844 *d = toLOWER_LC(*s);
3847 for (; s < send; d++, s++)
3851 if (source != dest) {
3853 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3863 SV * const sv = TOPs;
3865 register const char *s = SvPV_const(sv,len);
3867 SvUTF8_off(TARG); /* decontaminate */
3870 SvUPGRADE(TARG, SVt_PV);
3871 SvGROW(TARG, (len * 2) + 1);
3875 if (UTF8_IS_CONTINUED(*s)) {
3876 STRLEN ulen = UTF8SKIP(s);
3900 SvCUR_set(TARG, d - SvPVX_const(TARG));
3901 (void)SvPOK_only_UTF8(TARG);
3904 sv_setpvn(TARG, s, len);
3913 dVAR; dSP; dMARK; dORIGMARK;
3914 register AV *const av = MUTABLE_AV(POPs);
3915 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3917 if (SvTYPE(av) == SVt_PVAV) {
3918 const I32 arybase = CopARYBASE_get(PL_curcop);
3919 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3920 bool can_preserve = FALSE;
3926 can_preserve = SvCANEXISTDELETE(av);
3929 if (lval && localizing) {
3932 for (svp = MARK + 1; svp <= SP; svp++) {
3933 const I32 elem = SvIV(*svp);
3937 if (max > AvMAX(av))
3941 while (++MARK <= SP) {
3943 I32 elem = SvIV(*MARK);
3944 bool preeminent = TRUE;
3948 if (localizing && can_preserve) {
3949 /* If we can determine whether the element exist,
3950 * Try to preserve the existenceness of a tied array
3951 * element by using EXISTS and DELETE if possible.
3952 * Fallback to FETCH and STORE otherwise. */
3953 preeminent = av_exists(av, elem);
3956 svp = av_fetch(av, elem, lval);
3958 if (!svp || *svp == &PL_sv_undef)
3959 DIE(aTHX_ PL_no_aelem, elem);
3962 save_aelem(av, elem, svp);
3964 SAVEADELETE(av, elem);
3967 *MARK = svp ? *svp : &PL_sv_undef;
3970 if (GIMME != G_ARRAY) {
3972 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3982 AV *array = MUTABLE_AV(POPs);
3983 const I32 gimme = GIMME_V;
3984 IV *iterp = Perl_av_iter_p(aTHX_ array);
3985 const IV current = (*iterp)++;
3987 if (current > av_len(array)) {
3989 if (gimme == G_SCALAR)
3996 mPUSHi(CopARYBASE_get(PL_curcop) + current);
3997 if (gimme == G_ARRAY) {
3998 SV **const element = av_fetch(array, current, 0);
3999 PUSHs(element ? *element : &PL_sv_undef);
4008 AV *array = MUTABLE_AV(POPs);
4009 const I32 gimme = GIMME_V;
4011 *Perl_av_iter_p(aTHX_ array) = 0;
4013 if (gimme == G_SCALAR) {
4015 PUSHi(av_len(array) + 1);
4017 else if (gimme == G_ARRAY) {
4018 IV n = Perl_av_len(aTHX_ array);
4019 IV i = CopARYBASE_get(PL_curcop);
4023 if (PL_op->op_type == OP_AKEYS) {
4025 for (; i <= n; i++) {
4030 for (i = 0; i <= n; i++) {
4031 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4032 PUSHs(elem ? *elem : &PL_sv_undef);
4039 /* Associative arrays. */
4045 HV * hash = MUTABLE_HV(POPs);
4047 const I32 gimme = GIMME_V;
4050 /* might clobber stack_sp */
4051 entry = hv_iternext(hash);
4056 SV* const sv = hv_iterkeysv(entry);
4057 PUSHs(sv); /* won't clobber stack_sp */
4058 if (gimme == G_ARRAY) {
4061 /* might clobber stack_sp */
4062 val = hv_iterval(hash, entry);
4067 else if (gimme == G_SCALAR)
4074 S_do_delete_local(pTHX)
4078 const I32 gimme = GIMME_V;
4082 if (PL_op->op_private & OPpSLICE) {
4084 SV * const osv = POPs;
4085 const bool tied = SvRMAGICAL(osv)
4086 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4087 const bool can_preserve = SvCANEXISTDELETE(osv)
4088 || mg_find((const SV *)osv, PERL_MAGIC_env);
4089 const U32 type = SvTYPE(osv);
4090 if (type == SVt_PVHV) { /* hash element */
4091 HV * const hv = MUTABLE_HV(osv);
4092 while (++MARK <= SP) {
4093 SV * const keysv = *MARK;
4095 bool preeminent = TRUE;
4097 preeminent = hv_exists_ent(hv, keysv, 0);
4099 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4106 sv = hv_delete_ent(hv, keysv, 0, 0);
4107 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4110 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4112 *MARK = sv_mortalcopy(sv);
4118 SAVEHDELETE(hv, keysv);
4119 *MARK = &PL_sv_undef;
4123 else if (type == SVt_PVAV) { /* array element */
4124 if (PL_op->op_flags & OPf_SPECIAL) {
4125 AV * const av = MUTABLE_AV(osv);
4126 while (++MARK <= SP) {
4127 I32 idx = SvIV(*MARK);
4129 bool preeminent = TRUE;
4131 preeminent = av_exists(av, idx);
4133 SV **svp = av_fetch(av, idx, 1);
4140 sv = av_delete(av, idx, 0);
4141 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4144 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4146 *MARK = sv_mortalcopy(sv);
4152 SAVEADELETE(av, idx);
4153 *MARK = &PL_sv_undef;
4159 DIE(aTHX_ "Not a HASH reference");
4160 if (gimme == G_VOID)
4162 else if (gimme == G_SCALAR) {
4167 *++MARK = &PL_sv_undef;
4172 SV * const keysv = POPs;
4173 SV * const osv = POPs;
4174 const bool tied = SvRMAGICAL(osv)
4175 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4176 const bool can_preserve = SvCANEXISTDELETE(osv)
4177 || mg_find((const SV *)osv, PERL_MAGIC_env);
4178 const U32 type = SvTYPE(osv);
4180 if (type == SVt_PVHV) {
4181 HV * const hv = MUTABLE_HV(osv);
4182 bool preeminent = TRUE;
4184 preeminent = hv_exists_ent(hv, keysv, 0);
4186 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4193 sv = hv_delete_ent(hv, keysv, 0, 0);
4194 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4197 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4199 SV *nsv = sv_mortalcopy(sv);
4205 SAVEHDELETE(hv, keysv);
4207 else if (type == SVt_PVAV) {
4208 if (PL_op->op_flags & OPf_SPECIAL) {
4209 AV * const av = MUTABLE_AV(osv);
4210 I32 idx = SvIV(keysv);
4211 bool preeminent = TRUE;
4213 preeminent = av_exists(av, idx);
4215 SV **svp = av_fetch(av, idx, 1);
4222 sv = av_delete(av, idx, 0);
4223 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4226 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4228 SV *nsv = sv_mortalcopy(sv);
4234 SAVEADELETE(av, idx);
4237 DIE(aTHX_ "panic: avhv_delete no longer supported");
4240 DIE(aTHX_ "Not a HASH reference");
4243 if (gimme != G_VOID)
4257 if (PL_op->op_private & OPpLVAL_INTRO)
4258 return do_delete_local();
4261 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4263 if (PL_op->op_private & OPpSLICE) {
4265 HV * const hv = MUTABLE_HV(POPs);
4266 const U32 hvtype = SvTYPE(hv);
4267 if (hvtype == SVt_PVHV) { /* hash element */
4268 while (++MARK <= SP) {
4269 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4270 *MARK = sv ? sv : &PL_sv_undef;
4273 else if (hvtype == SVt_PVAV) { /* array element */
4274 if (PL_op->op_flags & OPf_SPECIAL) {
4275 while (++MARK <= SP) {
4276 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4277 *MARK = sv ? sv : &PL_sv_undef;
4282 DIE(aTHX_ "Not a HASH reference");
4285 else if (gimme == G_SCALAR) {
4290 *++MARK = &PL_sv_undef;
4296 HV * const hv = MUTABLE_HV(POPs);
4298 if (SvTYPE(hv) == SVt_PVHV)
4299 sv = hv_delete_ent(hv, keysv, discard, 0);
4300 else if (SvTYPE(hv) == SVt_PVAV) {
4301 if (PL_op->op_flags & OPf_SPECIAL)
4302 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4304 DIE(aTHX_ "panic: avhv_delete no longer supported");
4307 DIE(aTHX_ "Not a HASH reference");
4323 if (PL_op->op_private & OPpEXISTS_SUB) {
4325 SV * const sv = POPs;
4326 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4329 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4334 hv = MUTABLE_HV(POPs);
4335 if (SvTYPE(hv) == SVt_PVHV) {
4336 if (hv_exists_ent(hv, tmpsv, 0))
4339 else if (SvTYPE(hv) == SVt_PVAV) {
4340 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4341 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4346 DIE(aTHX_ "Not a HASH reference");
4353 dVAR; dSP; dMARK; dORIGMARK;
4354 register HV * const hv = MUTABLE_HV(POPs);
4355 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4356 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4357 bool can_preserve = FALSE;
4363 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4364 can_preserve = TRUE;
4367 while (++MARK <= SP) {
4368 SV * const keysv = *MARK;
4371 bool preeminent = TRUE;
4373 if (localizing && can_preserve) {
4374 /* If we can determine whether the element exist,
4375 * try to preserve the existenceness of a tied hash
4376 * element by using EXISTS and DELETE if possible.
4377 * Fallback to FETCH and STORE otherwise. */
4378 preeminent = hv_exists_ent(hv, keysv, 0);
4381 he = hv_fetch_ent(hv, keysv, lval, 0);
4382 svp = he ? &HeVAL(he) : NULL;
4385 if (!svp || *svp == &PL_sv_undef) {
4386 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4389 if (HvNAME_get(hv) && isGV(*svp))
4390 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4391 else if (preeminent)
4392 save_helem_flags(hv, keysv, svp,
4393 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4395 SAVEHDELETE(hv, keysv);
4398 *MARK = svp ? *svp : &PL_sv_undef;
4400 if (GIMME != G_ARRAY) {
4402 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4408 /* List operators. */
4413 if (GIMME != G_ARRAY) {
4415 *MARK = *SP; /* unwanted list, return last item */
4417 *MARK = &PL_sv_undef;
4427 SV ** const lastrelem = PL_stack_sp;
4428 SV ** const lastlelem = PL_stack_base + POPMARK;
4429 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4430 register SV ** const firstrelem = lastlelem + 1;
4431 const I32 arybase = CopARYBASE_get(PL_curcop);
4432 I32 is_something_there = FALSE;
4434 register const I32 max = lastrelem - lastlelem;
4435 register SV **lelem;
4437 if (GIMME != G_ARRAY) {
4438 I32 ix = SvIV(*lastlelem);
4443 if (ix < 0 || ix >= max)
4444 *firstlelem = &PL_sv_undef;
4446 *firstlelem = firstrelem[ix];
4452 SP = firstlelem - 1;
4456 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4457 I32 ix = SvIV(*lelem);
4462 if (ix < 0 || ix >= max)
4463 *lelem = &PL_sv_undef;
4465 is_something_there = TRUE;
4466 if (!(*lelem = firstrelem[ix]))
4467 *lelem = &PL_sv_undef;
4470 if (is_something_there)
4473 SP = firstlelem - 1;
4479 dVAR; dSP; dMARK; dORIGMARK;
4480 const I32 items = SP - MARK;
4481 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4482 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4483 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4484 ? newRV_noinc(av) : av);
4490 dVAR; dSP; dMARK; dORIGMARK;
4491 HV* const hv = newHV();
4494 SV * const key = *++MARK;
4495 SV * const val = newSV(0);
4497 sv_setsv(val, *++MARK);
4499 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4500 (void)hv_store_ent(hv,key,val,0);
4503 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4504 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4510 dVAR; dSP; dMARK; dORIGMARK;
4511 register AV *ary = MUTABLE_AV(*++MARK);
4515 register I32 offset;
4516 register I32 length;
4520 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4523 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4527 call_method("SPLICE",GIMME_V);
4536 offset = i = SvIV(*MARK);
4538 offset += AvFILLp(ary) + 1;
4540 offset -= CopARYBASE_get(PL_curcop);
4542 DIE(aTHX_ PL_no_aelem, i);
4544 length = SvIVx(*MARK++);
4546 length += AvFILLp(ary) - offset + 1;
4552 length = AvMAX(ary) + 1; /* close enough to infinity */
4556 length = AvMAX(ary) + 1;
4558 if (offset > AvFILLp(ary) + 1) {
4559 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4560 offset = AvFILLp(ary) + 1;
4562 after = AvFILLp(ary) + 1 - (offset + length);
4563 if (after < 0) { /* not that much array */
4564 length += after; /* offset+length now in array */
4570 /* At this point, MARK .. SP-1 is our new LIST */
4573 diff = newlen - length;
4574 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4577 /* make new elements SVs now: avoid problems if they're from the array */
4578 for (dst = MARK, i = newlen; i; i--) {
4579 SV * const h = *dst;
4580 *dst++ = newSVsv(h);
4583 if (diff < 0) { /* shrinking the area */
4584 SV **tmparyval = NULL;
4586 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4587 Copy(MARK, tmparyval, newlen, SV*);
4590 MARK = ORIGMARK + 1;
4591 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4592 MEXTEND(MARK, length);
4593 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4595 EXTEND_MORTAL(length);
4596 for (i = length, dst = MARK; i; i--) {
4597 sv_2mortal(*dst); /* free them eventualy */
4604 *MARK = AvARRAY(ary)[offset+length-1];
4607 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4608 SvREFCNT_dec(*dst++); /* free them now */
4611 AvFILLp(ary) += diff;
4613 /* pull up or down? */
4615 if (offset < after) { /* easier to pull up */
4616 if (offset) { /* esp. if nothing to pull */
4617 src = &AvARRAY(ary)[offset-1];
4618 dst = src - diff; /* diff is negative */
4619 for (i = offset; i > 0; i--) /* can't trust Copy */
4623 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4627 if (after) { /* anything to pull down? */
4628 src = AvARRAY(ary) + offset + length;
4629 dst = src + diff; /* diff is negative */
4630 Move(src, dst, after, SV*);
4632 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4633 /* avoid later double free */
4637 dst[--i] = &PL_sv_undef;
4640 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4641 Safefree(tmparyval);
4644 else { /* no, expanding (or same) */
4645 SV** tmparyval = NULL;
4647 Newx(tmparyval, length, SV*); /* so remember deletion */
4648 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4651 if (diff > 0) { /* expanding */
4652 /* push up or down? */
4653 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4657 Move(src, dst, offset, SV*);
4659 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4661 AvFILLp(ary) += diff;
4664 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4665 av_extend(ary, AvFILLp(ary) + diff);
4666 AvFILLp(ary) += diff;
4669 dst = AvARRAY(ary) + AvFILLp(ary);
4671 for (i = after; i; i--) {
4679 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4682 MARK = ORIGMARK + 1;
4683 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4685 Copy(tmparyval, MARK, length, SV*);
4687 EXTEND_MORTAL(length);
4688 for (i = length, dst = MARK; i; i--) {
4689 sv_2mortal(*dst); /* free them eventualy */
4696 else if (length--) {
4697 *MARK = tmparyval[length];
4700 while (length-- > 0)
4701 SvREFCNT_dec(tmparyval[length]);
4705 *MARK = &PL_sv_undef;
4706 Safefree(tmparyval);
4714 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4715 register AV * const ary = MUTABLE_AV(*++MARK);
4716 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4719 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4723 call_method("PUSH",G_SCALAR|G_DISCARD);
4728 PL_delaymagic = DM_DELAY;
4729 for (++MARK; MARK <= SP; MARK++) {
4730 SV * const sv = newSV(0);
4732 sv_setsv(sv, *MARK);
4733 av_store(ary, AvFILLp(ary)+1, sv);
4735 if (PL_delaymagic & DM_ARRAY)
4736 mg_set(MUTABLE_SV(ary));
4741 if (OP_GIMME(PL_op, 0) != G_VOID) {
4742 PUSHi( AvFILL(ary) + 1 );
4751 AV * const av = MUTABLE_AV(POPs);
4752 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4756 (void)sv_2mortal(sv);
4763 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4764 register AV *ary = MUTABLE_AV(*++MARK);
4765 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4768 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4772 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4778 av_unshift(ary, SP - MARK);
4780 SV * const sv = newSVsv(*++MARK);
4781 (void)av_store(ary, i++, sv);
4785 if (OP_GIMME(PL_op, 0) != G_VOID) {
4786 PUSHi( AvFILL(ary) + 1 );
4795 if (GIMME == G_ARRAY) {
4796 if (PL_op->op_private & OPpREVERSE_INPLACE) {
4800 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
4801 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
4802 av = MUTABLE_AV((*SP));
4803 /* In-place reversing only happens in void context for the array
4804 * assignment. We don't need to push anything on the stack. */
4807 if (SvMAGICAL(av)) {
4809 register SV *tmp = sv_newmortal();
4810 /* For SvCANEXISTDELETE */
4813 bool can_preserve = SvCANEXISTDELETE(av);
4815 for (i = 0, j = av_len(av); i < j; ++i, --j) {
4816 register SV *begin, *end;
4819 if (!av_exists(av, i)) {
4820 if (av_exists(av, j)) {
4821 register SV *sv = av_delete(av, j, 0);
4822 begin = *av_fetch(av, i, TRUE);
4823 sv_setsv_mg(begin, sv);
4827 else if (!av_exists(av, j)) {
4828 register SV *sv = av_delete(av, i, 0);
4829 end = *av_fetch(av, j, TRUE);
4830 sv_setsv_mg(end, sv);
4835 begin = *av_fetch(av, i, TRUE);
4836 end = *av_fetch(av, j, TRUE);
4837 sv_setsv(tmp, begin);
4838 sv_setsv_mg(begin, end);
4839 sv_setsv_mg(end, tmp);
4843 SV **begin = AvARRAY(av);
4844 SV **end = begin + AvFILLp(av);
4846 while (begin < end) {
4847 register SV * const tmp = *begin;
4857 register SV * const tmp = *MARK;
4861 /* safe as long as stack cannot get extended in the above */
4867 register char *down;
4871 PADOFFSET padoff_du;
4873 SvUTF8_off(TARG); /* decontaminate */
4875 do_join(TARG, &PL_sv_no, MARK, SP);
4877 sv_setsv(TARG, (SP > MARK)
4879 : (padoff_du = find_rundefsvoffset(),
4880 (padoff_du == NOT_IN_PAD
4881 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4882 ? DEFSV : PAD_SVl(padoff_du)));
4884 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4885 report_uninit(TARG);
4888 up = SvPV_force(TARG, len);
4890 if (DO_UTF8(TARG)) { /* first reverse each character */
4891 U8* s = (U8*)SvPVX(TARG);
4892 const U8* send = (U8*)(s + len);
4894 if (UTF8_IS_INVARIANT(*s)) {
4899 if (!utf8_to_uvchr(s, 0))
4903 down = (char*)(s - 1);
4904 /* reverse this character */
4908 *down-- = (char)tmp;
4914 down = SvPVX(TARG) + len - 1;
4918 *down-- = (char)tmp;
4920 (void)SvPOK_only_UTF8(TARG);
4932 register IV limit = POPi; /* note, negative is forever */
4933 SV * const sv = POPs;
4935 register const char *s = SvPV_const(sv, len);
4936 const bool do_utf8 = DO_UTF8(sv);
4937 const char *strend = s + len;
4939 register REGEXP *rx;
4941 register const char *m;
4943 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4944 I32 maxiters = slen + 10;
4945 I32 trailing_empty = 0;
4947 const I32 origlimit = limit;
4950 const I32 gimme = GIMME_V;
4952 const I32 oldsave = PL_savestack_ix;
4953 U32 make_mortal = SVs_TEMP;
4958 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4963 DIE(aTHX_ "panic: pp_split");
4966 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4967 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4969 RX_MATCH_UTF8_set(rx, do_utf8);
4972 if (pm->op_pmreplrootu.op_pmtargetoff) {
4973 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
4976 if (pm->op_pmreplrootu.op_pmtargetgv) {
4977 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4982 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4988 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
4990 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
4997 for (i = AvFILLp(ary); i >= 0; i--)
4998 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5000 /* temporarily switch stacks */
5001 SAVESWITCHSTACK(PL_curstack, ary);
5005 base = SP - PL_stack_base;
5007 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5009 while (*s == ' ' || is_utf8_space((U8*)s))
5012 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5013 while (isSPACE_LC(*s))
5021 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5025 gimme_scalar = gimme == G_SCALAR && !ary;
5028 limit = maxiters + 2;
5029 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5032 /* this one uses 'm' and is a negative test */
5034 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5035 const int t = UTF8SKIP(m);
5036 /* is_utf8_space returns FALSE for malform utf8 */
5042 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5043 while (m < strend && !isSPACE_LC(*m))
5046 while (m < strend && !isSPACE(*m))
5059 dstr = newSVpvn_flags(s, m-s,
5060 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5064 /* skip the whitespace found last */
5066 s = m + UTF8SKIP(m);
5070 /* this one uses 's' and is a positive test */
5072 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5074 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5075 while (s < strend && isSPACE_LC(*s))
5078 while (s < strend && isSPACE(*s))
5083 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5085 for (m = s; m < strend && *m != '\n'; m++)
5098 dstr = newSVpvn_flags(s, m-s,
5099 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5105 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5107 Pre-extend the stack, either the number of bytes or
5108 characters in the string or a limited amount, triggered by:
5110 my ($x, $y) = split //, $str;
5114 if (!gimme_scalar) {
5115 const U32 items = limit - 1;
5124 /* keep track of how many bytes we skip over */
5134 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5147 dstr = newSVpvn(s, 1);
5163 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5164 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5165 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5166 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5167 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5168 SV * const csv = CALLREG_INTUIT_STRING(rx);
5170 len = RX_MINLENRET(rx);
5171 if (len == 1 && !RX_UTF8(rx) && !tail) {
5172 const char c = *SvPV_nolen_const(csv);
5174 for (m = s; m < strend && *m != c; m++)
5185 dstr = newSVpvn_flags(s, m-s,
5186 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5189 /* The rx->minlen is in characters but we want to step
5190 * s ahead by bytes. */
5192 s = (char*)utf8_hop((U8*)m, len);
5194 s = m + len; /* Fake \n at the end */
5198 while (s < strend && --limit &&
5199 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5200 csv, multiline ? FBMrf_MULTILINE : 0)) )
5209 dstr = newSVpvn_flags(s, m-s,
5210 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5213 /* The rx->minlen is in characters but we want to step
5214 * s ahead by bytes. */
5216 s = (char*)utf8_hop((U8*)m, len);
5218 s = m + len; /* Fake \n at the end */
5223 maxiters += slen * RX_NPARENS(rx);
5224 while (s < strend && --limit)
5228 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5231 if (rex_return == 0)
5233 TAINT_IF(RX_MATCH_TAINTED(rx));
5234 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5237 orig = RX_SUBBEG(rx);
5239 strend = s + (strend - m);
5241 m = RX_OFFS(rx)[0].start + orig;
5250 dstr = newSVpvn_flags(s, m-s,
5251 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5254 if (RX_NPARENS(rx)) {
5256 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5257 s = RX_OFFS(rx)[i].start + orig;
5258 m = RX_OFFS(rx)[i].end + orig;
5260 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5261 parens that didn't match -- they should be set to
5262 undef, not the empty string */
5270 if (m >= orig && s >= orig) {
5271 dstr = newSVpvn_flags(s, m-s,
5272 (do_utf8 ? SVf_UTF8 : 0)
5276 dstr = &PL_sv_undef; /* undef, not "" */
5282 s = RX_OFFS(rx)[0].end + orig;
5286 if (!gimme_scalar) {
5287 iters = (SP - PL_stack_base) - base;
5289 if (iters > maxiters)
5290 DIE(aTHX_ "Split loop");
5292 /* keep field after final delim? */
5293 if (s < strend || (iters && origlimit)) {
5294 if (!gimme_scalar) {
5295 const STRLEN l = strend - s;
5296 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5301 else if (!origlimit) {
5303 iters -= trailing_empty;
5305 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5306 if (TOPs && !make_mortal)
5308 *SP-- = &PL_sv_undef;
5315 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5319 if (SvSMAGICAL(ary)) {
5321 mg_set(MUTABLE_SV(ary));
5324 if (gimme == G_ARRAY) {
5326 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5334 call_method("PUSH",G_SCALAR|G_DISCARD);
5337 if (gimme == G_ARRAY) {
5339 /* EXTEND should not be needed - we just popped them */
5341 for (i=0; i < iters; i++) {
5342 SV **svp = av_fetch(ary, i, FALSE);
5343 PUSHs((svp) ? *svp : &PL_sv_undef);
5350 if (gimme == G_ARRAY)
5362 SV *const sv = PAD_SVl(PL_op->op_targ);
5364 if (SvPADSTALE(sv)) {
5367 RETURNOP(cLOGOP->op_other);
5369 RETURNOP(cLOGOP->op_next);
5378 assert(SvTYPE(retsv) != SVt_PVCV);
5380 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
5381 retsv = refto(retsv);
5388 PP(unimplemented_op)
5391 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5400 HV * const hv = (HV*)POPs;
5402 if (SvRMAGICAL(hv)) {
5403 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5405 XPUSHs(magic_scalarpack(hv, mg));
5410 XPUSHs(boolSV(HvKEYS(hv) != 0));
5416 * c-indentation-style: bsd
5418 * indent-tabs-mode: t
5421 * ex: set ts=8 sts=4 sw=4 noet: