3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
34 it, since pid_t is an integral type.
37 #ifdef NEED_GETPID_PROTO
38 extern Pid_t getpid (void);
42 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
43 * This switches them over to IEEE.
45 #if defined(LIBM_LIB_VERSION)
46 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
49 /* variations on pp_null */
55 if (GIMME_V == G_SCALAR)
66 assert(SvTYPE(TARG) == SVt_PVAV);
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 if (!(PL_op->op_private & OPpPAD_STATE))
69 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
71 if (PL_op->op_flags & OPf_REF) {
75 if (GIMME == G_SCALAR)
76 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
81 if (gimme == G_ARRAY) {
82 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
84 if (SvMAGICAL(TARG)) {
86 for (i=0; i < (U32)maxarg; i++) {
87 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
88 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
92 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
96 else if (gimme == G_SCALAR) {
97 SV* const sv = sv_newmortal();
98 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
110 assert(SvTYPE(TARG) == SVt_PVHV);
112 if (PL_op->op_private & OPpLVAL_INTRO)
113 if (!(PL_op->op_private & OPpPAD_STATE))
114 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
115 if (PL_op->op_flags & OPf_REF)
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
123 if (gimme == G_ARRAY) {
126 else if (gimme == G_SCALAR) {
127 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
135 static const char S_no_symref_sv[] =
136 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
142 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
145 sv = amagic_deref_call(sv, to_gv_amg);
149 if (SvTYPE(sv) == SVt_PVIO) {
150 GV * const gv = MUTABLE_GV(sv_newmortal());
151 gv_init(gv, 0, "", 0, 0);
152 GvIOp(gv) = MUTABLE_IO(sv);
153 SvREFCNT_inc_void_NN(sv);
156 else if (!isGV_with_GP(sv))
157 DIE(aTHX_ "Not a GLOB reference");
160 if (!isGV_with_GP(sv)) {
161 if (!SvOK(sv) && sv != &PL_sv_undef) {
162 /* If this is a 'my' scalar and flag is set then vivify
166 Perl_croak_no_modify(aTHX);
167 if (PL_op->op_private & OPpDEREF) {
169 if (cUNOP->op_targ) {
171 SV * const namesv = PAD_SV(cUNOP->op_targ);
172 const char * const name = SvPV(namesv, len);
173 gv = MUTABLE_GV(newSV(0));
174 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
177 const char * const name = CopSTASHPV(PL_curcop);
180 prepare_SV_for_RV(sv);
181 SvRV_set(sv, MUTABLE_SV(gv));
186 if (PL_op->op_flags & OPf_REF ||
187 PL_op->op_private & HINT_STRICT_REFS)
188 DIE(aTHX_ PL_no_usym, "a symbol");
189 if (ckWARN(WARN_UNINITIALIZED))
193 if ((PL_op->op_flags & OPf_SPECIAL) &&
194 !(PL_op->op_flags & OPf_MOD))
196 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
198 && (!is_gv_magical_sv(sv,0)
199 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
206 if (PL_op->op_private & HINT_STRICT_REFS)
207 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
208 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
209 == OPpDONT_INIT_GV) {
210 /* We are the target of a coderef assignment. Return
211 the scalar unchanged, and let pp_sasssign deal with
215 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
217 /* FAKE globs in the symbol table cause weird bugs (#77810) */
218 if (sv) SvFAKE_off(sv);
221 if (PL_op->op_private & OPpLVAL_INTRO)
222 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
223 if (sv && SvFAKE(sv)) {
224 SV *newsv = sv_newmortal();
225 sv_setsv_flags(newsv, sv, 0);
233 /* Helper function for pp_rv2sv and pp_rv2av */
235 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
236 const svtype type, SV ***spp)
241 PERL_ARGS_ASSERT_SOFTREF2XV;
243 if (PL_op->op_private & HINT_STRICT_REFS) {
245 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
247 Perl_die(aTHX_ PL_no_usym, what);
250 if (PL_op->op_flags & OPf_REF)
251 Perl_die(aTHX_ PL_no_usym, what);
252 if (ckWARN(WARN_UNINITIALIZED))
254 if (type != SVt_PV && GIMME_V == G_ARRAY) {
258 **spp = &PL_sv_undef;
261 if ((PL_op->op_flags & OPf_SPECIAL) &&
262 !(PL_op->op_flags & OPf_MOD))
264 gv = gv_fetchsv(sv, 0, type);
266 && (!is_gv_magical_sv(sv,0)
267 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
269 **spp = &PL_sv_undef;
274 gv = gv_fetchsv(sv, GV_ADD, type);
284 if (!(PL_op->op_private & OPpDEREFed))
287 sv = amagic_deref_call(sv, to_sv_amg);
291 switch (SvTYPE(sv)) {
297 DIE(aTHX_ "Not a SCALAR reference");
304 if (!isGV_with_GP(gv)) {
305 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
311 if (PL_op->op_flags & OPf_MOD) {
312 if (PL_op->op_private & OPpLVAL_INTRO) {
313 if (cUNOP->op_first->op_type == OP_NULL)
314 sv = save_scalar(MUTABLE_GV(TOPs));
316 sv = save_scalar(gv);
318 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
320 else if (PL_op->op_private & OPpDEREF)
321 vivify_ref(sv, PL_op->op_private & OPpDEREF);
330 AV * const av = MUTABLE_AV(TOPs);
331 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
333 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
335 *sv = newSV_type(SVt_PVMG);
336 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
340 SETs(sv_2mortal(newSViv(
341 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
351 if (PL_op->op_flags & OPf_MOD || LVRET) {
352 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
353 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
355 LvTARG(ret) = SvREFCNT_inc_simple(sv);
356 PUSHs(ret); /* no SvSETMAGIC */
360 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
361 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
362 if (mg && mg->mg_len >= 0) {
367 PUSHi(i + CopARYBASE_get(PL_curcop));
380 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
382 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
385 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
386 /* (But not in defined().) */
388 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
391 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
392 if ((PL_op->op_private & OPpLVAL_INTRO)) {
393 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
396 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
399 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
403 cv = MUTABLE_CV(&PL_sv_undef);
404 SETs(MUTABLE_SV(cv));
414 SV *ret = &PL_sv_undef;
416 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
417 const char * s = SvPVX_const(TOPs);
418 if (strnEQ(s, "CORE::", 6)) {
419 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
420 if (code < 0) { /* Overridable. */
421 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
422 int i = 0, n = 0, seen_question = 0, defgv = 0;
424 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
426 if (code == -KEY_chop || code == -KEY_chomp
427 || code == -KEY_exec || code == -KEY_system)
429 if (code == -KEY_mkdir) {
430 ret = newSVpvs_flags("_;$", SVs_TEMP);
433 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
434 ret = newSVpvs_flags("+", SVs_TEMP);
437 if (code == -KEY_push || code == -KEY_unshift) {
438 ret = newSVpvs_flags("+@", SVs_TEMP);
441 if (code == -KEY_pop || code == -KEY_shift) {
442 ret = newSVpvs_flags(";+", SVs_TEMP);
445 if (code == -KEY_splice) {
446 ret = newSVpvs_flags("+;$$@", SVs_TEMP);
449 if (code == -KEY_tied || code == -KEY_untie) {
450 ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
453 if (code == -KEY_tie) {
454 ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
457 if (code == -KEY_readpipe) {
458 s = "CORE::backtick";
460 while (i < MAXO) { /* The slow way. */
461 if (strEQ(s + 6, PL_op_name[i])
462 || strEQ(s + 6, PL_op_desc[i]))
468 goto nonesuch; /* Should not happen... */
470 defgv = PL_opargs[i] & OA_DEFGV;
471 oa = PL_opargs[i] >> OASHIFT;
473 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
477 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
478 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
479 /* But globs are already references (kinda) */
480 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
484 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
487 if (defgv && str[n - 1] == '$')
490 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
492 else if (code) /* Non-Overridable */
494 else { /* None such */
496 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
500 cv = sv_2cv(TOPs, &stash, &gv, 0);
502 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
511 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
513 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
515 PUSHs(MUTABLE_SV(cv));
529 if (GIMME != G_ARRAY) {
533 *MARK = &PL_sv_undef;
534 *MARK = refto(*MARK);
538 EXTEND_MORTAL(SP - MARK);
540 *MARK = refto(*MARK);
545 S_refto(pTHX_ SV *sv)
550 PERL_ARGS_ASSERT_REFTO;
552 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
555 if (!(sv = LvTARG(sv)))
558 SvREFCNT_inc_void_NN(sv);
560 else if (SvTYPE(sv) == SVt_PVAV) {
561 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
562 av_reify(MUTABLE_AV(sv));
564 SvREFCNT_inc_void_NN(sv);
566 else if (SvPADTMP(sv) && !IS_PADGV(sv))
570 SvREFCNT_inc_void_NN(sv);
573 sv_upgrade(rv, SVt_IV);
583 SV * const sv = POPs;
588 if (!sv || !SvROK(sv))
591 pv = sv_reftype(SvRV(sv),TRUE);
592 PUSHp(pv, strlen(pv));
602 stash = CopSTASH(PL_curcop);
604 SV * const ssv = POPs;
608 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
609 Perl_croak(aTHX_ "Attempt to bless into a reference");
610 ptr = SvPV_const(ssv,len);
612 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
613 "Explicit blessing to '' (assuming package main)");
614 stash = gv_stashpvn(ptr, len, GV_ADD);
617 (void)sv_bless(TOPs, stash);
626 const char * const elem = SvPV_nolen_const(sv);
627 GV * const gv = MUTABLE_GV(POPs);
632 /* elem will always be NUL terminated. */
633 const char * const second_letter = elem + 1;
636 if (strEQ(second_letter, "RRAY"))
637 tmpRef = MUTABLE_SV(GvAV(gv));
640 if (strEQ(second_letter, "ODE"))
641 tmpRef = MUTABLE_SV(GvCVu(gv));
644 if (strEQ(second_letter, "ILEHANDLE")) {
645 /* finally deprecated in 5.8.0 */
646 deprecate("*glob{FILEHANDLE}");
647 tmpRef = MUTABLE_SV(GvIOp(gv));
650 if (strEQ(second_letter, "ORMAT"))
651 tmpRef = MUTABLE_SV(GvFORM(gv));
654 if (strEQ(second_letter, "LOB"))
655 tmpRef = MUTABLE_SV(gv);
658 if (strEQ(second_letter, "ASH"))
659 tmpRef = MUTABLE_SV(GvHV(gv));
662 if (*second_letter == 'O' && !elem[2])
663 tmpRef = MUTABLE_SV(GvIOp(gv));
666 if (strEQ(second_letter, "AME"))
667 sv = newSVhek(GvNAME_HEK(gv));
670 if (strEQ(second_letter, "ACKAGE")) {
671 const HV * const stash = GvSTASH(gv);
672 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
673 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
677 if (strEQ(second_letter, "CALAR"))
692 /* Pattern matching */
697 register unsigned char *s;
700 register I32 *sfirst;
704 if (sv == PL_lastscream) {
708 s = (unsigned char*)(SvPV(sv, len));
710 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
711 /* No point in studying a zero length string, and not safe to study
712 anything that doesn't appear to be a simple scalar (and hence might
713 change between now and when the regexp engine runs without our set
714 magic ever running) such as a reference to an object with overloaded
720 SvSCREAM_off(PL_lastscream);
721 SvREFCNT_dec(PL_lastscream);
723 PL_lastscream = SvREFCNT_inc_simple(sv);
725 s = (unsigned char*)(SvPV(sv, len));
729 if (pos > PL_maxscream) {
730 if (PL_maxscream < 0) {
731 PL_maxscream = pos + 80;
732 Newx(PL_screamfirst, 256, I32);
733 Newx(PL_screamnext, PL_maxscream, I32);
736 PL_maxscream = pos + pos / 4;
737 Renew(PL_screamnext, PL_maxscream, I32);
741 sfirst = PL_screamfirst;
742 snext = PL_screamnext;
744 if (!sfirst || !snext)
745 DIE(aTHX_ "do_study: out of memory");
747 for (ch = 256; ch; --ch)
752 register const I32 ch = s[pos];
754 snext[pos] = sfirst[ch] - pos;
761 /* piggyback on m//g magic */
762 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
771 if (PL_op->op_flags & OPf_STACKED)
773 else if (PL_op->op_private & OPpTARGET_MY)
779 TARG = sv_newmortal();
780 if(PL_op->op_type == OP_TRANSR) {
781 SV * const newsv = newSVsv(sv);
785 else PUSHi(do_trans(sv));
789 /* Lvalue operators. */
801 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
803 do_chop(TARG, *++MARK);
812 SETi(do_chomp(TOPs));
818 dVAR; dSP; dMARK; dTARGET;
819 register I32 count = 0;
822 count += do_chomp(POPs);
832 if (!PL_op->op_private) {
841 SV_CHECK_THINKFIRST_COW_DROP(sv);
843 switch (SvTYPE(sv)) {
847 av_undef(MUTABLE_AV(sv));
850 hv_undef(MUTABLE_HV(sv));
853 if (cv_const_sv((const CV *)sv))
854 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
855 CvANON((const CV *)sv) ? "(anonymous)"
856 : GvENAME(CvGV((const CV *)sv)));
860 /* let user-undef'd sub keep its identity */
861 GV* const gv = CvGV((const CV *)sv);
862 cv_undef(MUTABLE_CV(sv));
863 CvGV_set(MUTABLE_CV(sv), gv);
868 SvSetMagicSV(sv, &PL_sv_undef);
871 else if (isGV_with_GP(sv)) {
876 if((stash = GvHV((const GV *)sv)) && HvENAME_get(stash))
877 mro_isa_changed_in(stash);
878 /* undef *Pkg::meth_name ... */
879 else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
880 && HvENAME_get(stash))
881 mro_method_changed_in(stash);
883 gp_free(MUTABLE_GV(sv));
885 GvGP(sv) = gp_ref(gp);
887 GvLINE(sv) = CopLINE(PL_curcop);
888 GvEGV(sv) = MUTABLE_GV(sv);
894 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
909 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
910 Perl_croak_no_modify(aTHX);
911 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
912 && SvIVX(TOPs) != IV_MIN)
914 SvIV_set(TOPs, SvIVX(TOPs) - 1);
915 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
926 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
927 Perl_croak_no_modify(aTHX);
929 TARG = sv_newmortal();
930 sv_setsv(TARG, TOPs);
931 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
932 && SvIVX(TOPs) != IV_MAX)
934 SvIV_set(TOPs, SvIVX(TOPs) + 1);
935 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
940 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
950 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
951 Perl_croak_no_modify(aTHX);
953 TARG = sv_newmortal();
954 sv_setsv(TARG, TOPs);
955 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
956 && SvIVX(TOPs) != IV_MIN)
958 SvIV_set(TOPs, SvIVX(TOPs) - 1);
959 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
968 /* Ordinary operators. */
972 dVAR; dSP; dATARGET; SV *svl, *svr;
973 #ifdef PERL_PRESERVE_IVUV
976 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
979 #ifdef PERL_PRESERVE_IVUV
980 /* For integer to integer power, we do the calculation by hand wherever
981 we're sure it is safe; otherwise we call pow() and try to convert to
982 integer afterwards. */
984 SvIV_please_nomg(svr);
986 SvIV_please_nomg(svl);
995 const IV iv = SvIVX(svr);
999 goto float_it; /* Can't do negative powers this way. */
1003 baseuok = SvUOK(svl);
1005 baseuv = SvUVX(svl);
1007 const IV iv = SvIVX(svl);
1010 baseuok = TRUE; /* effectively it's a UV now */
1012 baseuv = -iv; /* abs, baseuok == false records sign */
1015 /* now we have integer ** positive integer. */
1018 /* foo & (foo - 1) is zero only for a power of 2. */
1019 if (!(baseuv & (baseuv - 1))) {
1020 /* We are raising power-of-2 to a positive integer.
1021 The logic here will work for any base (even non-integer
1022 bases) but it can be less accurate than
1023 pow (base,power) or exp (power * log (base)) when the
1024 intermediate values start to spill out of the mantissa.
1025 With powers of 2 we know this can't happen.
1026 And powers of 2 are the favourite thing for perl
1027 programmers to notice ** not doing what they mean. */
1029 NV base = baseuok ? baseuv : -(NV)baseuv;
1034 while (power >>= 1) {
1042 SvIV_please_nomg(svr);
1045 register unsigned int highbit = 8 * sizeof(UV);
1046 register unsigned int diff = 8 * sizeof(UV);
1047 while (diff >>= 1) {
1049 if (baseuv >> highbit) {
1053 /* we now have baseuv < 2 ** highbit */
1054 if (power * highbit <= 8 * sizeof(UV)) {
1055 /* result will definitely fit in UV, so use UV math
1056 on same algorithm as above */
1057 register UV result = 1;
1058 register UV base = baseuv;
1059 const bool odd_power = cBOOL(power & 1);
1063 while (power >>= 1) {
1070 if (baseuok || !odd_power)
1071 /* answer is positive */
1073 else if (result <= (UV)IV_MAX)
1074 /* answer negative, fits in IV */
1075 SETi( -(IV)result );
1076 else if (result == (UV)IV_MIN)
1077 /* 2's complement assumption: special case IV_MIN */
1080 /* answer negative, doesn't fit */
1081 SETn( -(NV)result );
1091 NV right = SvNV_nomg(svr);
1092 NV left = SvNV_nomg(svl);
1095 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1097 We are building perl with long double support and are on an AIX OS
1098 afflicted with a powl() function that wrongly returns NaNQ for any
1099 negative base. This was reported to IBM as PMR #23047-379 on
1100 03/06/2006. The problem exists in at least the following versions
1101 of AIX and the libm fileset, and no doubt others as well:
1103 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1104 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1105 AIX 5.2.0 bos.adt.libm 5.2.0.85
1107 So, until IBM fixes powl(), we provide the following workaround to
1108 handle the problem ourselves. Our logic is as follows: for
1109 negative bases (left), we use fmod(right, 2) to check if the
1110 exponent is an odd or even integer:
1112 - if odd, powl(left, right) == -powl(-left, right)
1113 - if even, powl(left, right) == powl(-left, right)
1115 If the exponent is not an integer, the result is rightly NaNQ, so
1116 we just return that (as NV_NAN).
1120 NV mod2 = Perl_fmod( right, 2.0 );
1121 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1122 SETn( -Perl_pow( -left, right) );
1123 } else if (mod2 == 0.0) { /* even integer */
1124 SETn( Perl_pow( -left, right) );
1125 } else { /* fractional power */
1129 SETn( Perl_pow( left, right) );
1132 SETn( Perl_pow( left, right) );
1133 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1135 #ifdef PERL_PRESERVE_IVUV
1137 SvIV_please_nomg(svr);
1145 dVAR; dSP; dATARGET; SV *svl, *svr;
1146 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1149 #ifdef PERL_PRESERVE_IVUV
1150 SvIV_please_nomg(svr);
1152 /* Unless the left argument is integer in range we are going to have to
1153 use NV maths. Hence only attempt to coerce the right argument if
1154 we know the left is integer. */
1155 /* Left operand is defined, so is it IV? */
1156 SvIV_please_nomg(svl);
1158 bool auvok = SvUOK(svl);
1159 bool buvok = SvUOK(svr);
1160 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1161 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1170 const IV aiv = SvIVX(svl);
1173 auvok = TRUE; /* effectively it's a UV now */
1175 alow = -aiv; /* abs, auvok == false records sign */
1181 const IV biv = SvIVX(svr);
1184 buvok = TRUE; /* effectively it's a UV now */
1186 blow = -biv; /* abs, buvok == false records sign */
1190 /* If this does sign extension on unsigned it's time for plan B */
1191 ahigh = alow >> (4 * sizeof (UV));
1193 bhigh = blow >> (4 * sizeof (UV));
1195 if (ahigh && bhigh) {
1197 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1198 which is overflow. Drop to NVs below. */
1199 } else if (!ahigh && !bhigh) {
1200 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1201 so the unsigned multiply cannot overflow. */
1202 const UV product = alow * blow;
1203 if (auvok == buvok) {
1204 /* -ve * -ve or +ve * +ve gives a +ve result. */
1208 } else if (product <= (UV)IV_MIN) {
1209 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1210 /* -ve result, which could overflow an IV */
1212 SETi( -(IV)product );
1214 } /* else drop to NVs below. */
1216 /* One operand is large, 1 small */
1219 /* swap the operands */
1221 bhigh = blow; /* bhigh now the temp var for the swap */
1225 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1226 multiplies can't overflow. shift can, add can, -ve can. */
1227 product_middle = ahigh * blow;
1228 if (!(product_middle & topmask)) {
1229 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1231 product_middle <<= (4 * sizeof (UV));
1232 product_low = alow * blow;
1234 /* as for pp_add, UV + something mustn't get smaller.
1235 IIRC ANSI mandates this wrapping *behaviour* for
1236 unsigned whatever the actual representation*/
1237 product_low += product_middle;
1238 if (product_low >= product_middle) {
1239 /* didn't overflow */
1240 if (auvok == buvok) {
1241 /* -ve * -ve or +ve * +ve gives a +ve result. */
1243 SETu( product_low );
1245 } else if (product_low <= (UV)IV_MIN) {
1246 /* 2s complement assumption again */
1247 /* -ve result, which could overflow an IV */
1249 SETi( -(IV)product_low );
1251 } /* else drop to NVs below. */
1253 } /* product_middle too large */
1254 } /* ahigh && bhigh */
1259 NV right = SvNV_nomg(svr);
1260 NV left = SvNV_nomg(svl);
1262 SETn( left * right );
1269 dVAR; dSP; dATARGET; SV *svl, *svr;
1270 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1273 /* Only try to do UV divide first
1274 if ((SLOPPYDIVIDE is true) or
1275 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1277 The assumption is that it is better to use floating point divide
1278 whenever possible, only doing integer divide first if we can't be sure.
1279 If NV_PRESERVES_UV is true then we know at compile time that no UV
1280 can be too large to preserve, so don't need to compile the code to
1281 test the size of UVs. */
1284 # define PERL_TRY_UV_DIVIDE
1285 /* ensure that 20./5. == 4. */
1287 # ifdef PERL_PRESERVE_IVUV
1288 # ifndef NV_PRESERVES_UV
1289 # define PERL_TRY_UV_DIVIDE
1294 #ifdef PERL_TRY_UV_DIVIDE
1295 SvIV_please_nomg(svr);
1297 SvIV_please_nomg(svl);
1299 bool left_non_neg = SvUOK(svl);
1300 bool right_non_neg = SvUOK(svr);
1304 if (right_non_neg) {
1308 const IV biv = SvIVX(svr);
1311 right_non_neg = TRUE; /* effectively it's a UV now */
1317 /* historically undef()/0 gives a "Use of uninitialized value"
1318 warning before dieing, hence this test goes here.
1319 If it were immediately before the second SvIV_please, then
1320 DIE() would be invoked before left was even inspected, so
1321 no inpsection would give no warning. */
1323 DIE(aTHX_ "Illegal division by zero");
1329 const IV aiv = SvIVX(svl);
1332 left_non_neg = TRUE; /* effectively it's a UV now */
1341 /* For sloppy divide we always attempt integer division. */
1343 /* Otherwise we only attempt it if either or both operands
1344 would not be preserved by an NV. If both fit in NVs
1345 we fall through to the NV divide code below. However,
1346 as left >= right to ensure integer result here, we know that
1347 we can skip the test on the right operand - right big
1348 enough not to be preserved can't get here unless left is
1351 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1354 /* Integer division can't overflow, but it can be imprecise. */
1355 const UV result = left / right;
1356 if (result * right == left) {
1357 SP--; /* result is valid */
1358 if (left_non_neg == right_non_neg) {
1359 /* signs identical, result is positive. */
1363 /* 2s complement assumption */
1364 if (result <= (UV)IV_MIN)
1365 SETi( -(IV)result );
1367 /* It's exact but too negative for IV. */
1368 SETn( -(NV)result );
1371 } /* tried integer divide but it was not an integer result */
1372 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1373 } /* left wasn't SvIOK */
1374 } /* right wasn't SvIOK */
1375 #endif /* PERL_TRY_UV_DIVIDE */
1377 NV right = SvNV_nomg(svr);
1378 NV left = SvNV_nomg(svl);
1379 (void)POPs;(void)POPs;
1380 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1381 if (! Perl_isnan(right) && right == 0.0)
1385 DIE(aTHX_ "Illegal division by zero");
1386 PUSHn( left / right );
1393 dVAR; dSP; dATARGET;
1394 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1398 bool left_neg = FALSE;
1399 bool right_neg = FALSE;
1400 bool use_double = FALSE;
1401 bool dright_valid = FALSE;
1404 SV * const svr = TOPs;
1405 SV * const svl = TOPm1s;
1406 SvIV_please_nomg(svr);
1408 right_neg = !SvUOK(svr);
1412 const IV biv = SvIVX(svr);
1415 right_neg = FALSE; /* effectively it's a UV now */
1422 dright = SvNV_nomg(svr);
1423 right_neg = dright < 0;
1426 if (dright < UV_MAX_P1) {
1427 right = U_V(dright);
1428 dright_valid = TRUE; /* In case we need to use double below. */
1434 /* At this point use_double is only true if right is out of range for
1435 a UV. In range NV has been rounded down to nearest UV and
1436 use_double false. */
1437 SvIV_please_nomg(svl);
1438 if (!use_double && SvIOK(svl)) {
1440 left_neg = !SvUOK(svl);
1444 const IV aiv = SvIVX(svl);
1447 left_neg = FALSE; /* effectively it's a UV now */
1455 dleft = SvNV_nomg(svl);
1456 left_neg = dleft < 0;
1460 /* This should be exactly the 5.6 behaviour - if left and right are
1461 both in range for UV then use U_V() rather than floor. */
1463 if (dleft < UV_MAX_P1) {
1464 /* right was in range, so is dleft, so use UVs not double.
1468 /* left is out of range for UV, right was in range, so promote
1469 right (back) to double. */
1471 /* The +0.5 is used in 5.6 even though it is not strictly
1472 consistent with the implicit +0 floor in the U_V()
1473 inside the #if 1. */
1474 dleft = Perl_floor(dleft + 0.5);
1477 dright = Perl_floor(dright + 0.5);
1488 DIE(aTHX_ "Illegal modulus zero");
1490 dans = Perl_fmod(dleft, dright);
1491 if ((left_neg != right_neg) && dans)
1492 dans = dright - dans;
1495 sv_setnv(TARG, dans);
1501 DIE(aTHX_ "Illegal modulus zero");
1504 if ((left_neg != right_neg) && ans)
1507 /* XXX may warn: unary minus operator applied to unsigned type */
1508 /* could change -foo to be (~foo)+1 instead */
1509 if (ans <= ~((UV)IV_MAX)+1)
1510 sv_setiv(TARG, ~ans+1);
1512 sv_setnv(TARG, -(NV)ans);
1515 sv_setuv(TARG, ans);
1524 dVAR; dSP; dATARGET;
1528 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1529 /* TODO: think of some way of doing list-repeat overloading ??? */
1534 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1540 const UV uv = SvUV_nomg(sv);
1542 count = IV_MAX; /* The best we can do? */
1546 const IV iv = SvIV_nomg(sv);
1553 else if (SvNOKp(sv)) {
1554 const NV nv = SvNV_nomg(sv);
1561 count = SvIV_nomg(sv);
1563 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1565 static const char oom_list_extend[] = "Out of memory during list extend";
1566 const I32 items = SP - MARK;
1567 const I32 max = items * count;
1569 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1570 /* Did the max computation overflow? */
1571 if (items > 0 && max > 0 && (max < items || max < count))
1572 Perl_croak(aTHX_ oom_list_extend);
1577 /* This code was intended to fix 20010809.028:
1580 for (($x =~ /./g) x 2) {
1581 print chop; # "abcdabcd" expected as output.
1584 * but that change (#11635) broke this code:
1586 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1588 * I can't think of a better fix that doesn't introduce
1589 * an efficiency hit by copying the SVs. The stack isn't
1590 * refcounted, and mortalisation obviously doesn't
1591 * Do The Right Thing when the stack has more than
1592 * one pointer to the same mortal value.
1596 *SP = sv_2mortal(newSVsv(*SP));
1606 repeatcpy((char*)(MARK + items), (char*)MARK,
1607 items * sizeof(const SV *), count - 1);
1610 else if (count <= 0)
1613 else { /* Note: mark already snarfed by pp_list */
1614 SV * const tmpstr = POPs;
1617 static const char oom_string_extend[] =
1618 "Out of memory during string extend";
1621 sv_setsv_nomg(TARG, tmpstr);
1622 SvPV_force_nomg(TARG, len);
1623 isutf = DO_UTF8(TARG);
1628 const STRLEN max = (UV)count * len;
1629 if (len > MEM_SIZE_MAX / count)
1630 Perl_croak(aTHX_ oom_string_extend);
1631 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1632 SvGROW(TARG, max + 1);
1633 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1634 SvCUR_set(TARG, SvCUR(TARG) * count);
1636 *SvEND(TARG) = '\0';
1639 (void)SvPOK_only_UTF8(TARG);
1641 (void)SvPOK_only(TARG);
1643 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1644 /* The parser saw this as a list repeat, and there
1645 are probably several items on the stack. But we're
1646 in scalar context, and there's no pp_list to save us
1647 now. So drop the rest of the items -- robin@kitsite.com
1659 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1660 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1663 useleft = USE_LEFT(svl);
1664 #ifdef PERL_PRESERVE_IVUV
1665 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1666 "bad things" happen if you rely on signed integers wrapping. */
1667 SvIV_please_nomg(svr);
1669 /* Unless the left argument is integer in range we are going to have to
1670 use NV maths. Hence only attempt to coerce the right argument if
1671 we know the left is integer. */
1672 register UV auv = 0;
1678 a_valid = auvok = 1;
1679 /* left operand is undef, treat as zero. */
1681 /* Left operand is defined, so is it IV? */
1682 SvIV_please_nomg(svl);
1684 if ((auvok = SvUOK(svl)))
1687 register const IV aiv = SvIVX(svl);
1690 auvok = 1; /* Now acting as a sign flag. */
1691 } else { /* 2s complement assumption for IV_MIN */
1699 bool result_good = 0;
1702 bool buvok = SvUOK(svr);
1707 register const IV biv = SvIVX(svr);
1714 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1715 else "IV" now, independent of how it came in.
1716 if a, b represents positive, A, B negative, a maps to -A etc
1721 all UV maths. negate result if A negative.
1722 subtract if signs same, add if signs differ. */
1724 if (auvok ^ buvok) {
1733 /* Must get smaller */
1738 if (result <= buv) {
1739 /* result really should be -(auv-buv). as its negation
1740 of true value, need to swap our result flag */
1752 if (result <= (UV)IV_MIN)
1753 SETi( -(IV)result );
1755 /* result valid, but out of range for IV. */
1756 SETn( -(NV)result );
1760 } /* Overflow, drop through to NVs. */
1765 NV value = SvNV_nomg(svr);
1769 /* left operand is undef, treat as zero - value */
1773 SETn( SvNV_nomg(svl) - value );
1780 dVAR; dSP; dATARGET; SV *svl, *svr;
1781 tryAMAGICbin_MG(lshift_amg, AMGf_assign);
1785 const IV shift = SvIV_nomg(svr);
1786 if (PL_op->op_private & HINT_INTEGER) {
1787 const IV i = SvIV_nomg(svl);
1791 const UV u = SvUV_nomg(svl);
1800 dVAR; dSP; dATARGET; SV *svl, *svr;
1801 tryAMAGICbin_MG(rshift_amg, AMGf_assign);
1805 const IV shift = SvIV_nomg(svr);
1806 if (PL_op->op_private & HINT_INTEGER) {
1807 const IV i = SvIV_nomg(svl);
1811 const UV u = SvUV_nomg(svl);
1821 tryAMAGICbin_MG(lt_amg, AMGf_set);
1822 #ifdef PERL_PRESERVE_IVUV
1823 SvIV_please_nomg(TOPs);
1825 SvIV_please_nomg(TOPm1s);
1826 if (SvIOK(TOPm1s)) {
1827 bool auvok = SvUOK(TOPm1s);
1828 bool buvok = SvUOK(TOPs);
1830 if (!auvok && !buvok) { /* ## IV < IV ## */
1831 const IV aiv = SvIVX(TOPm1s);
1832 const IV biv = SvIVX(TOPs);
1835 SETs(boolSV(aiv < biv));
1838 if (auvok && buvok) { /* ## UV < UV ## */
1839 const UV auv = SvUVX(TOPm1s);
1840 const UV buv = SvUVX(TOPs);
1843 SETs(boolSV(auv < buv));
1846 if (auvok) { /* ## UV < IV ## */
1848 const IV biv = SvIVX(TOPs);
1851 /* As (a) is a UV, it's >=0, so it cannot be < */
1856 SETs(boolSV(auv < (UV)biv));
1859 { /* ## IV < UV ## */
1860 const IV aiv = SvIVX(TOPm1s);
1864 /* As (b) is a UV, it's >=0, so it must be < */
1871 SETs(boolSV((UV)aiv < buv));
1877 #ifndef NV_PRESERVES_UV
1878 #ifdef PERL_PRESERVE_IVUV
1881 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1883 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1888 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1890 if (Perl_isnan(left) || Perl_isnan(right))
1892 SETs(boolSV(left < right));
1895 SETs(boolSV(SvNV_nomg(TOPs) < value));
1904 tryAMAGICbin_MG(gt_amg, AMGf_set);
1905 #ifdef PERL_PRESERVE_IVUV
1906 SvIV_please_nomg(TOPs);
1908 SvIV_please_nomg(TOPm1s);
1909 if (SvIOK(TOPm1s)) {
1910 bool auvok = SvUOK(TOPm1s);
1911 bool buvok = SvUOK(TOPs);
1913 if (!auvok && !buvok) { /* ## IV > IV ## */
1914 const IV aiv = SvIVX(TOPm1s);
1915 const IV biv = SvIVX(TOPs);
1918 SETs(boolSV(aiv > biv));
1921 if (auvok && buvok) { /* ## UV > UV ## */
1922 const UV auv = SvUVX(TOPm1s);
1923 const UV buv = SvUVX(TOPs);
1926 SETs(boolSV(auv > buv));
1929 if (auvok) { /* ## UV > IV ## */
1931 const IV biv = SvIVX(TOPs);
1935 /* As (a) is a UV, it's >=0, so it must be > */
1940 SETs(boolSV(auv > (UV)biv));
1943 { /* ## IV > UV ## */
1944 const IV aiv = SvIVX(TOPm1s);
1948 /* As (b) is a UV, it's >=0, so it cannot be > */
1955 SETs(boolSV((UV)aiv > buv));
1961 #ifndef NV_PRESERVES_UV
1962 #ifdef PERL_PRESERVE_IVUV
1965 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1967 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1972 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1974 if (Perl_isnan(left) || Perl_isnan(right))
1976 SETs(boolSV(left > right));
1979 SETs(boolSV(SvNV_nomg(TOPs) > value));
1988 tryAMAGICbin_MG(le_amg, AMGf_set);
1989 #ifdef PERL_PRESERVE_IVUV
1990 SvIV_please_nomg(TOPs);
1992 SvIV_please_nomg(TOPm1s);
1993 if (SvIOK(TOPm1s)) {
1994 bool auvok = SvUOK(TOPm1s);
1995 bool buvok = SvUOK(TOPs);
1997 if (!auvok && !buvok) { /* ## IV <= IV ## */
1998 const IV aiv = SvIVX(TOPm1s);
1999 const IV biv = SvIVX(TOPs);
2002 SETs(boolSV(aiv <= biv));
2005 if (auvok && buvok) { /* ## UV <= UV ## */
2006 UV auv = SvUVX(TOPm1s);
2007 UV buv = SvUVX(TOPs);
2010 SETs(boolSV(auv <= buv));
2013 if (auvok) { /* ## UV <= IV ## */
2015 const IV biv = SvIVX(TOPs);
2019 /* As (a) is a UV, it's >=0, so a cannot be <= */
2024 SETs(boolSV(auv <= (UV)biv));
2027 { /* ## IV <= UV ## */
2028 const IV aiv = SvIVX(TOPm1s);
2032 /* As (b) is a UV, it's >=0, so a must be <= */
2039 SETs(boolSV((UV)aiv <= buv));
2045 #ifndef NV_PRESERVES_UV
2046 #ifdef PERL_PRESERVE_IVUV
2049 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2051 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2056 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2058 if (Perl_isnan(left) || Perl_isnan(right))
2060 SETs(boolSV(left <= right));
2063 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2072 tryAMAGICbin_MG(ge_amg,AMGf_set);
2073 #ifdef PERL_PRESERVE_IVUV
2074 SvIV_please_nomg(TOPs);
2076 SvIV_please_nomg(TOPm1s);
2077 if (SvIOK(TOPm1s)) {
2078 bool auvok = SvUOK(TOPm1s);
2079 bool buvok = SvUOK(TOPs);
2081 if (!auvok && !buvok) { /* ## IV >= IV ## */
2082 const IV aiv = SvIVX(TOPm1s);
2083 const IV biv = SvIVX(TOPs);
2086 SETs(boolSV(aiv >= biv));
2089 if (auvok && buvok) { /* ## UV >= UV ## */
2090 const UV auv = SvUVX(TOPm1s);
2091 const UV buv = SvUVX(TOPs);
2094 SETs(boolSV(auv >= buv));
2097 if (auvok) { /* ## UV >= IV ## */
2099 const IV biv = SvIVX(TOPs);
2103 /* As (a) is a UV, it's >=0, so it must be >= */
2108 SETs(boolSV(auv >= (UV)biv));
2111 { /* ## IV >= UV ## */
2112 const IV aiv = SvIVX(TOPm1s);
2116 /* As (b) is a UV, it's >=0, so a cannot be >= */
2123 SETs(boolSV((UV)aiv >= buv));
2129 #ifndef NV_PRESERVES_UV
2130 #ifdef PERL_PRESERVE_IVUV
2133 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2135 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2140 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2142 if (Perl_isnan(left) || Perl_isnan(right))
2144 SETs(boolSV(left >= right));
2147 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2156 tryAMAGICbin_MG(ne_amg,AMGf_set);
2157 #ifndef NV_PRESERVES_UV
2158 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2160 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2164 #ifdef PERL_PRESERVE_IVUV
2165 SvIV_please_nomg(TOPs);
2167 SvIV_please_nomg(TOPm1s);
2168 if (SvIOK(TOPm1s)) {
2169 const bool auvok = SvUOK(TOPm1s);
2170 const bool buvok = SvUOK(TOPs);
2172 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2173 /* Casting IV to UV before comparison isn't going to matter
2174 on 2s complement. On 1s complement or sign&magnitude
2175 (if we have any of them) it could make negative zero
2176 differ from normal zero. As I understand it. (Need to
2177 check - is negative zero implementation defined behaviour
2179 const UV buv = SvUVX(POPs);
2180 const UV auv = SvUVX(TOPs);
2182 SETs(boolSV(auv != buv));
2185 { /* ## Mixed IV,UV ## */
2189 /* != is commutative so swap if needed (save code) */
2191 /* swap. top of stack (b) is the iv */
2195 /* As (a) is a UV, it's >0, so it cannot be == */
2204 /* As (b) is a UV, it's >0, so it cannot be == */
2208 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2210 SETs(boolSV((UV)iv != uv));
2217 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2219 if (Perl_isnan(left) || Perl_isnan(right))
2221 SETs(boolSV(left != right));
2224 SETs(boolSV(SvNV_nomg(TOPs) != value));
2233 tryAMAGICbin_MG(ncmp_amg, 0);
2234 #ifndef NV_PRESERVES_UV
2235 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2236 const UV right = PTR2UV(SvRV(POPs));
2237 const UV left = PTR2UV(SvRV(TOPs));
2238 SETi((left > right) - (left < right));
2242 #ifdef PERL_PRESERVE_IVUV
2243 /* Fortunately it seems NaN isn't IOK */
2244 SvIV_please_nomg(TOPs);
2246 SvIV_please_nomg(TOPm1s);
2247 if (SvIOK(TOPm1s)) {
2248 const bool leftuvok = SvUOK(TOPm1s);
2249 const bool rightuvok = SvUOK(TOPs);
2251 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2252 const IV leftiv = SvIVX(TOPm1s);
2253 const IV rightiv = SvIVX(TOPs);
2255 if (leftiv > rightiv)
2257 else if (leftiv < rightiv)
2261 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2262 const UV leftuv = SvUVX(TOPm1s);
2263 const UV rightuv = SvUVX(TOPs);
2265 if (leftuv > rightuv)
2267 else if (leftuv < rightuv)
2271 } else if (leftuvok) { /* ## UV <=> IV ## */
2272 const IV rightiv = SvIVX(TOPs);
2274 /* As (a) is a UV, it's >=0, so it cannot be < */
2277 const UV leftuv = SvUVX(TOPm1s);
2278 if (leftuv > (UV)rightiv) {
2280 } else if (leftuv < (UV)rightiv) {
2286 } else { /* ## IV <=> UV ## */
2287 const IV leftiv = SvIVX(TOPm1s);
2289 /* As (b) is a UV, it's >=0, so it must be < */
2292 const UV rightuv = SvUVX(TOPs);
2293 if ((UV)leftiv > rightuv) {
2295 } else if ((UV)leftiv < rightuv) {
2313 if (Perl_isnan(left) || Perl_isnan(right)) {
2317 value = (left > right) - (left < right);
2321 else if (left < right)
2323 else if (left > right)
2339 int amg_type = sle_amg;
2343 switch (PL_op->op_type) {
2362 tryAMAGICbin_MG(amg_type, AMGf_set);
2365 const int cmp = (IN_LOCALE_RUNTIME
2366 ? sv_cmp_locale_flags(left, right, 0)
2367 : sv_cmp_flags(left, right, 0));
2368 SETs(boolSV(cmp * multiplier < rhs));
2376 tryAMAGICbin_MG(seq_amg, AMGf_set);
2379 SETs(boolSV(sv_eq_flags(left, right, 0)));
2387 tryAMAGICbin_MG(sne_amg, AMGf_set);
2390 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2398 tryAMAGICbin_MG(scmp_amg, 0);
2401 const int cmp = (IN_LOCALE_RUNTIME
2402 ? sv_cmp_locale_flags(left, right, 0)
2403 : sv_cmp_flags(left, right, 0));
2411 dVAR; dSP; dATARGET;
2412 tryAMAGICbin_MG(band_amg, AMGf_assign);
2415 if (SvNIOKp(left) || SvNIOKp(right)) {
2416 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2417 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2418 if (PL_op->op_private & HINT_INTEGER) {
2419 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2423 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2426 if (left_ro_nonnum) SvNIOK_off(left);
2427 if (right_ro_nonnum) SvNIOK_off(right);
2430 do_vop(PL_op->op_type, TARG, left, right);
2439 dVAR; dSP; dATARGET;
2440 const int op_type = PL_op->op_type;
2442 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2445 if (SvNIOKp(left) || SvNIOKp(right)) {
2446 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2447 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2448 if (PL_op->op_private & HINT_INTEGER) {
2449 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2450 const IV r = SvIV_nomg(right);
2451 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2455 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2456 const UV r = SvUV_nomg(right);
2457 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2460 if (left_ro_nonnum) SvNIOK_off(left);
2461 if (right_ro_nonnum) SvNIOK_off(right);
2464 do_vop(op_type, TARG, left, right);
2474 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2476 SV * const sv = TOPs;
2477 const int flags = SvFLAGS(sv);
2479 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2483 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2484 /* It's publicly an integer, or privately an integer-not-float */
2487 if (SvIVX(sv) == IV_MIN) {
2488 /* 2s complement assumption. */
2489 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2492 else if (SvUVX(sv) <= IV_MAX) {
2497 else if (SvIVX(sv) != IV_MIN) {
2501 #ifdef PERL_PRESERVE_IVUV
2509 SETn(-SvNV_nomg(sv));
2510 else if (SvPOKp(sv)) {
2512 const char * const s = SvPV_nomg_const(sv, len);
2513 if (isIDFIRST(*s)) {
2514 sv_setpvs(TARG, "-");
2517 else if (*s == '+' || *s == '-') {
2518 sv_setsv_nomg(TARG, sv);
2519 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2521 else if (DO_UTF8(sv)) {
2522 SvIV_please_nomg(sv);
2524 goto oops_its_an_int;
2526 sv_setnv(TARG, -SvNV_nomg(sv));
2528 sv_setpvs(TARG, "-");
2533 SvIV_please_nomg(sv);
2535 goto oops_its_an_int;
2536 sv_setnv(TARG, -SvNV_nomg(sv));
2541 SETn(-SvNV_nomg(sv));
2549 tryAMAGICun_MG(not_amg, AMGf_set);
2550 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2557 tryAMAGICun_MG(compl_amg, 0);
2561 if (PL_op->op_private & HINT_INTEGER) {
2562 const IV i = ~SvIV_nomg(sv);
2566 const UV u = ~SvUV_nomg(sv);
2575 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2576 sv_setsv_nomg(TARG, sv);
2577 tmps = (U8*)SvPV_force_nomg(TARG, len);
2580 /* Calculate exact length, let's not estimate. */
2585 U8 * const send = tmps + len;
2586 U8 * const origtmps = tmps;
2587 const UV utf8flags = UTF8_ALLOW_ANYUV;
2589 while (tmps < send) {
2590 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2592 targlen += UNISKIP(~c);
2598 /* Now rewind strings and write them. */
2605 Newx(result, targlen + 1, U8);
2607 while (tmps < send) {
2608 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2610 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2613 sv_usepvn_flags(TARG, (char*)result, targlen,
2614 SV_HAS_TRAILING_NUL);
2621 Newx(result, nchar + 1, U8);
2623 while (tmps < send) {
2624 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2629 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2637 register long *tmpl;
2638 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2641 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2646 for ( ; anum > 0; anum--, tmps++)
2654 /* integer versions of some of the above */
2658 dVAR; dSP; dATARGET;
2659 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2662 SETi( left * right );
2670 dVAR; dSP; dATARGET;
2671 tryAMAGICbin_MG(div_amg, AMGf_assign);
2674 IV value = SvIV_nomg(right);
2676 DIE(aTHX_ "Illegal division by zero");
2677 num = SvIV_nomg(left);
2679 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2683 value = num / value;
2689 #if defined(__GLIBC__) && IVSIZE == 8
2696 /* This is the vanilla old i_modulo. */
2697 dVAR; dSP; dATARGET;
2698 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2702 DIE(aTHX_ "Illegal modulus zero");
2703 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2707 SETi( left % right );
2712 #if defined(__GLIBC__) && IVSIZE == 8
2717 /* This is the i_modulo with the workaround for the _moddi3 bug
2718 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2719 * See below for pp_i_modulo. */
2720 dVAR; dSP; dATARGET;
2721 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2725 DIE(aTHX_ "Illegal modulus zero");
2726 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2730 SETi( left % PERL_ABS(right) );
2737 dVAR; dSP; dATARGET;
2738 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2742 DIE(aTHX_ "Illegal modulus zero");
2743 /* The assumption is to use hereafter the old vanilla version... */
2745 PL_ppaddr[OP_I_MODULO] =
2747 /* .. but if we have glibc, we might have a buggy _moddi3
2748 * (at least glicb 2.2.5 is known to have this bug), in other
2749 * words our integer modulus with negative quad as the second
2750 * argument might be broken. Test for this and re-patch the
2751 * opcode dispatch table if that is the case, remembering to
2752 * also apply the workaround so that this first round works
2753 * right, too. See [perl #9402] for more information. */
2757 /* Cannot do this check with inlined IV constants since
2758 * that seems to work correctly even with the buggy glibc. */
2760 /* Yikes, we have the bug.
2761 * Patch in the workaround version. */
2763 PL_ppaddr[OP_I_MODULO] =
2764 &Perl_pp_i_modulo_1;
2765 /* Make certain we work right this time, too. */
2766 right = PERL_ABS(right);
2769 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2773 SETi( left % right );
2781 dVAR; dSP; dATARGET;
2782 tryAMAGICbin_MG(add_amg, AMGf_assign);
2784 dPOPTOPiirl_ul_nomg;
2785 SETi( left + right );
2792 dVAR; dSP; dATARGET;
2793 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2795 dPOPTOPiirl_ul_nomg;
2796 SETi( left - right );
2804 tryAMAGICbin_MG(lt_amg, AMGf_set);
2807 SETs(boolSV(left < right));
2815 tryAMAGICbin_MG(gt_amg, AMGf_set);
2818 SETs(boolSV(left > right));
2826 tryAMAGICbin_MG(le_amg, AMGf_set);
2829 SETs(boolSV(left <= right));
2837 tryAMAGICbin_MG(ge_amg, AMGf_set);
2840 SETs(boolSV(left >= right));
2848 tryAMAGICbin_MG(eq_amg, AMGf_set);
2851 SETs(boolSV(left == right));
2859 tryAMAGICbin_MG(ne_amg, AMGf_set);
2862 SETs(boolSV(left != right));
2870 tryAMAGICbin_MG(ncmp_amg, 0);
2877 else if (left < right)
2889 tryAMAGICun_MG(neg_amg, 0);
2891 SV * const sv = TOPs;
2892 IV const i = SvIV_nomg(sv);
2898 /* High falutin' math. */
2903 tryAMAGICbin_MG(atan2_amg, 0);
2906 SETn(Perl_atan2(left, right));
2914 int amg_type = sin_amg;
2915 const char *neg_report = NULL;
2916 NV (*func)(NV) = Perl_sin;
2917 const int op_type = PL_op->op_type;
2934 amg_type = sqrt_amg;
2936 neg_report = "sqrt";
2941 tryAMAGICun_MG(amg_type, 0);
2943 SV * const arg = POPs;
2944 const NV value = SvNV_nomg(arg);
2946 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2947 SET_NUMERIC_STANDARD();
2948 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2951 XPUSHn(func(value));
2956 /* Support Configure command-line overrides for rand() functions.
2957 After 5.005, perhaps we should replace this by Configure support
2958 for drand48(), random(), or rand(). For 5.005, though, maintain
2959 compatibility by calling rand() but allow the user to override it.
2960 See INSTALL for details. --Andy Dougherty 15 July 1998
2962 /* Now it's after 5.005, and Configure supports drand48() and random(),
2963 in addition to rand(). So the overrides should not be needed any more.
2964 --Jarkko Hietaniemi 27 September 1998
2967 #ifndef HAS_DRAND48_PROTO
2968 extern double drand48 (void);
2981 if (!PL_srand_called) {
2982 (void)seedDrand01((Rand_seed_t)seed());
2983 PL_srand_called = TRUE;
2993 const UV anum = (MAXARG < 1) ? seed() : POPu;
2994 (void)seedDrand01((Rand_seed_t)anum);
2995 PL_srand_called = TRUE;
2999 /* Historically srand always returned true. We can avoid breaking
3001 sv_setpvs(TARG, "0 but true");
3010 tryAMAGICun_MG(int_amg, AMGf_numeric);
3012 SV * const sv = TOPs;
3013 const IV iv = SvIV_nomg(sv);
3014 /* XXX it's arguable that compiler casting to IV might be subtly
3015 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3016 else preferring IV has introduced a subtle behaviour change bug. OTOH
3017 relying on floating point to be accurate is a bug. */
3022 else if (SvIOK(sv)) {
3024 SETu(SvUV_nomg(sv));
3029 const NV value = SvNV_nomg(sv);
3031 if (value < (NV)UV_MAX + 0.5) {
3034 SETn(Perl_floor(value));
3038 if (value > (NV)IV_MIN - 0.5) {
3041 SETn(Perl_ceil(value));
3052 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3054 SV * const sv = TOPs;
3055 /* This will cache the NV value if string isn't actually integer */
3056 const IV iv = SvIV_nomg(sv);
3061 else if (SvIOK(sv)) {
3062 /* IVX is precise */
3064 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3072 /* 2s complement assumption. Also, not really needed as
3073 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3079 const NV value = SvNV_nomg(sv);
3093 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3097 SV* const sv = POPs;
3099 tmps = (SvPV_const(sv, len));
3101 /* If Unicode, try to downgrade
3102 * If not possible, croak. */
3103 SV* const tsv = sv_2mortal(newSVsv(sv));
3106 sv_utf8_downgrade(tsv, FALSE);
3107 tmps = SvPV_const(tsv, len);
3109 if (PL_op->op_type == OP_HEX)
3112 while (*tmps && len && isSPACE(*tmps))
3116 if (*tmps == 'x' || *tmps == 'X') {
3118 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3120 else if (*tmps == 'b' || *tmps == 'B')
3121 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3123 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3125 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3139 SV * const sv = TOPs;
3141 if (SvGAMAGIC(sv)) {
3142 /* For an overloaded or magic scalar, we can't know in advance if
3143 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3144 it likes to cache the length. Maybe that should be a documented
3149 = sv_2pv_flags(sv, &len,
3150 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3153 sv_setsv(TARG, &PL_sv_undef);
3156 else if (DO_UTF8(sv)) {
3157 SETi(utf8_length((U8*)p, (U8*)p + len));
3161 } else if (SvOK(sv)) {
3162 /* Neither magic nor overloaded. */
3164 SETi(sv_len_utf8(sv));
3168 sv_setsv_nomg(TARG, &PL_sv_undef);
3188 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3190 const IV arybase = CopARYBASE_get(PL_curcop);
3192 const char *repl = NULL;
3194 const int num_args = PL_op->op_private & 7;
3195 bool repl_need_utf8_upgrade = FALSE;
3196 bool repl_is_utf8 = FALSE;
3201 repl = SvPV_const(repl_sv, repl_len);
3202 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3205 len_iv = SvIV(len_sv);
3206 len_is_uv = SvIOK_UV(len_sv);
3209 pos1_iv = SvIV(pos_sv);
3210 pos1_is_uv = SvIOK_UV(pos_sv);
3216 sv_utf8_upgrade(sv);
3218 else if (DO_UTF8(sv))
3219 repl_need_utf8_upgrade = TRUE;
3221 tmps = SvPV_const(sv, curlen);
3223 utf8_curlen = sv_len_utf8(sv);
3224 if (utf8_curlen == curlen)
3227 curlen = utf8_curlen;
3232 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3233 UV pos1_uv = pos1_iv-arybase;
3234 /* Overflow can occur when $[ < 0 */
3235 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3240 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3241 goto bound_fail; /* $[=3; substr($_,2,...) */
3243 else { /* pos < $[ */
3244 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3249 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3254 if (pos1_is_uv || pos1_iv > 0) {
3255 if ((UV)pos1_iv > curlen)
3260 if (!len_is_uv && len_iv < 0) {
3261 pos2_iv = curlen + len_iv;
3263 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3266 } else { /* len_iv >= 0 */
3267 if (!pos1_is_uv && pos1_iv < 0) {
3268 pos2_iv = pos1_iv + len_iv;
3269 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3271 if ((UV)len_iv > curlen-(UV)pos1_iv)
3274 pos2_iv = pos1_iv+len_iv;
3284 if (!pos2_is_uv && pos2_iv < 0) {
3285 if (!pos1_is_uv && pos1_iv < 0)
3289 else if (!pos1_is_uv && pos1_iv < 0)
3292 if ((UV)pos2_iv < (UV)pos1_iv)
3294 if ((UV)pos2_iv > curlen)
3298 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3299 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3300 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3301 STRLEN byte_len = len;
3302 STRLEN byte_pos = utf8_curlen
3303 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3305 if (lvalue && !repl) {
3308 if (!SvGMAGICAL(sv)) {
3310 SvPV_force_nolen(sv);
3311 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3312 "Attempt to use reference as lvalue in substr");
3314 if (isGV_with_GP(sv))
3315 SvPV_force_nolen(sv);
3316 else if (SvOK(sv)) /* is it defined ? */
3317 (void)SvPOK_only_UTF8(sv);
3319 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3322 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3323 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3325 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3326 LvTARGOFF(ret) = pos;
3327 LvTARGLEN(ret) = len;
3330 PUSHs(ret); /* avoid SvSETMAGIC here */
3334 SvTAINTED_off(TARG); /* decontaminate */
3335 SvUTF8_off(TARG); /* decontaminate */
3338 sv_setpvn(TARG, tmps, byte_len);
3339 #ifdef USE_LOCALE_COLLATE
3340 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3346 SV* repl_sv_copy = NULL;
3348 if (repl_need_utf8_upgrade) {
3349 repl_sv_copy = newSVsv(repl_sv);
3350 sv_utf8_upgrade(repl_sv_copy);
3351 repl = SvPV_const(repl_sv_copy, repl_len);
3352 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3356 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3359 SvREFCNT_dec(repl_sv_copy);
3363 PUSHs(TARG); /* avoid SvSETMAGIC here */
3368 Perl_croak(aTHX_ "substr outside of string");
3369 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3376 register const IV size = POPi;
3377 register const IV offset = POPi;
3378 register SV * const src = POPs;
3379 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3382 if (lvalue) { /* it's an lvalue! */
3383 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3384 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3386 LvTARG(ret) = SvREFCNT_inc_simple(src);
3387 LvTARGOFF(ret) = offset;
3388 LvTARGLEN(ret) = size;
3392 SvTAINTED_off(TARG); /* decontaminate */
3396 sv_setuv(ret, do_vecget(src, offset, size));
3412 const char *little_p;
3413 const I32 arybase = CopARYBASE_get(PL_curcop);
3416 const bool is_index = PL_op->op_type == OP_INDEX;
3419 /* arybase is in characters, like offset, so combine prior to the
3420 UTF-8 to bytes calculation. */
3421 offset = POPi - arybase;
3425 big_p = SvPV_const(big, biglen);
3426 little_p = SvPV_const(little, llen);
3428 big_utf8 = DO_UTF8(big);
3429 little_utf8 = DO_UTF8(little);
3430 if (big_utf8 ^ little_utf8) {
3431 /* One needs to be upgraded. */
3432 if (little_utf8 && !PL_encoding) {
3433 /* Well, maybe instead we might be able to downgrade the small
3435 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3438 /* If the large string is ISO-8859-1, and it's not possible to
3439 convert the small string to ISO-8859-1, then there is no
3440 way that it could be found anywhere by index. */
3445 /* At this point, pv is a malloc()ed string. So donate it to temp
3446 to ensure it will get free()d */
3447 little = temp = newSV(0);
3448 sv_usepvn(temp, pv, llen);
3449 little_p = SvPVX(little);
3452 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3455 sv_recode_to_utf8(temp, PL_encoding);
3457 sv_utf8_upgrade(temp);
3462 big_p = SvPV_const(big, biglen);
3465 little_p = SvPV_const(little, llen);
3469 if (SvGAMAGIC(big)) {
3470 /* Life just becomes a lot easier if I use a temporary here.
3471 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3472 will trigger magic and overloading again, as will fbm_instr()
3474 big = newSVpvn_flags(big_p, biglen,
3475 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3478 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3479 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3480 warn on undef, and we've already triggered a warning with the
3481 SvPV_const some lines above. We can't remove that, as we need to
3482 call some SvPV to trigger overloading early and find out if the
3484 This is all getting to messy. The API isn't quite clean enough,
3485 because data access has side effects.
3487 little = newSVpvn_flags(little_p, llen,
3488 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3489 little_p = SvPVX(little);
3493 offset = is_index ? 0 : biglen;
3495 if (big_utf8 && offset > 0)
3496 sv_pos_u2b(big, &offset, 0);
3502 else if (offset > (I32)biglen)
3504 if (!(little_p = is_index
3505 ? fbm_instr((unsigned char*)big_p + offset,
3506 (unsigned char*)big_p + biglen, little, 0)
3507 : rninstr(big_p, big_p + offset,
3508 little_p, little_p + llen)))
3511 retval = little_p - big_p;
3512 if (retval > 0 && big_utf8)
3513 sv_pos_b2u(big, &retval);
3517 PUSHi(retval + arybase);
3523 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3524 if (SvTAINTED(MARK[1]))
3525 TAINT_PROPER("sprintf");
3526 SvTAINTED_off(TARG);
3527 do_sprintf(TARG, SP-MARK, MARK+1);
3528 TAINT_IF(SvTAINTED(TARG));
3540 const U8 *s = (U8*)SvPV_const(argsv, len);
3542 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3543 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3544 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3548 XPUSHu(DO_UTF8(argsv) ?
3549 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3561 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3563 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3565 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3567 (void) POPs; /* Ignore the argument value. */
3568 value = UNICODE_REPLACEMENT;
3574 SvUPGRADE(TARG,SVt_PV);
3576 if (value > 255 && !IN_BYTES) {
3577 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3578 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3579 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3581 (void)SvPOK_only(TARG);
3590 *tmps++ = (char)value;
3592 (void)SvPOK_only(TARG);
3594 if (PL_encoding && !IN_BYTES) {
3595 sv_recode_to_utf8(TARG, PL_encoding);
3597 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3598 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3602 *tmps++ = (char)value;
3618 const char *tmps = SvPV_const(left, len);
3620 if (DO_UTF8(left)) {
3621 /* If Unicode, try to downgrade.
3622 * If not possible, croak.
3623 * Yes, we made this up. */
3624 SV* const tsv = sv_2mortal(newSVsv(left));
3627 sv_utf8_downgrade(tsv, FALSE);
3628 tmps = SvPV_const(tsv, len);
3630 # ifdef USE_ITHREADS
3632 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3633 /* This should be threadsafe because in ithreads there is only
3634 * one thread per interpreter. If this would not be true,
3635 * we would need a mutex to protect this malloc. */
3636 PL_reentrant_buffer->_crypt_struct_buffer =
3637 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3638 #if defined(__GLIBC__) || defined(__EMX__)
3639 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3640 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3641 /* work around glibc-2.2.5 bug */
3642 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3646 # endif /* HAS_CRYPT_R */
3647 # endif /* USE_ITHREADS */
3649 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3651 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3657 "The crypt() function is unimplemented due to excessive paranoia.");
3661 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3662 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3664 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3665 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3666 * See http://www.unicode.org/unicode/reports/tr16 */
3667 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3668 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3670 /* Below are several macros that generate code */
3671 /* Generates code to store a unicode codepoint c that is known to occupy
3672 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3673 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3675 *(p) = UTF8_TWO_BYTE_HI(c); \
3676 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3679 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3680 * available byte after the two bytes */
3681 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3683 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3684 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3687 /* Generates code to store the upper case of latin1 character l which is known
3688 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3689 * are only two characters that fit this description, and this macro knows
3690 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3692 #define STORE_NON_LATIN1_UC(p, l) \
3694 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3695 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3696 } else { /* Must be the following letter */ \
3697 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3701 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3702 * after the character stored */
3703 #define CAT_NON_LATIN1_UC(p, l) \
3705 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3706 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3708 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3712 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3713 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3714 * and must require two bytes to store it. Advances p to point to the next
3715 * available position */
3716 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3718 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3719 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3720 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3721 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3722 } else {/* else is one of the other two special cases */ \
3723 CAT_NON_LATIN1_UC((p), (l)); \
3729 /* Actually is both lcfirst() and ucfirst(). Only the first character
3730 * changes. This means that possibly we can change in-place, ie., just
3731 * take the source and change that one character and store it back, but not
3732 * if read-only etc, or if the length changes */
3737 STRLEN slen; /* slen is the byte length of the whole SV. */
3740 bool inplace; /* ? Convert first char only, in-place */
3741 bool doing_utf8 = FALSE; /* ? using utf8 */
3742 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3743 const int op_type = PL_op->op_type;
3746 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3747 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3748 * stored as UTF-8 at s. */
3749 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3750 * lowercased) character stored in tmpbuf. May be either
3751 * UTF-8 or not, but in either case is the number of bytes */
3755 s = (const U8*)SvPV_nomg_const(source, slen);
3757 if (ckWARN(WARN_UNINITIALIZED))
3758 report_uninit(source);
3763 /* We may be able to get away with changing only the first character, in
3764 * place, but not if read-only, etc. Later we may discover more reasons to
3765 * not convert in-place. */
3766 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3768 /* First calculate what the changed first character should be. This affects
3769 * whether we can just swap it out, leaving the rest of the string unchanged,
3770 * or even if have to convert the dest to UTF-8 when the source isn't */
3772 if (! slen) { /* If empty */
3773 need = 1; /* still need a trailing NUL */
3775 else if (DO_UTF8(source)) { /* Is the source utf8? */
3778 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3779 * and doesn't allow for the user to specify their own. When code is added to
3780 * detect if there is a user-defined mapping in force here, and if so to use
3781 * that, then the code below can be compiled. The detection would be a good
3782 * thing anyway, as currently the user-defined mappings only work on utf8
3783 * strings, and thus depend on the chosen internal storage method, which is a
3785 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3786 if (UTF8_IS_INVARIANT(*s)) {
3788 /* An invariant source character is either ASCII or, in EBCDIC, an
3789 * ASCII equivalent or a caseless C1 control. In both these cases,
3790 * the lower and upper cases of any character are also invariants
3791 * (and title case is the same as upper case). So it is safe to
3792 * use the simple case change macros which avoid the overhead of
3793 * the general functions. Note that if perl were to be extended to
3794 * do locale handling in UTF-8 strings, this wouldn't be true in,
3795 * for example, Lithuanian or Turkic. */
3796 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3800 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3803 /* Similarly, if the source character isn't invariant but is in the
3804 * latin1 range (or EBCDIC equivalent thereof), we have the case
3805 * changes compiled into perl, and can avoid the overhead of the
3806 * general functions. In this range, the characters are stored as
3807 * two UTF-8 bytes, and it so happens that any changed-case version
3808 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3812 /* Convert the two source bytes to a single Unicode code point
3813 * value, change case and save for below */
3814 chr = UTF8_ACCUMULATE(*s, *(s+1));
3815 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3816 U8 lower = toLOWER_LATIN1(chr);
3817 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3819 else { /* ucfirst */
3820 U8 upper = toUPPER_LATIN1_MOD(chr);
3822 /* Most of the latin1 range characters are well-behaved. Their
3823 * title and upper cases are the same, and are also in the
3824 * latin1 range. The macro above returns their upper (hence
3825 * title) case, and all that need be done is to save the result
3826 * for below. However, several characters are problematic, and
3827 * have to be handled specially. The MOD in the macro name
3828 * above means that these tricky characters all get mapped to
3829 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3830 * This mapping saves some tests for the majority of the
3833 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3835 /* Not tricky. Just save it. */
3836 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3838 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3840 /* This one is tricky because it is two characters long,
3841 * though the UTF-8 is still two bytes, so the stored
3842 * length doesn't change */
3843 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3844 *(tmpbuf + 1) = 's';
3848 /* The other two have their title and upper cases the same,
3849 * but are tricky because the changed-case characters
3850 * aren't in the latin1 range. They, however, do fit into
3851 * two UTF-8 bytes */
3852 STORE_NON_LATIN1_UC(tmpbuf, chr);
3857 #endif /* end of dont want to break user-defined casing */
3859 /* Here, can't short-cut the general case */
3861 utf8_to_uvchr(s, &ulen);
3862 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3863 else toLOWER_utf8(s, tmpbuf, &tculen);
3865 /* we can't do in-place if the length changes. */
3866 if (ulen != tculen) inplace = FALSE;
3867 need = slen + 1 - ulen + tculen;
3868 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3872 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3873 * latin1 is treated as caseless. Note that a locale takes
3875 tculen = 1; /* Most characters will require one byte, but this will
3876 * need to be overridden for the tricky ones */
3879 if (op_type == OP_LCFIRST) {
3881 /* lower case the first letter: no trickiness for any character */
3882 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3883 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3886 else if (IN_LOCALE_RUNTIME) {
3887 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3888 * have upper and title case different
3891 else if (! IN_UNI_8_BIT) {
3892 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3893 * on EBCDIC machines whatever the
3894 * native function does */
3896 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3897 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3899 /* tmpbuf now has the correct title case for all latin1 characters
3900 * except for the several ones that have tricky handling. All
3901 * of these are mapped by the MOD to the letter below. */
3902 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3904 /* The length is going to change, with all three of these, so
3905 * can't replace just the first character */
3908 /* We use the original to distinguish between these tricky
3910 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3911 /* Two character title case 'Ss', but can remain non-UTF-8 */
3914 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3919 /* The other two tricky ones have their title case outside
3920 * latin1. It is the same as their upper case. */
3922 STORE_NON_LATIN1_UC(tmpbuf, *s);
3924 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3925 * and their upper cases is 2. */
3928 /* The entire result will have to be in UTF-8. Assume worst
3929 * case sizing in conversion. (all latin1 characters occupy
3930 * at most two bytes in utf8) */
3931 convert_source_to_utf8 = TRUE;
3932 need = slen * 2 + 1;
3934 } /* End of is one of the three special chars */
3935 } /* End of use Unicode (Latin1) semantics */
3936 } /* End of changing the case of the first character */
3938 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3939 * generate the result */
3942 /* We can convert in place. This means we change just the first
3943 * character without disturbing the rest; no need to grow */
3945 s = d = (U8*)SvPV_force_nomg(source, slen);
3951 /* Here, we can't convert in place; we earlier calculated how much
3952 * space we will need, so grow to accommodate that */
3953 SvUPGRADE(dest, SVt_PV);
3954 d = (U8*)SvGROW(dest, need);
3955 (void)SvPOK_only(dest);
3962 if (! convert_source_to_utf8) {
3964 /* Here both source and dest are in UTF-8, but have to create
3965 * the entire output. We initialize the result to be the
3966 * title/lower cased first character, and then append the rest
3968 sv_setpvn(dest, (char*)tmpbuf, tculen);
3970 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3974 const U8 *const send = s + slen;
3976 /* Here the dest needs to be in UTF-8, but the source isn't,
3977 * except we earlier UTF-8'd the first character of the source
3978 * into tmpbuf. First put that into dest, and then append the
3979 * rest of the source, converting it to UTF-8 as we go. */
3981 /* Assert tculen is 2 here because the only two characters that
3982 * get to this part of the code have 2-byte UTF-8 equivalents */
3984 *d++ = *(tmpbuf + 1);
3985 s++; /* We have just processed the 1st char */
3987 for (; s < send; s++) {
3988 d = uvchr_to_utf8(d, *s);
3991 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3995 else { /* in-place UTF-8. Just overwrite the first character */
3996 Copy(tmpbuf, d, tculen, U8);
3997 SvCUR_set(dest, need - 1);
4000 else { /* Neither source nor dest are in or need to be UTF-8 */
4002 if (IN_LOCALE_RUNTIME) {
4006 if (inplace) { /* in-place, only need to change the 1st char */
4009 else { /* Not in-place */
4011 /* Copy the case-changed character(s) from tmpbuf */
4012 Copy(tmpbuf, d, tculen, U8);
4013 d += tculen - 1; /* Code below expects d to point to final
4014 * character stored */
4017 else { /* empty source */
4018 /* See bug #39028: Don't taint if empty */
4022 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4023 * the destination to retain that flag */
4027 if (!inplace) { /* Finish the rest of the string, unchanged */
4028 /* This will copy the trailing NUL */
4029 Copy(s + 1, d + 1, slen, U8);
4030 SvCUR_set(dest, need - 1);
4037 /* There's so much setup/teardown code common between uc and lc, I wonder if
4038 it would be worth merging the two, and just having a switch outside each
4039 of the three tight loops. There is less and less commonality though */
4053 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4054 && SvTEMP(source) && !DO_UTF8(source)
4055 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4057 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4058 * make the loop tight, so we overwrite the source with the dest before
4059 * looking at it, and we need to look at the original source
4060 * afterwards. There would also need to be code added to handle
4061 * switching to not in-place in midstream if we run into characters
4062 * that change the length.
4065 s = d = (U8*)SvPV_force_nomg(source, len);
4072 /* The old implementation would copy source into TARG at this point.
4073 This had the side effect that if source was undef, TARG was now
4074 an undefined SV with PADTMP set, and they don't warn inside
4075 sv_2pv_flags(). However, we're now getting the PV direct from
4076 source, which doesn't have PADTMP set, so it would warn. Hence the
4080 s = (const U8*)SvPV_nomg_const(source, len);
4082 if (ckWARN(WARN_UNINITIALIZED))
4083 report_uninit(source);
4089 SvUPGRADE(dest, SVt_PV);
4090 d = (U8*)SvGROW(dest, min);
4091 (void)SvPOK_only(dest);
4096 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4097 to check DO_UTF8 again here. */
4099 if (DO_UTF8(source)) {
4100 const U8 *const send = s + len;
4101 U8 tmpbuf[UTF8_MAXBYTES+1];
4103 /* All occurrences of these are to be moved to follow any other marks.
4104 * This is context-dependent. We may not be passed enough context to
4105 * move the iota subscript beyond all of them, but we do the best we can
4106 * with what we're given. The result is always better than if we
4107 * hadn't done this. And, the problem would only arise if we are
4108 * passed a character without all its combining marks, which would be
4109 * the caller's mistake. The information this is based on comes from a
4110 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4111 * itself) and so can't be checked properly to see if it ever gets
4112 * revised. But the likelihood of it changing is remote */
4113 bool in_iota_subscript = FALSE;
4116 if (in_iota_subscript && ! is_utf8_mark(s)) {
4117 /* A non-mark. Time to output the iota subscript */
4118 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4119 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4121 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4122 in_iota_subscript = FALSE;
4126 /* See comments at the first instance in this file of this ifdef */
4127 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4129 /* If the UTF-8 character is invariant, then it is in the range
4130 * known by the standard macro; result is only one byte long */
4131 if (UTF8_IS_INVARIANT(*s)) {
4135 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4137 /* Likewise, if it fits in a byte, its case change is in our
4139 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4140 U8 upper = toUPPER_LATIN1_MOD(orig);
4141 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4149 /* Otherwise, need the general UTF-8 case. Get the changed
4150 * case value and copy it to the output buffer */
4152 const STRLEN u = UTF8SKIP(s);
4155 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4156 if (uv == GREEK_CAPITAL_LETTER_IOTA
4157 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4159 in_iota_subscript = TRUE;
4162 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4163 /* If the eventually required minimum size outgrows
4164 * the available space, we need to grow. */
4165 const UV o = d - (U8*)SvPVX_const(dest);
4167 /* If someone uppercases one million U+03B0s we
4168 * SvGROW() one million times. Or we could try
4169 * guessing how much to allocate without allocating too
4170 * much. Such is life. See corresponding comment in
4171 * lc code for another option */
4173 d = (U8*)SvPVX(dest) + o;
4175 Copy(tmpbuf, d, ulen, U8);
4181 if (in_iota_subscript) {
4182 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4186 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4188 else { /* Not UTF-8 */
4190 const U8 *const send = s + len;
4192 /* Use locale casing if in locale; regular style if not treating
4193 * latin1 as having case; otherwise the latin1 casing. Do the
4194 * whole thing in a tight loop, for speed, */
4195 if (IN_LOCALE_RUNTIME) {
4198 for (; s < send; d++, s++)
4199 *d = toUPPER_LC(*s);
4201 else if (! IN_UNI_8_BIT) {
4202 for (; s < send; d++, s++) {
4207 for (; s < send; d++, s++) {
4208 *d = toUPPER_LATIN1_MOD(*s);
4209 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4211 /* The mainstream case is the tight loop above. To avoid
4212 * extra tests in that, all three characters that require
4213 * special handling are mapped by the MOD to the one tested
4215 * Use the source to distinguish between the three cases */
4217 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4219 /* uc() of this requires 2 characters, but they are
4220 * ASCII. If not enough room, grow the string */
4221 if (SvLEN(dest) < ++min) {
4222 const UV o = d - (U8*)SvPVX_const(dest);
4224 d = (U8*)SvPVX(dest) + o;
4226 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4227 continue; /* Back to the tight loop; still in ASCII */
4230 /* The other two special handling characters have their
4231 * upper cases outside the latin1 range, hence need to be
4232 * in UTF-8, so the whole result needs to be in UTF-8. So,
4233 * here we are somewhere in the middle of processing a
4234 * non-UTF-8 string, and realize that we will have to convert
4235 * the whole thing to UTF-8. What to do? There are
4236 * several possibilities. The simplest to code is to
4237 * convert what we have so far, set a flag, and continue on
4238 * in the loop. The flag would be tested each time through
4239 * the loop, and if set, the next character would be
4240 * converted to UTF-8 and stored. But, I (khw) didn't want
4241 * to slow down the mainstream case at all for this fairly
4242 * rare case, so I didn't want to add a test that didn't
4243 * absolutely have to be there in the loop, besides the
4244 * possibility that it would get too complicated for
4245 * optimizers to deal with. Another possibility is to just
4246 * give up, convert the source to UTF-8, and restart the
4247 * function that way. Another possibility is to convert
4248 * both what has already been processed and what is yet to
4249 * come separately to UTF-8, then jump into the loop that
4250 * handles UTF-8. But the most efficient time-wise of the
4251 * ones I could think of is what follows, and turned out to
4252 * not require much extra code. */
4254 /* Convert what we have so far into UTF-8, telling the
4255 * function that we know it should be converted, and to
4256 * allow extra space for what we haven't processed yet.
4257 * Assume the worst case space requirements for converting
4258 * what we haven't processed so far: that it will require
4259 * two bytes for each remaining source character, plus the
4260 * NUL at the end. This may cause the string pointer to
4261 * move, so re-find it. */
4263 len = d - (U8*)SvPVX_const(dest);
4264 SvCUR_set(dest, len);
4265 len = sv_utf8_upgrade_flags_grow(dest,
4266 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4268 d = (U8*)SvPVX(dest) + len;
4270 /* And append the current character's upper case in UTF-8 */
4271 CAT_NON_LATIN1_UC(d, *s);
4273 /* Now process the remainder of the source, converting to
4274 * upper and UTF-8. If a resulting byte is invariant in
4275 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4276 * append it to the output. */
4279 for (; s < send; s++) {
4280 U8 upper = toUPPER_LATIN1_MOD(*s);
4281 if UTF8_IS_INVARIANT(upper) {
4285 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4289 /* Here have processed the whole source; no need to continue
4290 * with the outer loop. Each character has been converted
4291 * to upper case and converted to UTF-8 */
4294 } /* End of processing all latin1-style chars */
4295 } /* End of processing all chars */
4296 } /* End of source is not empty */
4298 if (source != dest) {
4299 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4300 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4302 } /* End of isn't utf8 */
4320 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4321 && SvTEMP(source) && !DO_UTF8(source)) {
4323 /* We can convert in place, as lowercasing anything in the latin1 range
4324 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4326 s = d = (U8*)SvPV_force_nomg(source, len);
4333 /* The old implementation would copy source into TARG at this point.
4334 This had the side effect that if source was undef, TARG was now
4335 an undefined SV with PADTMP set, and they don't warn inside
4336 sv_2pv_flags(). However, we're now getting the PV direct from
4337 source, which doesn't have PADTMP set, so it would warn. Hence the
4341 s = (const U8*)SvPV_nomg_const(source, len);
4343 if (ckWARN(WARN_UNINITIALIZED))
4344 report_uninit(source);
4350 SvUPGRADE(dest, SVt_PV);
4351 d = (U8*)SvGROW(dest, min);
4352 (void)SvPOK_only(dest);
4357 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4358 to check DO_UTF8 again here. */
4360 if (DO_UTF8(source)) {
4361 const U8 *const send = s + len;
4362 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4365 /* See comments at the first instance in this file of this ifdef */
4366 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4367 if (UTF8_IS_INVARIANT(*s)) {
4369 /* Invariant characters use the standard mappings compiled in.
4374 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4376 /* As do the ones in the Latin1 range */
4377 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4378 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4383 /* Here, is utf8 not in Latin-1 range, have to go out and get
4384 * the mappings from the tables. */
4386 const STRLEN u = UTF8SKIP(s);
4389 #ifndef CONTEXT_DEPENDENT_CASING
4390 toLOWER_utf8(s, tmpbuf, &ulen);
4392 /* This is ifdefd out because it needs more work and thought. It isn't clear
4393 * that we should do it.
4394 * A minor objection is that this is based on a hard-coded rule from the
4395 * Unicode standard, and may change, but this is not very likely at all.
4396 * mktables should check and warn if it does.
4397 * More importantly, if the sigma occurs at the end of the string, we don't
4398 * have enough context to know whether it is part of a larger string or going
4399 * to be or not. It may be that we are passed a subset of the context, via
4400 * a \U...\E, for example, and we could conceivably know the larger context if
4401 * code were changed to pass that in. But, if the string passed in is an
4402 * intermediate result, and the user concatenates two strings together
4403 * after we have made a final sigma, that would be wrong. If the final sigma
4404 * occurs in the middle of the string we are working on, then we know that it
4405 * should be a final sigma, but otherwise we can't be sure. */
4407 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4409 /* If the lower case is a small sigma, it may be that we need
4410 * to change it to a final sigma. This happens at the end of
4411 * a word that contains more than just this character, and only
4412 * when we started with a capital sigma. */
4413 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4414 s > send - len && /* Makes sure not the first letter */
4415 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4418 /* We use the algorithm in:
4419 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4420 * is a CAPITAL SIGMA): If C is preceded by a sequence
4421 * consisting of a cased letter and a case-ignorable
4422 * sequence, and C is not followed by a sequence consisting
4423 * of a case ignorable sequence and then a cased letter,
4424 * then when lowercasing C, C becomes a final sigma */
4426 /* To determine if this is the end of a word, need to peek
4427 * ahead. Look at the next character */
4428 const U8 *peek = s + u;
4430 /* Skip any case ignorable characters */
4431 while (peek < send && is_utf8_case_ignorable(peek)) {
4432 peek += UTF8SKIP(peek);
4435 /* If we reached the end of the string without finding any
4436 * non-case ignorable characters, or if the next such one
4437 * is not-cased, then we have met the conditions for it
4438 * being a final sigma with regards to peek ahead, and so
4439 * must do peek behind for the remaining conditions. (We
4440 * know there is stuff behind to look at since we tested
4441 * above that this isn't the first letter) */
4442 if (peek >= send || ! is_utf8_cased(peek)) {
4443 peek = utf8_hop(s, -1);
4445 /* Here are at the beginning of the first character
4446 * before the original upper case sigma. Keep backing
4447 * up, skipping any case ignorable characters */
4448 while (is_utf8_case_ignorable(peek)) {
4449 peek = utf8_hop(peek, -1);
4452 /* Here peek points to the first byte of the closest
4453 * non-case-ignorable character before the capital
4454 * sigma. If it is cased, then by the Unicode
4455 * algorithm, we should use a small final sigma instead
4456 * of what we have */
4457 if (is_utf8_cased(peek)) {
4458 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4459 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4463 else { /* Not a context sensitive mapping */
4464 #endif /* End of commented out context sensitive */
4465 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4467 /* If the eventually required minimum size outgrows
4468 * the available space, we need to grow. */
4469 const UV o = d - (U8*)SvPVX_const(dest);
4471 /* If someone lowercases one million U+0130s we
4472 * SvGROW() one million times. Or we could try
4473 * guessing how much to allocate without allocating too
4474 * much. Such is life. Another option would be to
4475 * grow an extra byte or two more each time we need to
4476 * grow, which would cut down the million to 500K, with
4479 d = (U8*)SvPVX(dest) + o;
4481 #ifdef CONTEXT_DEPENDENT_CASING
4484 /* Copy the newly lowercased letter to the output buffer we're
4486 Copy(tmpbuf, d, ulen, U8);
4489 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4492 } /* End of looping through the source string */
4495 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4496 } else { /* Not utf8 */
4498 const U8 *const send = s + len;
4500 /* Use locale casing if in locale; regular style if not treating
4501 * latin1 as having case; otherwise the latin1 casing. Do the
4502 * whole thing in a tight loop, for speed, */
4503 if (IN_LOCALE_RUNTIME) {
4506 for (; s < send; d++, s++)
4507 *d = toLOWER_LC(*s);
4509 else if (! IN_UNI_8_BIT) {
4510 for (; s < send; d++, s++) {
4515 for (; s < send; d++, s++) {
4516 *d = toLOWER_LATIN1(*s);
4520 if (source != dest) {
4522 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4532 SV * const sv = TOPs;
4534 register const char *s = SvPV_const(sv,len);
4536 SvUTF8_off(TARG); /* decontaminate */
4539 SvUPGRADE(TARG, SVt_PV);
4540 SvGROW(TARG, (len * 2) + 1);
4544 if (UTF8_IS_CONTINUED(*s)) {
4545 STRLEN ulen = UTF8SKIP(s);
4569 SvCUR_set(TARG, d - SvPVX_const(TARG));
4570 (void)SvPOK_only_UTF8(TARG);
4573 sv_setpvn(TARG, s, len);
4582 dVAR; dSP; dMARK; dORIGMARK;
4583 register AV *const av = MUTABLE_AV(POPs);
4584 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4586 if (SvTYPE(av) == SVt_PVAV) {
4587 const I32 arybase = CopARYBASE_get(PL_curcop);
4588 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4589 bool can_preserve = FALSE;
4595 can_preserve = SvCANEXISTDELETE(av);
4598 if (lval && localizing) {
4601 for (svp = MARK + 1; svp <= SP; svp++) {
4602 const I32 elem = SvIV(*svp);
4606 if (max > AvMAX(av))
4610 while (++MARK <= SP) {
4612 I32 elem = SvIV(*MARK);
4613 bool preeminent = TRUE;
4617 if (localizing && can_preserve) {
4618 /* If we can determine whether the element exist,
4619 * Try to preserve the existenceness of a tied array
4620 * element by using EXISTS and DELETE if possible.
4621 * Fallback to FETCH and STORE otherwise. */
4622 preeminent = av_exists(av, elem);
4625 svp = av_fetch(av, elem, lval);
4627 if (!svp || *svp == &PL_sv_undef)
4628 DIE(aTHX_ PL_no_aelem, elem);
4631 save_aelem(av, elem, svp);
4633 SAVEADELETE(av, elem);
4636 *MARK = svp ? *svp : &PL_sv_undef;
4639 if (GIMME != G_ARRAY) {
4641 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4647 /* Smart dereferencing for keys, values and each */
4660 /* N.B.: AMG macros return sv if no overloading is found */
4661 SV *maybe_hv = AMG_CALLun(sv,to_hv);
4662 SV *maybe_av = AMG_CALLun(sv,to_av);
4663 if ( maybe_hv != sv && maybe_av != sv ) {
4664 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4665 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4666 PL_op_desc[PL_op->op_type]
4671 else if ( maybe_av != sv ) {
4672 if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
4673 /* @{} overload, but underlying reftype is HV */
4674 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4675 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
4676 PL_op_desc[PL_op->op_type]
4682 else if ( maybe_hv != sv ) {
4683 if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
4684 /* %{} overload, but underlying reftype is AV */
4685 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4686 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4687 PL_op_desc[PL_op->op_type]
4697 if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
4698 DIE(aTHX_ Perl_form(aTHX_ "Type of argument to %s must be hashref or arrayref",
4699 PL_op_desc[PL_op->op_type] ));
4702 /* Delegate to correct function for op type */
4704 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4705 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4708 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4716 AV *array = MUTABLE_AV(POPs);
4717 const I32 gimme = GIMME_V;
4718 IV *iterp = Perl_av_iter_p(aTHX_ array);
4719 const IV current = (*iterp)++;
4721 if (current > av_len(array)) {
4723 if (gimme == G_SCALAR)
4730 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4731 if (gimme == G_ARRAY) {
4732 SV **const element = av_fetch(array, current, 0);
4733 PUSHs(element ? *element : &PL_sv_undef);
4742 AV *array = MUTABLE_AV(POPs);
4743 const I32 gimme = GIMME_V;
4745 *Perl_av_iter_p(aTHX_ array) = 0;
4747 if (gimme == G_SCALAR) {
4749 PUSHi(av_len(array) + 1);
4751 else if (gimme == G_ARRAY) {
4752 IV n = Perl_av_len(aTHX_ array);
4753 IV i = CopARYBASE_get(PL_curcop);
4757 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4759 for (; i <= n; i++) {
4764 for (i = 0; i <= n; i++) {
4765 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4766 PUSHs(elem ? *elem : &PL_sv_undef);
4773 /* Associative arrays. */
4779 HV * hash = MUTABLE_HV(POPs);
4781 const I32 gimme = GIMME_V;
4784 /* might clobber stack_sp */
4785 entry = hv_iternext(hash);
4790 SV* const sv = hv_iterkeysv(entry);
4791 PUSHs(sv); /* won't clobber stack_sp */
4792 if (gimme == G_ARRAY) {
4795 /* might clobber stack_sp */
4796 val = hv_iterval(hash, entry);
4801 else if (gimme == G_SCALAR)
4808 S_do_delete_local(pTHX)
4812 const I32 gimme = GIMME_V;
4816 if (PL_op->op_private & OPpSLICE) {
4818 SV * const osv = POPs;
4819 const bool tied = SvRMAGICAL(osv)
4820 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4821 const bool can_preserve = SvCANEXISTDELETE(osv)
4822 || mg_find((const SV *)osv, PERL_MAGIC_env);
4823 const U32 type = SvTYPE(osv);
4824 if (type == SVt_PVHV) { /* hash element */
4825 HV * const hv = MUTABLE_HV(osv);
4826 while (++MARK <= SP) {
4827 SV * const keysv = *MARK;
4829 bool preeminent = TRUE;
4831 preeminent = hv_exists_ent(hv, keysv, 0);
4833 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4840 sv = hv_delete_ent(hv, keysv, 0, 0);
4841 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4844 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4846 *MARK = sv_mortalcopy(sv);
4852 SAVEHDELETE(hv, keysv);
4853 *MARK = &PL_sv_undef;
4857 else if (type == SVt_PVAV) { /* array element */
4858 if (PL_op->op_flags & OPf_SPECIAL) {
4859 AV * const av = MUTABLE_AV(osv);
4860 while (++MARK <= SP) {
4861 I32 idx = SvIV(*MARK);
4863 bool preeminent = TRUE;
4865 preeminent = av_exists(av, idx);
4867 SV **svp = av_fetch(av, idx, 1);
4874 sv = av_delete(av, idx, 0);
4875 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4878 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4880 *MARK = sv_mortalcopy(sv);
4886 SAVEADELETE(av, idx);
4887 *MARK = &PL_sv_undef;
4893 DIE(aTHX_ "Not a HASH reference");
4894 if (gimme == G_VOID)
4896 else if (gimme == G_SCALAR) {
4901 *++MARK = &PL_sv_undef;
4906 SV * const keysv = POPs;
4907 SV * const osv = POPs;
4908 const bool tied = SvRMAGICAL(osv)
4909 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4910 const bool can_preserve = SvCANEXISTDELETE(osv)
4911 || mg_find((const SV *)osv, PERL_MAGIC_env);
4912 const U32 type = SvTYPE(osv);
4914 if (type == SVt_PVHV) {
4915 HV * const hv = MUTABLE_HV(osv);
4916 bool preeminent = TRUE;
4918 preeminent = hv_exists_ent(hv, keysv, 0);
4920 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4927 sv = hv_delete_ent(hv, keysv, 0, 0);
4928 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4931 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4933 SV *nsv = sv_mortalcopy(sv);
4939 SAVEHDELETE(hv, keysv);
4941 else if (type == SVt_PVAV) {
4942 if (PL_op->op_flags & OPf_SPECIAL) {
4943 AV * const av = MUTABLE_AV(osv);
4944 I32 idx = SvIV(keysv);
4945 bool preeminent = TRUE;
4947 preeminent = av_exists(av, idx);
4949 SV **svp = av_fetch(av, idx, 1);
4956 sv = av_delete(av, idx, 0);
4957 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4960 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4962 SV *nsv = sv_mortalcopy(sv);
4968 SAVEADELETE(av, idx);
4971 DIE(aTHX_ "panic: avhv_delete no longer supported");
4974 DIE(aTHX_ "Not a HASH reference");
4977 if (gimme != G_VOID)
4991 if (PL_op->op_private & OPpLVAL_INTRO)
4992 return do_delete_local();
4995 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4997 if (PL_op->op_private & OPpSLICE) {
4999 HV * const hv = MUTABLE_HV(POPs);
5000 const U32 hvtype = SvTYPE(hv);
5001 if (hvtype == SVt_PVHV) { /* hash element */
5002 while (++MARK <= SP) {
5003 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5004 *MARK = sv ? sv : &PL_sv_undef;
5007 else if (hvtype == SVt_PVAV) { /* array element */
5008 if (PL_op->op_flags & OPf_SPECIAL) {
5009 while (++MARK <= SP) {
5010 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5011 *MARK = sv ? sv : &PL_sv_undef;
5016 DIE(aTHX_ "Not a HASH reference");
5019 else if (gimme == G_SCALAR) {
5024 *++MARK = &PL_sv_undef;
5030 HV * const hv = MUTABLE_HV(POPs);
5032 if (SvTYPE(hv) == SVt_PVHV)
5033 sv = hv_delete_ent(hv, keysv, discard, 0);
5034 else if (SvTYPE(hv) == SVt_PVAV) {
5035 if (PL_op->op_flags & OPf_SPECIAL)
5036 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5038 DIE(aTHX_ "panic: avhv_delete no longer supported");
5041 DIE(aTHX_ "Not a HASH reference");
5057 if (PL_op->op_private & OPpEXISTS_SUB) {
5059 SV * const sv = POPs;
5060 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5063 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5068 hv = MUTABLE_HV(POPs);
5069 if (SvTYPE(hv) == SVt_PVHV) {
5070 if (hv_exists_ent(hv, tmpsv, 0))
5073 else if (SvTYPE(hv) == SVt_PVAV) {
5074 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5075 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5080 DIE(aTHX_ "Not a HASH reference");
5087 dVAR; dSP; dMARK; dORIGMARK;
5088 register HV * const hv = MUTABLE_HV(POPs);
5089 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5090 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5091 bool can_preserve = FALSE;
5097 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
5098 can_preserve = TRUE;
5101 while (++MARK <= SP) {
5102 SV * const keysv = *MARK;
5105 bool preeminent = TRUE;
5107 if (localizing && can_preserve) {
5108 /* If we can determine whether the element exist,
5109 * try to preserve the existenceness of a tied hash
5110 * element by using EXISTS and DELETE if possible.
5111 * Fallback to FETCH and STORE otherwise. */
5112 preeminent = hv_exists_ent(hv, keysv, 0);
5115 he = hv_fetch_ent(hv, keysv, lval, 0);
5116 svp = he ? &HeVAL(he) : NULL;
5119 if (!svp || *svp == &PL_sv_undef) {
5120 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5123 if (HvNAME_get(hv) && isGV(*svp))
5124 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5125 else if (preeminent)
5126 save_helem_flags(hv, keysv, svp,
5127 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5129 SAVEHDELETE(hv, keysv);
5132 *MARK = svp ? *svp : &PL_sv_undef;
5134 if (GIMME != G_ARRAY) {
5136 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5142 /* List operators. */
5147 if (GIMME != G_ARRAY) {
5149 *MARK = *SP; /* unwanted list, return last item */
5151 *MARK = &PL_sv_undef;
5161 SV ** const lastrelem = PL_stack_sp;
5162 SV ** const lastlelem = PL_stack_base + POPMARK;
5163 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5164 register SV ** const firstrelem = lastlelem + 1;
5165 const I32 arybase = CopARYBASE_get(PL_curcop);
5166 I32 is_something_there = FALSE;
5168 register const I32 max = lastrelem - lastlelem;
5169 register SV **lelem;
5171 if (GIMME != G_ARRAY) {
5172 I32 ix = SvIV(*lastlelem);
5177 if (ix < 0 || ix >= max)
5178 *firstlelem = &PL_sv_undef;
5180 *firstlelem = firstrelem[ix];
5186 SP = firstlelem - 1;
5190 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5191 I32 ix = SvIV(*lelem);
5196 if (ix < 0 || ix >= max)
5197 *lelem = &PL_sv_undef;
5199 is_something_there = TRUE;
5200 if (!(*lelem = firstrelem[ix]))
5201 *lelem = &PL_sv_undef;
5204 if (is_something_there)
5207 SP = firstlelem - 1;
5213 dVAR; dSP; dMARK; dORIGMARK;
5214 const I32 items = SP - MARK;
5215 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5216 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5217 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5218 ? newRV_noinc(av) : av);
5224 dVAR; dSP; dMARK; dORIGMARK;
5225 HV* const hv = newHV();
5228 SV * const key = *++MARK;
5229 SV * const val = newSV(0);
5231 sv_setsv(val, *++MARK);
5233 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5234 (void)hv_store_ent(hv,key,val,0);
5237 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5238 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5244 dVAR; dSP; dMARK; dORIGMARK;
5245 register AV *ary = MUTABLE_AV(*++MARK);
5249 register I32 offset;
5250 register I32 length;
5254 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5257 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5260 ENTER_with_name("call_SPLICE");
5261 call_method("SPLICE",GIMME_V);
5262 LEAVE_with_name("call_SPLICE");
5270 offset = i = SvIV(*MARK);
5272 offset += AvFILLp(ary) + 1;
5274 offset -= CopARYBASE_get(PL_curcop);
5276 DIE(aTHX_ PL_no_aelem, i);
5278 length = SvIVx(*MARK++);
5280 length += AvFILLp(ary) - offset + 1;
5286 length = AvMAX(ary) + 1; /* close enough to infinity */
5290 length = AvMAX(ary) + 1;
5292 if (offset > AvFILLp(ary) + 1) {
5293 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5294 offset = AvFILLp(ary) + 1;
5296 after = AvFILLp(ary) + 1 - (offset + length);
5297 if (after < 0) { /* not that much array */
5298 length += after; /* offset+length now in array */
5304 /* At this point, MARK .. SP-1 is our new LIST */
5307 diff = newlen - length;
5308 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5311 /* make new elements SVs now: avoid problems if they're from the array */
5312 for (dst = MARK, i = newlen; i; i--) {
5313 SV * const h = *dst;
5314 *dst++ = newSVsv(h);
5317 if (diff < 0) { /* shrinking the area */
5318 SV **tmparyval = NULL;
5320 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5321 Copy(MARK, tmparyval, newlen, SV*);
5324 MARK = ORIGMARK + 1;
5325 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5326 MEXTEND(MARK, length);
5327 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5329 EXTEND_MORTAL(length);
5330 for (i = length, dst = MARK; i; i--) {
5331 sv_2mortal(*dst); /* free them eventualy */
5338 *MARK = AvARRAY(ary)[offset+length-1];
5341 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5342 SvREFCNT_dec(*dst++); /* free them now */
5345 AvFILLp(ary) += diff;
5347 /* pull up or down? */
5349 if (offset < after) { /* easier to pull up */
5350 if (offset) { /* esp. if nothing to pull */
5351 src = &AvARRAY(ary)[offset-1];
5352 dst = src - diff; /* diff is negative */
5353 for (i = offset; i > 0; i--) /* can't trust Copy */
5357 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5361 if (after) { /* anything to pull down? */
5362 src = AvARRAY(ary) + offset + length;
5363 dst = src + diff; /* diff is negative */
5364 Move(src, dst, after, SV*);
5366 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5367 /* avoid later double free */
5371 dst[--i] = &PL_sv_undef;
5374 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5375 Safefree(tmparyval);
5378 else { /* no, expanding (or same) */
5379 SV** tmparyval = NULL;
5381 Newx(tmparyval, length, SV*); /* so remember deletion */
5382 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5385 if (diff > 0) { /* expanding */
5386 /* push up or down? */
5387 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5391 Move(src, dst, offset, SV*);
5393 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5395 AvFILLp(ary) += diff;
5398 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5399 av_extend(ary, AvFILLp(ary) + diff);
5400 AvFILLp(ary) += diff;
5403 dst = AvARRAY(ary) + AvFILLp(ary);
5405 for (i = after; i; i--) {
5413 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5416 MARK = ORIGMARK + 1;
5417 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5419 Copy(tmparyval, MARK, length, SV*);
5421 EXTEND_MORTAL(length);
5422 for (i = length, dst = MARK; i; i--) {
5423 sv_2mortal(*dst); /* free them eventualy */
5430 else if (length--) {
5431 *MARK = tmparyval[length];
5434 while (length-- > 0)
5435 SvREFCNT_dec(tmparyval[length]);
5439 *MARK = &PL_sv_undef;
5440 Safefree(tmparyval);
5444 mg_set(MUTABLE_SV(ary));
5452 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5453 register AV * const ary = MUTABLE_AV(*++MARK);
5454 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5457 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5460 ENTER_with_name("call_PUSH");
5461 call_method("PUSH",G_SCALAR|G_DISCARD);
5462 LEAVE_with_name("call_PUSH");
5466 PL_delaymagic = DM_DELAY;
5467 for (++MARK; MARK <= SP; MARK++) {
5468 SV * const sv = newSV(0);
5470 sv_setsv(sv, *MARK);
5471 av_store(ary, AvFILLp(ary)+1, sv);
5473 if (PL_delaymagic & DM_ARRAY_ISA)
5474 mg_set(MUTABLE_SV(ary));
5479 if (OP_GIMME(PL_op, 0) != G_VOID) {
5480 PUSHi( AvFILL(ary) + 1 );
5489 AV * const av = PL_op->op_flags & OPf_SPECIAL
5490 ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5491 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5495 (void)sv_2mortal(sv);
5502 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5503 register AV *ary = MUTABLE_AV(*++MARK);
5504 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5507 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5510 ENTER_with_name("call_UNSHIFT");
5511 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5512 LEAVE_with_name("call_UNSHIFT");
5517 av_unshift(ary, SP - MARK);
5519 SV * const sv = newSVsv(*++MARK);
5520 (void)av_store(ary, i++, sv);
5524 if (OP_GIMME(PL_op, 0) != G_VOID) {
5525 PUSHi( AvFILL(ary) + 1 );
5534 if (GIMME == G_ARRAY) {
5535 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5539 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5540 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5541 av = MUTABLE_AV((*SP));
5542 /* In-place reversing only happens in void context for the array
5543 * assignment. We don't need to push anything on the stack. */
5546 if (SvMAGICAL(av)) {
5548 register SV *tmp = sv_newmortal();
5549 /* For SvCANEXISTDELETE */
5552 bool can_preserve = SvCANEXISTDELETE(av);
5554 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5555 register SV *begin, *end;
5558 if (!av_exists(av, i)) {
5559 if (av_exists(av, j)) {
5560 register SV *sv = av_delete(av, j, 0);
5561 begin = *av_fetch(av, i, TRUE);
5562 sv_setsv_mg(begin, sv);
5566 else if (!av_exists(av, j)) {
5567 register SV *sv = av_delete(av, i, 0);
5568 end = *av_fetch(av, j, TRUE);
5569 sv_setsv_mg(end, sv);
5574 begin = *av_fetch(av, i, TRUE);
5575 end = *av_fetch(av, j, TRUE);
5576 sv_setsv(tmp, begin);
5577 sv_setsv_mg(begin, end);
5578 sv_setsv_mg(end, tmp);
5582 SV **begin = AvARRAY(av);
5585 SV **end = begin + AvFILLp(av);
5587 while (begin < end) {
5588 register SV * const tmp = *begin;
5599 register SV * const tmp = *MARK;
5603 /* safe as long as stack cannot get extended in the above */
5609 register char *down;
5614 SvUTF8_off(TARG); /* decontaminate */
5616 do_join(TARG, &PL_sv_no, MARK, SP);
5618 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5619 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5620 report_uninit(TARG);
5623 up = SvPV_force(TARG, len);
5625 if (DO_UTF8(TARG)) { /* first reverse each character */
5626 U8* s = (U8*)SvPVX(TARG);
5627 const U8* send = (U8*)(s + len);
5629 if (UTF8_IS_INVARIANT(*s)) {
5634 if (!utf8_to_uvchr(s, 0))
5638 down = (char*)(s - 1);
5639 /* reverse this character */
5643 *down-- = (char)tmp;
5649 down = SvPVX(TARG) + len - 1;
5653 *down-- = (char)tmp;
5655 (void)SvPOK_only_UTF8(TARG);
5667 register IV limit = POPi; /* note, negative is forever */
5668 SV * const sv = POPs;
5670 register const char *s = SvPV_const(sv, len);
5671 const bool do_utf8 = DO_UTF8(sv);
5672 const char *strend = s + len;
5674 register REGEXP *rx;
5676 register const char *m;
5678 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5679 I32 maxiters = slen + 10;
5680 I32 trailing_empty = 0;
5682 const I32 origlimit = limit;
5685 const I32 gimme = GIMME_V;
5687 const I32 oldsave = PL_savestack_ix;
5688 U32 make_mortal = SVs_TEMP;
5693 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5698 DIE(aTHX_ "panic: pp_split");
5701 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5702 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5704 RX_MATCH_UTF8_set(rx, do_utf8);
5707 if (pm->op_pmreplrootu.op_pmtargetoff) {
5708 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5711 if (pm->op_pmreplrootu.op_pmtargetgv) {
5712 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5717 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5723 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5725 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5732 for (i = AvFILLp(ary); i >= 0; i--)
5733 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5735 /* temporarily switch stacks */
5736 SAVESWITCHSTACK(PL_curstack, ary);
5740 base = SP - PL_stack_base;
5742 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5744 while (*s == ' ' || is_utf8_space((U8*)s))
5747 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5748 while (isSPACE_LC(*s))
5756 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5760 gimme_scalar = gimme == G_SCALAR && !ary;
5763 limit = maxiters + 2;
5764 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5767 /* this one uses 'm' and is a negative test */
5769 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5770 const int t = UTF8SKIP(m);
5771 /* is_utf8_space returns FALSE for malform utf8 */
5777 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5778 while (m < strend && !isSPACE_LC(*m))
5781 while (m < strend && !isSPACE(*m))
5794 dstr = newSVpvn_flags(s, m-s,
5795 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5799 /* skip the whitespace found last */
5801 s = m + UTF8SKIP(m);
5805 /* this one uses 's' and is a positive test */
5807 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5809 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5810 while (s < strend && isSPACE_LC(*s))
5813 while (s < strend && isSPACE(*s))
5818 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5820 for (m = s; m < strend && *m != '\n'; m++)
5833 dstr = newSVpvn_flags(s, m-s,
5834 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5840 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5842 Pre-extend the stack, either the number of bytes or
5843 characters in the string or a limited amount, triggered by:
5845 my ($x, $y) = split //, $str;
5849 if (!gimme_scalar) {
5850 const U32 items = limit - 1;
5859 /* keep track of how many bytes we skip over */
5869 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5882 dstr = newSVpvn(s, 1);
5898 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5899 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5900 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5901 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5902 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5903 SV * const csv = CALLREG_INTUIT_STRING(rx);
5905 len = RX_MINLENRET(rx);
5906 if (len == 1 && !RX_UTF8(rx) && !tail) {
5907 const char c = *SvPV_nolen_const(csv);
5909 for (m = s; m < strend && *m != c; m++)
5920 dstr = newSVpvn_flags(s, m-s,
5921 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5924 /* The rx->minlen is in characters but we want to step
5925 * s ahead by bytes. */
5927 s = (char*)utf8_hop((U8*)m, len);
5929 s = m + len; /* Fake \n at the end */
5933 while (s < strend && --limit &&
5934 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5935 csv, multiline ? FBMrf_MULTILINE : 0)) )
5944 dstr = newSVpvn_flags(s, m-s,
5945 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5948 /* The rx->minlen is in characters but we want to step
5949 * s ahead by bytes. */
5951 s = (char*)utf8_hop((U8*)m, len);
5953 s = m + len; /* Fake \n at the end */
5958 maxiters += slen * RX_NPARENS(rx);
5959 while (s < strend && --limit)
5963 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5966 if (rex_return == 0)
5968 TAINT_IF(RX_MATCH_TAINTED(rx));
5969 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5972 orig = RX_SUBBEG(rx);
5974 strend = s + (strend - m);
5976 m = RX_OFFS(rx)[0].start + orig;
5985 dstr = newSVpvn_flags(s, m-s,
5986 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5989 if (RX_NPARENS(rx)) {
5991 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5992 s = RX_OFFS(rx)[i].start + orig;
5993 m = RX_OFFS(rx)[i].end + orig;
5995 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5996 parens that didn't match -- they should be set to
5997 undef, not the empty string */
6005 if (m >= orig && s >= orig) {
6006 dstr = newSVpvn_flags(s, m-s,
6007 (do_utf8 ? SVf_UTF8 : 0)
6011 dstr = &PL_sv_undef; /* undef, not "" */
6017 s = RX_OFFS(rx)[0].end + orig;
6021 if (!gimme_scalar) {
6022 iters = (SP - PL_stack_base) - base;
6024 if (iters > maxiters)
6025 DIE(aTHX_ "Split loop");
6027 /* keep field after final delim? */
6028 if (s < strend || (iters && origlimit)) {
6029 if (!gimme_scalar) {
6030 const STRLEN l = strend - s;
6031 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6036 else if (!origlimit) {
6038 iters -= trailing_empty;
6040 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6041 if (TOPs && !make_mortal)
6043 *SP-- = &PL_sv_undef;
6050 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6054 if (SvSMAGICAL(ary)) {
6056 mg_set(MUTABLE_SV(ary));
6059 if (gimme == G_ARRAY) {
6061 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6068 ENTER_with_name("call_PUSH");
6069 call_method("PUSH",G_SCALAR|G_DISCARD);
6070 LEAVE_with_name("call_PUSH");
6072 if (gimme == G_ARRAY) {
6074 /* EXTEND should not be needed - we just popped them */
6076 for (i=0; i < iters; i++) {
6077 SV **svp = av_fetch(ary, i, FALSE);
6078 PUSHs((svp) ? *svp : &PL_sv_undef);
6085 if (gimme == G_ARRAY)
6097 SV *const sv = PAD_SVl(PL_op->op_targ);
6099 if (SvPADSTALE(sv)) {
6102 RETURNOP(cLOGOP->op_other);
6104 RETURNOP(cLOGOP->op_next);
6113 assert(SvTYPE(retsv) != SVt_PVCV);
6115 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6116 retsv = refto(retsv);
6123 PP(unimplemented_op)
6126 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6134 HV * const hv = (HV*)POPs;
6136 if (SvRMAGICAL(hv)) {
6137 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6139 XPUSHs(magic_scalarpack(hv, mg));
6144 XPUSHs(boolSV(HvKEYS(hv) != 0));
6150 * c-indentation-style: bsd
6152 * indent-tabs-mode: t
6155 * ex: set ts=8 sts=4 sw=4 noet: